← Index
Performance Profile   « block view • line view • sub view »
For opac/opac-main.pl
  Run on Thu Jul 17 22:22:09 2008
Reported on Thu Jul 17 22:22:22 2008

File/usr/share/perl5/CGI/Session.pm
Statements Executed201
Total Time0.00098 seconds

Subroutines — ordered by inclusive time then name
CallsInclusive
Time		Subroutine
10.00921CGI::Session::flush
10.00618CGI::Session::new
10.00596CGI::Session::load
10.00531CGI::Session::_load_pluggables
10.00057CGI::Session::parse_dsn
40.00020CGI::Session::param
10.00009CGI::Session::_driver
30.00006CGI::Session::id
50.00006CGI::Session::_set_status
80.00005CGI::Session::_test_status
70.00004CGI::Session::dataref
10.00002CGI::Session::_unset_status
10.00002CGI::Session::_id_generator
10.00001CGI::Session::_set_query_or_sid
10.00001CGI::Session::_serializer
19e-06CGI::Session::remote_addr
00CGI::Session::BEGIN
00CGI::Session::DESTROY
00CGI::Session::__ANON__[:442]
00CGI::Session::_ip_matches
00CGI::Session::_reset_status
00CGI::Session::_str2seconds
00CGI::Session::atime
00CGI::Session::clear
00CGI::Session::close
00CGI::Session::cookie
00CGI::Session::ctime
00CGI::Session::delete
00CGI::Session::dump
00CGI::Session::etime
00CGI::Session::expire
00CGI::Session::find
00CGI::Session::http_header
00CGI::Session::import
00CGI::Session::is_empty
00CGI::Session::is_expired
00CGI::Session::is_new
00CGI::Session::load_param
00CGI::Session::name
00CGI::Session::query
00CGI::Session::save_param
00CGI::Session::trace
00CGI::Session::tracemsg

LineStmts.Exclusive
Time		Avg.Code
1package CGI::Session;
2
3# $Id: Session.pm 353 2006-12-05 02:10:19Z markstos $
4
5use strict;
6use Carp;
7use CGI::Session::ErrorHandler;
8
9@CGI::Session::ISA = qw( CGI::Session::ErrorHandler );
10$CGI::Session::VERSION = '4.20';
11$CGI::Session::NAME = 'CGISESSID';
12$CGI::Session::IP_MATCH = 0;
13
14sub STATUS_NEW () { 1 } # denotes session that's just created
15sub STATUS_MODIFIED () { 2 } # denotes session that needs synchronization
16sub STATUS_DELETED () { 4 } # denotes session that needs deletion
17sub STATUS_EXPIRED () { 8 } # denotes session that was expired.
18
19sub import {
20 my ($class, @args) = @_;
21
22 return unless @args;
23
24 ARG:
25 foreach my $arg (@args) {
26 if ($arg eq '-ip_match') {
27 $CGI::Session::IP_MATCH = 1;
28 last ARG;
29 }
30 }
31}
32
33
# spent 0.00618s within CGI::Session::new which was called: # 1 times (0.00618s) by C4::Auth::get_session at line 1179 of C4/Auth.pm
sub new {
34130.000054e-06 my ($class, @args) = @_;
35
36 my $self;
37 if (ref $class) {
38 #
39 # Called as an object method as in $session->new()...
40 #
41 $self = bless { %$class }, ref( $class );
42 $class = ref $class;
43 $self->_reset_status();
44 #
45 # Object may still have public data associated with it, but we
46 # don't care about that, since we want to leave that to the
47 # client's disposal. However, if new() was requested on an
48 # expired session, we already know that '_DATA' table is
49 # empty, since it was the job of flush() to empty '_DATA'
50 # after deleting. How do we know flush() was already called on
51 # an expired session? Because load() - constructor always
52 # calls flush() on all to-be expired sessions
53 #
54 }
55 else {
56 #
57 # Called as a class method as in CGI::Session->new()
58 #
59 $self = $class->load( @args );
# spent 0.00596s making 1 calls to CGI::Session::load
60 if (not defined $self) {
61 return $class->set_error( "new(): failed: " . $class->errstr );
62 }
63 }
64 my $dataref = $self->{_DATA};
65 unless ($dataref->{_SESSION_ID}) {
66 #
67 # Absence of '_SESSION_ID' can only signal:
68 # * Expired session: Because load() - constructor is required to
69 # empty contents of _DATA - table
70 # * Unavailable session: Such sessions are the ones that don't
71 # exist on datastore, but are requested by client
72 # * New session: When no specific session is requested to be loaded
73 #
74 my $id = $self->_id_generator()->generate_id(
# spent 0.00011s making 1 calls to CGI::Session::ID::md5::generate_id # spent 0.00002s making 1 calls to CGI::Session::_id_generator
75 $self->{_DRIVER_ARGS},
76 $self->{_CLAIMED_ID}
77 );
78 unless (defined $id) {
79 return $self->set_error( "Couldn't generate new SESSION-ID" );
80 }
81 $dataref->{_SESSION_ID} = $id;
82 $dataref->{_SESSION_CTIME} = $dataref->{_SESSION_ATIME} = time();
83 $self->_set_status( STATUS_NEW );
# spent 0.00002s making 1 calls to CGI::Session::_set_status
84 }
85 return $self;
86}
87
8818e-068e-06sub DESTROY { $_[0]->flush() }
# spent 0.00921s making 1 calls to CGI::Session::flush
89sub close { $_[0]->flush() }
90
91*param_hashref = \&dataref;
92my $avoid_single_use_warning = *param_hashref;
9370.000012e-06
# spent 0.00004s within CGI::Session::dataref which was called 7 times, avg 5e-06s/call: # 6 times (0.00003s) by CGI::Session::id at line 101 of /usr/share/perl5/CGI/Session.pm, avg 5e-06s/call # 1 times (6e-06s) by CGI::Session::flush at line 240 of /usr/share/perl5/CGI/Session.pm
sub dataref { $_[0]->{_DATA} }
94
95sub is_empty { !defined($_[0]->id) }
96
97sub is_expired { $_[0]->_test_status( STATUS_EXPIRED ) }
98
99sub is_new { $_[0]->_test_status( STATUS_NEW ) }
100
10130.000030.00001
# spent 0.00006s within CGI::Session::id which was called 3 times, avg 0.00002s/call: # 1 times (0.00003s) by C4::Auth::checkauth at line 584 of C4/Auth.pm # 1 times (0.00002s) by CGI::Session::flush at line 244 of /usr/share/perl5/CGI/Session.pm # 1 times (0.00002s) by CGI::Session::flush at line 220 of /usr/share/perl5/CGI/Session.pm
sub id { return defined($_[0]->dataref) ? $_[0]->dataref->{_SESSION_ID} : undef }
# spent 0.00003s making 6 calls to CGI::Session::dataref, avg 5e-06s/call
102
103# Last Access Time
104sub atime { return defined($_[0]->dataref) ? $_[0]->dataref->{_SESSION_ATIME} : undef }
105
106# Creation Time
107sub ctime { return defined($_[0]->dataref) ? $_[0]->dataref->{_SESSION_CTIME} : undef }
108
109
# spent 0.00009s within CGI::Session::_driver which was called: # 1 times (0.00009s) by CGI::Session::flush at line 228 of /usr/share/perl5/CGI/Session.pm
sub _driver {
11050.000025e-06 my $self = shift;
111 defined($self->{_OBJECTS}->{driver}) and return $self->{_OBJECTS}->{driver};
112 my $pm = "CGI::Session::Driver::" . $self->{_DSN}->{driver};
113 defined($self->{_OBJECTS}->{driver} = $pm->new( $self->{_DRIVER_ARGS} ))
# spent 0.00006s making 1 calls to CGI::Session::Driver::new
114 or die $pm->errstr();
115 return $self->{_OBJECTS}->{driver};
116}
117
118
# spent 0.00001s within CGI::Session::_serializer which was called: # 1 times (0.00001s) by CGI::Session::flush at line 229 of /usr/share/perl5/CGI/Session.pm
sub _serializer {
11936e-062e-06 my $self = shift;
120 defined($self->{_OBJECTS}->{serializer}) and return $self->{_OBJECTS}->{serializer};
121 return $self->{_OBJECTS}->{serializer} = "CGI::Session::Serialize::" . $self->{_DSN}->{serializer};
122}
123
124
125
# spent 0.00002s within CGI::Session::_id_generator which was called: # 1 times (0.00002s) by CGI::Session::new at line 74 of /usr/share/perl5/CGI/Session.pm
sub _id_generator {
12636e-062e-06 my $self = shift;
127 defined($self->{_OBJECTS}->{id}) and return $self->{_OBJECTS}->{id};
128 return $self->{_OBJECTS}->{id} = "CGI::Session::ID::" . $self->{_DSN}->{id};
129}
130
131sub _ip_matches {
132 return ( $_[0]->{_DATA}->{_SESSION_REMOTE_ADDR} eq $ENV{REMOTE_ADDR} );
133}
134
135
136# parses the DSN string and returns it as a hash.
137# Notably: Allows unique abbreviations of the keys: driver, serializer and 'id'.
138# Also, keys and values of the returned hash are lower-cased.
139
# spent 0.00057s within CGI::Session::parse_dsn which was called: # 1 times (0.00057s) by CGI::Session::load at line 680 of /usr/share/perl5/CGI/Session.pm
sub parse_dsn {
140110.000410.00004 my $self = shift;
141 my $dsn_str = shift;
142 croak "parse_dsn(): usage error" unless $dsn_str;
143
144 require Text::Abbrev;
145 my $abbrev = Text::Abbrev::abbrev( "driver", "serializer", "id" );
# spent 0.00013s making 1 calls to Text::Abbrev::abbrev
146 my %dsn_map = map { split /:/ } (split /;/, $dsn_str);
147 my %dsn = map { $abbrev->{lc $_}, lc $dsn_map{$_} } keys %dsn_map;
148 return \%dsn;
149}
150
151sub query {
152 my $self = shift;
153
154 if ( $self->{_QUERY} ) {
155 return $self->{_QUERY};
156 }
157# require CGI::Session::Query;
158# return $self->{_QUERY} = CGI::Session::Query->new();
159 require CGI;
160 return $self->{_QUERY} = CGI->new();
161}
162
163
164sub name {
165 my $self = shift;
166
167 if (ref $self) {
168 unless ( @_ ) {
169 return $self->{_NAME} || $CGI::Session::NAME;
170 }
171 return $self->{_NAME} = $_[0];
172 }
173
174 $CGI::Session::NAME = $_[0] if @_;
175 return $CGI::Session::NAME;
176}
177
178
179sub dump {
180 my $self = shift;
181
182 require Data::Dumper;
183 my $d = Data::Dumper->new([$self], [ref $self]);
184 $d->Deepcopy(1);
185 return $d->Dump();
186}
187
188
189
# spent 0.00006s within CGI::Session::_set_status which was called 5 times, avg 0.00001s/call: # 4 times (0.00004s) by CGI::Session::param at line 306 of /usr/share/perl5/CGI/Session.pm, avg 0.00001s/call # 1 times (0.00002s) by CGI::Session::new at line 83 of /usr/share/perl5/CGI/Session.pm
sub _set_status {
190200.000031e-06 my $self = shift;
191 croak "_set_status(): usage error" unless @_;
192 $self->{_STATUS} |= $_ for @_;
193}
194
195
196
# spent 0.00002s within CGI::Session::_unset_status which was called: # 1 times (0.00002s) by CGI::Session::flush at line 246 of /usr/share/perl5/CGI/Session.pm
sub _unset_status {
19740.000013e-06 my $self = shift;
198 croak "_unset_status(): usage error" unless @_;
199 $self->{_STATUS} &= ~$_ for @_;
200}
201
202
203sub _reset_status {
204 $_[0]->{_STATUS} = 0;
205}
206
207
# spent 0.00005s within CGI::Session::_test_status which was called 8 times, avg 6e-06s/call: # 4 times (0.00002s) by CGI::Session::param at line 257 of /usr/share/perl5/CGI/Session.pm, avg 6e-06s/call # 2 times (0.00001s) by CGI::Session::flush at line 223 of /usr/share/perl5/CGI/Session.pm, avg 5e-06s/call # 1 times (7e-06s) by CGI::Session::flush at line 231 of /usr/share/perl5/CGI/Session.pm # 1 times (7e-06s) by CGI::Session::flush at line 239 of /usr/share/perl5/CGI/Session.pm
sub _test_status {
20880.000012e-06 return $_[0]->{_STATUS} & $_[1];
209}
210
211
212
# spent 0.00921s within CGI::Session::flush which was called: # 1 times (0.00921s) by CGI::Session::DESTROY at line 88 of /usr/share/perl5/CGI/Session.pm
sub flush {
213130.000087e-06 my $self = shift;
214
215 # Would it be better to die or err if something very basic is wrong here?
216 # I'm trying to address the DESTORY related warning
217 # from: http://rt.cpan.org/Ticket/Display.html?id=17541
218 # return unless defined $self;
219
220 return unless $self->id; # <-- empty session
# spent 0.00002s making 1 calls to CGI::Session::id
221 return if !defined($self->{_STATUS}) or $self->{_STATUS} == 0; # <-- neither new, nor deleted nor modified
222
223 if ( $self->_test_status(STATUS_NEW) && $self->_test_status(STATUS_DELETED) ) {
# spent 0.00001s making 2 calls to CGI::Session::_test_status, avg 5e-06s/call
224 $self->{_DATA} = {};
225 return $self->_unset_status(STATUS_NEW, STATUS_DELETED);
226 }
227
228 my $driver = $self->_driver();
# spent 0.00009s making 1 calls to CGI::Session::_driver
229 my $serializer = $self->_serializer();
# spent 0.00001s making 1 calls to CGI::Session::_serializer
230
231 if ( $self->_test_status(STATUS_DELETED) ) {
# spent 7e-06s making 1 calls to CGI::Session::_test_status
232 defined($driver->remove($self->id)) or
233 return $self->set_error( "flush(): couldn't remove session data: " . $driver->errstr );
234 $self->{_DATA} = {}; # <-- removing all the data, making sure
235 # it won't be accessible after flush()
236 return $self->_unset_status(STATUS_DELETED);
237 }
238
239 if ( $self->_test_status(STATUS_NEW) || $self->_test_status(STATUS_MODIFIED) ) {
# spent 7e-06s making 1 calls to CGI::Session::_test_status
240 my $datastr = $serializer->freeze( $self->dataref );
# spent 0.00017s making 1 calls to CGI::Session::Serialize::yaml::freeze # spent 6e-06s making 1 calls to CGI::Session::dataref
241 unless ( defined $datastr ) {
242 return $self->set_error( "flush(): couldn't freeze data: " . $serializer->errstr );
243 }
244 defined( $driver->store($self->id, $datastr) ) or
# spent 0.00880s making 1 calls to CGI::Session::Driver::mysql::store # spent 0.00002s making 1 calls to CGI::Session::id
245 return $self->set_error( "flush(): couldn't store datastr: " . $driver->errstr);
246 $self->_unset_status(STATUS_NEW, STATUS_MODIFIED);
# spent 0.00002s making 1 calls to CGI::Session::_unset_status
247 }
248 return 1;
249}
250
251sub trace {}
252sub tracemsg {}
253
254
# spent 0.00020s within CGI::Session::param which was called 4 times, avg 0.00005s/call: # 1 times (0.00005s) by C4::Auth::checkauth at line 730 of C4/Auth.pm # 1 times (0.00004s) by C4::Auth::checkauth at line 731 of C4/Auth.pm # 1 times (0.00006s) by C4::Auth::checkauth at line 726 of C4/Auth.pm # 1 times (0.00005s) by C4::Auth::checkauth at line 732 of C4/Auth.pm
sub param {
255600.000091e-06 my ($self, @args) = @_;
256
257 if ($self->_test_status( STATUS_DELETED )) {
# spent 0.00002s making 4 calls to CGI::Session::_test_status, avg 6e-06s/call
258 carp "param(): attempt to read/write deleted session";
259 }
260
261 # USAGE: $s->param();
262 # DESC: Returns all the /public/ parameters
263 if (@args == 0) {
264 return grep { !/^_SESSION_/ } keys %{ $self->{_DATA} };
265 }
266 # USAGE: $s->param( $p );
267 # DESC: returns a specific session parameter
268 elsif (@args == 1) {
269 return $self->{_DATA}->{ $args[0] }
270 }
271
272
273 # USAGE: $s->param( -name => $n, -value => $v );
274 # DESC: Updates session data using CGI.pm's 'named param' syntax.
275 # Only public records can be set!
276 my %args = @args;
277 my ($name, $value) = @args{ qw(-name -value) };
278 if (defined $name && defined $value) {
279 if ($name =~ m/^_SESSION_/) {
280
281 carp "param(): attempt to write to private parameter";
282 return undef;
283 }
284 $self->_set_status( STATUS_MODIFIED );
285 return $self->{_DATA}->{ $name } = $value;
286 }
287
288 # USAGE: $s->param(-name=>$n);
289 # DESC: access to session data (public & private) using CGI.pm's 'named parameter' syntax.
290 return $self->{_DATA}->{ $args{'-name'} } if defined $args{'-name'};
291
292 # USAGE: $s->param($name, $value);
293 # USAGE: $s->param($name1 => $value1, $name2 => $value2 [,...]);
294 # DESC: updates one or more **public** records using simple syntax
295 if ((@args % 2) == 0) {
296 my $modified_cnt = 0;
297 ARG_PAIR:
298 while (my ($name, $val) = each %args) {
299 if ( $name =~ m/^_SESSION_/) {
300 carp "param(): attempt to write to private parameter";
301 next ARG_PAIR;
302 }
303 $self->{_DATA}->{ $name } = $val;
304 ++$modified_cnt;
305 }
306 $self->_set_status(STATUS_MODIFIED);
# spent 0.00004s making 4 calls to CGI::Session::_set_status, avg 0.00001s/call
307 return $modified_cnt;
308 }
309
310 # If we reached this far none of the expected syntax were
311 # detected. Syntax error
312 croak "param(): usage error. Invalid syntax";
313}
314
315
316
317sub delete { $_[0]->_set_status( STATUS_DELETED ) }
318
319
320*header = \&http_header;
321my $avoid_single_use_warning_again = *header;
322sub http_header {
323 my $self = shift;
324 return $self->query->header(-cookie=>$self->cookie, -type=>'text/html', @_);
325}
326
327sub cookie {
328 my $self = shift;
329
330 my $query = $self->query();
331 my $cookie= undef;
332
333 if ( $self->is_expired ) {
334 $cookie = $query->cookie( -name=>$self->name, -value=>$self->id, -expires=> '-1d', @_ );
335 }
336 elsif ( my $t = $self->expire ) {
337 $cookie = $query->cookie( -name=>$self->name, -value=>$self->id, -expires=> '+' . $t . 's', @_ );
338 }
339 else {
340 $cookie = $query->cookie( -name=>$self->name, -value=>$self->id, @_ );
341 }
342 return $cookie;
343}
344
345
346
347
348
349sub save_param {
350 my $self = shift;
351 my ($query, $params) = @_;
352
353 $query ||= $self->query();
354 $params ||= [ $query->param ];
355
356 for my $p ( @$params ) {
357 my @values = $query->param($p) or next;
358 if ( @values > 1 ) {
359 $self->param($p, \@values);
360 } else {
361 $self->param($p, $values[0]);
362 }
363 }
364 $self->_set_status( STATUS_MODIFIED );
365}
366
367
368
369sub load_param {
370 my $self = shift;
371 my ($query, $params) = @_;
372
373 $query ||= $self->query();
374 $params ||= [ $self->param ];
375
376 for ( @$params ) {
377 $query->param(-name=>$_, -value=>$self->param($_));
378 }
379}
380
381
382sub clear {
383 my $self = shift;
384 my $params = shift;
385 #warn ref($params);
386 if (defined $params) {
387 $params = [ $params ] unless ref $params;
388 }
389 else {
390 $params = [ $self->param ];
391 }
392
393 for ( grep { ! /^_SESSION_/ } @$params ) {
394 delete $self->{_DATA}->{$_};
395 }
396 $self->_set_status( STATUS_MODIFIED );
397}
398
399
400sub find {
401 my $class = shift;
402 my ($dsn, $coderef, $dsn_args);
403
404 # find( \%code )
405 if ( @_ == 1 ) {
406 $coderef = $_[0];
407 }
408 # find( $dsn, \&code, \%dsn_args )
409 else {
410 ($dsn, $coderef, $dsn_args) = @_;
411 }
412
413 unless ( $coderef && ref($coderef) && (ref $coderef eq 'CODE') ) {
414 croak "find(): usage error.";
415 }
416
417 my $driver;
418 if ( $dsn ) {
419 my $hashref = $class->parse_dsn( $dsn );
420 $driver = $hashref->{driver};
421 }
422 $driver ||= "file";
423 my $pm = "CGI::Session::Driver::" . ($driver =~ /(.*)/)[0];
424 eval "require $pm";
425 if (my $errmsg = $@ ) {
426 return $class->set_error( "find(): couldn't load driver." . $errmsg );
427 }
428
429 my $driver_obj = $pm->new( $dsn_args );
430 unless ( $driver_obj ) {
431 return $class->set_error( "find(): couldn't create driver object. " . $pm->errstr );
432 }
433
434 my $dont_update_atime = 0;
435 my $driver_coderef = sub {
436 my ($sid) = @_;
437 my $session = $class->load( $dsn, $sid, $dsn_args, $dont_update_atime );
438 unless ( $session ) {
439 return $class->set_error( "find(): couldn't load session '$sid'. " . $class->errstr );
440 }
441 $coderef->( $session );
442 };
443
444 defined($driver_obj->traverse( $driver_coderef ))
445 or return $class->set_error( "find(): traverse seems to have failed. " . $driver_obj->errstr );
446 return 1;
447}
448
449# $Id: Session.pm 353 2006-12-05 02:10:19Z markstos $
450
451=pod
452
453=head1 NAME
454
455CGI::Session - persistent session data in CGI applications
456
457=head1 SYNOPSIS
458
459 # Object initialization:
460 use CGI::Session;
461 $session = new CGI::Session();
462
463 $CGISESSID = $session->id();
464
465 # send proper HTTP header with cookies:
466 print $session->header();
467
468 # storing data in the session
469 $session->param('f_name', 'Sherzod');
470 # or
471 $session->param(-name=>'l_name', -value=>'Ruzmetov');
472
473 # flush the data from memory to the storage driver at least before your
474 # program finishes since auto-flushing can be unreliable
475 $session->flush();
476
477 # retrieving data
478 my $f_name = $session->param('f_name');
479 # or
480 my $l_name = $session->param(-name=>'l_name');
481
482 # clearing a certain session parameter
483 $session->clear(["l_name", "f_name"]);
484
485 # expire '_is_logged_in' flag after 10 idle minutes:
486 $session->expire('is_logged_in', '+10m')
487
488 # expire the session itself after 1 idle hour
489 $session->expire('+1h');
490
491 # delete the session for good
492 $session->delete();
493
494=head1 DESCRIPTION
495
496CGI-Session is a Perl5 library that provides an easy, reliable and modular session management system across HTTP requests.
497Persistency is a key feature for such applications as shopping carts, login/authentication routines, and application that
498need to carry data across HTTP requests. CGI::Session does that and many more.
499
500=head1 TRANSLATIONS
501
502This document is also available in Japanese.
503
504=over 4
505
506=item o
507
508Translation based on 4.14: http://digit.que.ne.jp/work/index.cgi?Perldoc/ja
509
510=item o
511
512Translation based on 3.11, including Cookbook and Tutorial: http://perldoc.jp/docs/modules/CGI-Session-3.11/
513
514=back
515
516=head1 TO LEARN MORE
517
518Current manual is optimized to be used as a quick reference. To learn more both about the philosophy and CGI::Session
519programming style, consider the following:
520
521=over 4
522
523=item *
524
525L<CGI::Session::Tutorial|CGI::Session::Tutorial> - extended CGI::Session manual. Also includes library architecture and driver specifications.
526
527=item *
528
529We also provide mailing lists for CGI::Session users. To subscribe to the list or browse the archives visit https://lists.sourceforge.net/lists/listinfo/cgi-session-user
530
531=item *
532
533B<RFC 2965> - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt
534
535=item *
536
537L<CGI|CGI> - standard CGI library
538
539=item *
540
541L<Apache::Session|Apache::Session> - another fine alternative to CGI::Session.
542
543=back
544
545=head1 METHODS
546
547Following is the overview of all the available methods accessible via CGI::Session object.
548
549=head2 new()
550
551=head2 new( $sid )
552
553=head2 new( $query )
554
555=head2 new( $dsn, $query||$sid )
556
557=head2 new( $dsn, $query||$sid, \%dsn_args )
558
559Constructor. 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">.
560
561Can 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.
562
563If 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>.
564
565If 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>.
566
567If 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:
568
569 $s = CGI::Session->new("driver:mysql", undef);
570 $s = CGI::Session->new("driver:sqlite", $sid);
571 $s = CGI::Session->new("driver:db_file", $query);
572 $s = CGI::Session->new("serializer:storable;id:incr", $sid);
573 # etc...
574
575
576Following data source components are supported:
577
578=over 4
579
580=item *
581
582B<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>
583
584=item *
585
586B<serializer> - serializer to be used to encode the data structure before saving
587in 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>.
588
589=item *
590
591B<id> - ID generator to use when new session is to be created. Available ID generator is L<md5|CGI::Session::ID::md5>
592
593=back
594
595For example, to get CGI::Session store its data using DB_File and serialize data using FreezeThaw:
596
597 $s = new CGI::Session("driver:DB_File;serializer:FreezeThaw", undef);
598
599If 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.
600
601undef is acceptable as a valid placeholder to any of the above arguments, which will force default behavior.
602
603=head2 load()
604
605=head2 load($query||$sid)
606
607=head2 load($dsn, $query||$sid)
608
609=head2 load($dsn, $query, \%dsn_args);
610
611Accepts the same arguments as new(), and also returns a new session object, or
612undef on failure. The difference is, L<new()|/"new"> can create new session if
613it detects expired and non-existing sessions, but C<load()> does not.
614
615C<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:
616
617 $s = CGI::Session->load() or die CGI::Session->errstr();
618 if ( $s->is_expired ) {
619 print $s->header(),
620 $cgi->start_html(),
621 $cgi->p("Your session timed out! Refresh the screen to start new session!")
622 $cgi->end_html();
623 exit(0);
624 }
625
626 if ( $s->is_empty ) {
627 $s = $s->new() or die $s->errstr;
628 }
629
630Notice, all I<expired> sessions are empty, but not all I<empty> sessions are expired!
631
632=cut
633
634# pass a true value as the fourth parameter if you want to skip the changing of
635# access time This isn't documented more formally, because it only called by
636# find().
637
# spent 0.00596s within CGI::Session::load which was called: # 1 times (0.00596s) by CGI::Session::new at line 59 of /usr/share/perl5/CGI/Session.pm
sub load {
638140.000064e-06 my $class = shift;
639 return $class->set_error( "called as instance method") if ref $class;
640 return $class->set_error( "Too many arguments") if @_ > 4;
641
642 my $self = bless {
643 _DATA => {
644 _SESSION_ID => undef,
645 _SESSION_CTIME => undef,
646 _SESSION_ATIME => undef,
647 _SESSION_REMOTE_ADDR => $ENV{REMOTE_ADDR} || "",
648 #
649 # Following two attributes may not exist in every single session, and declaring
650 # them now will force these to get serialized into database, wasting space. But they
651 # are here to remind the coder of their purpose
652 #
653# _SESSION_ETIME => undef,
654# _SESSION_EXPIRE_LIST => {}
655 }, # session data
656 _DSN => {}, # parsed DSN params
657 _OBJECTS => {}, # keeps necessary objects
658 _DRIVER_ARGS=> {}, # arguments to be passed to driver
659 _CLAIMED_ID => undef, # id **claimed** by client
660 _STATUS => 0, # status of the session object
661 _QUERY => undef # query object
662 }, $class;
663
664 my ($dsn,$query_or_sid,$dsn_args,$update_atime);
665 # load($query||$sid)
666 if ( @_ == 1 ) {
667 $self->_set_query_or_sid($_[0]);
668 }
669 # Two or more args passed:
670 # load($dsn, $query||$sid)
671 elsif ( @_ > 1 ) {
672 ($dsn, $query_or_sid, $dsn_args,$update_atime) = @_;
673
674 # Since $update_atime is not part of the public API
675 # we ignore any value but the one we use internally: 0.
676 if (defined $update_atime and $update_atime ne '0') {
677 return $class->set_error( "Too many arguments");
678 }
679
680 if ( defined $dsn ) { # <-- to avoid 'Uninitialized value...' warnings
# spent 0.00057s making 1 calls to CGI::Session::parse_dsn
681 $self->{_DSN} = $self->parse_dsn($dsn);
682 }
683 $self->_set_query_or_sid($query_or_sid);
# spent 0.00001s making 1 calls to CGI::Session::_set_query_or_sid
684
685 # load($dsn, $query, \%dsn_args);
686
687 $self->{_DRIVER_ARGS} = $dsn_args if defined $dsn_args;
688
689 }
690
691 $self->_load_pluggables();
# spent 0.00531s making 1 calls to CGI::Session::_load_pluggables
692
693 if (not defined $self->{_CLAIMED_ID}) {
694 my $query = $self->query();
695 eval {
696 $self->{_CLAIMED_ID} = $query->cookie( $self->name ) || $query->param( $self->name );
697 };
698 if ( my $errmsg = $@ ) {
699 return $class->set_error( "query object $query does not support cookie() and param() methods: " . $errmsg );
700 }
701 }
702
703 # No session is being requested. Just return an empty session
704 return $self unless $self->{_CLAIMED_ID};
705
706 # Attempting to load the session
707 my $driver = $self->_driver();
708 my $raw_data = $driver->retrieve( $self->{_CLAIMED_ID} );
709 unless ( defined $raw_data ) {
710 return $self->set_error( "load(): couldn't retrieve data: " . $driver->errstr );
711 }
712
713 # Requested session couldn't be retrieved
714 return $self unless $raw_data;
715
716 my $serializer = $self->_serializer();
717 $self->{_DATA} = $serializer->thaw($raw_data);
718 unless ( defined $self->{_DATA} ) {
719 #die $raw_data . "\n";
720 return $self->set_error( "load(): couldn't thaw() data using $serializer:" .
721 $serializer->errstr );
722 }
723 unless (defined($self->{_DATA}) && ref ($self->{_DATA}) && (ref $self->{_DATA} eq 'HASH') &&
724 defined($self->{_DATA}->{_SESSION_ID}) ) {
725 return $self->set_error( "Invalid data structure returned from thaw()" );
726 }
727
728 # checking if previous session ip matches current ip
729 if($CGI::Session::IP_MATCH) {
730 unless($self->_ip_matches) {
731 $self->_set_status( STATUS_DELETED );
732 $self->flush;
733 return $self;
734 }
735 }
736
737 # checking for expiration ticker
738 if ( $self->{_DATA}->{_SESSION_ETIME} ) {
739 if ( ($self->{_DATA}->{_SESSION_ATIME} + $self->{_DATA}->{_SESSION_ETIME}) <= time() ) {
740 $self->_set_status( STATUS_EXPIRED ); # <-- so client can detect expired sessions
741 $self->_set_status( STATUS_DELETED ); # <-- session should be removed from database
742 $self->flush(); # <-- flush() will do the actual removal!
743 return $self;
744 }
745 }
746
747 # checking expiration tickers of individuals parameters, if any:
748 my @expired_params = ();
749 while (my ($param, $max_exp_interval) = each %{ $self->{_DATA}->{_SESSION_EXPIRE_LIST} } ) {
750 if ( ($self->{_DATA}->{_SESSION_ATIME} + $max_exp_interval) <= time() ) {
751 push @expired_params, $param;
752 }
753 }
754 $self->clear(\@expired_params) if @expired_params;
755
756 # We update the atime by default, but if this (otherwise undocoumented)
757 # parameter is explicitly set to false, we'll turn the behavior off
758 if ( ! defined $update_atime ) {
759 $self->{_DATA}->{_SESSION_ATIME} = time(); # <-- updating access time
760 $self->_set_status( STATUS_MODIFIED ); # <-- access time modified above
761 }
762
763 return $self;
764}
765
766
767# set the input as a query object or session ID, depending on what it looks like.
768
# spent 0.00001s within CGI::Session::_set_query_or_sid which was called: # 1 times (0.00001s) by CGI::Session::load at line 683 of /usr/share/perl5/CGI/Session.pm
sub _set_query_or_sid {
76945e-061e-06 my $self = shift;
770 my $query_or_sid = shift;
771 if ( ref $query_or_sid){ $self->{_QUERY} = $query_or_sid }
772 else { $self->{_CLAIMED_ID} = $query_or_sid }
773}
774
775
776
# spent 0.00531s within CGI::Session::_load_pluggables which was called: # 1 times (0.00531s) by CGI::Session::load at line 691 of /usr/share/perl5/CGI/Session.pm
sub _load_pluggables {
777300.000145e-06 my ($self) = @_;
778
779 my %DEFAULT_FOR = (
780 driver => "file",
781 serializer => "default",
782 id => "md5",
783 );
784 my %SUBDIR_FOR = (
785 driver => "Driver",
786 serializer => "Serialize",
787 id => "ID",
788 );
789 my $dsn = $self->{_DSN};
790 foreach my $plug qw(driver serializer id) {
791 my $mod_name = $dsn->{ $plug };
792 if (not defined $mod_name) {
793 $mod_name = $DEFAULT_FOR{ $plug };
794 }
795 if ($mod_name =~ /^(\w+)$/) {
796
797 # Looks good. Put it into the dsn hash
798 $dsn->{ $plug } = $mod_name = $1;
799
800 # Put together the actual module name to load
801 my $prefix = join '::', (__PACKAGE__, $SUBDIR_FOR{ $plug }, q{});
802 $mod_name = $prefix . $mod_name;
803
804 ## See if we can load load it
805100 eval "require $mod_name";
806 if ($@) {
807 my $msg = $@;
808 return $self->set_error("couldn't load $mod_name: " . $msg);
809 }
810 }
811 else {
812 # do something here about bad name for a pluggable
813 }
814 }
815 return;
816}
817
818=pod
819