← Index
Performance Profile   « block view • line view • sub view »
For opac/opac-main.pl
  Run on Fri Jul 18 13:58:34 2008
Reported on Fri Jul 18 13:58:43 2008

File/usr/share/perl/5.8/CGI.pm
Statements Executed313
Total Time0.00702700000000002 seconds

Subroutines — ordered by inclusive time then name
CallsInclusive
Time		Subroutine
70.00702CGI::AUTOLOAD
70.00693CGI::_compile
10.00586CGI::new
10.00579CGI::init
70.00018CGI::param
190.00017CGI::self_or_default
30.00007CGI::charset
10.00006CGI::save_request
30.00002CGI::all_parameters
20.00002CGI::self_or_CGI
00CGI::BEGIN
00CGI::DESTROY
00CGI::__ANON__[:877]
00CGI::_checked
00CGI::_make_tag_func
00CGI::_reset_globals
00CGI::_selected
00CGI::_setup_symbols
00CGI::add_parameter
00CGI::binmode
00CGI::can
00CGI::cgi_error
00CGI::compile
00CGI::element_id
00CGI::element_tab
00CGI::expand_tags
00CGI::import
00CGI::initialize_globals
00CGI::parse_params
00CGI::print
00CGI::put
00CGI::r
00CGI::to_filehandle
00CGI::upload_hook
00CGITempFile::DESTROY
00CGITempFile::find_tempdir
00Fh::BEGIN
00Fh::DESTROY
00MultipartBuffer::BEGIN
00MultipartBuffer::DESTROY

<
LineStmts.Exclusive
Time		Avg.Code
1package CGI;
2require 5.004;
3use Carp 'croak';
4
5# See the bottom of this file for the POD documentation. Search for the
6# string '=head'.
7
8# You can run this file through either pod2man or pod2html to produce pretty
9# documentation in manual or html file format (these utilities are part of the
10# Perl 5 distribution).
11
12# Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
13# It may be used and modified freely, but I do request that this copyright
14# notice remain attached to the file. You may modify this module as you
15# wish, but if you redistribute a modified version, please attach a note
16# listing the modifications you have made.
17
18# The most recent version and complete docs are available at:
19# http://stein.cshl.org/WWW/software/CGI/
20
21$CGI::revision = '$Id: CGI.pm,v 1.194 2005/12/06 22:12:56 lstein Exp $';
22$CGI::VERSION='3.15';
23
24# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
25# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
26# $CGITempFile::TMPDIRECTORY = '/usr/tmp';
27use CGI::Util qw(rearrange make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
28
29#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
30# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
31
32use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
33 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
34
35{
36 local $^W = 0;
37 $TAINTED = substr("$0$^X",0,0);
38}
39
40$MOD_PERL = 0; # no mod_perl by default
41@SAVED_SYMBOLS = ();
42
43# >>>>> Here are some globals that you might want to adjust <<<<<<
44sub initialize_globals {
45 # Set this to 1 to enable copious autoloader debugging messages
46 $AUTOLOAD_DEBUG = 0;
47
48 # Set this to 1 to generate XTML-compatible output
49 $XHTML = 1;
50
51 # Change this to the preferred DTD to print in start_html()
52 # or use default_dtd('text of DTD to use');
53 $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
54 'http://www.w3.org/TR/html4/loose.dtd' ] ;
55
56 # Set this to 1 to enable NOSTICKY scripts
57 # or:
58 # 1) use CGI qw(-nosticky)
59 # 2) $CGI::nosticky(1)
60 $NOSTICKY = 0;
61
62 # Set this to 1 to enable NPH scripts
63 # or:
64 # 1) use CGI qw(-nph)
65 # 2) CGI::nph(1)
66 # 3) print header(-nph=>1)
67 $NPH = 0;
68
69 # Set this to 1 to enable debugging from @ARGV
70 # Set to 2 to enable debugging from STDIN
71 $DEBUG = 1;
72
73 # Set this to 1 to make the temporary files created
74 # during file uploads safe from prying eyes
75 # or do...
76 # 1) use CGI qw(:private_tempfiles)
77 # 2) CGI::private_tempfiles(1);
78 $PRIVATE_TEMPFILES = 0;
79
80 # Set this to 1 to generate automatic tab indexes
81 $TABINDEX = 0;
82
83 # Set this to 1 to cause files uploaded in multipart documents
84 # to be closed, instead of caching the file handle
85 # or:
86 # 1) use CGI qw(:close_upload_files)
87 # 2) $CGI::close_upload_files(1);
88 # Uploads with many files run out of file handles.
89 # Also, for performance, since the file is already on disk,
90 # it can just be renamed, instead of read and written.
91 $CLOSE_UPLOAD_FILES = 0;
92
93 # Set this to a positive value to limit the size of a POSTing
94 # to a certain number of bytes:
95 $POST_MAX = -1;
96
97 # Change this to 1 to disable uploads entirely:
98 $DISABLE_UPLOADS = 0;
99
100 # Automatically determined -- don't change
101 $EBCDIC = 0;
102
103 # Change this to 1 to suppress redundant HTTP headers
104 $HEADERS_ONCE = 0;
105
106 # separate the name=value pairs by semicolons rather than ampersands
107 $USE_PARAM_SEMICOLONS = 1;
108
109 # Do not include undefined params parsed from query string
110 # use CGI qw(-no_undef_params);
111 $NO_UNDEF_PARAMS = 0;
112
113 # Other globals that you shouldn't worry about.
114 undef $Q;
115 $BEEN_THERE = 0;
116 $DTD_PUBLIC_IDENTIFIER = "";
117 undef @QUERY_PARAM;
118 undef %EXPORT;
119 undef $QUERY_CHARSET;
120 undef %QUERY_FIELDNAMES;
121
122 # prevent complaints by mod_perl
123 1;
124}
125
126# ------------------ START OF THE LIBRARY ------------
127
128*end_form = \&endform;
129
130# make mod_perlhappy
131initialize_globals();
132
133# FIGURE OUT THE OS WE'RE RUNNING UNDER
134# Some systems support the $^O variable. If not
135# available then require() the Config library
136unless ($OS) {
137 unless ($OS = $^O) {
138 require Config;
139 $OS = $Config::Config{'osname'};
140 }
141}
142if ($OS =~ /^MSWin/i) {
143 $OS = 'WINDOWS';
144} elsif ($OS =~ /^VMS/i) {
145 $OS = 'VMS';
146} elsif ($OS =~ /^dos/i) {
147 $OS = 'DOS';
148} elsif ($OS =~ /^MacOS/i) {
149 $OS = 'MACINTOSH';
150} elsif ($OS =~ /^os2/i) {
151 $OS = 'OS2';
152} elsif ($OS =~ /^epoc/i) {
153 $OS = 'EPOC';
154} elsif ($OS =~ /^cygwin/i) {
155 $OS = 'CYGWIN';
156} else {
157 $OS = 'UNIX';
158}
159
160# Some OS logic. Binary mode enabled on DOS, NT and VMS
161$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN)/;
162
163# This is the default class for the CGI object to use when all else fails.
164$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
165
166# This is where to look for autoloaded routines.
167$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
168
169# The path separator is a slash, backslash or semicolon, depending
170# on the paltform.
171$SL = {
172 UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/',
173 WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
174 }->{$OS};
175
176# This no longer seems to be necessary
177# Turn on NPH scripts by default when running under IIS server!
178# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
179$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
180
181# Turn on special checking for Doug MacEachern's modperl
182if (exists $ENV{MOD_PERL}) {
183 # mod_perl handlers may run system() on scripts using CGI.pm;
184 # Make sure so we don't get fooled by inherited $ENV{MOD_PERL}
185 if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
186 $MOD_PERL = 2;
187 require Apache2::Response;
188 require Apache2::RequestRec;
189 require Apache2::RequestUtil;
190 require Apache2::RequestIO;
191 require APR::Pool;
192 } else {
193 $MOD_PERL = 1;
194 require Apache;
195 }
196}
197
198# Turn on special checking for ActiveState's PerlEx
199$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
200
201# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
202# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
203# and sometimes CR). The most popular VMS web server
204# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
205# use ASCII, so \015\012 means something different. I find this all
206# really annoying.
207$EBCDIC = "\t" ne "\011";
208if ($OS eq 'VMS') {
209 $CRLF = "\n";
210} elsif ($EBCDIC) {
211 $CRLF= "\r\n";
212} else {
213 $CRLF = "\015\012";
214}
215
216if ($needs_binmode) {
217 $CGI::DefaultClass->binmode(\*main::STDOUT);
218 $CGI::DefaultClass->binmode(\*main::STDIN);
219 $CGI::DefaultClass->binmode(\*main::STDERR);
220}
221
222%EXPORT_TAGS = (
223 ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
224 tt u i b blockquote pre img a address cite samp dfn html head
225 base body Link nextid title meta kbd start_html end_html
226 input Select option comment charset escapeHTML/],
227 ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param
228 embed basefont style span layer ilayer font frameset frame script small big Area Map/],
229 ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
230 ins label legend noframes noscript object optgroup Q
231 thead tbody tfoot/],
232 ':netscape'=>[qw/blink fontsize center/],
233 ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
234 submit reset defaults radio_group popup_menu button autoEscape
235 scrolling_list image_button start_form end_form startform endform
236 start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
237 ':cgi'=>[qw/param upload path_info path_translated request_uri url self_url script_name
238 cookie Dump
239 raw_cookie request_method query_string Accept user_agent remote_host content_type
240 remote_addr referer server_name server_software server_port server_protocol virtual_port
241 virtual_host remote_ident auth_type http append
242 save_parameters restore_parameters param_fetch
243 remote_user user_name header redirect import_names put
244 Delete Delete_all url_param cgi_error/],
245 ':ssl' => [qw/https/],
246 ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
247 ':html' => [qw/:html2 :html3 :html4 :netscape/],
248 ':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
249 ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
250 ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/]
251 );
252
253# Custom 'can' method for both autoloaded and non-autoloaded subroutines.
254# Author: Cees Hek <cees@sitesuite.com.au>
255
256sub can {
257 my($class, $method) = @_;
258
259 # See if UNIVERSAL::can finds it.
260
261 if (my $func = $class -> SUPER::can($method) ){
262 return $func;
263 }
264
265 # Try to compile the function.
266
267 eval {
268 # _compile looks at $AUTOLOAD for the function name.
269
270 local $AUTOLOAD = join "::", $class, $method;
271 &_compile;
272 };
273
274 # Now that the function is loaded (if it exists)
275 # just use UNIVERSAL::can again to do the work.
276
277 return $class -> SUPER::can($method);
278}
279
280# to import symbols into caller
281sub import {
282 my $self = shift;
283
284 # This causes modules to clash.
285 undef %EXPORT_OK;
286 undef %EXPORT;
287
288 $self->_setup_symbols(@_);
289 my ($callpack, $callfile, $callline) = caller;
290
291 # To allow overriding, search through the packages
292 # Till we find one in which the correct subroutine is defined.
293 my @packages = ($self,@{"$self\:\:ISA"});
294 foreach $sym (keys %EXPORT) {
295 my $pck;
296 my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
297 foreach $pck (@packages) {
298 if (defined(&{"$pck\:\:$sym"})) {
299 $def = $pck;
300 last;
301 }
302 }
303 *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
304 }
305}
306
307sub compile {
308 my $pack = shift;
309 $pack->_setup_symbols('-compile',@_);
310}
311
312sub expand_tags {
313 my($tag) = @_;
314 return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
315 my(@r);
316 return ($tag) unless $EXPORT_TAGS{$tag};
317 foreach (@{$EXPORT_TAGS{$tag}}) {
318 push(@r,&expand_tags($_));
319 }
320 return @r;
321}
322
323#### Method: new
324# The new routine. This will check the current environment
325# for an existing query string, and initialize itself, if so.
326####
327
# spent 0.00586s within CGI::new which was called: # 1 times (0.00586s) at line 23 of opac/opac-main.pl
sub new {
32890.000033e-06 my($class,@initializer) = @_;
329 my $self = {};
330
331 bless $self,ref $class || $class || $DefaultClass;
332 if (ref($initializer[0])
333 && (UNIVERSAL::isa($initializer[0],'Apache')
334 ||
335 UNIVERSAL::isa($initializer[0],'Apache2::RequestRec')
336 )) {
337 $self->r(shift @initializer);
338 }
339 if (ref($initializer[0])
340 && (UNIVERSAL::isa($initializer[0],'CODE'))) {
341 $self->upload_hook(shift @initializer, shift @initializer);
342 }
343 if ($MOD_PERL) {
344 if ($MOD_PERL == 1) {
345 $self->r(Apache->request) unless $self->r;
346 my $r = $self->r;
347 $r->register_cleanup(\&CGI::_reset_globals);
348 }
349 else {
350 # XXX: once we have the new API
351 # will do a real PerlOptions -SetupEnv check
352 $self->r(Apache2::RequestUtil->request) unless $self->r;
353 my $r = $self->r;
354 $r->subprocess_env unless exists $ENV{REQUEST_METHOD};
355 $r->pool->cleanup_register(\&CGI::_reset_globals);
356 }
357 undef $NPH;
358 }
359 $self->_reset_globals if $PERLEX;
360 $self->init(@initializer);
# spent 0.00579s making 1 calls to CGI::init
361 return $self;
362}
363
364# We provide a DESTROY method so that we can ensure that
365# temporary files are closed (via Fh->DESTROY) before they
366# are unlinked (via CGITempFile->DESTROY) because it is not
367# possible to unlink an open file on Win32. We explicitly
368# call DESTROY on each, rather than just undefing them and
369# letting Perl DESTROY them by garbage collection, in case the
370# user is still holding any reference to them as well.
371sub DESTROY {
37222e-061e-06 my $self = shift;
373 if ($OS eq 'WINDOWS') {
374 foreach my $href (values %{$self->{'.tmpfiles'}}) {
375 $href->{hndl}->DESTROY if defined $href->{hndl};
376 $href->{name}->DESTROY if defined $href->{name};
377 }
378 }
379}
380
381sub r {
382 my $self = shift;
383 my $r = $self->{'.r'};
384 $self->{'.r'} = shift if @_;
385 $r;
386}
387
388sub upload_hook {
389 my $self;
390 if (ref $_[0] eq 'CODE') {
391 $CGI::Q = $self = $CGI::DefaultClass->new(@_);
392 } else {
393 $self = shift;
394 }
395 my ($hook,$data) = @_;
396 $self->{'.upload_hook'} = $hook;
397 $self->{'.upload_data'} = $data;
398}
399
400#### Method: param
401# Returns the value(s)of a named parameter.
402# If invoked in a list context, returns the
403# entire list. Otherwise returns the first
404# member of the list.
405# If name is not provided, return a list of all
406# the known parameters names available.
407# If more than one argument is provided, the
408# second and subsequent arguments are used to
409# set the value of the parameter.
410####
411
# spent 0.00018s within CGI::param which was called 7 times, avg 0.00003s/call: # 2 times (0.00005s) by CGI::delete at line 15 of /usr/share/perl/5.8/CGI.pm, avg 0.00002s/call # 1 times (0.00003s) by C4::Auth::checkauth at line 497 of C4/Auth.pm # 1 times (0.00003s) by C4::Auth::checkauth at line 587 of C4/Auth.pm # 1 times (0.00003s) by CGI::init at line 648 of /usr/share/perl/5.8/CGI.pm # 1 times (0.00002s) by CGI::init at line 654 of /usr/share/perl/5.8/CGI.pm # 1 times (0.00002s) by CGI::save_request at line 706 of /usr/share/perl/5.8/CGI.pm
sub param {
412300.000072e-06 my($self,@p) = self_or_default(@_);
# spent 0.00006s making 7 calls to CGI::self_or_default, avg 8e-06s/call
413 return $self->all_parameters unless @p;
# spent 0.00002s making 3 calls to CGI::all_parameters, avg 8e-06s/call
414 my($name,$value,@other);
415
416 # For compatibility between old calling style and use_named_parameters() style,
417 # we have to special case for a single parameter present.
418 if (@p > 1) {
419 ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
420 my(@values);
421
422 if (substr($p[0],0,1) eq '-') {
423 @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
424 } else {
425 foreach ($value,@other) {
426 push(@values,$_) if defined($_);
427 }
428 }
429 # If values is provided, then we set it.
430 if (@values) {
431 $self->add_parameter($name);
432 $self->{$name}=[@values];
433 }
434 } else {
435 $name = $p[0];
436 }
437
438 return unless defined($name) && $self->{$name};
439 return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
440}
441
442
# spent 0.00017s within CGI::self_or_default which was called 19 times, avg 9e-06s/call: # 7 times (0.00006s) by CGI::param at line 412 of /usr/share/perl/5.8/CGI.pm, avg 8e-06s/call # 3 times (0.00003s) by CGI::cookie at line 2 of /usr/share/perl/5.8/CGI.pm, avg 0.00001s/call # 3 times (0.00003s) by CGI::charset at line 891 of /usr/share/perl/5.8/CGI.pm, avg 1e-05s/call # 2 times (0.00002s) by CGI::unescapeHTML at line 4 of /usr/share/perl/5.8/CGI.pm, avg 9e-06s/call # 2 times (0.00002s) by CGI::delete at line 5 of /usr/share/perl/5.8/CGI.pm, avg 8e-06s/call # 1 times (9e-06s) by CGI::cache at line 2 of /usr/share/perl/5.8/CGI.pm # 1 times (0.00002s) by CGI::header at line 2 of /usr/share/perl/5.8/CGI.pm
sub self_or_default {
443570.000081e-06 return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
444 unless (defined($_[0]) &&
445 (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
446 ) {
447 $Q = $CGI::DefaultClass->new unless defined($Q);
448 unshift(@_,$Q);
449 }
450 return wantarray ? @_ : $Q;
451}
452
453
# spent 0.00002s within CGI::self_or_CGI which was called 2 times, avg 0.00001s/call: # 2 times (0.00002s) by CGI::https at line 3 of /usr/share/perl/5.8/CGI.pm, avg 0.00001s/call
sub self_or_CGI {
45449e-062e-06 local $^W=0; # prevent a warning
455 if (defined($_[0]) &&
456 (substr(ref($_[0]),0,3) eq 'CGI'
457 || UNIVERSAL::isa($_[0],'CGI'))) {
458 return @_;
459 } else {
460 return ($DefaultClass,@_);
461 }
462}
463
464########################################
465# THESE METHODS ARE MORE OR LESS PRIVATE
466# GO TO THE __DATA__ SECTION TO SEE MORE
467# PUBLIC METHODS
468########################################
469
470# Initialize the query object from the environment.
471# If a parameter list is found, this object will be set
472# to an associative array in which parameter names are keys
473# and the values are stored as lists
474# If a keyword list is found, this method creates a bogus
475# parameter list with the single parameter 'keywords'.
476
477
# spent 0.00579s within CGI::init which was called: # 1 times (0.00579s) by CGI::new at line 360 of /usr/share/perl/5.8/CGI.pm
sub init {
478280.000104e-06 my $self = shift;
479 my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
480
481 my $initializer = shift; # for backward compatibility
482 local($/) = "\n";
483
484 # set autoescaping on by default
485 $self->{'escape'} = 1;
486
487 # if we get called more than once, we want to initialize
488 # ourselves from the original query (which may be gone
489 # if it was read from STDIN originally.)
490 if (defined(@QUERY_PARAM) && !defined($initializer)) {
491 foreach (@QUERY_PARAM) {
492 $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
493 }
494 $self->charset($QUERY_CHARSET);
495 $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
496 return;
497 }
498
499 $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
500 $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
501
502 $fh = to_filehandle($initializer) if $initializer;
503
504 # set charset to the safe ISO-8859-1
505 $self->charset('ISO-8859-1');
# spent 0.00003s making 1 calls to CGI::charset
506
507 METHOD: {
508
509 # avoid unreasonably large postings
510 if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
511 # quietly read and discard the post
512 my $buffer;
513 my $tmplength = $content_length;
514 while($tmplength > 0) {
515 my $maxbuffer = ($tmplength < 10000)?$tmplength:10000;
516 my $bytesread = $MOD_PERL ? $self->r->read($buffer,$maxbuffer) : read(STDIN,$buffer,$maxbuffer);
517 $tmplength -= $bytesread;
518 }
519 $self->cgi_error("413 Request entity too large");
520 last METHOD;
521 }
522
523 # Process multipart postings, but only if the initializer is
524 # not defined.
525 if ($meth eq 'POST'
526 && defined($ENV{'CONTENT_TYPE'})
527 && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
528 && !defined($initializer)
529 ) {
530 my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
531 $self->read_multipart($boundary,$content_length);
532 last METHOD;
533 }
534
535 # If initializer is defined, then read parameters
536 # from it.
537 if (defined($initializer)) {
538 if (UNIVERSAL::isa($initializer,'CGI')) {
539 $query_string = $initializer->query_string;
540 last METHOD;
541 }
542 if (ref($initializer) && ref($initializer) eq 'HASH') {
543 foreach (keys %$initializer) {
544 $self->param('-name'=>$_,'-value'=>$initializer->{$_});
545 }
546 last METHOD;
547 }
548
549 if (defined($fh) && ($fh ne '')) {
550 while (<$fh>) {
551 chomp;
552 last if /^=/;
553 push(@lines,$_);
554 }
555 # massage back into standard format
556 if ("@lines" =~ /=/) {
557 $query_string=join("&",@lines);
558 } else {
559 $query_string=join("+",@lines);
560 }
561 last METHOD;
562 }
563
564 if (defined($fh) && ($fh ne '')) {
565 while (<$fh>) {
566 chomp;
567 last if /^=/;
568 push(@lines,$_);
569 }
570 # massage back into standard format
571 if ("@lines" =~ /=/) {
572 $query_string=join("&",@lines);
573 } else {
574 $query_string=join("+",@lines);
575 }
576 last METHOD;
577 }
578
579 # last chance -- treat it as a string
580 $initializer = $$initializer if ref($initializer) eq 'SCALAR';
581 $query_string = $initializer;
582
583 last METHOD;
584 }
585
586 # If method is GET or HEAD, fetch the query from
587 # the environment.
588 if ($meth=~/^(GET|HEAD)$/) {
589 if ($MOD_PERL) {
590 $query_string = $self->r->args;
591 } else {
592 $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
593 $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
594 }
595 last METHOD;
596 }
597
598 if ($meth eq 'POST') {
599 $self->read_from_client(\$query_string,$content_length,0)
600 if $content_length > 0;
601 # Some people want to have their cake and eat it too!
602 # Uncomment this line to have the contents of the query string
603 # APPENDED to the POST data.
604 # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
605 last METHOD;
606 }
607
608 # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
609 # Check the command line and then the standard input for data.
610 # We use the shellwords package in order to behave the way that
611 # UN*X programmers expect.
612 if ($DEBUG)
613 {
614 my $cmdline_ret = read_from_cmdline();
# spent 0.00521s making 1 calls to CGI::AUTOLOAD
615 $query_string = $cmdline_ret->{'query_string'};
616 if (defined($cmdline_ret->{'subpath'}))
617 {
618 $self->path_info($cmdline_ret->{'subpath'});
619 }
620 }
621 }
622
623# YL: Begin Change for XML handler 10/19/2001
624 if ($meth eq 'POST'
625 && defined($ENV{'CONTENT_TYPE'})
626 && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
627 && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
628 my($param) = 'POSTDATA' ;
629 $self->add_parameter($param) ;
630 push (@{$self->{$param}},$query_string);
631 undef $query_string ;
632 }
633# YL: End Change for XML handler 10/19/2001
634
635 # We now have the query string in hand. We do slightly
636 # different things for keyword lists and parameter lists.
637 if (defined $query_string && length $query_string) {
638 if ($query_string =~ /[&=;]/) {
639 $self->parse_params($query_string);
640 } else {
641 $self->add_parameter('keywords');
642 $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
643 }
644 }
645
646 # Special case. Erase everything if there is a field named
647 # .defaults.
648 if ($self->param('.defaults')) {
# spent 0.00003s making 1 calls to CGI::param
649 $self->delete_all();
650 }
651
652 # Associative array containing our defined fieldnames
653 $self->{'.fieldnames'} = {};
654 foreach ($self->param('.cgifields')) {
# spent 0.00002s making 1 calls to CGI::param
655 $self->{'.fieldnames'}->{$_}++;
656 }
657
658 # Clear out our default submission button flag if present
659 $self->delete('.submit');
# spent 0.00019s making 1 calls to CGI::AUTOLOAD
660 $self->delete('.cgifields');
# spent 0.00006s making 1 calls to CGI::delete
661
662 $self->save_request unless defined $initializer;
# spent 0.00006s making 1 calls to CGI::save_request
663}
664
665# FUNCTIONS TO OVERRIDE:
666# Turn a string into a filehandle
667sub to_filehandle {
668 my $thingy = shift;
669 return undef unless $thingy;
670 return $thingy if UNIVERSAL::isa($thingy,'GLOB');
671 return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
672 if (!ref($thingy)) {
673 my $caller = 1;
674 while (my $package = caller($caller++)) {
675 my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
676 return $tmp if defined(fileno($tmp));
677 }
678 }
679 return undef;
680}
681
682# send output to the browser
683sub put {
684 my($self,@p) = self_or_default(@_);
685 $self->print(@p);
686}
687
688# print to standard output (for overriding in mod_perl)
689sub print {
690 shift;
691 CORE::print(@_);
692}
693
694# get/set last cgi_error
695sub cgi_error {
696 my ($self,$err) = self_or_default(@_);
697 $self->{'.cgi_error'} = $err if defined $err;
698 return $self->{'.cgi_error'};
699}
700
701
# spent 0.00006s within CGI::save_request which was called: # 1 times (0.00006s) by CGI::init at line 662 of /usr/share/perl/5.8/CGI.pm
sub save_request {
70250.000023e-06 my($self) = @_;
703 # We're going to play with the package globals now so that if we get called
704 # again, we initialize ourselves in exactly the same way. This allows
705 # us to have several of these objects.
706 @QUERY_PARAM = $self->param; # save list of parameters
# spent 0.00002s making 1 calls to CGI::param
707 foreach (@QUERY_PARAM) {
708 next unless defined $_;
709 $QUERY_PARAM{$_}=$self->{$_};
710 }
711 $QUERY_CHARSET = $self->charset;
# spent 0.00002s making 1 calls to CGI::charset
712 %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
713}
714
715sub parse_params {
716 my($self,$tosplit) = @_;
717 my(@pairs) = split(/[&;]/,$tosplit);
718 my($param,$value);
719 foreach (@pairs) {
720 ($param,$value) = split('=',$_,2);
721 next unless defined $param;
722 next if $NO_UNDEF_PARAMS and not defined $value;
723 $value = '' unless defined $value;
724 $param = unescape($param);
725 $value = unescape($value);
726 $self->add_parameter($param);
727 push (@{$self->{$param}},$value);
728 }
729}
730
731sub add_parameter {
732 my($self,$param)=@_;
733 return unless defined $param;
734 push (@{$self->{'.parameters'}},$param)
735 unless defined($self->{$param});
736}
737
738
# spent 0.00002s within CGI::all_parameters which was called 3 times, avg 8e-06s/call: # 3 times (0.00002s) by CGI::param at line 413 of /usr/share/perl/5.8/CGI.pm, avg 8e-06s/call
sub all_parameters {
73980.000011e-06 my $self = shift;
740 return () unless defined($self) && $self->{'.parameters'};
741 return () unless @{$self->{'.parameters'}};
742 return @{$self->{'.parameters'}};
743}
744
745# put a filehandle into binary mode (DOS)
746sub binmode {
747 return unless defined($_[1]) && defined fileno($_[1]);
748 CORE::binmode($_[1]);
749}
750
751sub _make_tag_func {
752 my ($self,$tagname) = @_;
753 my $func = qq(
754 sub $tagname {
755 my (\$q,\$a,\@rest) = self_or_default(\@_);
756 my(\$attr) = '';
757 if (ref(\$a) && ref(\$a) eq 'HASH') {
758 my(\@attr) = make_attributes(\$a,\$q->{'escape'});
759 \$attr = " \@attr" if \@attr;
760 } else {
761 unshift \@rest,\$a if defined \$a;
762 }
763 );
764 if ($tagname=~/start_(\w+)/i) {
765 $func .= qq! return "<\L$1\E\$attr>";} !;
766 } elsif ($tagname=~/end_(\w+)/i) {
767 $func .= qq! return "<\L/$1\E>"; } !;
768 } else {
769 $func .= qq#
770 return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest;
771 my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
772 my \@result = map { "\$tag\$_\$untag" }
773 (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
774 return "\@result";
775 }#;
776 }
777return $func;
778}
779
780
# spent 0.00702s within CGI::AUTOLOAD which was called 7 times, avg 0.00100s/call: # 1 times (0.00070s) by C4::Output::output_html_with_http_headers at line 369 of C4/Output.pm # 1 times (0.00028s) by C4::Output::themelanguage at line 143 of C4/Output.pm # 1 times (0.00026s) by C4::Auth::get_template_and_user at line 297 of C4/Auth.pm # 1 times (0.00019s) by CGI::init at line 659 of /usr/share/perl/5.8/CGI.pm # 1 times (0.00521s) by CGI::init at line 614 of /usr/share/perl/5.8/CGI.pm # 1 times (0.00026s) by CGI::header at line 25 of /usr/share/perl/5.8/CGI.pm # 1 times (0.00012s) by CGI::header at line 56 of /usr/share/perl/5.8/CGI.pm
sub AUTOLOAD {
781210.000052e-06 print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
782 my $func = &_compile;
# spent 0.00693s making 7 calls to CGI::_compile, avg 0.00099s/call
783 goto &$func;
784}
785
786
# spent 0.00693s within CGI::_compile which was called 7 times, avg 0.00099s/call: # 7 times (0.00693s) by CGI::AUTOLOAD at line 782 of /usr/share/perl/5.8/CGI.pm, avg 0.00099s/call
sub _compile {
7871380.006630.00005 my($func) = $AUTOLOAD;
788 my($pack,$func_name);
789 {
790 local($1,$2); # this fixes an obscure variable suicide problem.
791 $func=~/(.+)::([^:]+)$/;
792 ($pack,$func_name) = ($1,$2);
793 $pack=~s/::SUPER$//; # fix another obscure problem
794 $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
795 unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
796
797 my($sub) = \%{"$pack\:\:SUBS"};
798 unless (%$sub) {
799 my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
800 local ($@,$!);
801100 eval "package $pack; $$auto";
802 croak("$AUTOLOAD: $@") if $@;
803 $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
804 }
805 my($code) = $sub->{$func_name};
806
807 $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
808 if (!$code) {
809 (my $base = $func_name) =~ s/^(start_|end_)//i;
810 if ($EXPORT{':any'} ||
811 $EXPORT{'-any'} ||
812 $EXPORT{$base} ||
813 (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
814 && $EXPORT_OK{$base}) {
815 $code = $CGI::DefaultClass->_make_tag_func($func_name);
816 }
817 }
818 croak("Undefined subroutine $AUTOLOAD\n") unless $code;
819 local ($@,$!);
820100 eval "package $pack; $code";
821 if ($@) {
822 $@ =~ s/ at .*\n//;
823 croak("$AUTOLOAD: $@");
824 }
825 }
826 CORE::delete($sub->{$func_name}); #free storage
827 return "$pack\:\:$func_name";
828}
829
830sub _selected {
831 my $self = shift;
832 my $value = shift;
833 return '' unless $value;
834 return $XHTML ? qq(selected="selected" ) : qq(selected );
835}
836
837sub _checked {
838 my $self = shift;
839 my $value = shift;
840 return '' unless $value;
841 return $XHTML ? qq(checked="checked" ) : qq(checked );
842}
843
844sub _reset_globals { initialize_globals(); }
845
846sub _setup_symbols {
847 my $self = shift;
848 my $compile = 0;
849
850 # to avoid reexporting unwanted variables
851 undef %EXPORT;
852
853 foreach (@_) {
854 $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
855 $NPH++, next if /^[:-]nph$/;