← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 11:58:52 2013
Reported on Tue Oct 15 12:01:04 2013

Filename/usr/share/perl5/CGI/Session.pm
StatementsExecuted 491 statements in 7.17ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
3112.64ms6.42msCGI::Session::::_load_pluggablesCGI::Session::_load_pluggables
311930µs1.27msCGI::Session::::parse_dsnCGI::Session::parse_dsn
311350µs8.94msCGI::Session::::loadCGI::Session::load
111288µs365µsCGI::Session::::BEGIN@7CGI::Session::BEGIN@7
311284µs13.4msCGI::Session::::flushCGI::Session::flush
311231µs9.57msCGI::Session::::newCGI::Session::new
552211µs256µsCGI::Session::::paramCGI::Session::param
311106µs342µsCGI::Session::::_driverCGI::Session::_driver
842101µs146µsCGI::Session::::idCGI::Session::id
132176µs76µsCGI::Session::::CORE:matchCGI::Session::CORE:match (opcode)
174161µs61µsCGI::Session::::_test_statusCGI::Session::_test_status
192152µs52µsCGI::Session::::datarefCGI::Session::dataref
31140µs40µsCGI::Session::::_unset_statusCGI::Session::_unset_status
72138µs38µsCGI::Session::::_set_statusCGI::Session::_set_status
21135µs626µsCGI::Session::::queryCGI::Session::query
31135µs35µsCGI::Session::::_serializerCGI::Session::_serializer
33234µs13.5msCGI::Session::::DESTROYCGI::Session::DESTROY
31130µs30µsCGI::Session::::_id_generatorCGI::Session::_id_generator
41130µs30µsCGI::Session::::nameCGI::Session::name
31127µs27µsCGI::Session::::_set_query_or_sidCGI::Session::_set_query_or_sid
11122µs27µsCGI::Session::::BEGIN@5CGI::Session::BEGIN@5
11113µs63µsCGI::Session::::BEGIN@6CGI::Session::BEGIN@6
1119µs9µsCGI::Session::::importCGI::Session::import
1117µs7µsCGI::Session::::remote_addrCGI::Session::remote_addr
0000s0sCGI::Session::::__ANON__[:451]CGI::Session::__ANON__[:451]
0000s0sCGI::Session::::_ip_matchesCGI::Session::_ip_matches
0000s0sCGI::Session::::_reset_statusCGI::Session::_reset_status
0000s0sCGI::Session::::_str2secondsCGI::Session::_str2seconds
0000s0sCGI::Session::::atimeCGI::Session::atime
0000s0sCGI::Session::::clearCGI::Session::clear
0000s0sCGI::Session::::closeCGI::Session::close
0000s0sCGI::Session::::cookieCGI::Session::cookie
0000s0sCGI::Session::::ctimeCGI::Session::ctime
0000s0sCGI::Session::::deleteCGI::Session::delete
0000s0sCGI::Session::::dumpCGI::Session::dump
0000s0sCGI::Session::::etimeCGI::Session::etime
0000s0sCGI::Session::::expireCGI::Session::expire
0000s0sCGI::Session::::findCGI::Session::find
0000s0sCGI::Session::::http_headerCGI::Session::http_header
0000s0sCGI::Session::::is_emptyCGI::Session::is_empty
0000s0sCGI::Session::::is_expiredCGI::Session::is_expired
0000s0sCGI::Session::::is_newCGI::Session::is_new
0000s0sCGI::Session::::load_paramCGI::Session::load_param
0000s0sCGI::Session::::save_paramCGI::Session::save_param
0000s0sCGI::Session::::traceCGI::Session::trace
0000s0sCGI::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
1package CGI::Session;
2
3# $Id: Session.pm 459 2009-03-21 02:00:17Z markstos $
4
5331µs233µs
# spent 27µs (22+5) within CGI::Session::BEGIN@5 which was called: # once (22µs+5µs) by C4::Auth::BEGIN@25 at line 5
use strict;
# spent 27µs making 1 call to CGI::Session::BEGIN@5 # spent 6µs making 1 call to strict::import
6333µs2114µs
# spent 63µs (13+51) within CGI::Session::BEGIN@6 which was called: # once (13µs+51µs) by C4::Auth::BEGIN@25 at line 6
use Carp;
# spent 63µs making 1 call to CGI::Session::BEGIN@6 # spent 50µs making 1 call to Exporter::import
733.74ms1365µs
# spent 365µs (288+77) within CGI::Session::BEGIN@7 which was called: # once (288µs+77µs) by C4::Auth::BEGIN@25 at line 7
use CGI::Session::ErrorHandler;
# spent 365µs making 1 call to CGI::Session::BEGIN@7
8
9118µs@CGI::Session::ISA = qw( CGI::Session::ErrorHandler );
1011µs$CGI::Session::VERSION = '4.41';
111600ns$CGI::Session::NAME = 'CGISESSID';
121300ns$CGI::Session::IP_MATCH = 0;
13
14sub STATUS_UNSET () { 1 << 0 } # denotes session that's resetted
15sub STATUS_NEW () { 1 << 1 } # denotes session that's just created
16sub STATUS_MODIFIED () { 1 << 2 } # denotes session that needs synchronization
17sub STATUS_DELETED () { 1 << 3 } # denotes session that needs deletion
18sub STATUS_EXPIRED () { 1 << 4 } # denotes session that was expired.
19
20
# spent 9µs within CGI::Session::import which was called: # once (9µs+0s) by C4::Auth::BEGIN@25 at line 25 of /usr/share/koha/lib/C4/Auth.pm
sub import {
21217µs my ($class, @args) = @_;
22
23 return unless @args;
24
25 ARG:
26 foreach my $arg (@args) {
27 if ($arg eq '-ip_match') {
28 $CGI::Session::IP_MATCH = 1;
29 last ARG;
30 }
31 }
32}
33
34
# spent 9.57ms (231µs+9.34) within CGI::Session::new which was called 3 times, avg 3.19ms/call: # 3 times (231µs+9.34ms) by C4::Auth::get_session at line 1523 of /usr/share/koha/lib/C4/Auth.pm, avg 3.19ms/call
sub new {
3545204µs my ($class, @args) = @_;
36
37 my $self;
38 if (ref $class) {
39 #
40 # Called as an object method as in $session->new()...
41 #
42 $self = bless { %$class }, ref( $class );
43 $class = ref $class;
44 $self->_reset_status();
45 #
46 # Object may still have public data associated with it, but we
47 # don't care about that, since we want to leave that to the
48 # client's disposal. However, if new() was requested on an
49 # expired session, we already know that '_DATA' table is
50 # empty, since it was the job of flush() to empty '_DATA'
51 # after deleting. How do we know flush() was already called on
52 # an expired session? Because load() - constructor always
53 # calls flush() on all to-be expired sessions
54 #
55 }
56 else {
57 #
58 # Called as a class method as in CGI::Session->new()
59 #
60
61 # Start fresh with error reporting. Errors in past objects shouldn't affect this one.
62380µs $class->set_error('');
# spent 80µs making 3 calls to CGI::Session::ErrorHandler::set_error, avg 27µs/call
63
6438.94ms $self = $class->load( @args );
# spent 8.94ms making 3 calls to CGI::Session::load, avg 2.98ms/call
65 if (not defined $self) {
66 return $class->set_error( "new(): failed: " . $class->errstr );
67 }
68 }
69
70 my $dataref = $self->{_DATA};
71 unless ($dataref->{_SESSION_ID}) {
72 #
73 # Absence of '_SESSION_ID' can only signal:
74 # * Expired session: Because load() - constructor is required to
75 # empty contents of _DATA - table
76 # * Unavailable session: Such sessions are the ones that don't
77 # exist on datastore, but are requested by client
78 # * New session: When no specific session is requested to be loaded
79 #
809300µs my $id = $self->_id_generator()->generate_id(
# spent 262µs making 3 calls to CGI::Session::ID::md5::generate_id, avg 87µs/call # spent 30µs making 3 calls to CGI::Session::_id_generator, avg 10µs/call # spent 8µs making 3 calls to Digest::MD5::DESTROY, avg 3µs/call
81 $self->{_DRIVER_ARGS},
82 $self->{_CLAIMED_ID}
83 );
84 unless (defined $id) {
85 return $self->set_error( "Couldn't generate new SESSION-ID" );
86 }
87 $dataref->{_SESSION_ID} = $id;
88 $dataref->{_SESSION_CTIME} = $dataref->{_SESSION_ATIME} = time();
89 $dataref->{_SESSION_REMOTE_ADDR} = $ENV{REMOTE_ADDR} || "";
90321µs $self->_set_status( STATUS_NEW );
# spent 21µs making 3 calls to CGI::Session::_set_status, avg 7µs/call
91 }
92 return $self;
93}
94
95342µs313.4ms
# spent 13.5ms (34µs+13.4) within CGI::Session::DESTROY which was called 3 times, avg 4.49ms/call: # once (12µs+5.74ms) by main::RUNTIME at line 690 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (13µs+4.26ms) by C4::Auth::checkauth at line 806 of /usr/share/koha/lib/C4/Auth.pm # once (9µs+3.43ms) by C4::Auth::get_template_and_user at line 365 of /usr/share/koha/lib/C4/Auth.pm
sub DESTROY { $_[0]->flush() }
# spent 13.4ms making 3 calls to CGI::Session::flush, avg 4.48ms/call
96sub close { $_[0]->flush() }
97
9813µs*param_hashref = \&dataref;
9912µsmy $avoid_single_use_warning = *param_hashref;
1001978µs
# spent 52µs within CGI::Session::dataref which was called 19 times, avg 3µs/call: # 16 times (44µs+0s) by CGI::Session::id at line 108, avg 3µs/call # 3 times (8µs+0s) by CGI::Session::flush at line 249, avg 2µs/call
sub dataref { $_[0]->{_DATA} }
101
102sub is_empty { !defined($_[0]->id) }
103
104sub is_expired { $_[0]->_test_status( STATUS_EXPIRED ) }
105
106sub is_new { $_[0]->_test_status( STATUS_NEW ) }
107
108888µs1644µs
# spent 146µs (101+44) within CGI::Session::id which was called 8 times, avg 18µs/call: # 3 times (38µs+18µs) by CGI::Session::flush at line 227, avg 19µs/call # 3 times (29µs+13µs) by CGI::Session::flush at line 253, avg 14µs/call # once (23µs+8µs) by C4::Auth::checkauth at line 810 of /usr/share/koha/lib/C4/Auth.pm # once (10µs+5µs) by C4::Auth::checkauth at line 812 of /usr/share/koha/lib/C4/Auth.pm
sub id { return defined($_[0]->dataref) ? $_[0]->dataref->{_SESSION_ID} : undef }
# spent 44µs making 16 calls to CGI::Session::dataref, avg 3µs/call
109
110# Last Access Time
111sub atime { return defined($_[0]->dataref) ? $_[0]->dataref->{_SESSION_ATIME} : undef }
112
113# Creation Time
114sub ctime { return defined($_[0]->dataref) ? $_[0]->dataref->{_SESSION_CTIME} : undef }
115
116
# spent 342µs (106+236) within CGI::Session::_driver which was called 3 times, avg 114µs/call: # 3 times (106µs+236µs) by CGI::Session::flush at line 237, avg 114µs/call
sub _driver {
11715113µs my $self = shift;
118 defined($self->{_OBJECTS}->{driver}) and return $self->{_OBJECTS}->{driver};
119 my $pm = "CGI::Session::Driver::" . $self->{_DSN}->{driver};
1203236µs defined($self->{_OBJECTS}->{driver} = $pm->new( $self->{_DRIVER_ARGS} ))
# spent 236µs making 3 calls to CGI::Session::Driver::new, avg 79µs/call
121 or die $pm->errstr();
122 return $self->{_OBJECTS}->{driver};
123}
124
125
# spent 35µs within CGI::Session::_serializer which was called 3 times, avg 12µs/call: # 3 times (35µs+0s) by CGI::Session::flush at line 238, avg 12µs/call
sub _serializer {
126942µs my $self = shift;
127 defined($self->{_OBJECTS}->{serializer}) and return $self->{_OBJECTS}->{serializer};
128 return $self->{_OBJECTS}->{serializer} = "CGI::Session::Serialize::" . $self->{_DSN}->{serializer};
129}
130
131
132
# spent 30µs within CGI::Session::_id_generator which was called 3 times, avg 10µs/call: # 3 times (30µs+0s) by CGI::Session::new at line 80, avg 10µs/call
sub _id_generator {
133934µs my $self = shift;
134 defined($self->{_OBJECTS}->{id}) and return $self->{_OBJECTS}->{id};
135 return $self->{_OBJECTS}->{id} = "CGI::Session::ID::" . $self->{_DSN}->{id};
136}
137
138sub _ip_matches {
139 return ( $_[0]->{_DATA}->{_SESSION_REMOTE_ADDR} eq $ENV{REMOTE_ADDR} );
140}
141
142
143# parses the DSN string and returns it as a hash.
144# Notably: Allows unique abbreviations of the keys: driver, serializer and 'id'.
145# Also, keys and values of the returned hash are lower-cased.
146
# spent 1.27ms (930µs+339µs) within CGI::Session::parse_dsn which was called 3 times, avg 423µs/call: # 3 times (930µs+339µs) by CGI::Session::load at line 688, avg 423µs/call
sub parse_dsn {
14733861µs my $self = shift;
148 my $dsn_str = shift;
149 croak "parse_dsn(): usage error" unless $dsn_str;
150
151 require Text::Abbrev;
1523339µs my $abbrev = Text::Abbrev::abbrev( "driver", "serializer", "id" );
# spent 339µs making 3 calls to Text::Abbrev::abbrev, avg 113µs/call
153 my %dsn_map = map { split /:/ } (split /;/, $dsn_str);
154 my %dsn = map { $abbrev->{lc $_}, lc $dsn_map{$_} } keys %dsn_map;
155 return \%dsn;
156}
157
158
# spent 626µs (35+591) within CGI::Session::query which was called 2 times, avg 313µs/call: # 2 times (35µs+591µs) by CGI::Session::load at line 705, avg 313µs/call
sub query {
159835µs my $self = shift;
160
161 if ( $self->{_QUERY} ) {
162 return $self->{_QUERY};
163 }
164# require CGI::Session::Query;
165# return $self->{_QUERY} = CGI::Session::Query->new();
166 require CGI;
1672591µs return $self->{_QUERY} = CGI->new();
# spent 591µs making 2 calls to CGI::new, avg 295µs/call
168}
169
170
171
# spent 30µs within CGI::Session::name which was called 4 times, avg 8µs/call: # 4 times (30µs+0s) by CGI::Session::load at line 707, avg 8µs/call
sub name {
1721237µs my $self = shift;
173
174 if (ref $self) {
175 unless ( @_ ) {
176 return $self->{_NAME} || $CGI::Session::NAME;
177 }
178 return $self->{_NAME} = $_[0];
179 }
180
181 $CGI::Session::NAME = $_[0] if @_;
182 return $CGI::Session::NAME;
183}
184
185
186sub dump {
187 my $self = shift;
188
189 require Data::Dumper;
190 my $d = Data::Dumper->new([$self], [ref $self]);
191 $d->Deepcopy(1);
192 return $d->Dump();
193}
194
195
196
# spent 38µs within CGI::Session::_set_status which was called 7 times, avg 5µs/call: # 4 times (17µs+0s) by CGI::Session::param at line 315, avg 4µs/call # 3 times (21µs+0s) by CGI::Session::new at line 90, avg 7µs/call
sub _set_status {
1972149µs my $self = shift;
198 croak "_set_status(): usage error" unless @_;
199 $self->{_STATUS} |= $_[0];
200}
201
202
203
# spent 40µs within CGI::Session::_unset_status which was called 3 times, avg 13µs/call: # 3 times (40µs+0s) by CGI::Session::flush at line 255, avg 13µs/call
sub _unset_status {
204941µs my $self = shift;
205 croak "_unset_status(): usage error" unless @_;
206 $self->{_STATUS} &= ~$_[0];
207}
208
209
210sub _reset_status {
211 $_[0]->{_STATUS} = STATUS_UNSET;
212}
213
214
# spent 61µs within CGI::Session::_test_status which was called 17 times, avg 4µs/call: # 6 times (15µs+0s) by CGI::Session::flush at line 232, avg 3µs/call # 5 times (24µs+0s) by CGI::Session::param at line 266, avg 5µs/call # 3 times (12µs+0s) by CGI::Session::flush at line 240, avg 4µs/call # 3 times (11µs+0s) by CGI::Session::flush at line 248, avg 4µs/call
sub _test_status {
2151795µs return $_[0]->{_STATUS} & $_[1];
216}
217
218
219
# spent 13.4ms (284µs+13.1) within CGI::Session::flush which was called 3 times, avg 4.48ms/call: # 3 times (284µs+13.1ms) by CGI::Session::DESTROY at line 95, avg 4.48ms/call
sub flush {
22039230µs my $self = shift;
221
222 # Would it be better to die or err if something very basic is wrong here?
223 # I'm trying to address the DESTORY related warning
224 # from: http://rt.cpan.org/Ticket/Display.html?id=17541
225 # return unless defined $self;
226
227357µs return unless $self->id; # <-- empty session
# spent 57µs making 3 calls to CGI::Session::id, avg 19µs/call
228
229 # neither new, nor deleted nor modified
230 return if !defined($self->{_STATUS}) or $self->{_STATUS} == STATUS_UNSET;
231
232615µs if ( $self->_test_status(STATUS_NEW) && $self->_test_status(STATUS_DELETED) ) {
# spent 15µs making 6 calls to CGI::Session::_test_status, avg 3µs/call
233 $self->{_DATA} = {};
234 return $self->_unset_status(STATUS_NEW | STATUS_DELETED);
235 }
236
2373342µs my $driver = $self->_driver();
# spent 342µs making 3 calls to CGI::Session::_driver, avg 114µs/call
238335µs my $serializer = $self->_serializer();
# spent 35µs making 3 calls to CGI::Session::_serializer, avg 12µs/call
239
240312µs if ( $self->_test_status(STATUS_DELETED) ) {
# spent 12µs making 3 calls to CGI::Session::_test_status, avg 4µs/call
241 defined($driver->remove($self->id)) or
242 return $self->set_error( "flush(): couldn't remove session data: " . $driver->errstr );
243 $self->{_DATA} = {}; # <-- removing all the data, making sure
244 # it won't be accessible after flush()
245 return $self->_unset_status(STATUS_DELETED);
246 }
247
248311µs if ( $self->_test_status(STATUS_NEW | STATUS_MODIFIED) ) {
# spent 11µs making 3 calls to CGI::Session::_test_status, avg 4µs/call
2496538µs my $datastr = $serializer->freeze( $self->dataref );
# spent 530µs making 3 calls to CGI::Session::Serialize::yaml::freeze, avg 177µs/call # spent 8µs making 3 calls to CGI::Session::dataref, avg 2µs/call
250 unless ( defined $datastr ) {
251 return $self->set_error( "flush(): couldn't freeze data: " . $serializer->errstr );
252 }
253612.1ms defined( $driver->store($self->id, $datastr) ) or
# spent 12.1ms making 3 calls to CGI::Session::Driver::mysql::store, avg 4.02ms/call # spent 42µs making 3 calls to CGI::Session::id, avg 14µs/call
254 return $self->set_error( "flush(): couldn't store datastr: " . $driver->errstr);
255340µs $self->_unset_status(STATUS_NEW | STATUS_MODIFIED);
# spent 40µs making 3 calls to CGI::Session::_unset_status, avg 13µs/call
256 }
257 return 1;
258}
259
260sub trace {}
261sub tracemsg {}
262
263
# spent 256µs (211+46) within CGI::Session::param which was called 5 times, avg 51µs/call: # once (67µs+14µs) by C4::Auth::checkauth at line 1024 of /usr/share/koha/lib/C4/Auth.pm # once (53µs+10µs) by main::RUNTIME at line 692 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (44µs+8µs) by C4::Auth::checkauth at line 1026 of /usr/share/koha/lib/C4/Auth.pm # once (30µs+8µs) by C4::Auth::checkauth at line 1025 of /usr/share/koha/lib/C4/Auth.pm # once (17µs+6µs) by C4::Auth::get_template_and_user at line 367 of /usr/share/koha/lib/C4/Auth.pm
sub param {
26463211µs my ($self, @args) = @_;
265
266524µs if ($self->_test_status( STATUS_DELETED )) {
# spent 24µs making 5 calls to CGI::Session::_test_status, avg 5µs/call
267 carp "param(): attempt to read/write deleted session";
268 }
269
270 # USAGE: $s->param();
271 # DESC: Returns all the /public/ parameters
272 if (@args == 0) {
273 return grep { !/^_SESSION_/ } keys %{ $self->{_DATA} };
274 }
275 # USAGE: $s->param( $p );
276 # DESC: returns a specific session parameter
277 elsif (@args == 1) {
278 return $self->{_DATA}->{ $args[0] }
279 }
280
281
282 # USAGE: $s->param( -name => $n, -value => $v );
283 # DESC: Updates session data using CGI.pm's 'named param' syntax.
284 # Only public records can be set!
285 my %args = @args;
286 my ($name, $value) = @args{ qw(-name -value) };
287 if (defined $name && defined $value) {
288 if ($name =~ m/^_SESSION_/) {
289
290 carp "param(): attempt to write to private parameter";
291 return undef;
292 }
293 $self->_set_status( STATUS_MODIFIED );
294 return $self->{_DATA}->{ $name } = $value;
295 }
296
297 # USAGE: $s->param(-name=>$n);
298 # DESC: access to session data (public & private) using CGI.pm's 'named parameter' syntax.
299 return $self->{_DATA}->{ $args{'-name'} } if defined $args{'-name'};
300
301 # USAGE: $s->param($name, $value);
302 # USAGE: $s->param($name1 => $value1, $name2 => $value2 [,...]);
303 # DESC: updates one or more **public** records using simple syntax
304 if ((@args % 2) == 0) {
305 my $modified_cnt = 0;
306 ARG_PAIR:
307 while (my ($name, $val) = each %args) {
30845µs if ( $name =~ m/^_SESSION_/) {
# spent 5µs making 4 calls to CGI::Session::CORE:match, avg 1µs/call
309 carp "param(): attempt to write to private parameter";
310 next ARG_PAIR;
311 }
312 $self->{_DATA}->{ $name } = $val;
313 ++$modified_cnt;
314 }
315417µs $self->_set_status(STATUS_MODIFIED);
# spent 17µs making 4 calls to CGI::Session::_set_status, avg 4µs/call
316 return $modified_cnt;
317 }
318
319 # If we reached this far none of the expected syntax were
320 # detected. Syntax error
321 croak "param(): usage error. Invalid syntax";
322}
323
- -
326sub delete { $_[0]->_set_status( STATUS_DELETED ) }
327
328
3291800ns*header = \&http_header;
3301700nsmy $avoid_single_use_warning_again = *header;
331sub http_header {
332 my $self = shift;
333 return $self->query->header(-cookie=>$self->cookie, -type=>'text/html', @_);
334}
335
336sub cookie {
337 my $self = shift;
338
339 my $query = $self->query();
340 my $cookie= undef;
341
342 if ( $self->is_expired ) {
343 $cookie = $query->cookie( -name=>$self->name, -value=>$self->id, -expires=> '-1d', @_ );
344 }
345 elsif ( my $t = $self->expire ) {
346 $cookie = $query->cookie( -name=>$self->name, -value=>$self->id, -expires=> '+' . $t . 's', @_ );
347 }
348 else {
349 $cookie = $query->cookie( -name=>$self->name, -value=>$self->id, @_ );
350 }
351 return $cookie;
352}
353
- -
358sub save_param {
359 my $self = shift;
360 my ($query, $params) = @_;
361
362 $query ||= $self->query();
363 $params ||= [ $query->param ];
364
365 for my $p ( @$params ) {
366 my @values = $query->param($p) or next;
367 if ( @values > 1 ) {
368 $self->param($p, \@values);
369 } else {
370 $self->param($p, $values[0]);
371 }
372 }
373 $self->_set_status( STATUS_MODIFIED );
374}
375
- -
378sub load_param {
379 my $self = shift;
380 my ($query, $params) = @_;
381
382 $query ||= $self->query();
383 $params ||= [ $self->param ];
384
385 for ( @$params ) {
386 $query->param(-name=>$_, -value=>$self->param($_));
387 }
388}
389
390
391sub clear {
392 my $self = shift;
393 my $params = shift;
394 #warn ref($params);
395 if (defined $params) {
396 $params = [ $params ] unless ref $params;
397 }
398 else {
399 $params = [ $self->param ];
400 }
401
402 for ( grep { ! /^_SESSION_/ } @$params ) {
403 delete $self->{_DATA}->{$_};
404 }
405 $self->_set_status( STATUS_MODIFIED );
406}
407
408
409sub find {
410 my $class = shift;
411 my ($dsn, $coderef, $dsn_args);
412
413 # find( \%code )
414 if ( @_ == 1 ) {
415 $coderef = $_[0];
416 }
417 # find( $dsn, \&code, \%dsn_args )
418 else {
419 ($dsn, $coderef, $dsn_args) = @_;
420 }
421
422 unless ( $coderef && ref($coderef) && (ref $coderef eq 'CODE') ) {
423 croak "find(): usage error.";
424 }
425
426 my $driver;
427 if ( $dsn ) {
428 my $hashref = $class->parse_dsn( $dsn );
429 $driver = $hashref->{driver};
430 }
431 $driver ||= "file";
432 my $pm = "CGI::Session::Driver::" . ($driver =~ /(.*)/)[0];
433 eval "require $pm";
434 if (my $errmsg = $@ ) {
435 return $class->set_error( "find(): couldn't load driver." . $errmsg );
436 }
437
438 my $driver_obj = $pm->new( $dsn_args );
439 unless ( $driver_obj ) {
440 return $class->set_error( "find(): couldn't create driver object. " . $pm->errstr );
441 }
442
443 my $dont_update_atime = 0;
444 my $driver_coderef = sub {
445 my ($sid) = @_;
446 my $session = $class->load( $dsn, $sid, $dsn_args, $dont_update_atime );
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: Session.pm 459 2009-03-21 02:00:17Z markstos $
459
460=pod
461
- -
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 8.94ms (350µs+8.59) within CGI::Session::load which was called 3 times, avg 2.98ms/call: # 3 times (350µs+8.59ms) by CGI::Session::new at line 64, avg 2.98ms/call
sub load {
63456303µs my $class = shift;
635 return $class->set_error( "called as instance method") if ref $class;
636 return $class->set_error( "Too many arguments provided to load()") if @_ > 5;
637
638 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 my ($dsn,$query_or_sid,$dsn_args,$update_atime,$params);
661 # load($query||$sid)
662 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 ($dsn, $query_or_sid, $dsn_args,$update_atime) = @_;
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 if ( ref $update_atime and ref $update_atime eq 'HASH' ) {
674 $params = {%$update_atime};
675 $update_atime = $params->{'update_atime'};
676
677 if ($params->{'name'}) {
678 $self->{_NAME} = $params->{'name'};
679 }
680 }
681
682 # Since $update_atime is not part of the public API
683 # we ignore any value but the one we use internally: 0.
684 if (defined $update_atime and $update_atime ne '0') {
685 return $class->set_error( "Too many arguments to load(). First extra argument was: $update_atime");
686 }
687
68831.27ms if ( defined $dsn ) { # <-- to avoid 'Uninitialized value...' warnings
# spent 1.27ms making 3 calls to CGI::Session::parse_dsn, avg 423µs/call
689 $self->{_DSN} = $self->parse_dsn($dsn);
690 }
691327µs $self->_set_query_or_sid($query_or_sid);
# spent 27µs making 3 calls to CGI::Session::_set_query_or_sid, avg 9µs/call
692
693 # load($dsn, $query, \%dsn_args);
694
695 $self->{_DRIVER_ARGS} = $dsn_args if defined $dsn_args;
696
697 }
698
69936.42ms $self->_load_pluggables();
# spent 6.42ms making 3 calls to CGI::Session::_load_pluggables, avg 2.14ms/call
700
701 # Did load_pluggable fail? If so, return undef, just like $class->set_error() would
702338µs return undef if $class->errstr;
# spent 38µs making 3 calls to CGI::Session::ErrorHandler::errstr, avg 13µs/call
703
704 if (not defined $self->{_CLAIMED_ID}) {
7052626µs my $query = $self->query();
# spent 626µs making 2 calls to CGI::Session::query, avg 313µs/call
706 eval {
7078216µs $self->{_CLAIMED_ID} = $query->cookie( $self->name ) || $query->param( $self->name );
# spent 149µs making 2 calls to CGI::cookie, avg 75µs/call # spent 37µs making 2 calls to CGI::param, avg 18µs/call # spent 30µs making 4 calls to CGI::Session::name, avg 8µs/call
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 return $self unless $self->{_CLAIMED_ID};
716
717 # Attempting to load the session
718 my $driver = $self->_driver();
719 my $raw_data = $driver->retrieve( $self->{_CLAIMED_ID} );
720 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 return $self unless $raw_data;
726
727 my $serializer = $self->_serializer();
728 $self->{_DATA} = $serializer->thaw($raw_data);
729 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 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 # checking if previous session ip matches current ip
740 if($CGI::Session::IP_MATCH) {
741 unless($self->_ip_matches) {
742 $self->_set_status( STATUS_DELETED );
743 $self->flush;
744 return $self;
745 }
746 }
747
748 # checking for expiration ticker
749 if ( $self->{_DATA}->{_SESSION_ETIME} ) {
750 if ( ($self->{_DATA}->{_SESSION_ATIME} + $self->{_DATA}->{_SESSION_ETIME}) <= time() ) {
751 $self->_set_status( STATUS_EXPIRED | # <-- so client can detect expired sessions
752 STATUS_DELETED ); # <-- session should be removed from database
753 $self->flush(); # <-- flush() will do the actual removal!
754 return $self;
755 }
756 }
757
758 # checking expiration tickers of individuals parameters, if any:
759 my @expired_params = ();
760 while (my ($param, $max_exp_interval) = each %{ $self->{_DATA}->{_SESSION_EXPIRE_LIST} } ) {
761 if ( ($self->{_DATA}->{_SESSION_ATIME} + $max_exp_interval) <= time() ) {
762 push @expired_params, $param;
763 }
764 }
765 $self->clear(\@expired_params) if @expired_params;
766
767 # We update the atime by default, but if this (otherwise undocoumented)
768 # parameter is explicitly set to false, we'll turn the behavior off
769 if ( ! defined $update_atime ) {
770 $self->{_DATA}->{_SESSION_ATIME} = time(); # <-- updating access time
771 $self->_set_status( STATUS_MODIFIED ); # <-- access time modified above
772 }
773
774 return $self;
775}
776
777
778# set the input as a query object or session ID, depending on what it looks like.
779
# spent 27µs within CGI::Session::_set_query_or_sid which was called 3 times, avg 9µs/call: # 3 times (27µs+0s) by CGI::Session::load at line 691, avg 9µs/call
sub _set_query_or_sid {
7801233µs my $self = shift;
781 my $query_or_sid = shift;
782 if ( ref $query_or_sid){ $self->{_QUERY} = $query_or_sid }
783 else { $self->{_CLAIMED_ID} = $query_or_sid }
784}
785
786
787
# spent 6.42ms (2.64+3.78) within CGI::Session::_load_pluggables which was called 3 times, avg 2.14ms/call: # 3 times (2.64ms+3.78ms) by CGI::Session::load at line 699, avg 2.14ms/call
sub _load_pluggables {
78890807µs my ($self) = @_;
789
790 my %DEFAULT_FOR = (
791 driver => "file",
792 serializer => "default",
793 id => "md5",
794 );
795 my %SUBDIR_FOR = (
796 driver => "Driver",
797 serializer => "Serialize",
798 id => "ID",
799 );
800 my $dsn = $self->{_DSN};
801 foreach my $plug qw(driver serializer id) {
802 my $mod_name = $dsn->{ $plug };
803 if (not defined $mod_name) {
804 $mod_name = $DEFAULT_FOR{ $plug };
805 }
806972µs if ($mod_name =~ /^(\w+)$/) {
# spent 72µs making 9 calls to CGI::Session::CORE:match, avg 8µs/call
807
808 # Looks good. Put it into the dsn hash
809 $dsn->{ $plug } = $mod_name = $1;
810
811 # Put together the actual module name to load
812 my $prefix = join '::', (__PACKAGE__, $SUBDIR_FOR{ $plug }, q{});
813 $mod_name = $prefix . $mod_name;
814
815 ## See if we can load load it
816 eval "require $mod_name";
# spent 180µs executing statements in 3 string evals (merged) # spent 157µs executing statements in 3 string evals (merged) # spent 142µs executing statements in 3 string evals (merged)
817 if ($@) {
818 my $msg = $@;
819 return $self->set_error("couldn't load $mod_name: " . $msg);
820 }
821 }
822 else {
823 # do something here about bad name for a pluggable
824 }
825 }
826 return;
827}
828
829=pod
830
- -
9621500ns*expires = \&expire;
9631400nsmy $prevent_warning = \&expires;
964sub etime { $_[0]->expire() }
965sub expire {
966 my $self = shift;
967
968 # no params, just return the expiration time.
969 if (not @_) {
970 return $self->{_DATA}->{_SESSION_ETIME};
971 }
972 # We have just a time
973 elsif ( @_ == 1 ) {
974 my $time = $_[0];
975 # If 0 is passed, cancel expiration
976 if ( defined $time && ($time =~ m/^\d$/) && ($time == 0) ) {
977 $self->{_DATA}->{_SESSION_ETIME} = undef;
978 $self->_set_status( STATUS_MODIFIED );
979 }
980 # set the expiration to this time
981 else {
982 $self->{_DATA}->{_SESSION_ETIME} = $self->_str2seconds( $time );
983 $self->_set_status( STATUS_MODIFIED );
984 }
985 }
986 # If we get this far, we expect expire($param,$time)
987 # ( This would be a great use of a Perl6 multi sub! )
988 else {
989 my ($param, $time) = @_;
990 if ( ($time =~ m/^\d$/) && ($time == 0) ) {
991 delete $self->{_DATA}->{_SESSION_EXPIRE_LIST}->{ $param };
992 $self->_set_status( STATUS_MODIFIED );
993 } else {
994 $self->{_DATA}->{_SESSION_EXPIRE_LIST}->{ $param } = $self->_str2seconds( $time );
995 $self->_set_status( STATUS_MODIFIED );
996 }
997 }
998 return 1;
999}
1000
1001# =head2 _str2seconds()
1002#
1003# my $secs = $self->_str2seconds('1d')
1004#
1005# Takes a CGI.pm-style time representation and returns an equivalent number
1006# of seconds.
1007#
1008# See the docs of expire() for more detail.
1009#
1010# =cut
1011
1012sub _str2seconds {
1013 my $self = shift;
1014 my ($str) = @_;
1015
1016 return unless defined $str;
1017 return $str if $str =~ m/^[-+]?\d+$/;
1018
1019 my %_map = (
1020 s => 1,
1021 m => 60,
1022 h => 3600,
1023 d => 86400,
1024 w => 604800,
1025 M => 2592000,
1026 y => 31536000
1027 );
1028
1029 my ($koef, $d) = $str =~ m/^([+-]?\d+)([smhdwMy])$/;
1030 unless ( defined($koef) && defined($d) ) {
1031 die "_str2seconds(): couldn't parse '$str' into \$koef and \$d parts. Possible invalid syntax";
1032 }
1033 return $koef * $_map{ $d };
1034}
1035
1036
1037=pod
1038
- -
1179110µs
# spent 7µs within CGI::Session::remote_addr which was called: # once (7µs+0s) by C4::Auth::checkauth at line 1024 of /usr/share/koha/lib/C4/Auth.pm
sub remote_addr { return $_[0]->{_DATA}->{_SESSION_REMOTE_ADDR} }
1180
1181=pod
1182
- -
1472113µs1;
1473
 
# spent 76µs within CGI::Session::CORE:match which was called 13 times, avg 6µs/call: # 9 times (72µs+0s) by CGI::Session::_load_pluggables at line 806, avg 8µs/call # 4 times (5µs+0s) by CGI::Session::param at line 308, avg 1µs/call
sub CGI::Session::CORE:match; # opcode
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.