Profile of CGI/Session.pm

Filename	/usr/share/perl5/CGI/Session.pm
Statements	Executed 375 statements in 5.80ms

Subroutines
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
2	1	1	1.43ms	3.36ms	CGI::Session::::_load_pluggablesCGI::Session::_load_pluggables
2	1	1	569µs	650µs	CGI::Session::::parse_dsnCGI::Session::parse_dsn
1	1	1	297µs	347µs	CGI::Session::::BEGIN@4CGI::Session::BEGIN@4
2	1	1	217µs	5.18ms	CGI::Session::::loadCGI::Session::load
20	10	2	91µs	114µs	CGI::Session::::paramCGI::Session::param
2	1	1	82µs	2.18ms	CGI::Session::::flushCGI::Session::flush
4	2	1	41µs	102µs	CGI::Session::::_driverCGI::Session::_driver
2	1	1	36µs	5.23ms	CGI::Session::::newCGI::Session::new
5	3	2	29µs	38µs	CGI::Session::::idCGI::Session::id
26	4	1	25µs	25µs	CGI::Session::::_test_statusCGI::Session::_test_status
7	2	1	24µs	24µs	CGI::Session::::CORE:matchCGI::Session::CORE:match (opcode)
1	1	1	17µs	25µs	CGI::Session::::BEGIN@2CGI::Session::BEGIN@2
4	2	1	15µs	15µs	CGI::Session::::_serializerCGI::Session::_serializer
1	1	1	13µs	46µs	CGI::Session::::BEGIN@3CGI::Session::BEGIN@3
2	2	1	10µs	2.19ms	CGI::Session::::DESTROYCGI::Session::DESTROY
12	2	1	10µs	10µs	CGI::Session::::datarefCGI::Session::dataref
3	2	1	10µs	10µs	CGI::Session::::_set_statusCGI::Session::_set_status
2	1	1	10µs	10µs	CGI::Session::::_unset_statusCGI::Session::_unset_status
2	1	1	7µs	7µs	CGI::Session::::_set_query_or_sidCGI::Session::_set_query_or_sid
1	1	1	6µs	6µs	CGI::Session::::importCGI::Session::import
0	0	0	0s	0s	CGI::Session::::__ANON__[:451]CGI::Session::__ANON__[:451]
0	0	0	0s	0s	CGI::Session::::_id_generatorCGI::Session::_id_generator
0	0	0	0s	0s	CGI::Session::::_reset_statusCGI::Session::_reset_status
0	0	0	0s	0s	CGI::Session::::_str2secondsCGI::Session::_str2seconds
0	0	0	0s	0s	CGI::Session::::atimeCGI::Session::atime
0	0	0	0s	0s	CGI::Session::::clearCGI::Session::clear
0	0	0	0s	0s	CGI::Session::::closeCGI::Session::close
0	0	0	0s	0s	CGI::Session::::cookieCGI::Session::cookie
0	0	0	0s	0s	CGI::Session::::ctimeCGI::Session::ctime
0	0	0	0s	0s	CGI::Session::::deleteCGI::Session::delete
0	0	0	0s	0s	CGI::Session::::dumpCGI::Session::dump
0	0	0	0s	0s	CGI::Session::::etimeCGI::Session::etime
0	0	0	0s	0s	CGI::Session::::expireCGI::Session::expire
0	0	0	0s	0s	CGI::Session::::findCGI::Session::find
0	0	0	0s	0s	CGI::Session::::http_headerCGI::Session::http_header
0	0	0	0s	0s	CGI::Session::::ip_matchesCGI::Session::ip_matches
0	0	0	0s	0s	CGI::Session::::is_emptyCGI::Session::is_empty
0	0	0	0s	0s	CGI::Session::::is_expiredCGI::Session::is_expired
0	0	0	0s	0s	CGI::Session::::is_newCGI::Session::is_new
0	0	0	0s	0s	CGI::Session::::load_paramCGI::Session::load_param
0	0	0	0s	0s	CGI::Session::::nameCGI::Session::name
0	0	0	0s	0s	CGI::Session::::queryCGI::Session::query
0	0	0	0s	0s	CGI::Session::::remote_addrCGI::Session::remote_addr
0	0	0	0s	0s	CGI::Session::::save_paramCGI::Session::save_param
0	0	0	0s	0s	CGI::Session::::traceCGI::Session::trace
0	0	0	0s	0s	CGI::Session::::tracemsgCGI::Session::tracemsg

Call graph for these subroutines as a Graphviz dot language file.

Line	State ments	Time on line	Calls	Time in subs	Code
1					package CGI::Session;
2	2	40µs	2	33µs	# spent 25µs (17+8) within CGI::Session::BEGIN@2 which was called: # once (17µs+8µs) by C4::Auth::BEGIN@25 at line 2 use strict; # spent 25µs making 1 call to CGI::Session::BEGIN@2 # spent 8µs making 1 call to strict::import
3	2	76µs	2	79µs	# spent 46µs (13+33) within CGI::Session::BEGIN@3 which was called: # once (13µs+33µs) by C4::Auth::BEGIN@25 at line 3 use Carp; # spent 46µs making 1 call to CGI::Session::BEGIN@3 # spent 33µs making 1 call to Exporter::import
4	2	4.25ms	1	347µs	# spent 347µs (297+50) within CGI::Session::BEGIN@4 which was called: # once (297µs+50µs) by C4::Auth::BEGIN@25 at line 4 use CGI::Session::ErrorHandler; # spent 347µs making 1 call to CGI::Session::BEGIN@4
5
6	1	16µs			@CGI::Session::ISA = qw( CGI::Session::ErrorHandler );
7	1	1µs			$CGI::Session::VERSION = '4.48';
8	1	500ns			$CGI::Session::NAME = 'CGISESSID';
9	1	300ns			$CGI::Session::IP_MATCH = 0;
10
11					sub STATUS_UNSET () { 1 << 0 } # denotes session that's resetted
12					sub STATUS_NEW () { 1 << 1 } # denotes session that's just created
13					sub STATUS_MODIFIED () { 1 << 2 } # denotes session that needs synchronization
14					sub STATUS_DELETED () { 1 << 3 } # denotes session that needs deletion
15					sub STATUS_EXPIRED () { 1 << 4 } # denotes session that was expired.
16
17					# spent 6µs within CGI::Session::import which was called: # once (6µs+0s) by C4::Auth::BEGIN@25 at line 25 of C4/Auth.pm sub import {
18	1	1µs			my ($class, @args) = @_;
19
20	1	10µs			return unless @args;
21
22					ARG:
23					for my $arg (@args) {
24					if ($arg eq '-ip_match') {
25					$CGI::Session::IP_MATCH = 1;
26					last ARG;
27					}
28					}
29					}
30
31					# spent 5.23ms (36µs+5.19) within CGI::Session::new which was called 2 times, avg 2.62ms/call: # 2 times (36µs+5.19ms) by C4::Auth::get_session at line 1705 of C4/Auth.pm, avg 2.62ms/call sub new {
32	2	3µs			my ($class, @args) = @_;
33
34	2	400ns			my $self;
35	2	2µs			if (ref $class) {
36					#
37					# Called as an object method as in $session->new()...
38					#
39					$self = bless { %$class }, ref( $class );
40					$class = ref $class;
41					$self->_reset_status();
42					#
43					# Object may still have public data associated with it, but we
44					# don't care about that, since we want to leave that to the
45					# client's disposal. However, if new() was requested on an
46					# expired session, we already know that '_DATA' table is
47					# empty, since it was the job of flush() to empty '_DATA'
48					# after deleting. How do we know flush() was already called on
49					# an expired session? Because load() - constructor always
50					# calls flush() on all to-be expired sessions
51					#
52					}
53					else {
54					#
55					# Called as a class method as in CGI::Session->new()
56					#
57
58					# Start fresh with error reporting. Errors in past objects shouldn't affect this one.
59	2	10µs	2	14µs	$class->set_error(''); # spent 14µs making 2 calls to CGI::Session::ErrorHandler::set_error, avg 7µs/call
60
61	2	8µs	2	5.18ms	$self = $class->load( @args ); # spent 5.18ms making 2 calls to CGI::Session::load, avg 2.59ms/call
62	2	1µs			if (not defined $self) {
63					return $class->set_error( "new(): failed: " . $class->errstr );
64					}
65					}
66
67	2	2µs			my $dataref = $self->{_DATA};
68	2	800ns			unless ($dataref->{_SESSION_ID}) {
69					#
70					# Absence of '_SESSION_ID' can only signal:
71					# * Expired session: Because load() - constructor is required to
72					# empty contents of _DATA - table
73					# * Unavailable session: Such sessions are the ones that don't
74					# exist on datastore, but are requested by client
75					# * New session: When no specific session is requested to be loaded
76					#
77					my $id = $self->_id_generator()->generate_id(
78					$self->{_DRIVER_ARGS},
79					$self->{_CLAIMED_ID}
80					);
81					unless (defined $id) {
82					return $self->set_error( "Couldn't generate new SESSION-ID" );
83					}
84					$dataref->{_SESSION_ID} = $id;
85					$dataref->{_SESSION_CTIME} = $dataref->{_SESSION_ATIME} = time();
86					$dataref->{_SESSION_REMOTE_ADDR} = $ENV{REMOTE_ADDR} \|\| "";
87					$self->_set_status( STATUS_NEW );
88					}
89	2	7µs			return $self;
90					}
91
92	2	12µs	2	2.18ms	# spent 2.19ms (10µs+2.18) within CGI::Session::DESTROY which was called 2 times, avg 1.09ms/call: # once (6µs+1.90ms) by C4::Auth::checkauth at line 775 of C4/Auth.pm # once (4µs+278µs) by C4::Search::History::get_from_session at line 390 of C4/Auth.pm sub DESTROY { $_[0]->flush() } # spent 2.18ms making 2 calls to CGI::Session::flush, avg 1.09ms/call
93					sub close { $_[0]->flush() }
94
95	1	2µs			*param_hashref = \&dataref;
96	1	2µs			my $avoid_single_use_warning = *param_hashref;
97	12	23µs			# spent 10µs within CGI::Session::dataref which was called 12 times, avg 842ns/call: # 10 times (9µs+0s) by CGI::Session::id at line 105, avg 860ns/call # 2 times (2µs+0s) by CGI::Session::flush at line 247, avg 750ns/call sub dataref { $_[0]->{_DATA} }
98
99					sub is_empty { !defined($_[0]->id) }
100
101					sub is_expired { $_[0]->_test_status( STATUS_EXPIRED ) }
102
103					sub is_new { $_[0]->_test_status( STATUS_NEW ) }
104
105	5	25µs	10	9µs	# spent 38µs (29+9) within CGI::Session::id which was called 5 times, avg 8µs/call: # 2 times (11µs+3µs) by CGI::Session::flush at line 225, avg 7µs/call # 2 times (9µs+3µs) by CGI::Session::flush at line 251, avg 6µs/call # once (9µs+3µs) by C4::Auth::checkauth at line 883 of C4/Auth.pm sub id { return defined($_[0]->dataref) ? $_[0]->dataref->{_SESSION_ID} : undef } # spent 9µs making 10 calls to CGI::Session::dataref, avg 860ns/call
106
107					# Last Access Time
108					sub atime { return defined($_[0]->dataref) ? $_[0]->dataref->{_SESSION_ATIME} : undef }
109
110					# Creation Time
111					sub ctime { return defined($_[0]->dataref) ? $_[0]->dataref->{_SESSION_CTIME} : undef }
112
113					# spent 102µs (41+61) within CGI::Session::_driver which was called 4 times, avg 25µs/call: # 2 times (36µs+61µs) by CGI::Session::load at line 718, avg 48µs/call # 2 times (5µs+0s) by CGI::Session::flush at line 235, avg 2µs/call sub _driver {
114	4	2µs			my $self = shift;
115	4	19µs			defined($self->{_OBJECTS}->{driver}) and return $self->{_OBJECTS}->{driver};
116	2	4µs			my $pm = "CGI::Session::Driver::" . $self->{_DSN}->{driver};
117	2	12µs	2	61µs	defined($self->{_OBJECTS}->{driver} = $pm->new( $self->{_DRIVER_ARGS} )) # spent 61µs making 2 calls to CGI::Session::Driver::new, avg 30µs/call
118					or die $pm->errstr();
119	2	6µs			return $self->{_OBJECTS}->{driver};
120					}
121
122					# spent 15µs within CGI::Session::_serializer which was called 4 times, avg 4µs/call: # 2 times (10µs+0s) by CGI::Session::load at line 727, avg 5µs/call # 2 times (4µs+0s) by CGI::Session::flush at line 236, avg 2µs/call sub _serializer {
123	4	2µs			my $self = shift;
124	4	8µs			defined($self->{_OBJECTS}->{serializer}) and return $self->{_OBJECTS}->{serializer};
125	2	10µs			return $self->{_OBJECTS}->{serializer} = "CGI::Session::Serialize::" . $self->{_DSN}->{serializer};
126					}
127
128
129					sub _id_generator {
130					my $self = shift;
131					defined($self->{_OBJECTS}->{id}) and return $self->{_OBJECTS}->{id};
132					return $self->{_OBJECTS}->{id} = "CGI::Session::ID::" . $self->{_DSN}->{id};
133					}
134
135					sub ip_matches {
136					return ( $_[0]->{_DATA}->{_SESSION_REMOTE_ADDR} eq $ENV{REMOTE_ADDR} );
137					}
138
139
140					# parses the DSN string and returns it as a hash.
141					# Notably: Allows unique abbreviations of the keys: driver, serializer and 'id'.
142					# Also, keys and values of the returned hash are lower-cased.
143					# spent 650µs (569+80) within CGI::Session::parse_dsn which was called 2 times, avg 325µs/call: # 2 times (569µs+80µs) by CGI::Session::load at line 688, avg 325µs/call sub parse_dsn {
144	2	600ns			my $self = shift;
145	2	700ns			my $dsn_str = shift;
146	2	400ns			croak "parse_dsn(): usage error" unless $dsn_str;
147
148	2	492µs			require Text::Abbrev;
149	2	4µs	2	80µs	my $abbrev = Text::Abbrev::abbrev( "driver", "serializer", "id" ); # spent 80µs making 2 calls to Text::Abbrev::abbrev, avg 40µs/call
150	8	16µs			my %dsn_map = map { split /:/ } (split /;/, $dsn_str);
151	2	12µs			my %dsn = map { $abbrev->{lc $_}, lc $dsn_map{$_} } keys %dsn_map;
152	2	12µs			return \%dsn;
153					}
154
155					sub query {
156					my $self = shift;
157
158					if ( $self->{_QUERY} ) {
159					return $self->{_QUERY};
160					}
161					# require CGI::Session::Query;
162					# return $self->{_QUERY} = CGI::Session::Query->new();
163					require CGI;
164					return $self->{_QUERY} = CGI->new();
165					}
166
167
168					sub name {
169					my $self = shift;
170					my $name = shift;
171
172					if (ref $self) {
173					unless ( defined $name ) {
174					return $self->{_NAME} \|\| $CGI::Session::NAME;
175					}
176					return $self->{_NAME} = $name;
177					}
178
179					$CGI::Session::NAME = $name if defined $name;
180					return $CGI::Session::NAME;
181					}
182
183
184					sub dump {
185					my $self = shift;
186
187					require Data::Dumper;
188					my $d = Data::Dumper->new([$self], [ref $self]);
189					$d->Deepcopy(1);
190					return $d->Dump();
191					}
192
193
194					# spent 10µs within CGI::Session::_set_status which was called 3 times, avg 3µs/call: # 2 times (7µs+0s) by CGI::Session::load at line 774, avg 4µs/call # once (3µs+0s) by CGI::Session::param at line 313 sub _set_status {
195	3	2µs			my $self = shift;
196	3	800ns			croak "_set_status(): usage error" unless @_;
197	3	11µs			$self->{_STATUS} \|= $_[0];
198					}
199
200
201					# spent 10µs within CGI::Session::_unset_status which was called 2 times, avg 5µs/call: # 2 times (10µs+0s) by CGI::Session::flush at line 253, avg 5µs/call sub _unset_status {
202	2	1µs			my $self = shift;
203	2	1µs			croak "_unset_status(): usage error" unless @_;
204	2	8µs			$self->{_STATUS} &= ~$_[0];
205					}
206
207
208					sub _reset_status {
209					$_[0]->{_STATUS} = STATUS_UNSET;
210					}
211
212					# spent 25µs within CGI::Session::_test_status which was called 26 times, avg 946ns/call: # 20 times (19µs+0s) by CGI::Session::param at line 264, avg 965ns/call # 2 times (2µs+0s) by CGI::Session::flush at line 230, avg 1µs/call # 2 times (2µs+0s) by CGI::Session::flush at line 238, avg 800ns/call # 2 times (1µs+0s) by CGI::Session::flush at line 246, avg 650ns/call sub _test_status {
213	26	48µs			return $_[0]->{_STATUS} & $_[1];
214					}
215
216
217					# spent 2.18ms (82µs+2.09) within CGI::Session::flush which was called 2 times, avg 1.09ms/call: # 2 times (82µs+2.09ms) by CGI::Session::DESTROY at line 92, avg 1.09ms/call sub flush {
218	2	800ns			my $self = shift;
219
220					# Would it be better to die or err if something very basic is wrong here?
221					# I'm trying to address the DESTROY related warning
222					# from: http://rt.cpan.org/Ticket/Display.html?id=17541
223					# return unless defined $self;
224
225	2	4µs	2	14µs	return unless $self->id; # <-- empty session # spent 14µs making 2 calls to CGI::Session::id, avg 7µs/call
226
227					# neither new, nor deleted nor modified
228	2	2µs			return if !defined($self->{_STATUS}) or $self->{_STATUS} == STATUS_UNSET;
229
230	2	3µs	2	2µs	if ( $self->_test_status(STATUS_NEW) && $self->_test_status(STATUS_DELETED) ) { # spent 2µs making 2 calls to CGI::Session::_test_status, avg 1µs/call
231					$self->{_DATA} = {};
232					return $self->_unset_status(STATUS_NEW \| STATUS_DELETED);
233					}
234
235	2	3µs	2	5µs	my $driver = $self->_driver(); # spent 5µs making 2 calls to CGI::Session::_driver, avg 2µs/call
236	2	3µs	2	4µs	my $serializer = $self->_serializer(); # spent 4µs making 2 calls to CGI::Session::_serializer, avg 2µs/call
237
238	2	2µs	2	2µs	if ( $self->_test_status(STATUS_DELETED) ) { # spent 2µs making 2 calls to CGI::Session::_test_status, avg 800ns/call
239					defined($driver->remove($self->id)) or
240					return $self->set_error( "flush(): couldn't remove session data: " . $driver->errstr );
241					$self->{_DATA} = {}; # <-- removing all the data, making sure
242					# it won't be accessible after flush()
243					return $self->_unset_status(STATUS_DELETED);
244					}
245
246	2	4µs	2	1µs	if ( $self->_test_status(STATUS_NEW \| STATUS_MODIFIED) ) { # spent 1µs making 2 calls to CGI::Session::_test_status, avg 650ns/call
247	2	8µs	4	169µs	my $datastr = $serializer->freeze( $self->dataref ); # spent 167µs making 2 calls to CGI::Session::Serialize::yaml::freeze, avg 84µs/call # spent 2µs making 2 calls to CGI::Session::dataref, avg 750ns/call
248	2	800ns			unless ( defined $datastr ) {
249					return $self->set_error( "flush(): couldn't freeze data: " . $serializer->errstr );
250					}
251	2	8µs	4	1.89ms	defined( $driver->store($self->id, $datastr) ) or # spent 1.88ms making 2 calls to CGI::Session::Driver::mysql::store, avg 938µs/call # spent 11µs making 2 calls to CGI::Session::id, avg 6µs/call
252					return $self->set_error( "flush(): couldn't store datastr: " . $driver->errstr);
253	2	9µs	2	10µs	$self->_unset_status(STATUS_NEW \| STATUS_MODIFIED); # spent 10µs making 2 calls to CGI::Session::_unset_status, avg 5µs/call
254					}
255	2	6µs			return 1;
256					}
257
258					sub trace {}
259					sub tracemsg {}
260
261					# spent 114µs (91+23) within CGI::Session::param which was called 20 times, avg 6µs/call: # 11 times (34µs+7µs) by C4::Auth::checkauth at line 798 of C4/Auth.pm, avg 4µs/call # once (22µs+6µs) by C4::Auth::checkauth at line 888 of C4/Auth.pm # once (8µs+2µs) by C4::Auth::checkauth at line 797 of C4/Auth.pm # once (7µs+3µs) by C4::Search::History::get_from_session at line 204 of C4/Search/History.pm # once (4µs+1µs) by C4::Auth::checkauth at line 806 of C4/Auth.pm # once (4µs+900ns) by C4::Auth::checkauth at line 810 of C4/Auth.pm # once (3µs+800ns) by C4::Auth::checkauth at line 807 of C4/Auth.pm # once (3µs+700ns) by C4::Auth::checkauth at line 811 of C4/Auth.pm # once (3µs+700ns) by C4::Auth::checkauth at line 808 of C4/Auth.pm # once (3µs+700ns) by C4::Auth::checkauth at line 813 of C4/Auth.pm sub param {
262	20	10µs			my ($self, @args) = @_;
263
264	20	19µs	20	19µs	if ($self->_test_status( STATUS_DELETED )) { # spent 19µs making 20 calls to CGI::Session::_test_status, avg 965ns/call
265					carp "param(): attempt to read/write deleted session";
266					}
267
268					# USAGE: $s->param();
269					# DESC: Returns all the /public/ parameters
270	20	50µs			if (@args == 0) {
271					return grep { !/^_SESSION_/ } keys %{ $self->{_DATA} };
272					}
273					# USAGE: $s->param( $p );
274					# DESC: returns a specific session parameter
275					elsif (@args == 1) {
276					return $self->{_DATA}->{ $args[0] }
277					}
278
279
280					# USAGE: $s->param( -name => $n, -value => $v );
281					# DESC: Updates session data using CGI.pm's 'named param' syntax.
282					# Only public records can be set!
283	1	1µs			my %args = @args;
284	1	900ns			my ($name, $value) = @args{ qw(-name -value) };
285	1	400ns			if (defined $name && defined $value) {
286					if ($name =~ m/^_SESSION_/) {
287
288					carp "param(): attempt to write to private parameter";
289					return undef;
290					}
291					$self->_set_status( STATUS_MODIFIED );
292					return $self->{_DATA}->{ $name } = $value;
293					}
294
295					# USAGE: $s->param(-name=>$n);
296					# DESC: access to session data (public & private) using CGI.pm's 'named parameter' syntax.
297	1	600ns			return $self->{_DATA}->{ $args{'-name'} } if defined $args{'-name'};
298
299					# USAGE: $s->param($name, $value);
300					# USAGE: $s->param($name1 => $value1, $name2 => $value2 [,...]);
301					# DESC: updates one or more public records using simple syntax
302	1	900ns			if ((@args % 2) == 0) {
303	1	400ns			my $modified_cnt = 0;
304					ARG_PAIR:
305	1	3µs			while (my ($name, $val) = each %args) {
306	1	4µs	1	1µs	if ( $name =~ m/^_SESSION_/) { # spent 1µs making 1 call to CGI::Session::CORE:match
307					carp "param(): attempt to write to private parameter";
308					next ARG_PAIR;
309					}
310	1	1µs			$self->{_DATA}->{ $name } = $val;
311	1	400ns			++$modified_cnt;
312					}
313	1	2µs	1	3µs	$self->_set_status(STATUS_MODIFIED); # spent 3µs making 1 call to CGI::Session::_set_status
314	1	4µs			return $modified_cnt;
315					}
316
317					# If we reached this far none of the expected syntax were
318					# detected. Syntax error
319					croak "param(): usage error. Invalid syntax";
320					}
321
- -
324					sub delete { $_[0]->_set_status( STATUS_DELETED ) }
325
326
327	1	400ns			*header = \&http_header;
328	1	600ns			my $avoid_single_use_warning_again = *header;
329					sub http_header {
330					my $self = shift;
331					return $self->query->header(-cookie=>$self->cookie, -type=>'text/html', @_);
332					}
333
334					sub cookie {
335					my $self = shift;
336
337					my $query = $self->query();
338					my $cookie= undef;
339
340					if ( $self->is_expired ) {
341					$cookie = $query->cookie( -name=>$self->name, -value=>$self->id, -expires=> '-1d', @_ );
342					}
343					elsif ( my $t = $self->expire ) {
344					$cookie = $query->cookie( -name=>$self->name, -value=>$self->id, -expires=> '+' . $t . 's', @_ );
345					}
346					else {
347					$cookie = $query->cookie( -name=>$self->name, -value=>$self->id, @_ );
348					}
349					return $cookie;
350					}
351
- -
356					sub save_param {
357					my $self = shift;
358					my ($query, $params) = @_;
359
360					$query \|\|= $self->query();
361					$params \|\|= [ $query->param ];
362
363					for my $p ( @$params ) {
364					my @values = $query->param($p) or next;
365					if ( @values > 1 ) {
366					$self->param($p, \@values);
367					} else {
368					$self->param($p, $values[0]);
369					}
370					}
371					$self->_set_status( STATUS_MODIFIED );
372					}
373
- -
376					sub load_param {
377					my $self = shift;
378					my ($query, $params) = @_;
379
380					$query \|\|= $self->query();
381					$params \|\|= [ $self->param ];
382
383					for ( @$params ) {
384					$query->param(-name=>$_, -value=>$self->param($_));
385					}
386					}
387
388
389					sub clear {
390					my $self = shift;
391					my $params = shift;
392					#warn ref($params);
393					if (defined $params) {
394					$params = [ $params ] unless ref $params;
395					}
396					else {
397					$params = [ $self->param ];
398					}
399
400					for ( grep { ! /^_SESSION_/ } @$params ) {
401					delete $self->{_DATA}->{$_};
402					}
403					$self->_set_status( STATUS_MODIFIED );
404					}
405
406
407					sub find {
408					my $class = shift;
409					my ($dsn, $coderef, $dsn_args);
410
411					# find( \%code )
412					if ( @_ == 1 ) {
413					$coderef = $_[0];
414					}
415					# find( $dsn, \&code, \%dsn_args )
416					else {
417					($dsn, $coderef, $dsn_args) = @_;
418					}
419
420					unless ( $coderef && ref($coderef) && (ref $coderef eq 'CODE') ) {
421					croak "find(): usage error.";
422					}
423
424					my $driver;
425					if ( $dsn ) {
426					my $hashref = $class->parse_dsn( $dsn );
427					$driver = $hashref->{driver};
428					}
429					$driver \|\|= "file";
430					my $pm = "CGI::Session::Driver::" . ($driver =~ /(.*)/)[0];
431					eval "require $pm";
432					if (my $errmsg = $@ ) {
433					return $class->set_error( "find(): couldn't load driver." . $errmsg );
434					}
435
436					my $driver_obj = $pm->new( $dsn_args );
437					unless ( $driver_obj ) {
438					return $class->set_error( "find(): couldn't create driver object. " . $pm->errstr );
439					}
440
441					# Read-only isn't the perfect name here. In read-only mode, we skip the ip_match check,
442					# and don't update the atime. We do still delete expired sessions and session params.
443					my $read_only = 1;
444					my $driver_coderef = sub {
445					my ($sid) = @_;
446					my $session = $class->load( $dsn, $sid, $dsn_args, $read_only );
447					unless ( $session ) {
448					return $class->set_error( "find(): couldn't load session '$sid'. " . $class->errstr );
449					}
450					$coderef->( $session );
451					};
452
453					defined($driver_obj->traverse( $driver_coderef ))
454					or return $class->set_error( "find(): traverse seems to have failed. " . $driver_obj->errstr );
455					return 1;
456					}
457
458					# $Id$
459
460					=pod
461
462					=head1 NAME
463
464					CGI::Session - persistent session data in CGI applications
465
466					=head1 SYNOPSIS
467
468					# Object initialization:
469					use CGI::Session;
470					$session = CGI::Session->new();
471
472					$CGISESSID = $session->id();
473
474					# Send proper HTTP header with cookies:
475					print $session->header();
476
477					# Storing data in the session:
478					$session->param('f_name', 'Sherzod');
479					# or
480					$session->param(-name=>'l_name', -value=>'Ruzmetov');
481
482					# Flush the data from memory to the storage driver at least before your
483					# program finishes since auto-flushing can be unreliable.
484					$session->flush();
485
486					# Retrieving data:
487					my $f_name = $session->param('f_name');
488					# or
489					my $l_name = $session->param(-name=>'l_name');
490
491					# Clearing a certain session parameter:
492					$session->clear(["l_name", "f_name"]);
493
494					# Expire '_is_logged_in' flag after 10 idle minutes:
495					$session->expire('is_logged_in', '+10m')
496
497					# Expire the session itself after 1 idle hour:
498					$session->expire('+1h');
499
500					# Delete the session for good:
501					$session->delete();
502					$session->flush(); # Recommended practice says use flush() after delete().
503
504					=head1 DESCRIPTION
505
506					CGI::Session provides an easy, reliable and modular session management system across HTTP requests.
507
508					=head1 METHODS
509
510					Following is the overview of all the available methods accessible via CGI::Session object.
511
512					=head2 new()
513
514					=head2 new( $sid )
515
516					=head2 new( $query )
517
518					=head2 new( $dsn, $query\|\|$sid )
519
520					=head2 new( $dsn, $query\|\|$sid, \%dsn_args )
521
522					=head2 new( $dsn, $query\|\|$sid, \%dsn_args, \%session_params )
523
524					Constructor. Returns new session object, or undef on failure. Error message is accessible through L<errstr() - class method\|CGI::Session::ErrorHandler/"errstr()">. If called on an already initialized session will re-initialize the session based on already configured object. This is only useful after a call to L<load()\|/"load()">.
525
526					Can accept up to three arguments, $dsn - Data Source Name, $query\|\|$sid - query object OR a string representing session id, and finally, \%dsn_args, arguments used by $dsn components.
527
528					If called without any arguments, $dsn defaults to I<driver:file;serializer:default;id:md5>, $query\|\|$sid defaults to C<< CGI->new() >>, and C<\%dsn_args> defaults to I<undef>.
529
530					If called with a single argument, it will be treated either as C<$query> object, or C<$sid>, depending on its type. If argument is a string , C<new()> will treat it as session id and will attempt to retrieve the session from data store. If it fails, will create a new session id, which will be accessible through L<id() method\|/"id">. If argument is an object, L<cookie()\|CGI/cookie> and L<param()\|CGI/param> methods will be called on that object to recover a potential C<$sid> and retrieve it from data store. If it fails, C<new()> will create a new session id, which will be accessible through L<id() method\|/"id">. C<name()> will define the name of the query parameter and/or cookie name to be requested, defaults to I<CGISESSID>.
531
532					If called with two arguments first will be treated as $dsn, and second will be treated as $query or $sid or undef, depending on its type. Some examples of this syntax are:
533
534					$s = CGI::Session->new("driver:mysql", undef);
535					$s = CGI::Session->new("driver:sqlite", $sid);
536					$s = CGI::Session->new("driver:db_file", $query);
537					$s = CGI::Session->new("serializer:storable;id:incr", $sid);
538					# etc...
539
540					Briefly, C<new()> will return an initialized session object with a valid id, whereas C<load()> may return
541					an empty session object with an undefined id.
542
543					Tests are provided (t/new_with_undef.t and t/load_with_undef.t) to clarify the result of calling C<new()> and C<load()>
544					with undef, or with an initialized CGI object with an undefined or fake CGISESSID.
545
546					You are strongly advised to run the old-fashioned 'make test TEST_FILES=t/new_with_undef.t TEST_VERBOSE=1'
547					or the new-fangled 'prove -v t/new_with_undef.t', for both new.t and load.t, and examine the output.
548
549					Following data source components are supported:
550
551					=over 4
552
553					=item *
554
555					B<driver> - CGI::Session driver. Available drivers are L<file\|CGI::Session::Driver::file>, L<db_file\|CGI::Session::Driver::db_file>, L<mysql\|CGI::Session::Driver::mysql> and L<sqlite\|CGI::Session::Driver::sqlite>. Third party drivers are welcome. For driver specs consider L<CGI::Session::Driver\|CGI::Session::Driver>
556
557					=item *
558
559					B<serializer> - serializer to be used to encode the data structure before saving
560					in the disk. Available serializers are L<storable\|CGI::Session::Serialize::storable>, L<freezethaw\|CGI::Session::Serialize::freezethaw> and L<default\|CGI::Session::Serialize::default>. Default serializer will use L<Data::Dumper\|Data::Dumper>.
561
562					=item *
563
564					B<id> - ID generator to use when new session is to be created. Available ID generator is L<md5\|CGI::Session::ID::md5>
565
566					=back
567
568					For example, to get CGI::Session store its data using DB_File and serialize data using FreezeThaw:
569
570					$s = CGI::Session->new("driver:DB_File;serializer:FreezeThaw", undef);
571
572					If called with three arguments, first two will be treated as in the previous example, and third argument will be C<\%dsn_args>, which will be passed to C<$dsn> components (namely, driver, serializer and id generators) for initialization purposes. Since all the $dsn components must initialize to some default value, this third argument should not be required for most drivers to operate properly.
573
574					If called with four arguments, the first three match previous examples. The fourth argument must be a hash reference with parameters to be used by the CGI::Session object. (see \%session_params above )
575
576					The following is a list of the current keys:
577
578					=over
579
580					=item *
581
582					B<name> - Name to use for the cookie/query parameter name. This defaults to CGISESSID. This can be altered or accessed by the C<name> accessor.
583
584					=back
585
586					undef is acceptable as a valid placeholder to any of the above arguments, which will force default behavior.
587
588					=head2 load()
589
590					=head2 load( $query\|\|$sid )
591
592					=head2 load( $dsn, $query\|\|$sid )
593
594					=head2 load( $dsn, $query, \%dsn_args )
595
596					=head2 load( $dsn, $query, \%dsn_args, \%session_params )
597
598					Accepts the same arguments as new(), and also returns a new session object, or
599					undef on failure. The difference is, L<new()\|/"new()"> can create a new session if
600					it detects expired and non-existing sessions, but C<load()> does not.
601
602					C<load()> is useful to detect expired or non-existing sessions without forcing the library to create new sessions. So now you can do something like this:
603
604					$s = CGI::Session->load() or die CGI::Session->errstr();
605					if ( $s->is_expired ) {
606					print $s->header(),
607					$cgi->start_html(),
608					$cgi->p("Your session timed out! Refresh the screen to start new session!")
609					$cgi->end_html();
610					exit(0);
611					}
612
613					if ( $s->is_empty ) {
614					$s = $s->new() or die $s->errstr;
615					}
616
617					Notice: All I<expired> sessions are empty, but not all I<empty> sessions are expired!
618
619					Briefly, C<new()> will return an initialized session object with a valid id, whereas C<load()> may return
620					an empty session object with an undefined id.
621
622					Tests are provided (t/new_with_undef.t and t/load_with_undef.t) to clarify the result of calling C<new()> and C<load()>
623					with undef, or with an initialized CGI object with an undefined or fake CGISESSID.
624
625					You are strongly advised to run the old-fashioned 'make test TEST_FILES=t/new_with_undef.t TEST_VERBOSE=1'
626					or the new-fangled 'prove -v t/new_with_undef.t', for both new.t and load.t, and examine the output.
627
628					=cut
629
630					# pass a true value as the fourth parameter if you want to skip the changing of
631					# access time This isn't documented more formally, because it only called by
632					# find().
633					# spent 5.18ms (217µs+4.96) within CGI::Session::load which was called 2 times, avg 2.59ms/call: # 2 times (217µs+4.96ms) by CGI::Session::new at line 61, avg 2.59ms/call sub load {
634	2	900ns			my $class = shift;
635	2	700ns			return $class->set_error( "called as instance method") if ref $class;
636	2	2µs			return $class->set_error( "Too many arguments provided to load()") if @_ > 5;
637
638	2	20µs			my $self = bless {
639					_DATA => {
640					_SESSION_ID => undef,
641					_SESSION_CTIME => undef,
642					_SESSION_ATIME => undef,
643					_SESSION_REMOTE_ADDR => $ENV{REMOTE_ADDR} \|\| "",
644					#
645					# Following two attributes may not exist in every single session, and declaring
646					# them now will force these to get serialized into database, wasting space. But they
647					# are here to remind the coder of their purpose
648					#
649					# _SESSION_ETIME => undef,
650					# _SESSION_EXPIRE_LIST => {}
651					}, # session data
652					_DSN => {}, # parsed DSN params
653					_OBJECTS => {}, # keeps necessary objects
654					_DRIVER_ARGS=> {}, # arguments to be passed to driver
655					_CLAIMED_ID => undef, # id claimed by client
656					_STATUS => STATUS_UNSET,# status of the session object
657					_QUERY => undef # query object
658					}, $class;
659
660	2	1µs			my ($dsn,$query_or_sid,$dsn_args,$read_only,$params);
661					# load($query\|\|$sid)
662	2	2µs			if ( @_ == 1 ) {
663					$self->_set_query_or_sid($_[0]);
664					}
665					# Two or more args passed:
666					# load($dsn, $query\|\|$sid)
667					elsif ( @_ > 1 ) {
668	2	2µs			($dsn, $query_or_sid, $dsn_args,$read_only) = @_;
669
670					# Make it backwards-compatible (update_atime is an undocumented key in %$params).
671					# In fact, update_atime as a key is not used anywhere in the code as yet.
672					# This patch is part of the patch for RT#33437.
673	2	600ns			if ( ref $read_only and ref $read_only eq 'HASH' ) {
674					$params = {%$read_only};
675					$read_only = $params->{'read_only'};
676
677					if ($params->{'name'}) {
678					$self->{_NAME} = $params->{'name'};
679					}
680					}
681
682					# Since $read_only is not part of the public API
683					# we ignore any value but the one we use internally: 1.
684	2	600ns			if (defined $read_only and $read_only != '1') {
685					return $class->set_error( "Too many arguments to load(). First extra argument was: $read_only");
686					}
687
688	2	13µs	2	650µs	if ( defined $dsn ) { # <-- to avoid 'Uninitialized value...' warnings # spent 650µs making 2 calls to CGI::Session::parse_dsn, avg 325µs/call
689					$self->{_DSN} = $self->parse_dsn($dsn);
690					}
691	2	4µs	2	7µs	$self->_set_query_or_sid($query_or_sid); # spent 7µs making 2 calls to CGI::Session::_set_query_or_sid, avg 4µs/call
692
693					# load($dsn, $query, \%dsn_args);
694
695	2	1µs			$self->{_DRIVER_ARGS} = $dsn_args if defined $dsn_args;
696
697					}
698
699	2	5µs	2	3.36ms	$self->_load_pluggables(); # spent 3.36ms making 2 calls to CGI::Session::_load_pluggables, avg 1.68ms/call
700
701					# Did load_pluggable fail? If so, return undef, just like $class->set_error() would
702	2	8µs	2	9µs	return undef if $class->errstr; # spent 9µs making 2 calls to CGI::Session::ErrorHandler::errstr, avg 5µs/call
703
704	2	2µs			if (not defined $self->{_CLAIMED_ID}) {
705					my $query = $self->query();
706					eval {
707					$self->{_CLAIMED_ID} = $query->cookie( $self->name ) \|\| $query->param( $self->name );
708					};
709					if ( my $errmsg = $@ ) {
710					return $class->set_error( "query object $query does not support cookie() and param() methods: " . $errmsg );
711					}
712					}
713
714					# No session is being requested. Just return an empty session
715	2	800ns			return $self unless $self->{_CLAIMED_ID};
716
717					# Attempting to load the session
718	2	13µs	2	97µs	my $driver = $self->_driver(); # spent 97µs making 2 calls to CGI::Session::_driver, avg 48µs/call
719	2	8µs	2	479µs	my $raw_data = $driver->retrieve( $self->{_CLAIMED_ID} ); # spent 479µs making 2 calls to CGI::Session::Driver::DBI::retrieve, avg 240µs/call
720	2	800ns			unless ( defined $raw_data ) {
721					return $self->set_error( "load(): couldn't retrieve data: " . $driver->errstr );
722					}
723
724					# Requested session couldn't be retrieved
725	2	400ns			return $self unless $raw_data;
726
727	2	5µs	2	10µs	my $serializer = $self->_serializer(); # spent 10µs making 2 calls to CGI::Session::_serializer, avg 5µs/call
728	2	10µs	2	340µs	$self->{_DATA} = $serializer->thaw($raw_data); # spent 340µs making 2 calls to CGI::Session::Serialize::yaml::thaw, avg 170µs/call
729	2	2µs			unless ( defined $self->{_DATA} ) {
730					#die $raw_data . "\n";
731					return $self->set_error( "load(): couldn't thaw() data using $serializer:" .
732					$serializer->errstr );
733					}
734	2	5µs			unless (defined($self->{_DATA}) && ref ($self->{_DATA}) && (ref $self->{_DATA} eq 'HASH') &&
735					defined($self->{_DATA}->{_SESSION_ID}) ) {
736					return $self->set_error( "Invalid data structure returned from thaw()" );
737					}
738
739
740					# checking for expiration ticker
741	2	2µs			if ( $self->{_DATA}->{_SESSION_ETIME} ) {
742					if ( ($self->{_DATA}->{_SESSION_ATIME} + $self->{_DATA}->{_SESSION_ETIME}) <= time() ) {
743					$self->_set_status( STATUS_EXPIRED \| # <-- so client can detect expired sessions
744					STATUS_DELETED ); # <-- session should be removed from database
745					$self->flush(); # <-- flush() will do the actual removal!
746					return $self;
747					}
748					}
749
750					# checking expiration tickers of individuals parameters, if any:
751	2	2µs			my @expired_params = ();
752	2	1µs			if ( $self->{_DATA}->{_SESSION_EXPIRE_LIST} ) {
753					while (my ($param, $max_exp_interval) = each %{ $self->{_DATA}->{_SESSION_EXPIRE_LIST} } ) {
754					if ( ($self->{_DATA}->{_SESSION_ATIME} + $max_exp_interval) <= time() ) {
755					push @expired_params, $param;
756					}
757					}
758					}
759	2	1µs			$self->clear(\@expired_params) if @expired_params;
760
- -
763	2	1µs			if (not defined $read_only) {
764					# checking if previous session ip matches current ip
765	2	1µs			if($CGI::Session::IP_MATCH) {
766					unless($self->ip_matches) {
767					$self->_set_status( STATUS_DELETED );
768					$self->flush;
769					return $self;
770					}
771					}
772
773	2	2µs			$self->{_DATA}->{_SESSION_ATIME} = time(); # <-- updating access time
774	2	6µs	2	7µs	$self->_set_status( STATUS_MODIFIED ); # <-- access time modified above # spent 7µs making 2 calls to CGI::Session::_set_status, avg 4µs/call
775					}
776
777	2	8µs			return $self;
778					}
779
780
781					# set the input as a query object or session ID, depending on what it looks like.
782					# spent 7µs within CGI::Session::_set_query_or_sid which was called 2 times, avg 4µs/call: # 2 times (7µs+0s) by CGI::Session::load at line 691, avg 4µs/call sub _set_query_or_sid {
783	2	800ns			my $self = shift;
784	2	1µs			my $query_or_sid = shift;
785	2	8µs			if ( ref $query_or_sid){ $self->{_QUERY} = $query_or_sid }
786	2	2µs			else { $self->{_CLAIMED_ID} = $query_or_sid }
787					}
788
789
790					# spent 3.36ms (1.43+1.94) within CGI::Session::_load_pluggables which was called 2 times, avg 1.68ms/call: # 2 times (1.43ms+1.94ms) by CGI::Session::load at line 699, avg 1.68ms/call sub _load_pluggables {
791	2	1µs			my ($self) = @_;
792
793	2	4µs			my %DEFAULT_FOR = (
794					driver => "file",
795					serializer => "default",
796					id => "md5",
797					);
798	2	2µs			my %SUBDIR_FOR = (
799					driver => "Driver",
800					serializer => "Serialize",
801					id => "ID",
802					);
803	2	1µs			my $dsn = $self->{_DSN};
804	2	2µs			for my $plug (qw(driver serializer id)) {
805	6	5µs			my $mod_name = $dsn->{ $plug };
806	6	2µs			if (not defined $mod_name) {
807					$mod_name = $DEFAULT_FOR{ $plug };
808					}
809	6	49µs	6	22µs	if ($mod_name =~ /^(\w+)$/) { # spent 22µs making 6 calls to CGI::Session::CORE:match, avg 4µs/call
810
811					# Looks good. Put it into the dsn hash
812	6	13µs			$dsn->{ $plug } = $mod_name = $1;
813
814					# Put together the actual module name to load
815	6	7µs			my $prefix = join '::', (__PACKAGE__, $SUBDIR_FOR{ $plug }, q{});
816	6	5µs			$mod_name = $prefix . $mod_name;
817
818					## See if we can load load it
819	6	220µs			eval "require $mod_name"; # spent 120µs executing statements in 2 string evals (merged) # spent 112µs executing statements in 2 string evals (merged) # spent 95µs executing statements in 2 string evals (merged)
820	6	2µs			if ($@) {
821					my $msg = $@;
822					return $self->set_error("couldn't load $mod_name: " . $msg);
823					}
824					}
825					else {
826					# do something here about bad name for a pluggable
827					}
828					}
829	2	12µs			return;
830					}
831
832					=pod
833
834					=head2 id()
835
836					Returns effective ID for a session. Since effective ID and claimed ID can differ, valid session id should always
837					be retrieved using this method.
838
839					=head2 param($name)
840
841					=head2 param(-name=E<gt>$name)
842
843					Used in either of the above syntax returns a session parameter set to $name or undef if it doesn't exist. If it's called on a deleted method param() will issue a warning but return value is not defined.
844
845					=head2 param($name, $value)
846
847					=head2 param(-name=E<gt>$name, -value=E<gt>$value)
848
849					Used in either of the above syntax assigns a new value to $name parameter,
850					which can later be retrieved with previously introduced param() syntax. C<$value>
851					may be a scalar, arrayref or hashref.
852
853					Attempts to set parameter names that start with I<_SESSION_> will trigger
854					a warning and undef will be returned.
855
856					=head2 param_hashref()
857
858					B<Deprecated>. Use L<dataref()\|/"dataref()"> instead.
859
860					=head2 dataref()
861
862					Returns reference to session's data table:
863
864					$params = $s->dataref();
865					$sid = $params->{_SESSION_ID};
866					$name= $params->{name};
867					# etc...
868
869					Useful for having all session data in a hashref, but too risky to update.
870
871					=head2 save_param()
872
873					=head2 save_param($query)
874
875					=head2 save_param($query, \@list)
876
877					Saves query parameters to session object. In other words, it's the same as calling L<param($name, $value)\|/"param($name)"> for every single query parameter returned by C<< $query->param() >>. The first argument, if present, should be either CGI object or any object which can provide param() method. If it's undef, defaults to the return value of L<query()\|/"query()">, which returns C<< CGI->new >>. If second argument is present and is a reference to an array, only those query parameters found in the array will be stored in the session. undef is a valid placeholder for any argument to force default behavior.
878
879					=head2 load_param()
880
881					=head2 load_param($query)
882
883					=head2 load_param($query, \@list)
884
885					Loads session parameters into a query object. The first argument, if present, should be query object, or any other object which can provide param() method. If second argument is present and is a reference to an array, only parameters found in that array will be loaded to the query object.
886
887					=head2 clear()
888
889					=head2 clear('field')
890
891					=head2 clear(\@list)
892
893					Clears parameters from the session object.
894
895					With no parameters, all fields are cleared. If passed a single parameter or a
896					reference to an array, only the named parameters are cleared.
897
898					=head2 flush()
899
900					Synchronizes data in memory with the copy serialized by the driver. Call flush()
901					if you need to access the session from outside the current session object. You should
902					call flush() sometime before your program exits.
903
904					As a last resort, CGI::Session will automatically call flush for you just
905					before the program terminates or session object goes out of scope. Automatic
906					flushing has proven to be unreliable, and in some cases is now required
907					in places that worked with CGI::Session 3.x.
908
909					Always explicitly calling C<flush()> on the session before the
910					program exits is recommended. For extra safety, call it immediately after
911					every important session update.
912
913					Also see L<A Warning about Auto-flushing>
914
915					=head2 atime()
916
917					Read-only method. Returns the last access time of the session in seconds from epoch. This time is used internally while
918					auto-expiring sessions and/or session parameters.
919
920					=head2 ctime()
921
922					Read-only method. Returns the time when the session was first created in seconds from epoch.
923
924					=head2 expire()
925
926					=head2 expire($time)
927
928					=head2 expire($param, $time)
929
930					Sets expiration interval relative to L<atime()\|/"atime()">.
931
932					If used with no arguments, returns the expiration interval if it was ever set. If no expiration was ever set, returns undef. For backwards compatibility, a method named C<etime()> does the same thing.
933
934					Second form sets an expiration time. This value is checked when previously stored session is asked to be retrieved, and if its expiration interval has passed, it will be expunged from the disk immediately. Passing 0 cancels expiration.
935
936					By using the third syntax you can set the expiration interval for a particular
937					session parameter, say I<~logged-in>. This would cause the library call clear()
938					on the parameter when its time is up. Note it only makes sense to set this value to
939					something I<earlier> than when the whole session expires. Passing 0 cancels expiration.
940
941					All the time values should be given in the form of seconds. Following keywords are also supported for your convenience:
942
943					+-----------+---------------+
944					\| alias \| meaning \|
945					+-----------+---------------+
946					\| s \| Second \|
947					\| m \| Minute \|
948					\| h \| Hour \|
949					\| d \| Day \|
950					\| w \| Week \|
951					\| M \| Month \|
952					\| y \| Year \|
953					+-----------+---------------+
954
955					Examples:
956
957					$session->expire("2h"); # expires in two hours
958					$session->expire(0); # cancel expiration
959					$session->expire("~logged-in", "10m"); # expires '~logged-in' parameter after 10 idle minutes
960
961					Note: all the expiration times are relative to session's last access time, not to its creation time. To expire a session immediately, call L<delete()\|/"delete">. To expire a specific session parameter immediately, call L<clear([$name])\|/"clear">.
962
963					=cut
964
965	1	300ns			*expires = \&expire;
966	1	400ns			my $prevent_warning = \&expires;
967					sub etime { $_[0]->expire() }
968					sub expire {
969					my $self = shift;
970
971					# no params, just return the expiration time.
972					if (not @_) {
973					return $self->{_DATA}->{_SESSION_ETIME};
974					}
975					# We have just a time
976					elsif ( @_ == 1 ) {
977					my $time = $_[0];
978					# If 0 is passed, cancel expiration
979					if ( defined $time && ($time =~ m/^\d$/) && ($time == 0) ) {
980					$self->{_DATA}->{_SESSION_ETIME} = undef;
981					$self->_set_status( STATUS_MODIFIED );
982					}
983					# set the expiration to this time
984					else {
985					$self->{_DATA}->{_SESSION_ETIME} = $self->_str2seconds( $time );
986					$self->_set_status( STATUS_MODIFIED );
987					}
988					}
989					# If we get this far, we expect expire($param,$time)
990					# ( This would be a great use of a Perl6 multi sub! )
991					else {
992					my ($param, $time) = @_;
993					if ( ($time =~ m/^\d$/) && ($time == 0) ) {
994					delete $self->{_DATA}->{_SESSION_EXPIRE_LIST}->{ $param };
995					$self->_set_status( STATUS_MODIFIED );
996					} else {
997					$self->{_DATA}->{_SESSION_EXPIRE_LIST}->{ $param } = $self->_str2seconds( $time );
998					$self->_set_status( STATUS_MODIFIED );
999					}
1000					}
1001					return 1;
1002					}
1003
1004					# =head2 _str2seconds()
1005					#
1006					# my $secs = $self->_str2seconds('1d')
1007					#
1008					# Takes a CGI.pm-style time representation and returns an equivalent number
1009					# of seconds.
1010					#
1011					# See the docs of expire() for more detail.
1012					#
1013					# =cut
1014
1015					sub _str2seconds {
1016					my $self = shift;
1017					my ($str) = @_;
1018
1019					return unless defined $str;
1020					return $str if $str =~ m/^[-+]?\d+$/;
1021
1022					my %_map = (
1023					s => 1,
1024					m => 60,
1025					h => 3600,
1026					d => 86400,
1027					w => 604800,
1028					M => 2592000,
1029					y => 31536000
1030					);
1031
1032					my ($koef, $d) = $str =~ m/^([+-]?\d+)([smhdwMy])$/;
1033					unless ( defined($koef) && defined($d) ) {
1034					die "_str2seconds(): couldn't parse '$str' into \$koef and \$d parts. Possible invalid syntax";
1035					}
1036					return $koef * $_map{ $d };
1037					}
1038
1039
1040					=pod
1041
1042					=head2 is_new()
1043
1044					Returns true only for a brand new session.
1045
1046					=head2 is_expired()
1047
1048					Tests whether session initialized using L<load()\|/"load"> is to be expired. This method works only on sessions initialized with load():
1049
1050					$s = CGI::Session->load() or die CGI::Session->errstr;
1051					if ( $s->is_expired ) {
1052					die "Your session expired. Please refresh";
1053					}
1054					if ( $s->is_empty ) {
1055					$s = $s->new() or die $s->errstr;
1056					}
1057
1058
1059					=head2 is_empty()
1060
1061					Returns true for sessions that are empty. It's preferred way of testing whether requested session was loaded successfully or not:
1062
1063					$s = CGI::Session->load($sid);
1064					if ( $s->is_empty ) {
1065					$s = $s->new();
1066					}
1067
1068					Actually, the above code is nothing but waste. The same effect could've been achieved by saying:
1069
1070					$s = CGI::Session->new( $sid );
1071
1072					L<is_empty()\|/"is_empty"> is useful only if you wanted to catch requests for expired sessions, and create new session afterwards. See L<is_expired()\|/"is_expired"> for an example.
1073
1074					=head2 ip_match()
1075
1076					Returns true if $ENV{REMOTE_ADDR} matches the remote address stored in the session.
1077
1078					If you have an application where you are sure your users' IPs are constant
1079					during a session, you can consider enabling an option to make this check:
1080
1081					use CGI::Session '-ip_match';
1082
1083					Usually you don't call ip_match() directly, but by using the above method. It is useful
1084					only if you want to call it inside of coderef passed to the L<find()\|/"find( \&code )"> method.
1085
1086					=head2 delete()
1087
1088					Sets the objects status to be "deleted". Subsequent read/write requests on the
1089					same object will fail. To physically delete it from the data store you need to call L<flush()\|/"flush()">.
1090					CGI::Session attempts to do this automatically when the object is being destroyed (usually as
1091					the script exits), but see L<A Warning about Auto-flushing>.
1092
1093					=head2 find( \&code )
1094
1095					=head2 find( $dsn, \&code )
1096
1097					=head2 find( $dsn, \&code, \%dsn_args )
1098
1099					Experimental feature. Executes \&code for every session object stored in disk, passing initialized CGI::Session object as the first argument of \&code. Useful for housekeeping purposes, such as for removing expired sessions. Following line, for instance, will remove sessions already expired, but are still in disk:
1100
1101					The following line, for instance, will remove sessions already expired, but which are still on disk:
1102
1103					CGI::Session->find( sub {} );
1104
1105					Notice, above \&code didn't have to do anything, because load(), which is called to initialize sessions inside L<find()\|/"find( \&code )">, will automatically remove expired sessions. Following example will remove all the objects that are 10+ days old:
1106
1107					CGI::Session->find( \&purge );
1108					sub purge {
1109					my ($session) = @_;
1110					next if $session->is_empty; # <-- already expired?!
1111					if ( ($session->ctime + 3600*240) <= time() ) {
1112					$session->delete();
1113					$session->flush(); # Recommended practice says use flush() after delete().
1114					}
1115					}
1116
1117					B<Note>: find will not change the modification or access times on the sessions it returns.
1118
1119					Explanation of the 3 parameters to C<find()>:
1120
1121					=over 4
1122
1123					=item $dsn
1124
1125					This is the DSN (Data Source Name) used by CGI::Session to control what type of
1126					sessions you previously created and what type of sessions you now wish method
1127					C<find()> to pass to your callback.
1128
1129					The default value is defined above, in the docs for method C<new()>, and is
1130					'driver:file;serializer:default;id:md5'.
1131
1132					Do not confuse this DSN with the DSN arguments mentioned just below, under \%dsn_args.
1133
1134					=item \&code
1135
1136					This is the callback provided by you (i.e. the caller of method C<find()>)
1137					which is called by CGI::Session once for each session found by method C<find()>
1138					which matches the given $dsn.
1139
1140					There is no default value for this coderef.
1141
1142					When your callback is actually called, the only parameter is a session. If you
1143					want to call a subroutine you already have with more parameters, you can
1144					achieve this by creating an anonymous subroutine that calls your subroutine
1145					with the parameters you want. For example:
1146
1147					CGI::Session->find($dsn, sub { my_subroutine( @_, 'param 1', 'param 2' ) } );
1148					CGI::Session->find($dsn, sub { $coderef->( @_, $extra_arg ) } );
1149
1150					Or if you wish, you can define a sub generator as such:
1151
1152					sub coderef_with_args {
1153					my ( $coderef, @params ) = @_;
1154					return sub { $coderef->( @_, @params ) };
1155					}
1156
1157					CGI::Session->find($dsn, coderef_with_args( $coderef, 'param 1', 'param 2' ) );
1158
1159					=item \%dsn_args
1160
1161					If your $dsn uses file-based storage, then this hashref might contain keys such as:
1162
1163					{
1164					Directory => Value 1,
1165					NoFlock => Value 2,
1166					UMask => Value 3
1167					}
1168
1169					If your $dsn uses db-based storage, then this hashref contains (up to) 3 keys, and looks like:
1170
1171					{
1172					DataSource => Value 1,
1173					User => Value 2,
1174					Password => Value 3
1175					}
1176
1177					These 3 form the DSN, username and password used by DBI to control access to your database server,
1178					and hence are only relevant when using db-based sessions.
1179
1180					The default value of this hashref is undef.
1181
1182					=back
1183
1184					B<Note:> find() is meant to be convenient, not necessarily efficient. It's best suited in cron scripts.
1185
1186					=head2 name($new_name)
1187
1188					The $new_name parameter is optional. If supplied it sets the query or cookie parameter name to be used.
1189
1190					It defaults to I<$CGI::Session::NAME>, which defaults to I<CGISESSID>.
1191
1192					You are strongly discouraged from using the global variable I<$CGI::Session::NAME>, since it is
1193					deprecated (as are all global variables) and will be removed in a future version of this module.
1194
1195					Return value: The current query or cookie parameter name.
1196
1197					=head1 MISCELLANEOUS METHODS
1198
1199					=head2 remote_addr()
1200
1201					Returns the remote address of the user who created the session for the first time. Returns undef if variable REMOTE_ADDR wasn't present in the environment when the session was created.
1202
1203					=cut
1204
1205					sub remote_addr { return $_[0]->{_DATA}->{_SESSION_REMOTE_ADDR} }
1206
1207					=pod
1208
1209					=head2 errstr()
1210
1211					Class method. Returns last error message from the library.
1212
1213					=head2 dump()
1214
1215					Returns a dump of the session object. Useful for debugging purposes only.
1216
1217					=head2 header()
1218
1219					A wrapper for C<CGI>'s header() method. Calling this method
1220					is equivalent to something like this:
1221
1222					$cookie = CGI::Cookie->new(-name=>$session->name, -value=>$session->id);
1223					print $cgi->header(-cookie=>$cookie, @_);
1224
1225					You can minimize the above into:
1226
1227					print $session->header();
1228
1229					It will retrieve the name of the session cookie from C<$session->name()> which defaults to C<$CGI::Session::NAME>. If you want to use a different name for your session cookie, do something like this before creating session object:
1230
1231					CGI::Session->name("MY_SID");
1232					$session = CGI::Session->new(undef, $cgi, \%attrs);
1233
1234					Now, $session->header() uses "MY_SID" as the name for the session cookie. For all additional options that can
1235					be passed, see the C<header()> docs in C<CGI>.
1236
1237					=head2 query()
1238
1239					Returns query object associated with current session object. Default query object class is C<CGI>.
1240
1241					=head2 DEPRECATED METHODS
1242
1243					These methods exist solely for for compatibility with CGI::Session 3.x.
1244
1245					=head3 close()
1246
1247					Closes the session. Using flush() is recommended instead, since that's exactly what a call
1248					to close() does now.
1249
1250					=head1 DISTRIBUTION
1251
1252					CGI::Session consists of several components such as L<drivers\|"DRIVERS">, L<serializers\|"SERIALIZERS"> and L<id generators\|"ID GENERATORS">. This section lists what is available.
1253
1254					=head2 DRIVERS
1255
1256					The following drivers are included in the standard distribution:
1257
1258					=over 4
1259
1260					=item *
1261
1262					L<file\|CGI::Session::Driver::file> - default driver for storing session data in plain files. Full name: B<CGI::Session::Driver::file>
1263
1264					=item *
1265
1266					L<db_file\|CGI::Session::Driver::db_file> - for storing session data in BerkelyDB. Requires: L<DB_File>.
1267					Full name: B<CGI::Session::Driver::db_file>
1268
1269					=item *
1270
1271					L<mysql\|CGI::Session::Driver::mysql> - for storing session data in MySQL tables. Requires L<DBI\|DBI> and L<DBD::mysql\|DBD::mysql>.
1272					Full name: B<CGI::Session::Driver::mysql>
1273
1274					=item *
1275
1276					L<sqlite\|CGI::Session::Driver::sqlite> - for storing session data in SQLite. Requires L<DBI\|DBI> and L<DBD::SQLite\|DBD::SQLite>.
1277					Full name: B<CGI::Session::Driver::sqlite>
1278
1279					=back
1280
1281					Other drivers are available from CPAN.
1282
1283					=head2 SERIALIZERS
1284
1285					=over 4
1286
1287					=item *
1288
1289					L<default\|CGI::Session::Serialize::default> - default data serializer. Uses standard L<Data::Dumper\|Data::Dumper>.
1290					Full name: B<CGI::Session::Serialize::default>.
1291
1292					=item *
1293
1294					L<storable\|CGI::Session::Serialize::storable> - serializes data using L<Storable>. Requires L<Storable>.
1295					Full name: B<CGI::Session::Serialize::storable>.
1296
1297					=item *
1298
1299					L<freezethaw\|CGI::Session::Serialize::freezethaw> - serializes data using L<FreezeThaw>. Requires L<FreezeThaw>.
1300					Full name: B<CGI::Session::Serialize::freezethaw>
1301
1302					=item *
1303
1304					L<yaml\|CGI::Session::Serialize::yaml> - serializes data using YAML. Requires L<YAML> or L<YAML::Syck>.
1305					Full name: B<CGI::Session::Serialize::yaml>
1306
1307					=back
1308
1309					=head2 ID GENERATORS
1310
1311					The following ID generators are included in the standard distribution.
1312
1313					=over 4
1314
1315					=item *
1316
1317					L<md5\|CGI::Session::ID::md5> - generates 32 character long hexadecimal string. Requires L<Digest::MD5\|Digest::MD5>.
1318					Full name: B<CGI::Session::ID::md5>.
1319
1320					=item *
1321
1322					L<incr\|CGI::Session::ID::incr> - generates incremental session ids.
1323
1324					=item *
1325
1326					L<static\|CGI::Session::ID::static> - generates static session ids. B<CGI::Session::ID::static>
1327
1328					=back
1329
1330					=head1 A Warning about Auto-flushing
1331
1332					Auto-flushing can be unreliable for the following reasons. Explicit flushing
1333					after key session updates is recommended.
1334
1335					=over 4
1336
1337					=item If the C<DBI> handle goes out of scope before the session variable
1338
1339					For database-stored sessions, if the C<DBI> handle has gone out of scope before
1340					the auto-flushing happens, auto-flushing will fail.
1341
1342					=item Circular references
1343
1344					If the calling code contains a circular reference, it's possible that your
1345					C<CGI::Session> object will not be destroyed until it is too late for
1346					auto-flushing to work. You can find circular references with a tool like
1347					L<Devel::Cycle>.
1348
1349					In particular, these modules are known to contain circular references which
1350					lead to this problem:
1351
1352					=over 4
1353
1354					=item CGI::Application::Plugin::DebugScreen V 0.06
1355
1356					=item CGI::Application::Plugin::ErrorPage before version 1.20
1357
1358					=back
1359
1360					=item Signal handlers
1361
1362					If your application may receive signals, there is an increased chance that the
1363					signal will arrive after the session was updated but before it is auto-flushed
1364					at object destruction time.
1365
1366					=back
1367
1368					=head1 A Warning about UTF8
1369
1370					You are strongly encouraged to refer to, at least, the first of these articles, for help with UTF8.
1371
1372					L<http://en.wikibooks.org/wiki/Perl_Programming/Unicode_UTF-8>
1373
1374					L<http://perl.bristolbath.org/blog/lyle/2008/12/giving-cgiapplication-internationalization-i18n.html>
1375
1376					L<http://metsankulma.homelinux.net/cgi-bin/l10n_example_4/main.cgi>
1377
1378					L<http://rassie.org/archives/247>
1379
1380					L<http://www.di-mgt.com.au/cryptoInternational2.html>
1381
1382					Briefly, these are the issues:
1383
1384					=over 4
1385
1386					=item The file containing the source code of your program
1387
1388					Consider "use utf8;" or "use encoding 'utf8';".
1389
1390					=item Influencing the encoding of the program's input
1391
1392					Use:
1393
1394					binmode STDIN, ":encoding(utf8)";.
1395
1396					Of course, the program can get input from other sources, e.g. HTML template files, not just STDIN.
1397
1398					=item Influencing the encoding of the program's output
1399
1400					Use:
1401
1402					binmode STDOUT, ":encoding(utf8)";
1403
1404					When using CGI.pm, you can use $q->charset('UTF-8'). This is the same as passing 'UTF-8' to CGI's C<header()> method.
1405
1406					Alternately, when using CGI::Session, you can use $session->header(charset => 'utf-8'), which will be
1407					passed to the query object's C<header()> method. Clearly this is preferable when the query object might not be
1408					of type CGI.
1409
1410					See L</header()> for a fuller discussion of the use of the C<header()> method in conjunction with cookies.
1411
1412					=back
1413
1414					=head1 TRANSLATIONS
1415
1416					This document is also available in Japanese.
1417
1418					=over 4
1419
1420					=item o
1421
1422					Translation based on 4.14: http://digit.que.ne.jp/work/index.cgi?Perldoc/ja
1423
1424					=item o
1425
1426					Translation based on 3.11, including Cookbook and Tutorial: http://perldoc.jp/docs/modules/CGI-Session-3.11/
1427
1428					=back
1429
1430					=head1 CREDITS
1431
1432					CGI::Session evolved to what it is today with the help of following developers. The list doesn't follow any strict order, but somewhat chronological. Specifics can be found in F<Changes> file
1433
1434					=over 4
1435
1436					=item Andy Lester
1437
1438					=item Brian King E<lt>mrbbking@mac.comE<gt>
1439
1440					=item Olivier Dragon E<lt>dragon@shadnet.shad.caE<gt>
1441
1442					=item Adam Jacob E<lt>adam@sysadminsith.orgE<gt>
1443
1444					=item Igor Plisco E<lt>igor@plisco.ruE<gt>
1445
1446					=item Mark Stosberg
1447
1448					=item Matt LeBlanc E<lt>mleblanc@cpan.orgE<gt>
1449
1450					=item Shawn Sorichetti
1451
1452					=item Ron Savage
1453
1454					=item Rhesa Rozendaal
1455
1456					He suggested Devel::Cycle to help debugging.
1457
1458					=back
1459
1460					Also, many people on the CGI::Application and CGI::Session mailing lists have contributed ideas and
1461					suggestions, and battled publicly with bugs, all of which has helped.
1462
1463					=head1 COPYRIGHT
1464
1465					Copyright (C) 2001-2005 Sherzod Ruzmetov E<lt>sherzodr@cpan.orgE<gt>. All rights reserved.
1466					This library is free software. You can modify and or distribute it under the same terms as Perl itself.
1467
1468					=head1 PUBLIC CODE REPOSITORY
1469
1470					You can see what the developers have been up to since the last release by
1471					checking out the code repository. You can browse the git repository from here:
1472
1473					http://github.com/cromedome/cgi-session/tree/master
1474
1475					Or check out the code with:
1476
1477					git clone git://github.com/cromedome/cgi-session.git
1478
1479					=head1 SUPPORT
1480
1481					If you need help using CGI::Session, ask on the mailing list. You can ask the
1482					list by sending your questions to cgi-session-user@lists.sourceforge.net .
1483
1484					You can subscribe to the mailing list at https://lists.sourceforge.net/lists/listinfo/cgi-session-user .
1485
1486					Bug reports can be submitted at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-Session
1487
1488					=head1 AUTHOR
1489
1490					Sherzod Ruzmetov C<sherzodr@cpan.org>
1491
1492					Mark Stosberg became a co-maintainer during the development of 4.0. C<markstos@cpan.org>.
1493
1494					Ron Savage became a co-maintainer during the development of 4.30. C<rsavage@cpan.org>.
1495
1496					If you would like support, ask on the mailing list as describe above. The
1497					maintainers and other users are subscribed to it.
1498
1499					=head1 SEE ALSO
1500
1501					To learn more both about the philosophy and CGI::Session programming style,
1502					consider the following:
1503
1504					=over 4
1505
1506					=item *
1507
1508					L<CGI::Session::Tutorial\|CGI::Session::Tutorial> - extended CGI::Session manual. Also includes library architecture and driver specifications.
1509
1510					=item *
1511
1512					We also provide mailing lists for CGI::Session users. To subscribe to the list
1513					or browse the archives visit
1514					https://lists.sourceforge.net/lists/listinfo/cgi-session-user
1515
1516					=item * B<RFC 2109> - The primary spec for cookie handing in use, defining the "Cookie:" and "Set-Cookie:" HTTP headers.
1517					Available at L<http://www.ietf.org/rfc/rfc2109.txt>. A newer spec, RFC 2965 is meant to obsolete it with "Set-Cookie2"
1518					and "Cookie2" headers, but even of 2008, the newer spec is not widely supported. See L<http://www.ietf.org/rfc/rfc2965.txt>
1519
1520					=item *
1521
1522					L<Apache::Session\|Apache::Session> - an alternative to CGI::Session.
1523
1524					=back
1525
1526					=cut
1527
1528	1	8µs			1;
1529

					# spent 24µs within CGI::Session::CORE:match which was called 7 times, avg 3µs/call: # 6 times (22µs+0s) by CGI::Session::_load_pluggables at line 809, avg 4µs/call # once (1µs+0s) by CGI::Session::param at line 306 sub CGI::Session::CORE:match; # opcode