← 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 17:10:45 2013
Reported on Tue Oct 15 17:12:24 2013

Filename/usr/share/perl/5.10/CGI.pm
StatementsExecuted 1329 statements in 21.1ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
23118.92ms9.09msCGI::::_compile CGI::_compile
1112.32ms2.64msCGI::::BEGIN@27 CGI::BEGIN@27
38267596µs1.05msCGI::::param CGI::param
721110416µs416µsCGI::::self_or_default CGI::self_or_default
232211294µs9.38msCGI::::AUTOLOAD CGI::AUTOLOAD
311255µs5.14msCGI::::init CGI::init
75305232µs232µsCGI::::CORE:match CGI::CORE:match (opcode)
444131µs249µsCGI::::import CGI::import
322117µs5.25msCGI::::new CGI::new
41194µs118µsCGI::::_setup_symbols CGI::_setup_symbols
54275µs107µsCGI::::charset CGI::charset
92271µs79µsCGI::::self_or_CGI CGI::self_or_CGI
5010647µs47µsCGI::::CORE:subst CGI::CORE:subst (opcode)
11142µs128µsFh::::BEGIN@3739 Fh::BEGIN@3739
182142µs42µsCGI::::CORE:regcomp CGI::CORE:regcomp (opcode)
11135µs52µsCGITempFile::::find_tempdir CGITempFile::find_tempdir
11130µs66µsCGI::::parse_params CGI::parse_params
32128µs28µsCGI::::add_parameter CGI::add_parameter
11120µs40µsCGI::::save_request CGI::save_request
33220µs20µsCGI::::DESTROY CGI::DESTROY
51120µs20µsCGI::::all_parameters CGI::all_parameters
11117µs17µsCGI::::initialize_globals CGI::initialize_globals
11116µs50µsCGI::::BEGIN@3 CGI::BEGIN@3
21114µs14µsCGITempFile::::CORE:ftdir CGITempFile::CORE:ftdir (opcode)
11114µs80µsMultipartBuffer::::BEGIN@3812MultipartBuffer::BEGIN@3812
11114µs70µsCGI::::BEGIN@32 CGI::BEGIN@32
11110µs12µsCGI::::expand_tags CGI::expand_tags
81110µs10µsCGI::::CORE:substcont CGI::CORE:substcont (opcode)
1112µs2µsCGITempFile::::CORE:ftewrite CGITempFile::CORE:ftewrite (opcode)
0000s0sCGI::::__ANON__[:927] CGI::__ANON__[:927]
0000s0sCGI::::_checked CGI::_checked
0000s0sCGI::::_make_tag_func CGI::_make_tag_func
0000s0sCGI::::_reset_globals CGI::_reset_globals
0000s0sCGI::::_selected CGI::_selected
0000s0sCGI::::binmode CGI::binmode
0000s0sCGI::::can CGI::can
0000s0sCGI::::cgi_error CGI::cgi_error
0000s0sCGI::::compile CGI::compile
0000s0sCGI::::element_id CGI::element_id
0000s0sCGI::::element_tab CGI::element_tab
0000s0sCGI::::print CGI::print
0000s0sCGI::::put CGI::put
0000s0sCGI::::r CGI::r
0000s0sCGI::::to_filehandle CGI::to_filehandle
0000s0sCGI::::upload_hook CGI::upload_hook
0000s0sCGITempFile::::DESTROY CGITempFile::DESTROY
0000s0sFh::::DESTROY Fh::DESTROY
0000s0sMultipartBuffer::::DESTROYMultipartBuffer::DESTROY
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package CGI;
2156µsrequire 5.004;
3376µs285µs
# spent 50µs (16+35) within CGI::BEGIN@3 which was called: # once (16µs+35µs) by C4::Templates::BEGIN@6 at line 3
use Carp 'croak';
# spent 50µs making 1 call to CGI::BEGIN@3 # spent 35µs making 1 call to Exporter::import
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
211900ns$CGI::revision = '$Id: CGI.pm,v 1.263 2009/02/11 16:56:37 lstein Exp $';
221300ns$CGI::VERSION='3.43';
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';
273141µs22.76ms
# spent 2.64ms (2.32+326µs) within CGI::BEGIN@27 which was called: # once (2.32ms+326µs) by C4::Templates::BEGIN@6 at line 27
use CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
# spent 2.64ms making 1 call to CGI::BEGIN@27 # spent 116µs making 1 call to Exporter::import
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
3219µs156µs
# spent 70µs (14+56) within CGI::BEGIN@32 which was called: # once (14µs+56µs) by C4::Templates::BEGIN@6 at line 33
use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
# spent 56µs making 1 call to constant::import
3328.24ms170µs 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
# spent 70µs making 1 call to CGI::BEGIN@32
34
35{
3625µs local $^W = 0;
3715µs $TAINTED = substr("$0$^X",0,0);
38}
39
401500ns$MOD_PERL = 0; # no mod_perl by default
41
42#global settings
431300ns$POST_MAX = -1; # no limit to uploaded files
441300ns$DISABLE_UPLOADS = 0;
45
4611µs@SAVED_SYMBOLS = ();
47
48
49# >>>>> Here are some globals that you might want to adjust <<<<<<
50
# spent 17µs within CGI::initialize_globals which was called: # once (17µs+0s) by C4::Templates::BEGIN@6 at line 134
sub initialize_globals {
51 # Set this to 1 to enable copious autoloader debugging messages
521800ns $AUTOLOAD_DEBUG = 0;
53
54 # Set this to 1 to generate XTML-compatible output
551600ns $XHTML = 1;
56
57 # Change this to the preferred DTD to print in start_html()
58 # or use default_dtd('text of DTD to use');
5912µs $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
60 'http://www.w3.org/TR/html4/loose.dtd' ] ;
61
62 # Set this to 1 to enable NOSTICKY scripts
63 # or:
64 # 1) use CGI qw(-nosticky)
65 # 2) $CGI::nosticky(1)
661600ns $NOSTICKY = 0;
67
68 # Set this to 1 to enable NPH scripts
69 # or:
70 # 1) use CGI qw(-nph)
71 # 2) CGI::nph(1)
72 # 3) print header(-nph=>1)
731400ns $NPH = 0;
74
75 # Set this to 1 to enable debugging from @ARGV
76 # Set to 2 to enable debugging from STDIN
771700ns $DEBUG = 1;
78
79 # Set this to 1 to make the temporary files created
80 # during file uploads safe from prying eyes
81 # or do...
82 # 1) use CGI qw(:private_tempfiles)
83 # 2) CGI::private_tempfiles(1);
841500ns $PRIVATE_TEMPFILES = 0;
85
86 # Set this to 1 to generate automatic tab indexes
871500ns $TABINDEX = 0;
88
89 # Set this to 1 to cause files uploaded in multipart documents
90 # to be closed, instead of caching the file handle
91 # or:
92 # 1) use CGI qw(:close_upload_files)
93 # 2) $CGI::close_upload_files(1);
94 # Uploads with many files run out of file handles.
95 # Also, for performance, since the file is already on disk,
96 # it can just be renamed, instead of read and written.
971500ns $CLOSE_UPLOAD_FILES = 0;
98
99 # Automatically determined -- don't change
1001500ns $EBCDIC = 0;
101
102 # Change this to 1 to suppress redundant HTTP headers
1031400ns $HEADERS_ONCE = 0;
104
105 # separate the name=value pairs by semicolons rather than ampersands
1061300ns $USE_PARAM_SEMICOLONS = 1;
107
108 # Do not include undefined params parsed from query string
109 # use CGI qw(-no_undef_params);
1101400ns $NO_UNDEF_PARAMS = 0;
111
112 # return everything as utf-8
1131600ns $PARAM_UTF8 = 0;
114
115 # Other globals that you shouldn't worry about.
1161800ns undef $Q;
1171700ns $BEEN_THERE = 0;
1181600ns $DTD_PUBLIC_IDENTIFIER = "";
1191600ns undef @QUERY_PARAM;
1201700ns undef %EXPORT;
1211400ns undef $QUERY_CHARSET;
1221500ns undef %QUERY_FIELDNAMES;
1231800ns undef %QUERY_TMPFILES;
124
125 # prevent complaints by mod_perl
12616µs 1;
127}
128
129# ------------------ START OF THE LIBRARY ------------
130
13116µs*end_form = \&endform;
132
133# make mod_perlhappy
13413µs117µsinitialize_globals();
# spent 17µs making 1 call to CGI::initialize_globals
135
136# FIGURE OUT THE OS WE'RE RUNNING UNDER
137# Some systems support the $^O variable. If not
138# available then require() the Config library
1391800nsunless ($OS) {
14012µs unless ($OS = $^O) {
141 require Config;
142 $OS = $Config::Config{'osname'};
143 }
144}
145119µs76µsif ($OS =~ /^MSWin/i) {
# spent 6µs making 7 calls to CGI::CORE:match, avg 900ns/call
146 $OS = 'WINDOWS';
147} elsif ($OS =~ /^VMS/i) {
148 $OS = 'VMS';
149} elsif ($OS =~ /^dos/i) {
150 $OS = 'DOS';
151} elsif ($OS =~ /^MacOS/i) {
152 $OS = 'MACINTOSH';
153} elsif ($OS =~ /^os2/i) {
154 $OS = 'OS2';
155} elsif ($OS =~ /^epoc/i) {
156 $OS = 'EPOC';
157} elsif ($OS =~ /^cygwin/i) {
158 $OS = 'CYGWIN';
159} else {
1601400ns $OS = 'UNIX';
161}
162
163# Some OS logic. Binary mode enabled on DOS, NT and VMS
16414µs11µs$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN)/;
# spent 1µs making 1 call to CGI::CORE:match
165
166# This is the default class for the CGI object to use when all else fails.
1671700ns$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
168
169# This is where to look for autoloaded routines.
1701500ns$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
171
172# The path separator is a slash, backslash or semicolon, depending
173# on the paltform.
174110µs$SL = {
175 UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/',
176 WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
177 }->{$OS};
178
179# This no longer seems to be necessary
180# Turn on NPH scripts by default when running under IIS server!
181# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
1821900ns$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
183
184# Turn on special checking for Doug MacEachern's modperl
1851900nsif (exists $ENV{MOD_PERL}) {
186 # mod_perl handlers may run system() on scripts using CGI.pm;
187 # Make sure so we don't get fooled by inherited $ENV{MOD_PERL}
188 if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
189 $MOD_PERL = 2;
190 require Apache2::Response;
191 require Apache2::RequestRec;
192 require Apache2::RequestUtil;
193 require Apache2::RequestIO;
194 require APR::Pool;
195 } else {
196 $MOD_PERL = 1;
197 require Apache;
198 }
199}
200
201# Turn on special checking for ActiveState's PerlEx
2021500ns$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
203
204# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
205# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
206# and sometimes CR). The most popular VMS web server
207# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
208# use ASCII, so \015\012 means something different. I find this all
209# really annoying.
21012µs$EBCDIC = "\t" ne "\011";
2111800nsif ($OS eq 'VMS') {
212 $CRLF = "\n";
213} elsif ($EBCDIC) {
214 $CRLF= "\r\n";
215} else {
2161600ns $CRLF = "\015\012";
217}
218
2191200nsif ($needs_binmode) {
220 $CGI::DefaultClass->binmode(\*main::STDOUT);
221 $CGI::DefaultClass->binmode(\*main::STDIN);
222 $CGI::DefaultClass->binmode(\*main::STDERR);
223}
224
225%EXPORT_TAGS = (
226136µs ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
227 tt u i b blockquote pre img a address cite samp dfn html head
228 base body Link nextid title meta kbd start_html end_html
229 input Select option comment charset escapeHTML/],
230 ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param nobr
231 embed basefont style span layer ilayer font frameset frame script small big Area Map/],
232 ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
233 ins label legend noframes noscript object optgroup Q
234 thead tbody tfoot/],
235 ':netscape'=>[qw/blink fontsize center/],
236 ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
237 submit reset defaults radio_group popup_menu button autoEscape
238 scrolling_list image_button start_form end_form startform endform
239 start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
240 ':cgi'=>[qw/param upload path_info path_translated request_uri url self_url script_name
241 cookie Dump
242 raw_cookie request_method query_string Accept user_agent remote_host content_type
243 remote_addr referer server_name server_software server_port server_protocol virtual_port
244 virtual_host remote_ident auth_type http append
245 save_parameters restore_parameters param_fetch
246 remote_user user_name header redirect import_names put
247 Delete Delete_all url_param cgi_error/],
248 ':ssl' => [qw/https/],
249 ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
250 ':html' => [qw/:html2 :html3 :html4 :netscape/],
251 ':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
252 ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
253 ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/]
254 );
255
256# Custom 'can' method for both autoloaded and non-autoloaded subroutines.
257# Author: Cees Hek <cees@sitesuite.com.au>
258
259sub can {
260 my($class, $method) = @_;
261
262 # See if UNIVERSAL::can finds it.
263
264 if (my $func = $class -> SUPER::can($method) ){
265 return $func;
266 }
267
268 # Try to compile the function.
269
270 eval {
271 # _compile looks at $AUTOLOAD for the function name.
272
273 local $AUTOLOAD = join "::", $class, $method;
274 &_compile;
275 };
276
277 # Now that the function is loaded (if it exists)
278 # just use UNIVERSAL::can again to do the work.
279
280 return $class -> SUPER::can($method);
281}
282
283# to import symbols into caller
284
# spent 249µs (131+118) within CGI::import which was called 4 times, avg 62µs/call: # once (45µs+92µs) by main::BEGIN@64 at line 64 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (35µs+12µs) by CGI::Cookie::BEGIN@19 at line 19 of CGI/Cookie.pm # once (27µs+8µs) by C4::Auth_with_cas::BEGIN@27 at line 27 of /usr/share/koha/lib/C4/Auth_with_cas.pm # once (24µs+6µs) by C4::Templates::BEGIN@6 at line 6 of /usr/share/koha/lib/C4/Templates.pm
sub import {
28546µs my $self = shift;
286
287 # This causes modules to clash.
28846µs undef %EXPORT_OK;
28945µs undef %EXPORT;
290
291419µs4118µs $self->_setup_symbols(@_);
# spent 118µs making 4 calls to CGI::_setup_symbols, avg 30µs/call
292416µs my ($callpack, $callfile, $callline) = caller;
293
294 # To allow overriding, search through the packages
295 # Till we find one in which the correct subroutine is defined.
296417µs my @packages = ($self,@{"$self\:\:ISA"});
297465µs for $sym (keys %EXPORT) {
2981300ns my $pck;
29913µs my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
30011µs for $pck (@packages) {
30112µs if (defined(&{"$pck\:\:$sym"})) {
302 $def = $pck;
303 last;
304 }
305 }
306115µs *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
307 }
308}
309
310sub compile {
311 my $pack = shift;
312 $pack->_setup_symbols('-compile',@_);
313}
314
315
# spent 12µs (10+2) within CGI::expand_tags which was called: # once (10µs+2µs) by CGI::_setup_symbols at line 931
sub expand_tags {
31611µs my($tag) = @_;
31715µs12µs return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
# spent 2µs making 1 call to CGI::CORE:match
3181400ns my(@r);
31916µs return ($tag) unless $EXPORT_TAGS{$tag};
320 for (@{$EXPORT_TAGS{$tag}}) {
321 push(@r,&expand_tags($_));
322 }
323 return @r;
324}
325
326#### Method: new
327# The new routine. This will check the current environment
328# for an existing query string, and initialize itself, if so.
329####
330
# spent 5.25ms (117µs+5.14) within CGI::new which was called 3 times, avg 1.75ms/call: # 2 times (81µs+574µs) by CGI::Session::query at line 167 of CGI/Session.pm, avg 328µs/call # once (36µs+4.56ms) by main::RUNTIME at line 65 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
sub new {
33139µs my($class,@initializer) = @_;
33234µs my $self = {};
333
334344µs bless $self,ref $class || $class || $DefaultClass;
335
336 # always use a tempfile
337310µs $self->{'use_tempfile'} = 1;
338
33933µs if (ref($initializer[0])
340 && (UNIVERSAL::isa($initializer[0],'Apache')
341 ||
342 UNIVERSAL::isa($initializer[0],'Apache2::RequestRec')
343 )) {
344 $self->r(shift @initializer);
345 }
34633µs if (ref($initializer[0])
347 && (UNIVERSAL::isa($initializer[0],'CODE'))) {
348 $self->upload_hook(shift @initializer, shift @initializer);
349 $self->{'use_tempfile'} = shift @initializer if (@initializer > 0);
350 }
35133µs if ($MOD_PERL) {
352 if ($MOD_PERL == 1) {
353 $self->r(Apache->request) unless $self->r;
354 my $r = $self->r;
355 $r->register_cleanup(\&CGI::_reset_globals);
356 $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
357 }
358 else {
359 # XXX: once we have the new API
360 # will do a real PerlOptions -SetupEnv check
361 $self->r(Apache2::RequestUtil->request) unless $self->r;
362 my $r = $self->r;
363 $r->subprocess_env unless exists $ENV{REQUEST_METHOD};
364 $r->pool->cleanup_register(\&CGI::_reset_globals);
365 $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
366 }
367 undef $NPH;
368 }
36933µs $self->_reset_globals if $PERLEX;
370324µs35.14ms $self->init(@initializer);
# spent 5.14ms making 3 calls to CGI::init, avg 1.71ms/call
371315µs return $self;
372}
373
374# We provide a DESTROY method so that we can ensure that
375# temporary files are closed (via Fh->DESTROY) before they
376# are unlinked (via CGITempFile->DESTROY) because it is not
377# possible to unlink an open file on Win32. We explicitly
378# call DESTROY on each, rather than just undefing them and
379# letting Perl DESTROY them by garbage collection, in case the
380# user is still holding any reference to them as well.
381
# spent 20µs within CGI::DESTROY which was called 3 times, avg 7µs/call: # once (7µs+0s) by main::NULL at line 0 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (7µs+0s) by main::RUNTIME at line 690 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (6µs+0s) by C4::Auth::get_template_and_user at line 365 of /usr/share/koha/lib/C4/Auth.pm
sub DESTROY {
38234µs my $self = shift;
383326µs if ($OS eq 'WINDOWS') {
384 for my $href (values %{$self->{'.tmpfiles'}}) {
385 $href->{hndl}->DESTROY if defined $href->{hndl};
386 $href->{name}->DESTROY if defined $href->{name};
387 }
388 }
389}
390
391sub r {
392 my $self = shift;
393 my $r = $self->{'.r'};
394 $self->{'.r'} = shift if @_;
395 $r;
396}
397
398sub upload_hook {
399 my $self;
400 if (ref $_[0] eq 'CODE') {
401 $CGI::Q = $self = $CGI::DefaultClass->new(@_);
402 } else {
403 $self = shift;
404 }
405 my ($hook,$data,$use_tempfile) = @_;
406 $self->{'.upload_hook'} = $hook;
407 $self->{'.upload_data'} = $data;
408 $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile;
409}
410
411#### Method: param
412# Returns the value(s)of a named parameter.
413# If invoked in a list context, returns the
414# entire list. Otherwise returns the first
415# member of the list.
416# If name is not provided, return a list of all
417# the known parameters names available.
418# If more than one argument is provided, the
419# second and subsequent arguments are used to
420# set the value of the parameter.
421####
422
# spent 1.05ms (596µs+453µs) within CGI::param which was called 38 times, avg 28µs/call: # 7 times (65µs+36µs) by CGI::FETCH at line 3 of (eval 1061)[CGI.pm:869], avg 14µs/call # 2 times (142µs+237µs) by CGI::init at line 514, avg 189µs/call # 2 times (45µs+18µs) by C4::Auth::get_template_and_user at line 373 of /usr/share/koha/lib/C4/Auth.pm, avg 31µs/call # 2 times (53µs+5µs) by CGI::query_string at line 6 of (eval 1132)[CGI.pm:869], avg 29µs/call # 2 times (21µs+8µs) by CGI::Session::load at line 707 of CGI/Session.pm, avg 15µs/call # 2 times (15µs+13µs) by CGI::query_string at line 4 of (eval 1132)[CGI.pm:869], avg 14µs/call # 2 times (14µs+13µs) by CGI::delete at line 15 of (eval 1048)[CGI.pm:869], avg 13µs/call # once (10µs+31µs) by main::RUNTIME at line 406 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (28µs+10µs) by main::RUNTIME at line 102 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (21µs+10µs) by main::RUNTIME at line 97 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (21µs+9µs) by C4::Auth::checkauth at line 699 of /usr/share/koha/lib/C4/Auth.pm # once (20µs+5µs) by main::RUNTIME at line 393 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (15µs+7µs) by main::RUNTIME at line 548 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (14µs+7µs) by main::RUNTIME at line 361 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (15µs+6µs) by main::RUNTIME at line 385 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (13µs+7µs) by CGI::init at line 696 # once (13µs+4µs) by main::RUNTIME at line 340 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (11µs+4µs) by main::RUNTIME at line 100 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (12µs+3µs) by C4::Auth::checkauth at line 816 of /usr/share/koha/lib/C4/Auth.pm # once (11µs+4µs) by C4::Auth::checkauth at line 703 of /usr/share/koha/lib/C4/Auth.pm # once (8µs+2µs) by main::RUNTIME at line 67 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (5µs+5µs) by CGI::save_request at line 754 # once (6µs+3µs) by main::RUNTIME at line 371 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (6µs+2µs) by main::RUNTIME at line 442 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (6µs+2µs) by CGI::init at line 702 # once (6µs+2µs) by main::RUNTIME at line 380 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
sub param {
42338152µs38218µs my($self,@p) = self_or_default(@_);
# spent 218µs making 38 calls to CGI::self_or_default, avg 6µs/call
4243841µs520µs return $self->all_parameters unless @p;
# spent 20µs making 5 calls to CGI::all_parameters, avg 4µs/call
4253323µs my($name,$value,@other);
426
427 # For compatibility between old calling style and use_named_parameters() style,
428 # we have to special case for a single parameter present.
4293342µs if (@p > 1) {
430226µs2194µs ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
# spent 194µs making 2 calls to CGI::Util::rearrange, avg 97µs/call
43122µs my(@values);
432
433214µs if (substr($p[0],0,1) eq '-') {
434 @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
435 } else {
436 for ($value,@other) {
437 push(@values,$_) if defined($_);
438 }
439 }
440 # If values is provided, then we set it.
44125µs if (@values or defined $value) {
442213µs222µs $self->add_parameter($name);
# spent 22µs making 2 calls to CGI::add_parameter, avg 11µs/call
44328µs $self->{param}{$name}=[@values];
444 }
445 } else {
4463124µs $name = $p[0];
447 }
448
44933162µs return unless defined($name) && $self->{param}{$name};
450
451748µs my @result = @{$self->{param}{$name}};
452
45376µs if ($PARAM_UTF8) {
454 eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions
455 @result = map {ref $_ ? $_ : Encode::decode(utf8=>$_) } @result;
456 }
457
458750µs return wantarray ? @result : $result[0];
459}
460
461
# spent 416µs within CGI::self_or_default which was called 72 times, avg 6µs/call: # 38 times (218µs+0s) by CGI::param at line 423, avg 6µs/call # 13 times (99µs+0s) by CGI::cookie at line 2 of (eval 1049)[CGI.pm:869], avg 8µs/call # 5 times (33µs+0s) by CGI::charset at line 941, avg 7µs/call # 4 times (17µs+0s) by CGI::unescapeHTML at line 4 of (eval 1150)[CGI.pm:869], avg 4µs/call # 2 times (8µs+0s) by CGI::url at line 2 of (eval 1127)[CGI.pm:869], avg 4µs/call # 2 times (6µs+0s) by CGI::path_info at line 2 of (eval 1128)[CGI.pm:869], avg 3µs/call # 2 times (6µs+0s) by CGI::script_name at line 2 of (eval 1131)[CGI.pm:869], avg 3µs/call # 2 times (6µs+0s) by CGI::delete at line 5 of (eval 1048)[CGI.pm:869], avg 3µs/call # 2 times (6µs+0s) by CGI::query_string at line 2 of (eval 1132)[CGI.pm:869], avg 3µs/call # once (12µs+0s) by CGI::header at line 2 of (eval 1149)[CGI.pm:869] # once (7µs+0s) by CGI::cache at line 2 of (eval 1151)[CGI.pm:869]
sub self_or_default {
4627288µs return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
4637290µs unless (defined($_[0]) &&
464 (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
465 ) {
466 $Q = $CGI::DefaultClass->new unless defined($Q);
467 unshift(@_,$Q);
468 }
46972333µs return wantarray ? @_ : $Q;
470}
471
472
# spent 79µs (71+9) within CGI::self_or_CGI which was called 9 times, avg 9µs/call: # 5 times (41µs+0s) by CGI::https at line 3 of (eval 1055)[CGI.pm:869], avg 8µs/call # 4 times (29µs+9µs) by CGI::http at line 2 of (eval 1136)[CGI.pm:869], avg 9µs/call
sub self_or_CGI {
473914µs local $^W=0; # prevent a warning
474959µs49µs if (defined($_[0]) &&
# spent 9µs making 4 calls to UNIVERSAL::isa, avg 2µs/call
475 (substr(ref($_[0]),0,3) eq 'CGI'
476 || UNIVERSAL::isa($_[0],'CGI'))) {
477 return @_;
478 } else {
479413µs return ($DefaultClass,@_);
480 }
481}
482
483########################################
484# THESE METHODS ARE MORE OR LESS PRIVATE
485# GO TO THE __DATA__ SECTION TO SEE MORE
486# PUBLIC METHODS
487########################################
488
489# Initialize the query object from the environment.
490# If a parameter list is found, this object will be set
491# to a hash in which parameter names are keys
492# and the values are stored as lists
493# If a keyword list is found, this method creates a bogus
494# parameter list with the single parameter 'keywords'.
495
496
# spent 5.14ms (255µs+4.88) within CGI::init which was called 3 times, avg 1.71ms/call: # 3 times (255µs+4.88ms) by CGI::new at line 370, avg 1.71ms/call
sub init {
49734µs my $self = shift;
498311µs my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
499
50031µs my $is_xforms;
501
50233µs my $initializer = shift; # for backward compatibility
503319µs local($/) = "\n";
504
505 # set autoescaping on by default
50638µs $self->{'escape'} = 1;
507
508 # if we get called more than once, we want to initialize
509 # ourselves from the original query (which may be gone
510 # if it was read from STDIN originally.)
51137µs if (defined(@QUERY_PARAM) && !defined($initializer)) {
51226µs for my $name (@QUERY_PARAM) {
51326µs my $val = $QUERY_PARAM{$name}; # always an arrayref;
514213µs2379µs $self->param('-name'=>$name,'-value'=> $val);
# spent 379µs making 2 calls to CGI::param, avg 189µs/call
515226µs if (defined $val and ref $val eq 'ARRAY') {
516 for my $fh (grep {defined(fileno($_))} @$val) {
517 seek($fh,0,0); # reset the filehandle.
518 }
519
520 }
521 }
522214µs250µs $self->charset($QUERY_CHARSET);
# spent 50µs making 2 calls to CGI::charset, avg 25µs/call
52328µs $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
52429µs $self->{'.tmpfiles'} = {%QUERY_TMPFILES};
525214µs return;
526 }
527
52812µs $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
52911µs $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
530
5311500ns $fh = to_filehandle($initializer) if $initializer;
532
533 # set charset to the safe ISO-8859-1
53414µs123µs $self->charset('ISO-8859-1');
# spent 23µs making 1 call to CGI::charset
535
536 METHOD: {
537
538 # avoid unreasonably large postings
53923µs if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
540 #discard the post, unread
541 $self->cgi_error("413 Request entity too large");
542 last METHOD;
543 }
544
545 # Process multipart postings, but only if the initializer is
546 # not defined.
54711µs if ($meth eq 'POST'
548 && defined($ENV{'CONTENT_TYPE'})
549 && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
550 && !defined($initializer)
551 ) {
552 my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
553 $self->read_multipart($boundary,$content_length);
554 last METHOD;
555 }
556
557 # Process XForms postings. We know that we have XForms in the
558 # following cases:
559 # method eq 'POST' && content-type eq 'application/xml'
560 # method eq 'POST' && content-type =~ /multipart\/related.+start=/
561 # There are more cases, actually, but for now, we don't support other
562 # methods for XForm posts.
563 # In a XForm POST, the QUERY_STRING is parsed normally.
564 # If the content-type is 'application/xml', we just set the param
565 # XForms:Model (referring to the xml syntax) param containing the
566 # unparsed XML data.
567 # In the case of multipart/related we set XForms:Model as above, but
568 # the other parts are available as uploads with the Content-ID as the
569 # the key.
570 # See the URL below for XForms specs on this issue.
571 # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options
5721800ns if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) {
573 if ($ENV{'CONTENT_TYPE'} eq 'application/xml') {
574 my($param) = 'XForms:Model';
575 my($value) = '';
576 $self->add_parameter($param);
577 $self->read_from_client(\$value,$content_length,0)
578 if $content_length > 0;
579 push (@{$self->{param}{$param}},$value);
580 $is_xforms = 1;
581 } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\<?([^\"\>]+)\>?\"?/) {
582 my($boundary,$start) = ($1,$2);
583 my($param) = 'XForms:Model';
584 $self->add_parameter($param);
585 my($value) = $self->read_multipart_related($start,$boundary,$content_length,0);
586 push (@{$self->{param}{$param}},$value);
587 if ($MOD_PERL) {
588 $query_string = $self->r->args;
589 } else {
590 $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
591 $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
592 }
593 $is_xforms = 1;
594 }
595 }
596
597
598 # If initializer is defined, then read parameters
599 # from it.
6001600ns if (!$is_xforms && defined($initializer)) {
601 if (UNIVERSAL::isa($initializer,'CGI')) {
602 $query_string = $initializer->query_string;
603 last METHOD;
604 }
605 if (ref($initializer) && ref($initializer) eq 'HASH') {
606 for (keys %$initializer) {
607 $self->param('-name'=>$_,'-value'=>$initializer->{$_});
608 }
609 last METHOD;
610 }
611
612 if (defined($fh) && ($fh ne '')) {
613 while (<$fh>) {
614 chomp;
615 last if /^=/;
616 push(@lines,$_);
617 }
618 # massage back into standard format
619 if ("@lines" =~ /=/) {
620 $query_string=join("&",@lines);
621 } else {
622 $query_string=join("+",@lines);
623 }
624 last METHOD;
625 }
626
627 # last chance -- treat it as a string
628 $initializer = $$initializer if ref($initializer) eq 'SCALAR';
629 $query_string = $initializer;
630
631 last METHOD;
632 }
633
634 # If method is GET or HEAD, fetch the query from
635 # the environment.
63617µs11µs if ($is_xforms || $meth=~/^(GET|HEAD)$/) {
# spent 1µs making 1 call to CGI::CORE:match
637 if ($MOD_PERL) {
638 $query_string = $self->r->args;
639 } else {
640 $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
641 $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
642 }
643 last METHOD;
644 }
645
64612µs if ($meth eq 'POST' || $meth eq 'PUT') {
647 $self->read_from_client(\$query_string,$content_length,0)
648 if $content_length > 0;
649 # Some people want to have their cake and eat it too!
650 # Uncomment this line to have the contents of the query string
651 # APPENDED to the POST data.
652 # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
653 last METHOD;
654 }
655
656 # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
657 # Check the command line and then the standard input for data.
658 # We use the shellwords package in order to behave the way that
659 # UN*X programmers expect.
66012µs if ($DEBUG)
661 {
662110µs13.98ms my $cmdline_ret = read_from_cmdline();
# spent 3.98ms making 1 call to CGI::AUTOLOAD
66312µs $query_string = $cmdline_ret->{'query_string'};
66413µs if (defined($cmdline_ret->{'subpath'}))
665 {
666 $self->path_info($cmdline_ret->{'subpath'});
667 }
668 }
669 }
670
671# YL: Begin Change for XML handler 10/19/2001
67212µs if (!$is_xforms && ($meth eq 'POST' || $meth eq 'PUT')
673 && defined($ENV{'CONTENT_TYPE'})
674 && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
675 && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
676 my($param) = $meth . 'DATA' ;
677 $self->add_parameter($param) ;
678 push (@{$self->{param}{$param}},$query_string);
679 undef $query_string ;
680 }
681# YL: End Change for XML handler 10/19/2001
682
683 # We now have the query string in hand. We do slightly
684 # different things for keyword lists and parameter lists.
68512µs if (defined $query_string && length $query_string) {
686111µs270µs if ($query_string =~ /[&=;]/) {
# spent 66µs making 1 call to CGI::parse_params # spent 3µs making 1 call to CGI::CORE:match
687 $self->parse_params($query_string);
688 } else {
689 $self->add_parameter('keywords');
690 $self->{param}{'keywords'} = [$self->parse_keywordlist($query_string)];
691 }
692 }
693
694 # Special case. Erase everything if there is a field named
695 # .defaults.
69614µs120µs if ($self->param('.defaults')) {
# spent 20µs making 1 call to CGI::param
697 $self->delete_all();
698 }
699
700 # hash containing our defined fieldnames
70112µs $self->{'.fieldnames'} = {};
70214µs18µs for ($self->param('.cgifields')) {
# spent 8µs making 1 call to CGI::param
703 $self->{'.fieldnames'}->{$_}++;
704 }
705
706 # Clear out our default submission button flag if present
707110µs1174µs $self->delete('.submit');
# spent 174µs making 1 call to CGI::AUTOLOAD
70812µs137µs $self->delete('.cgifields');
# spent 37µs making 1 call to CGI::delete
709
710111µs140µs $self->save_request unless defined $initializer;
# spent 40µs making 1 call to CGI::save_request
711}
712
713# FUNCTIONS TO OVERRIDE:
714# Turn a string into a filehandle
715sub to_filehandle {
716 my $thingy = shift;
717 return undef unless $thingy;
718 return $thingy if UNIVERSAL::isa($thingy,'GLOB');
719 return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
720 if (!ref($thingy)) {
721 my $caller = 1;
722 while (my $package = caller($caller++)) {
723 my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
724 return $tmp if defined(fileno($tmp));
725 }
726 }
727 return undef;
728}
729
730# send output to the browser
731sub put {
732 my($self,@p) = self_or_default(@_);
733 $self->print(@p);
734}
735
736# print to standard output (for overriding in mod_perl)
737sub print {
738 shift;
739 CORE::print(@_);
740}
741
742# get/set last cgi_error
743sub cgi_error {
744 my ($self,$err) = self_or_default(@_);
745 $self->{'.cgi_error'} = $err if defined $err;
746 return $self->{'.cgi_error'};
747}
748
749
# spent 40µs (20+20) within CGI::save_request which was called: # once (20µs+20µs) by CGI::init at line 710
sub save_request {
7501900ns my($self) = @_;
751 # We're going to play with the package globals now so that if we get called
752 # again, we initialize ourselves in exactly the same way. This allows
753 # us to have several of these objects.
75413µs110µs @QUERY_PARAM = $self->param; # save list of parameters
# spent 10µs making 1 call to CGI::param
75511µs for (@QUERY_PARAM) {
7561400ns next unless defined $_;
75712µs $QUERY_PARAM{$_}=$self->{param}{$_};
758 }
75914µs110µs $QUERY_CHARSET = $self->charset;
# spent 10µs making 1 call to CGI::charset
76012µs %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
76115µs %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} };
762}
763
764
# spent 66µs (30+37) within CGI::parse_params which was called: # once (30µs+37µs) by CGI::init at line 686
sub parse_params {
76511µs my($self,$tosplit) = @_;
76613µs my(@pairs) = split(/[&;]/,$tosplit);
7671500ns my($param,$value);
76814µs for (@pairs) {
76912µs ($param,$value) = split('=',$_,2);
7701600ns next unless defined $param;
7711800ns next if $NO_UNDEF_PARAMS and not defined $value;
7721300ns $value = '' unless defined $value;
77315µs124µs $param = unescape($param);
# spent 24µs making 1 call to CGI::Util::unescape
77412µs17µs $value = unescape($value);
# spent 7µs making 1 call to CGI::Util::unescape
77513µs16µs $self->add_parameter($param);
# spent 6µs making 1 call to CGI::add_parameter
77613µs push (@{$self->{param}{$param}},$value);
777 }
778}
779
780
# spent 28µs within CGI::add_parameter which was called 3 times, avg 9µs/call: # 2 times (22µs+0s) by CGI::param at line 442, avg 11µs/call # once (6µs+0s) by CGI::parse_params at line 775
sub add_parameter {
78134µs my($self,$param)=@_;
78232µs return unless defined $param;
783330µs push (@{$self->{'.parameters'}},$param)
784 unless defined($self->{param}{$param});
785}
786
787
# spent 20µs within CGI::all_parameters which was called 5 times, avg 4µs/call: # 5 times (20µs+0s) by CGI::param at line 424, avg 4µs/call
sub all_parameters {
78853µs my $self = shift;
78955µs return () unless defined($self) && $self->{'.parameters'};
79053µs return () unless @{$self->{'.parameters'}};
791513µs return @{$self->{'.parameters'}};
792}
793
794# put a filehandle into binary mode (DOS)
795sub binmode {
796 return unless defined($_[1]) && defined fileno($_[1]);
797 CORE::binmode($_[1]);
798}
799
800sub _make_tag_func {
801 my ($self,$tagname) = @_;
802 my $func = qq(
803 sub $tagname {
804 my (\$q,\$a,\@rest) = self_or_default(\@_);
805 my(\$attr) = '';
806 if (ref(\$a) && ref(\$a) eq 'HASH') {
807 my(\@attr) = make_attributes(\$a,\$q->{'escape'});
808 \$attr = " \@attr" if \@attr;
809 } else {
810 unshift \@rest,\$a if defined \$a;
811 }
812 );
813 if ($tagname=~/start_(\w+)/i) {
814 $func .= qq! return "<\L$1\E\$attr>";} !;
815 } elsif ($tagname=~/end_(\w+)/i) {
816 $func .= qq! return "<\L/$1\E>"; } !;
817 } else {
818 $func .= qq#
819 return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest;
820 my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
821 my \@result = map { "\$tag\$_\$untag" }
822 (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
823 return "\@result";
824 }#;
825 }
826return $func;
827}
828
829
# spent 9.38ms (294µs+9.09) within CGI::AUTOLOAD which was called 23 times, avg 408µs/call: # 2 times (50µs+175µs) by main::RUNTIME at line 339 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl, avg 113µs/call # once (30µs+3.95ms) by CGI::init at line 662 # once (21µs+1.09ms) by C4::Output::output_with_http_headers at line 471 of /usr/share/koha/lib/C4/Output.pm # once (13µs+482µs) by main::RUNTIME at line 628 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (15µs+442µs) by C4::Auth::get_template_and_user at line 303 of /usr/share/koha/lib/C4/Auth.pm # once (14µs+408µs) by CGI::header at line 55 of (eval 1149)[CGI.pm:869] # once (13µs+366µs) by C4::Templates::getlanguage at line 331 of /usr/share/koha/lib/C4/Templates.pm # once (18µs+249µs) by main::RUNTIME at line 331 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (14µs+248µs) by CGI::header at line 80 of (eval 1149)[CGI.pm:869] # once (11µs+193µs) by CGI::Vars at line 4 of (eval 1059)[CGI.pm:869] # once (8µs+184µs) by CGI::path_info at line 7 of (eval 1128)[CGI.pm:869] # once (8µs+168µs) by CGI::url at line 12 of (eval 1127)[CGI.pm:869] # once (8µs+166µs) by CGI::init at line 707 # once (12µs+146µs) by main::RUNTIME at line 333 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl # once (9µs+147µs) by CGI::url at line 25 of (eval 1127)[CGI.pm:869] # once (7µs+131µs) by CGI::url at line 9 of (eval 1127)[CGI.pm:869] # once (8µs+128µs) by CGI::url at line 23 of (eval 1127)[CGI.pm:869] # once (7µs+113µs) by CGI::url at line 10 of (eval 1127)[CGI.pm:869] # once (8µs+96µs) by CGI::_name_and_path_from_env at line 5 of (eval 1129)[CGI.pm:869] # once (7µs+69µs) by CGI::protocol at line 5 of (eval 1133)[CGI.pm:869] # once (6µs+68µs) by CGI::protocol at line 6 of (eval 1133)[CGI.pm:869] # once (8µs+65µs) by CGI::url at line 30 of (eval 1127)[CGI.pm:869]
sub AUTOLOAD {
8302314µs print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
8312351µs239.09ms my $func = &_compile;
# spent 9.09ms making 23 calls to CGI::_compile, avg 395µs/call
83223212µs238.96ms goto &$func;
# spent 2.89ms making 1 call to CGI::cookie # spent 2.85ms making 1 call to CGI::header # spent 1.79ms making 1 call to CGI::url # spent 363µs making 1 call to CGI::path_info # spent 241µs making 1 call to CGI::Vars # spent 214µs making 1 call to CGI::protocol # spent 147µs making 1 call to CGI::_name_and_path_from_env # spent 126µs making 1 call to CGI::query_string # spent 68µs making 1 call to CGI::delete # spent 58µs making 1 call to CGI::FETCH # spent 40µs making 1 call to CGI::script_name # spent 35µs making 1 call to CGI::read_from_cmdline # spent 30µs making 1 call to CGI::cache # spent 29µs making 1 call to CGI::unescapeHTML # spent 27µs making 1 call to CGI::http # spent 19µs making 1 call to CGI::https # spent 12µs making 1 call to CGI::TIEHASH # spent 5µs making 1 call to CGI::FIRSTKEY # spent 3µs making 1 call to CGI::NEXTKEY # spent 3µs making 1 call to CGI::server_port # spent 2µs making 1 call to CGI::request_uri # spent 2µs making 1 call to CGI::server_name # spent 2µs making 1 call to CGI::server_protocol
833}
834
835
# spent 9.09ms (8.92+163µs) within CGI::_compile which was called 23 times, avg 395µs/call: # 23 times (8.92ms+163µs) by CGI::AUTOLOAD at line 831, avg 395µs/call
sub _compile {
8362322µs my($func) = $AUTOLOAD;
8372313µs my($pack,$func_name);
838 {
83946101µs local($1,$2); # this fixes an obscure variable suicide problem.
84023300µs23147µs $func=~/(.+)::([^:]+)$/;
# spent 147µs making 23 calls to CGI::CORE:match, avg 6µs/call
8412355µs ($pack,$func_name) = ($1,$2);
8422375µs2316µs $pack=~s/::SUPER$//; # fix another obscure problem
# spent 16µs making 23 calls to CGI::CORE:subst, avg 696ns/call
843 $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
8442360µs unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
845
8462354µs my($sub) = \%{"$pack\:\:SUBS"};
8472378µs unless (%$sub) {
84812µs my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
84914µs local ($@,$!);
85013.32ms eval "package $pack; $$auto";
# spent 261µs executing statements in string eval
8511900ns croak("$AUTOLOAD: $@") if $@;
85218µs $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
853 }
8542391µs my($code) = $sub->{$func_name};
855
8562311µs $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
857236µs if (!$code) {
858 (my $base = $func_name) =~ s/^(start_|end_)//i;
859 if ($EXPORT{':any'} ||
860 $EXPORT{'-any'} ||
861 $EXPORT{$base} ||
862 (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
863 && $EXPORT_OK{$base}) {
864 $code = $CGI::DefaultClass->_make_tag_func($func_name);
865 }
866 }
867237µs croak("Undefined subroutine $AUTOLOAD\n") unless $code;
8682355µs local ($@,$!);
869234.37ms eval "package $pack; $code";
# spent 665µs executing statements in string eval
# includes 2.93ms spent executing 13 calls to 1 sub defined therein. # spent 584µs executing statements in string eval
# includes 493µs spent executing 1 call to 1 sub defined therein. # spent 134µs executing statements in string eval
# includes 183µs spent executing 2 calls to 1 sub defined therein. # spent 75µs executing statements in string eval
# includes 69µs spent executing 5 calls to 1 sub defined therein. # spent 59µs executing statements in string eval
# includes 56µs spent executing 4 calls to 1 sub defined therein. # spent 47µs executing statements in string eval
# includes 43µs spent executing 7 calls to 1 sub defined therein. # spent 43µs executing statements in string eval
# includes 51µs spent executing 2 calls to 1 sub defined therein. # spent 42µs executing statements in string eval
# includes 56µs spent executing 2 calls to 1 sub defined therein. # spent 37µs executing statements in string eval
# includes 40µs spent executing 2 calls to 1 sub defined therein. # spent 36µs executing statements in string eval
# includes 25µs spent executing 1 call to 1 sub defined therein. # spent 33µs executing statements in string eval
# includes 30µs spent executing 4 calls to 1 sub defined therein. # spent 33µs executing statements in string eval
# includes 36µs spent executing 2 calls to 1 sub defined therein. # spent 24µs executing statements in string eval
# includes 23µs spent executing 1 call to 1 sub defined therein. # spent 22µs executing statements in string eval
# includes 27µs spent executing 2 calls to 1 sub defined therein. # spent 21µs executing statements in string eval
# includes 19µs spent executing 2 calls to 1 sub defined therein. # spent 20µs executing statements in string eval
# includes 26µs spent executing 1 call to 1 sub defined therein. # spent 16µs executing statements in string eval
# includes 10µs spent executing 4 calls to 1 sub defined therein. # spent 15µs executing statements in string eval
# includes 9µs spent executing 1 call to 1 sub defined therein. # spent 14µs executing statements in string eval
# includes 5µs spent executing 1 call to 1 sub defined therein. # spent 13µs executing statements in string eval
# includes 8µs spent executing 4 calls to 1 sub defined therein. # spent 6µs executing statements in string eval
# includes 4µs spent executing 2 calls to 1 sub defined therein. # spent 6µs executing statements in string eval
# includes 4µs spent executing 2 calls to 1 sub defined therein. # spent 5µs executing statements in string eval
# includes 3µs spent executing 1 call to 1 sub defined therein.
87023100µs if ($@) {
871 $@ =~ s/ at .*\n//;
872 croak("$AUTOLOAD: $@");
873 }
874 }
8752326µs CORE::delete($sub->{$func_name}); #free storage
87623187µs return "$pack\:\:$func_name";
877}
878
879sub _selected {
880 my $self = shift;
881 my $value = shift;
882 return '' unless $value;
883 return $XHTML ? qq(selected="selected" ) : qq(selected );
884}
885
886sub _checked {
887 my $self = shift;
888 my $value = shift;
889 return '' unless $value;
890 return $XHTML ? qq(checked="checked" ) : qq(checked );
891}
892
893sub _reset_globals { initialize_globals(); }
894
895
# spent 118µs (94+24) within CGI::_setup_symbols which was called 4 times, avg 30µs/call: # 4 times (94µs+24µs) by CGI::import at line 291, avg 30µs/call
sub _setup_symbols {
89644µs my $self = shift;
89742µs my $compile = 0;
898
899 # to avoid reexporting unwanted variables
90042µs undef %EXPORT;
901
90247µs for (@_) {
90319µs12µs $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
# spent 2µs making 1 call to CGI::CORE:match
90413µs11µs $NPH++, next if /^[:-]nph$/;
# spent 1µs making 1 call to CGI::CORE:match
90513µs1500ns $NOSTICKY++, next if /^[:-]nosticky$/;
# spent 500ns making 1 call to CGI::CORE:match
90613µs1900ns $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
# spent 900ns making 1 call to CGI::CORE:match
90714µs1600ns $DEBUG=2, next if /^[:-][Dd]ebug$/;
# spent 600ns making 1 call to CGI::CORE:match
90814µs1600ns $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
# spent 600ns making 1 call to CGI::CORE:match
90913µs1600ns $PARAM_UTF8++, next if /^[:-]utf8$/;
# spent 600ns making 1 call to CGI::CORE:match
91013µs1700ns $XHTML++, next if /^[:-]xhtml$/;
# spent 700ns making 1 call to CGI::CORE:match
91113µs1700ns $XHTML=0, next if /^[:-]no_?xhtml$/;
# spent 700ns making 1 call to CGI::CORE:match
91213µs1500ns $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
# spent 500ns making 1 call to CGI::CORE:match
91313µs1700ns $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
# spent 700ns making 1 call to CGI::CORE:match
91414µs1600ns $TABINDEX++, next if /^[:-]tabindex$/;
# spent 600ns making 1 call to CGI::CORE:match
91514µs1500ns $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
# spent 500ns making 1 call to CGI::CORE:match
91613µs1600ns $EXPORT{$_}++, next if /^[:-]any$/;
# spent 600ns making 1 call to CGI::CORE:match
91713µs1800ns $compile++, next if /^[:-]compile$/;
# spent 800ns making 1 call to CGI::CORE:match
91813µs1700ns $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
# spent 700ns making 1 call to CGI::CORE:match
919
920 # This is probably extremely evil code -- to be deleted some day.
92113µs1500ns if (/^[-]autoload$/) {
# spent 500ns making 1 call to CGI::CORE:match
922 my($pkg) = caller(1);
923 *{"${pkg}::AUTOLOAD"} = sub {
924 my($routine) = $AUTOLOAD;
925 $routine =~ s/^.*::/CGI::/;
926 &$routine;
927 };
928 next;
929 }
930
93116µs112µs for (&expand_tags($_)) {
# spent 12µs making 1 call to CGI::expand_tags
93212µs tr/a-zA-Z0-9_//cd; # don't allow weird function names
93313µs $EXPORT{$_}++;
934 }
935 }
93642µs _compile_all(keys %EXPORT) if $compile;
937430µs @SAVED_SYMBOLS = @_;
938}
939
940
# spent 107µs (75+33) within CGI::charset which was called 5 times, avg 21µs/call: # 2 times (35µs+15µs) by CGI::init at line 522, avg 25µs/call # once (17µs+7µs) by CGI::header at line 43 of (eval 1149)[CGI.pm:869] # once (14µs+9µs) by CGI::init at line 534 # once (8µs+2µs) by CGI::save_request at line 759
sub charset {
941525µs533µs my ($self,$charset) = self_or_default(@_);
# spent 33µs making 5 calls to CGI::self_or_default, avg 7µs/call
942511µs $self->{'.charset'} = $charset if defined $charset;
943534µs $self->{'.charset'};
944}
945
946sub element_id {
947 my ($self,$new_value) = self_or_default(@_);
948 $self->{'.elid'} = $new_value if defined $new_value;
949 sprintf('%010d',$self->{'.elid'}++);
950}
951
952sub element_tab {
953 my ($self,$new_value) = self_or_default(@_);
954 $self->{'.etab'} ||= 1;
955 $self->{'.etab'} = $new_value if defined $new_value;
956 my $tab = $self->{'.etab'}++;
957 return '' unless $TABINDEX or defined $new_value;
958 return qq(tabindex="$tab" );
959}
960
961###############################################################################
962################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
963###############################################################################
9641600ns$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
965150µs$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
966
967%SUBS = (
968
969'URL_ENCODED'=> <<'END_OF_FUNC',
970sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
971END_OF_FUNC
972
973'MULTIPART' => <<'END_OF_FUNC',
974sub MULTIPART { 'multipart/form-data'; }
975END_OF_FUNC
976
977'SERVER_PUSH' => <<'END_OF_FUNC',
978sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
979END_OF_FUNC
980
981'new_MultipartBuffer' => <<'END_OF_FUNC',
982# Create a new multipart buffer
983sub new_MultipartBuffer {
984 my($self,$boundary,$length) = @_;
985 return MultipartBuffer->new($self,$boundary,$length);
986}
987END_OF_FUNC
988
989'read_from_client' => <<'END_OF_FUNC',
990# Read data from a file handle
991sub read_from_client {
992 my($self, $buff, $len, $offset) = @_;
993 local $^W=0; # prevent a warning
994 return $MOD_PERL
995 ? $self->r->read($$buff, $len, $offset)
996 : read(\*STDIN, $$buff, $len, $offset);
997}
998END_OF_FUNC
999
1000'delete' => <<'END_OF_FUNC',
1001#### Method: delete
1002# Deletes the named parameter entirely.
1003####
1004sub delete {
1005 my($self,@p) = self_or_default(@_);
1006 my(@names) = rearrange([NAME],@p);
1007 my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
1008 my %to_delete;
1009 for my $name (@to_delete)
1010 {
1011 CORE::delete $self->{param}{$name};
1012 CORE::delete $self->{'.fieldnames'}->{$name};
1013 $to_delete{$name}++;
1014 }
1015 @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
1016 return;
1017}
1018END_OF_FUNC
1019
1020#### Method: import_names
1021# Import all parameters into the given namespace.
1022# Assumes namespace 'Q' if not specified
1023####
1024'import_names' => <<'END_OF_FUNC',
1025sub import_names {
1026 my($self,$namespace,$delete) = self_or_default(@_);
1027 $namespace = 'Q' unless defined($namespace);
1028 die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
1029 if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
1030 # can anyone find an easier way to do this?
1031 for (keys %{"${namespace}::"}) {
1032 local *symbol = "${namespace}::${_}";
1033 undef $symbol;
1034 undef @symbol;
1035 undef %symbol;
1036 }
1037 }
1038 my($param,@value,$var);
1039 for $param ($self->param) {
1040 # protect against silly names
1041 ($var = $param)=~tr/a-zA-Z0-9_/_/c;
1042 $var =~ s/^(?=\d)/_/;
1043 local *symbol = "${namespace}::$var";
1044 @value = $self->param($param);
1045 @symbol = @value;
1046 $symbol = $value[0];
1047 }
1048}
1049END_OF_FUNC
1050
1051#### Method: keywords
1052# Keywords acts a bit differently. Calling it in a list context
1053# returns the list of keywords.
1054# Calling it in a scalar context gives you the size of the list.
1055####
1056'keywords' => <<'END_OF_FUNC',
1057sub keywords {
1058 my($self,@values) = self_or_default(@_);
1059 # If values is provided, then we set it.
1060 $self->{param}{'keywords'}=[@values] if @values;
1061 my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : ();
1062 @result;
1063}
1064END_OF_FUNC
1065
1066# These are some tie() interfaces for compatibility
1067# with Steve Brenner's cgi-lib.pl routines
1068'Vars' => <<'END_OF_FUNC',
1069sub Vars {
1070 my $q = shift;
1071 my %in;
1072 tie(%in,CGI,$q);
1073 return %in if wantarray;
1074 return \%in;
1075}
1076END_OF_FUNC
1077
1078# These are some tie() interfaces for compatibility
1079# with Steve Brenner's cgi-lib.pl routines
1080'ReadParse' => <<'END_OF_FUNC',
1081sub ReadParse {
1082 local(*in);
1083 if (@_) {
1084 *in = $_[0];
1085 } else {
1086 my $pkg = caller();
1087 *in=*{"${pkg}::in"};
1088 }
1089 tie(%in,CGI);
1090 return scalar(keys %in);
1091}
1092END_OF_FUNC
1093
1094'PrintHeader' => <<'END_OF_FUNC',
1095sub PrintHeader {
1096 my($self) = self_or_default(@_);
1097 return $self->header();
1098}
1099END_OF_FUNC
1100
1101'HtmlTop' => <<'END_OF_FUNC',
1102sub HtmlTop {
1103 my($self,@p) = self_or_default(@_);
1104 return $self->start_html(@p);
1105}
1106END_OF_FUNC
1107
1108'HtmlBot' => <<'END_OF_FUNC',
1109sub HtmlBot {
1110 my($self,@p) = self_or_default(@_);
1111 return $self->end_html(@p);
1112}
1113END_OF_FUNC
1114
1115'SplitParam' => <<'END_OF_FUNC',
1116sub SplitParam {
1117 my ($param) = @_;
1118 my (@params) = split ("\0", $param);
1119 return (wantarray ? @params : $params[0]);
1120}
1121END_OF_FUNC
1122
1123'MethGet' => <<'END_OF_FUNC',
1124sub MethGet {
1125 return request_method() eq 'GET';
1126}
1127END_OF_FUNC
1128
1129'MethPost' => <<'END_OF_FUNC',
1130sub MethPost {
1131 return request_method() eq 'POST';
1132}
1133END_OF_FUNC
1134
1135'TIEHASH' => <<'END_OF_FUNC',
1136sub TIEHASH {
1137 my $class = shift;
1138 my $arg = $_[0];
1139 if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
1140 return $arg;
1141 }
1142 return $Q ||= $class->new(@_);
1143}
1144END_OF_FUNC
1145
1146'STORE' => <<'END_OF_FUNC',
1147sub STORE {
1148 my $self = shift;
1149 my $tag = shift;
1150 my $vals = shift;
1151 my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
1152 $self->param(-name=>$tag,-value=>\@vals);
1153}
1154END_OF_FUNC
1155
1156'FETCH' => <<'END_OF_FUNC',
1157sub FETCH {
1158 return $_[0] if $_[1] eq 'CGI';
1159 return undef unless defined $_[0]->param($_[1]);
1160 return join("\0",$_[0]->param($_[1]));
1161}
1162END_OF_FUNC
1163
1164'FIRSTKEY' => <<'END_OF_FUNC',
1165sub FIRSTKEY {
1166 $_[0]->{'.iterator'}=0;
1167 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1168}
1169END_OF_FUNC
1170
1171'NEXTKEY' => <<'END_OF_FUNC',
1172sub NEXTKEY {
1173 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1174}
1175END_OF_FUNC
1176
1177'EXISTS' => <<'END_OF_FUNC',
1178sub EXISTS {
1179 exists $_[0]->{param}{$_[1]};
1180}
1181END_OF_FUNC
1182
1183'DELETE' => <<'END_OF_FUNC',
1184sub DELETE {
1185 $_[0]->delete($_[1]);
1186}
1187END_OF_FUNC
1188
1189'CLEAR' => <<'END_OF_FUNC',
1190sub CLEAR {
1191 %{$_[0]}=();
1192}
1193####
1194END_OF_FUNC
1195
1196####
1197# Append a new value to an existing query
1198####
1199'append' => <<'EOF',
1200sub append {
1201 my($self,@p) = self_or_default(@_);
1202 my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
1203 my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
1204 if (@values) {
1205 $self->add_parameter($name);
1206 push(@{$self->{param}{$name}},@values);
1207 }
1208 return $self->param($name);
1209}
1210EOF
1211
1212#### Method: delete_all
1213# Delete all parameters
1214####
1215'delete_all' => <<'EOF',
1216sub delete_all {
1217 my($self) = self_or_default(@_);
1218 my @param = $self->param();
1219 $self->delete(@param);
1220}
1221EOF
1222
1223'Delete' => <<'EOF',
1224sub Delete {
1225 my($self,@p) = self_or_default(@_);
1226 $self->delete(@p);
1227}
1228EOF
1229
1230'Delete_all' => <<'EOF',
1231sub Delete_all {
1232 my($self,@p) = self_or_default(@_);
1233 $self->delete_all(@p);
1234}
1235EOF
1236
1237#### Method: autoescape
1238# If you want to turn off the autoescaping features,
1239# call this method with undef as the argument
1240'autoEscape' => <<'END_OF_FUNC',
1241sub autoEscape {
1242 my($self,$escape) = self_or_default(@_);
1243 my $d = $self->{'escape'};
1244 $self->{'escape'} = $escape;
1245 $d;
1246}
1247END_OF_FUNC
1248
1249
1250#### Method: version
1251# Return the current version
1252####
1253'version' => <<'END_OF_FUNC',
1254sub version {
1255 return $VERSION;
1256}
1257END_OF_FUNC
1258
1259#### Method: url_param
1260# Return a parameter in the QUERY_STRING, regardless of
1261# whether this was a POST or a GET
1262####
1263'url_param' => <<'END_OF_FUNC',
1264sub url_param {
1265 my ($self,@p) = self_or_default(@_);
1266 my $name = shift(@p);
1267 return undef unless exists($ENV{QUERY_STRING});
1268 unless (exists($self->{'.url_param'})) {
1269 $self->{'.url_param'}={}; # empty hash
1270 if ($ENV{QUERY_STRING} =~ /=/) {
1271 my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
1272 my($param,$value);
1273 for (@pairs) {
1274 ($param,$value) = split('=',$_,2);
1275 $param = unescape($param);
1276 $value = unescape($value);
1277 push(@{$self->{'.url_param'}->{$param}},$value);
1278 }
1279 } else {
1280 $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
1281 }
1282 }
1283 return keys %{$self->{'.url_param'}} unless defined($name);
1284 return () unless $self->{'.url_param'}->{$name};
1285 return wantarray ? @{$self->{'.url_param'}->{$name}}
1286 : $self->{'.url_param'}->{$name}->[0];
1287}
1288END_OF_FUNC
1289
1290#### Method: Dump
1291# Returns a string in which all the known parameter/value
1292# pairs are represented as nested lists, mainly for the purposes
1293# of debugging.
1294####
1295'Dump' => <<'END_OF_FUNC',
1296sub Dump {
1297 my($self) = self_or_default(@_);
1298 my($param,$value,@result);
1299 return '<ul></ul>' unless $self->param;
1300 push(@result,"<ul>");
1301 for $param ($self->param) {
1302 my($name)=$self->escapeHTML($param);
1303 push(@result,"<li><strong>$param</strong></li>");
1304 push(@result,"<ul>");
1305 for $value ($self->param($param)) {
1306 $value = $self->escapeHTML($value);
1307 $value =~ s/\n/<br \/>\n/g;
1308 push(@result,"<li>$value</li>");
1309 }
1310 push(@result,"</ul>");
1311 }
1312 push(@result,"</ul>");
1313 return join("\n",@result);
1314}
1315END_OF_FUNC
1316
1317#### Method as_string
1318#
1319# synonym for "dump"
1320####
1321'as_string' => <<'END_OF_FUNC',
1322sub as_string {
1323 &Dump(@_);
1324}
1325END_OF_FUNC
1326
1327#### Method: save
1328# Write values out to a filehandle in such a way that they can
1329# be reinitialized by the filehandle form of the new() method
1330####
1331'save' => <<'END_OF_FUNC',
1332sub save {
1333 my($self,$filehandle) = self_or_default(@_);
1334 $filehandle = to_filehandle($filehandle);
1335 my($param);
1336 local($,) = ''; # set print field separator back to a sane value
1337 local($\) = ''; # set output line separator to a sane value
1338 for $param ($self->param) {
1339 my($escaped_param) = escape($param);
1340 my($value);
1341 for $value ($self->param($param)) {
1342 print $filehandle "$escaped_param=",escape("$value"),"\n";
1343 }
1344 }
1345 for (keys %{$self->{'.fieldnames'}}) {
1346 print $filehandle ".cgifields=",escape("$_"),"\n";
1347 }
1348 print $filehandle "=\n"; # end of record
1349}
1350END_OF_FUNC
1351
1352
1353#### Method: save_parameters
1354# An alias for save() that is a better name for exportation.
1355# Only intended to be used with the function (non-OO) interface.
1356####
1357'save_parameters' => <<'END_OF_FUNC',
1358sub save_parameters {
1359 my $fh = shift;
1360 return save(to_filehandle($fh));
1361}
1362END_OF_FUNC
1363
1364#### Method: restore_parameters
1365# A way to restore CGI parameters from an initializer.
1366# Only intended to be used with the function (non-OO) interface.
1367####
1368'restore_parameters' => <<'END_OF_FUNC',
1369sub restore_parameters {
1370 $Q = $CGI::DefaultClass->new(@_);
1371}
1372END_OF_FUNC
1373
1374#### Method: multipart_init
1375# Return a Content-Type: style header for server-push
1376# This has to be NPH on most web servers, and it is advisable to set $| = 1
1377#
1378# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1379# contribution, updated by Andrew Benham (adsb@bigfoot.com)
1380####
1381'multipart_init' => <<'END_OF_FUNC',
1382sub multipart_init {
1383 my($self,@p) = self_or_default(@_);
1384 my($boundary,@other) = rearrange_header([BOUNDARY],@p);
1385 if (!$boundary) {
1386 $boundary = '------- =_';
1387 my @chrs = ('0'..'9', 'A'..'Z', 'a'..'z');
1388 for (1..17) {
1389 $boundary .= $chrs[rand(scalar @chrs)];
1390 }
1391 }
1392
1393 $self->{'separator'} = "$CRLF--$boundary$CRLF";
1394 $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
1395 $type = SERVER_PUSH($boundary);
1396 return $self->header(
1397 -nph => 0,
1398 -type => $type,
1399 (map { split "=", $_, 2 } @other),
1400 ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
1401}
1402END_OF_FUNC
1403
1404
1405#### Method: multipart_start
1406# Return a Content-Type: style header for server-push, start of section
1407#
1408# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1409# contribution, updated by Andrew Benham (adsb@bigfoot.com)
1410####
1411'multipart_start' => <<'END_OF_FUNC',
1412sub multipart_start {
1413 my(@header);
1414 my($self,@p) = self_or_default(@_);
1415 my($type,@other) = rearrange([TYPE],@p);
1416 $type = $type || 'text/html';
1417 push(@header,"Content-Type: $type");
1418
1419 # rearrange() was designed for the HTML portion, so we
1420 # need to fix it up a little.
1421 for (@other) {
1422 # Don't use \s because of perl bug 21951
1423 next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
1424 ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
1425 }
1426 push(@header,@other);
1427 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1428 return $header;
1429}
1430END_OF_FUNC
1431
1432
1433#### Method: multipart_end
1434# Return a MIME boundary separator for server-push, end of section
1435#
1436# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1437# contribution
1438####
1439'multipart_end' => <<'END_OF_FUNC',
1440sub multipart_end {
1441 my($self,@p) = self_or_default(@_);
1442 return $self->{'separator'};
1443}
1444END_OF_FUNC
1445
1446
1447#### Method: multipart_final
1448# Return a MIME boundary separator for server-push, end of all sections
1449#
1450# Contributed by Andrew Benham (adsb@bigfoot.com)
1451####
1452'multipart_final' => <<'END_OF_FUNC',
1453sub multipart_final {
1454 my($self,@p) = self_or_default(@_);
1455 return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
1456}
1457END_OF_FUNC
1458
1459
1460#### Method: header
1461# Return a Content-Type: style header
1462#
1463####
1464'header' => <<'END_OF_FUNC',
1465sub header {
1466 my($self,@p) = self_or_default(@_);
1467 my(@header);
1468
1469 return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
1470
1471 my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
1472 rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
1473 'STATUS',['COOKIE','COOKIES'],'TARGET',
1474 'EXPIRES','NPH','CHARSET',
1475 'ATTACHMENT','P3P'],@p);
1476
1477 # Since $cookie and $p3p may be array references,
1478 # we must stringify them before CR escaping is done.
1479 my @cookie;
1480 for (ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie) {
1481 my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
1482 push(@cookie,$cs) if defined $cs and $cs ne '';
1483 }
1484 $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
1485
1486 # CR escaping for values, per RFC 822
1487 for my $header ($type,$status,@cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) {
1488 if (defined $header) {
1489 # From RFC 822:
1490 # Unfolding is accomplished by regarding CRLF immediately
1491 # followed by a LWSP-char as equivalent to the LWSP-char.
1492 $header =~ s/$CRLF(\s)/$1/g;
1493
1494 # All other uses of newlines are invalid input.
1495 if ($header =~ m/$CRLF|\015|\012/) {
1496 # shorten very long values in the diagnostic
1497 $header = substr($header,0,72).'...' if (length $header > 72);
1498 die "Invalid header value contains a newline not followed by whitespace: $header";
1499 }
1500 }
1501 }
1502
1503 $nph ||= $NPH;
1504
1505 $type ||= 'text/html' unless defined($type);
1506
1507 if (defined $charset) {
1508 $self->charset($charset);
1509 } else {
1510 $charset = $self->charset if $type =~ /^text\//;
1511 }
1512 $charset ||= '';
1513
1514 # rearrange() was designed for the HTML portion, so we
1515 # need to fix it up a little.
1516 for (@other) {
1517 # Don't use \s because of perl bug 21951
1518 next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s;
1519 ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
1520 }
1521
1522 $type .= "; charset=$charset"
1523 if $type ne ''
1524 and $type !~ /\bcharset\b/
1525 and defined $charset
1526 and $charset ne '';
1527
1528 # Maybe future compatibility. Maybe not.
1529 my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
1530 push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
1531 push(@header,"Server: " . &server_software()) if $nph;
1532
1533 push(@header,"Status: $status") if $status;
1534 push(@header,"Window-Target: $target") if $target;
1535 push(@header,"P3P: policyref=\"/w3c/p3p.xml\", CP=\"$p3p\"") if $p3p;
1536 # push all the cookies -- there may be several
1537 push(@header,map {"Set-Cookie: $_"} @cookie);
1538 # if the user indicates an expiration time, then we need
1539 # both an Expires and a Date header (so that the browser is
1540 # uses OUR clock)
1541 push(@header,"Expires: " . expires($expires,'http'))
1542 if $expires;
1543 push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
1544 push(@header,"Pragma: no-cache") if $self->cache();
1545 push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
1546 push(@header,map {ucfirst $_} @other);
1547 push(@header,"Content-Type: $type") if $type ne '';
1548 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1549 if (($MOD_PERL >= 1) && !$nph) {
1550 $self->r->send_cgi_header($header);
1551 return '';
1552 }
1553 return $header;
1554}
1555END_OF_FUNC
1556
1557
1558#### Method: cache
1559# Control whether header() will produce the no-cache
1560# Pragma directive.
1561####
1562'cache' => <<'END_OF_FUNC',
1563sub cache {
1564 my($self,$new_value) = self_or_default(@_);
1565 $new_value = '' unless $new_value;
1566 if ($new_value ne '') {
1567 $self->{'cache'} = $new_value;
1568 }
1569 return $self->{'cache'};
1570}
1571END_OF_FUNC
1572
1573
1574#### Method: redirect
1575# Return a Location: style header
1576#
1577####
1578'redirect' => <<'END_OF_FUNC',
1579sub redirect {
1580 my($self,@p) = self_or_default(@_);
1581 my($url,$target,$status,$cookie,$nph,@other) =
1582 rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p);
1583 $status = '302 Found' unless defined $status;
1584 $url ||= $self->self_url;
1585 my(@o);
1586 for (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
1587 unshift(@o,
1588 '-Status' => $status,
1589 '-Location'=> $url,
1590 '-nph' => $nph);
1591 unshift(@o,'-Target'=>$target) if $target;
1592 unshift(@o,'-Type'=>'');
1593 my @unescaped;
1594 unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
1595 return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
1596}
1597END_OF_FUNC
1598
1599
1600#### Method: start_html
1601# Canned HTML header
1602#
1603# Parameters:
1604# $title -> (optional) The title for this HTML document (-title)
1605# $author -> (optional) e-mail address of the author (-author)
1606# $base -> (optional) if set to true, will enter the BASE address of this document
1607# for resolving relative references (-base)
1608# $xbase -> (optional) alternative base at some remote location (-xbase)
1609# $target -> (optional) target window to load all links into (-target)
1610# $script -> (option) Javascript code (-script)
1611# $no_script -> (option) Javascript <noscript> tag (-noscript)
1612# $meta -> (optional) Meta information tags
1613# $head -> (optional) any other elements you'd like to incorporate into the <head> tag
1614# (a scalar or array ref)
1615# $style -> (optional) reference to an external style sheet
1616# @other -> (optional) any other named parameters you'd like to incorporate into
1617# the <body> tag.
1618####
1619'start_html' => <<'END_OF_FUNC',
1620sub start_html {
1621 my($self,@p) = &self_or_default(@_);
1622 my($title,$author,$base,$xbase,$script,$noscript,
1623 $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) =
1624 rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,
1625 META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p);
1626
1627 $self->element_id(0);
1628 $self->element_tab(0);
1629
1630 $encoding = lc($self->charset) unless defined $encoding;
1631
1632 # Need to sort out the DTD before it's okay to call escapeHTML().
1633 my(@result,$xml_dtd);
1634 if ($dtd) {
1635 if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
1636 $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
1637 } else {
1638 $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
1639 }
1640 } else {
1641 $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
1642 }
1643
1644 $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
1645 $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
1646 push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml;
1647
1648 if (ref($dtd) && ref($dtd) eq 'ARRAY') {
1649 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
1650 $DTD_PUBLIC_IDENTIFIER = $dtd->[0];
1651 } else {
1652 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
1653 $DTD_PUBLIC_IDENTIFIER = $dtd;
1654 }
1655
1656 # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
1657 # call escapeHTML(). Strangely enough, the title needs to be escaped as
1658 # HTML while the author needs to be escaped as a URL.
1659 $title = $self->escapeHTML($title || 'Untitled Document');
1660 $author = $self->escape($author);
1661
1662 if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2)/i) {
1663 $lang = "" unless defined $lang;
1664 $XHTML = 0;
1665 }
1666 else {
1667 $lang = 'en-US' unless defined $lang;
1668 }
1669
1670 my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : '';
1671 my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />)
1672 if $XHTML && $encoding && !$declare_xml;
1673
1674 push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>)
1675 : ($lang ? qq(<html lang="$lang">) : "<html>")
1676 . "<head><title>$title</title>");
1677 if (defined $author) {
1678 push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
1679 : "<link rev=\"made\" href=\"mailto:$author\">");
1680 }
1681
1682 if ($base || $xbase || $target) {
1683 my $href = $xbase || $self->url('-path'=>1);
1684 my $t = $target ? qq/ target="$target"/ : '';
1685 push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
1686 }
1687
1688 if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
1689 for (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
1690 : qq(<meta name="$_" content="$meta->{$_}">)); }
1691 }
1692
1693 my $meta_bits_set = 0;
1694 if( $head ) {
1695 if( ref $head ) {
1696 push @result, @$head;
1697 $meta_bits_set = 1 if grep { /http-equiv=["']Content-Type/i }@$head;
1698 }
1699 else {
1700 push @result, $head;
1701 $meta_bits_set = 1 if $head =~ /http-equiv=["']Content-Type/i;
1702 }
1703 }
1704
1705 # handle the infrequently-used -style and -script parameters
1706 push(@result,$self->_style($style)) if defined $style;
1707 push(@result,$self->_script($script)) if defined $script;
1708 push(@result,$meta_bits) if defined $meta_bits and !$meta_bits_set;
1709
1710 # handle -noscript parameter
1711 push(@result,<<END) if $noscript;
1712<noscript>
1713$noscript
1714</noscript>
1715END
1716 ;
1717 my($other) = @other ? " @other" : '';
1718 push(@result,"</head>\n<body$other>\n");
1719 return join("\n",@result);
1720}
1721END_OF_FUNC
1722
1723### Method: _style
1724# internal method for generating a CSS style section
1725####
1726'_style' => <<'END_OF_FUNC',
1727sub _style {
1728 my ($self,$style) = @_;
1729 my (@result);
1730
1731 my $type = 'text/css';
1732 my $rel = 'stylesheet';
1733
1734
1735 my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
1736 my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
1737
1738 my @s = ref($style) eq 'ARRAY' ? @$style : $style;
1739 my $other = '';
1740
1741 for my $s (@s) {
1742 if (ref($s)) {
1743 my($src,$code,$verbatim,$stype,$alternate,$foo,@other) =
1744 rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)],
1745 ('-foo'=>'bar',
1746 ref($s) eq 'ARRAY' ? @$s : %$s));
1747 my $type = defined $stype ? $stype : 'text/css';
1748 my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet';
1749 $other = "@other" if @other;
1750
1751 if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
1752 { # If it is, push a LINK tag for each one
1753 for $src (@$src)
1754 {
1755 push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
1756 : qq(<link rel="$rel" type="$type" href="$src"$other>)) if $src;
1757 }
1758 }
1759 else
1760 { # Otherwise, push the single -src, if it exists.
1761 push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
1762 : qq(<link rel="$rel" type="$type" href="$src"$other>)
1763 ) if $src;
1764 }
1765 if ($verbatim) {
1766 my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim;
1767 push(@result, "<style type=\"text/css\">\n$_\n</style>") for @v;
1768 }
1769 my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code;
1770 push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c;
1771
1772 } else {
1773 my $src = $s;
1774 push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
1775 : qq(<link rel="$rel" type="$type" href="$src"$other>));
1776 }
1777 }
1778 @result;
1779}
1780END_OF_FUNC
1781
1782'_script' => <<'END_OF_FUNC',
1783sub _script {
1784 my ($self,$script) = @_;
1785 my (@result);
1786
1787 my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
1788 for $script (@scripts) {
1789 my($src,$code,$language);
1790 if (ref($script)) { # script is a hash
1791 ($src,$code,$type) =
1792 rearrange(['SRC','CODE',['LANGUAGE','TYPE']],
1793 '-foo'=>'bar', # a trick to allow the '-' to be omitted
1794 ref($script) eq 'ARRAY' ? @$script : %$script);
1795 $type ||= 'text/javascript';
1796 unless ($type =~ m!\w+/\w+!) {
1797 $type =~ s/[\d.]+$//;
1798 $type = "text/$type";
1799 }
1800 } else {
1801 ($src,$code,$type) = ('',$script, 'text/javascript');
1802 }
1803
1804 my $comment = '//'; # javascript by default
1805 $comment = '#' if $type=~/perl|tcl/i;
1806 $comment = "'" if $type=~/vbscript/i;
1807
1808 my ($cdata_start,$cdata_end);
1809 if ($XHTML) {
1810 $cdata_start = "$comment<![CDATA[\n";
1811 $cdata_end .= "\n$comment]]>";
1812 } else {
1813 $cdata_start = "\n<!-- Hide script\n";
1814 $cdata_end = $comment;
1815 $cdata_end .= " End script hiding -->\n";
1816 }
1817 my(@satts);
1818 push(@satts,'src'=>$src) if $src;
1819 push(@satts,'type'=>$type);
1820 $code = $cdata_start . $code . $cdata_end if defined $code;
1821 push(@result,$self->script({@satts},$code || ''));
1822 }
1823 @result;
1824}
1825END_OF_FUNC
1826
1827#### Method: end_html
1828# End an HTML document.
1829# Trivial method for completeness. Just returns "</body>"
1830####
1831'end_html' => <<'END_OF_FUNC',
1832sub end_html {
1833 return "\n</body>\n</html>";
1834}
1835END_OF_FUNC
1836
1837
1838################################
1839# METHODS USED IN BUILDING FORMS
1840################################
1841
1842#### Method: isindex
1843# Just prints out the isindex tag.
1844# Parameters:
1845# $action -> optional URL of script to run
1846# Returns:
1847# A string containing a <isindex> tag
1848'isindex' => <<'END_OF_FUNC',
1849sub isindex {
1850 my($self,@p) = self_or_default(@_);
1851 my($action,@other) = rearrange([ACTION],@p);
1852 $action = qq/ action="$action"/ if $action;
1853 my($other) = @other ? " @other" : '';
1854 return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>";
1855}
1856END_OF_FUNC
1857
1858
1859#### Method: startform
1860# Start a form
1861# Parameters:
1862# $method -> optional submission method to use (GET or POST)
1863# $action -> optional URL of script to run
1864# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1865'startform' => <<'END_OF_FUNC',
1866sub startform {
1867 my($self,@p) = self_or_default(@_);
1868
1869 my($method,$action,$enctype,@other) =
1870 rearrange([METHOD,ACTION,ENCTYPE],@p);
1871
1872 $method = $self->escapeHTML(lc($method || 'post'));
1873 $enctype = $self->escapeHTML($enctype || &URL_ENCODED);
1874 if (defined $action) {
1875 $action = $self->escapeHTML($action);
1876 }
1877 else {
1878 $action = $self->escapeHTML($self->request_uri || $self->self_url);
1879 }
1880 $action = qq(action="$action");
1881 my($other) = @other ? " @other" : '';
1882 $self->{'.parametersToAdd'}={};
1883 return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
1884}
1885END_OF_FUNC
1886
1887
1888#### Method: start_form
1889# synonym for startform
1890'start_form' => <<'END_OF_FUNC',
1891sub start_form {
1892 $XHTML ? &start_multipart_form : &startform;
1893}
1894END_OF_FUNC
1895
1896'end_multipart_form' => <<'END_OF_FUNC',
1897sub end_multipart_form {
1898 &endform;
1899}
1900END_OF_FUNC
1901
1902#### Method: start_multipart_form
1903# synonym for startform
1904'start_multipart_form' => <<'END_OF_FUNC',
1905sub start_multipart_form {
1906 my($self,@p) = self_or_default(@_);
1907 if (defined($p[0]) && substr($p[0],0,1) eq '-') {
1908 return $self->startform(-enctype=>&MULTIPART,@p);
1909 } else {
1910 my($method,$action,@other) =
1911 rearrange([METHOD,ACTION],@p);
1912 return $self->startform($method,$action,&MULTIPART,@other);
1913 }
1914}
1915END_OF_FUNC
1916
1917
1918#### Method: endform
1919# End a form
1920'endform' => <<'END_OF_FUNC',
1921sub endform {
1922 my($self,@p) = self_or_default(@_);
1923 if ( $NOSTICKY ) {
1924 return wantarray ? ("</form>") : "\n</form>";
1925 } else {
1926 if (my @fields = $self->get_fields) {
1927 return wantarray ? ("<div>",@fields,"</div>","</form>")
1928 : "<div>".(join '',@fields)."</div>\n</form>";
1929 } else {
1930 return "</form>";
1931 }
1932 }
1933}
1934END_OF_FUNC
1935
1936
1937'_textfield' => <<'END_OF_FUNC',
1938sub _textfield {
1939 my($self,$tag,@p) = self_or_default(@_);
1940 my($name,$default,$size,$maxlength,$override,$tabindex,@other) =
1941 rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p);
1942
1943 my $current = $override ? $default :
1944 (defined($self->param($name)) ? $self->param($name) : $default);
1945
1946 $current = defined($current) ? $self->escapeHTML($current,1) : '';
1947 $name = defined($name) ? $self->escapeHTML($name) : '';
1948 my($s) = defined($size) ? qq/ size="$size"/ : '';
1949 my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
1950 my($other) = @other ? " @other" : '';
1951 # this entered at cristy's request to fix problems with file upload fields
1952 # and WebTV -- not sure it won't break stuff
1953 my($value) = $current ne '' ? qq(value="$current") : '';
1954 $tabindex = $self->element_tab($tabindex);
1955 return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />)
1956 : qq(<input type="$tag" name="$name" $value$s$m$other>);
1957}
1958END_OF_FUNC
1959
1960#### Method: textfield
1961# Parameters:
1962# $name -> Name of the text field
1963# $default -> Optional default value of the field if not
1964# already defined.
1965# $size -> Optional width of field in characaters.
1966# $maxlength -> Optional maximum number of characters.
1967# Returns:
1968# A string containing a <input type="text"> field
1969#
1970'textfield' => <<'END_OF_FUNC',
1971sub textfield {
1972 my($self,@p) = self_or_default(@_);
1973 $self->_textfield('text',@p);
1974}
1975END_OF_FUNC
1976
1977
1978#### Method: filefield
1979# Parameters:
1980# $name -> Name of the file upload field
1981# $size -> Optional width of field in characaters.
1982# $maxlength -> Optional maximum number of characters.
1983# Returns:
1984# A string containing a <input type="file"> field
1985#
1986'filefield' => <<'END_OF_FUNC',
1987sub filefield {
1988 my($self,@p) = self_or_default(@_);
1989 $self->_textfield('file',@p);
1990}
1991END_OF_FUNC
1992
1993
1994#### Method: password
1995# Create a "secret password" entry field
1996# Parameters:
1997# $name -> Name of the field
1998# $default -> Optional default value of the field if not
1999# already defined.
2000# $size -> Optional width of field in characters.
2001# $maxlength -> Optional maximum characters that can be entered.
2002# Returns:
2003# A string containing a <input type="password"> field
2004#
2005'password_field' => <<'END_OF_FUNC',
2006sub password_field {
2007 my ($self,@p) = self_or_default(@_);
2008 $self->_textfield('password',@p);
2009}
2010END_OF_FUNC
2011
2012#### Method: textarea
2013# Parameters:
2014# $name -> Name of the text field
2015# $default -> Optional default value of the field if not
2016# already defined.
2017# $rows -> Optional number of rows in text area
2018# $columns -> Optional number of columns in text area
2019# Returns:
2020# A string containing a <textarea></textarea> tag
2021#
2022'textarea' => <<'END_OF_FUNC',
2023sub textarea {
2024 my($self,@p) = self_or_default(@_);
2025 my($name,$default,$rows,$cols,$override,$tabindex,@other) =
2026 rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p);
2027
2028 my($current)= $override ? $default :
2029 (defined($self->param($name)) ? $self->param($name) : $default);
2030
2031 $name = defined($name) ? $self->escapeHTML($name) : '';
2032 $current = defined($current) ? $self->escapeHTML($current) : '';
2033 my($r) = $rows ? qq/ rows="$rows"/ : '';
2034 my($c) = $cols ? qq/ cols="$cols"/ : '';
2035 my($other) = @other ? " @other" : '';
2036 $tabindex = $self->element_tab($tabindex);
2037 return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>};
2038}
2039END_OF_FUNC
2040
2041
2042#### Method: button
2043# Create a javascript button.
2044# Parameters:
2045# $name -> (optional) Name for the button. (-name)
2046# $value -> (optional) Value of the button when selected (and visible name) (-value)
2047# $onclick -> (optional) Text of the JavaScript to run when the button is
2048# clicked.
2049# Returns:
2050# A string containing a <input type="button"> tag
2051####
2052'button' => <<'END_OF_FUNC',
2053sub button {
2054 my($self,@p) = self_or_default(@_);
2055
2056 my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],
2057 [ONCLICK,SCRIPT],TABINDEX],@p);
2058
2059 $label=$self->escapeHTML($label);
2060 $value=$self->escapeHTML($value,1);
2061 $script=$self->escapeHTML($script);
2062
2063 my($name) = '';
2064 $name = qq/ name="$label"/ if $label;
2065 $value = $value || $label;
2066 my($val) = '';
2067 $val = qq/ value="$value"/ if $value;
2068 $script = qq/ onclick="$script"/ if $script;
2069 my($other) = @other ? " @other" : '';
2070 $tabindex = $self->element_tab($tabindex);
2071 return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />)
2072 : qq(<input type="button"$name$val$script$other>);
2073}
2074END_OF_FUNC
2075
2076
2077#### Method: submit
2078# Create a "submit query" button.
2079# Parameters:
2080# $name -> (optional) Name for the button.
2081# $value -> (optional) Value of the button when selected (also doubles as label).
2082# $label -> (optional) Label printed on the button(also doubles as the value).
2083# Returns:
2084# A string containing a <input type="submit"> tag
2085####
2086'submit' => <<'END_OF_FUNC',
2087sub submit {
2088 my($self,@p) = self_or_default(@_);
2089
2090 my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p);
2091
2092 $label=$self->escapeHTML($label);
2093 $value=$self->escapeHTML($value,1);
2094
2095 my $name = $NOSTICKY ? '' : 'name=".submit" ';
2096 $name = qq/name="$label" / if defined($label);
2097 $value = defined($value) ? $value : $label;
2098 my $val = '';
2099 $val = qq/value="$value" / if defined($value);
2100 $tabindex = $self->element_tab($tabindex);
2101 my($other) = @other ? "@other " : '';
2102 return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>)
2103 : qq(<input type="submit" $name$val$other>);
2104}
2105END_OF_FUNC
2106
2107
2108#### Method: reset
2109# Create a "reset" button.
2110# Parameters:
2111# $name -> (optional) Name for the button.
2112# Returns:
2113# A string containing a <input type="reset"> tag
2114####
2115'reset' => <<'END_OF_FUNC',
2116sub reset {
2117 my($self,@p) = self_or_default(@_);
2118 my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p);
2119 $label=$self->escapeHTML($label);
2120 $value=$self->escapeHTML($value,1);
2121 my ($name) = ' name=".reset"';
2122 $name = qq/ name="$label"/ if defined($label);
2123 $value = defined($value) ? $value : $label;
2124 my($val) = '';
2125 $val = qq/ value="$value"/ if defined($value);
2126 my($other) = @other ? " @other" : '';
2127 $tabindex = $self->element_tab($tabindex);
2128 return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />)
2129 : qq(<input type="reset"$name$val$other>);
2130}
2131END_OF_FUNC
2132
2133
2134#### Method: defaults
2135# Create a "defaults" button.
2136# Parameters:
2137# $name -> (optional) Name for the button.
2138# Returns:
2139# A string containing a <input type="submit" name=".defaults"> tag
2140#
2141# Note: this button has a special meaning to the initialization script,
2142# and tells it to ERASE the current query string so that your defaults
2143# are used again!
2144####
2145'defaults' => <<'END_OF_FUNC',
2146sub defaults {
2147 my($self,@p) = self_or_default(@_);
2148
2149 my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p);
2150
2151 $label=$self->escapeHTML($label,1);
2152 $label = $label || "Defaults";
2153 my($value) = qq/ value="$label"/;
2154 my($other) = @other ? " @other" : '';
2155 $tabindex = $self->element_tab($tabindex);
2156 return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />)
2157 : qq/<input type="submit" NAME=".defaults"$value$other>/;
2158}
2159END_OF_FUNC
2160
2161
2162#### Method: comment
2163# Create an HTML <!-- comment -->
2164# Parameters: a string
2165'comment' => <<'END_OF_FUNC',
2166sub comment {
2167 my($self,@p) = self_or_CGI(@_);
2168 return "<!-- @p -->";
2169}
2170END_OF_FUNC
2171
2172#### Method: checkbox
2173# Create a checkbox that is not logically linked to any others.
2174# The field value is "on" when the button is checked.
2175# Parameters:
2176# $name -> Name of the checkbox
2177# $checked -> (optional) turned on by default if true
2178# $value -> (optional) value of the checkbox, 'on' by default
2179# $label -> (optional) a user-readable label printed next to the box.
2180# Otherwise the checkbox name is used.
2181# Returns:
2182# A string containing a <input type="checkbox"> field
2183####
2184'checkbox' => <<'END_OF_FUNC',
2185sub checkbox {
2186 my($self,@p) = self_or_default(@_);
2187
2188 my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) =
2189 rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES,
2190 [OVERRIDE,FORCE],TABINDEX],@p);
2191
2192 $value = defined $value ? $value : 'on';
2193
2194 if (!$override && ($self->{'.fieldnames'}->{$name} ||
2195 defined $self->param($name))) {
2196 $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
2197 } else {
2198 $checked = $self->_checked($checked);
2199 }
2200 my($the_label) = defined $label ? $label : $name;
2201 $name = $self->escapeHTML($name);
2202 $value = $self->escapeHTML($value,1);
2203 $the_label = $self->escapeHTML($the_label);
2204 my($other) = @other ? "@other " : '';
2205 $tabindex = $self->element_tab($tabindex);
2206 $self->register_parameter($name);
2207 return $XHTML ? CGI::label($labelattributes,
2208 qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
2209 : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
2210}
2211END_OF_FUNC
2212
- -
2215# Escape HTML -- used internally
2216'escapeHTML' => <<'END_OF_FUNC',
2217sub escapeHTML {
2218 # hack to work around earlier hacks
2219 push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
2220 my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
2221 return undef unless defined($toencode);
2222 return $toencode if ref($self) && !$self->{'escape'};
2223 $toencode =~ s{&}{&amp;}gso;
2224 $toencode =~ s{<}{&lt;}gso;
2225 $toencode =~ s{>}{&gt;}gso;
2226 if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
2227 # $quot; was accidentally omitted from the HTML 3.2 DTD -- see
2228 # <http://validator.w3.org/docs/errors.html#bad-entity> /
2229 # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
2230 $toencode =~ s{"}{&#34;}gso;
2231 }
2232 else {
2233 $toencode =~ s{"}{&quot;}gso;
2234 }
2235 # Handle bug in some browsers with Latin charsets
2236 if ($self->{'.charset'} &&
2237 (uc($self->{'.charset'}) eq 'ISO-8859-1' ||
2238 uc($self->{'.charset'}) eq 'WINDOWS-1252'))
2239 {
2240 $toencode =~ s{'}{&#39;}gso;
2241 $toencode =~ s{\x8b}{&#8249;}gso;
2242 $toencode =~ s{\x9b}{&#8250;}gso;
2243 if (defined $newlinestoo && $newlinestoo) {
2244 $toencode =~ s{\012}{&#10;}gso;
2245 $toencode =~ s{\015}{&#13;}gso;
2246 }
2247 }
2248 return $toencode;
2249}
2250END_OF_FUNC
2251
2252# unescape HTML -- used internally
2253'unescapeHTML' => <<'END_OF_FUNC',
2254sub unescapeHTML {
2255 # hack to work around earlier hacks
2256 push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
2257 my ($self,$string) = CGI::self_or_default(@_);
2258 return undef unless defined($string);
2259 my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
2260 : 1;
2261 # thanks to Randal Schwartz for the correct solution to this one
2262 $string=~ s[&(.*?);]{
2263 local $_ = $1;
2264 /^amp$/i ? "&" :
2265 /^quot$/i ? '"' :
2266 /^gt$/i ? ">" :
2267 /^lt$/i ? "<" :
2268 /^#(\d+)$/ && $latin ? chr($1) :
2269 /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
2270 $_
2271 }gex;
2272 return $string;
2273}
2274END_OF_FUNC
2275
2276# Internal procedure - don't use
2277'_tableize' => <<'END_OF_FUNC',
2278sub _tableize {
2279 my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
2280 my @rowheaders = $rowheaders ? @$rowheaders : ();
2281 my @colheaders = $colheaders ? @$colheaders : ();
2282 my($result);
2283
2284 if (defined($columns)) {
2285 $rows = int(0.99 + @elements/$columns) unless defined($rows);
2286 }
2287 if (defined($rows)) {
2288 $columns = int(0.99 + @elements/$rows) unless defined($columns);
2289 }
2290
2291 # rearrange into a pretty table
2292 $result = "<table>";
2293 my($row,$column);
2294 unshift(@colheaders,'') if @colheaders && @rowheaders;
2295 $result .= "<tr>" if @colheaders;
2296 for (@colheaders) {
2297 $result .= "<th>$_</th>";
2298 }
2299 for ($row=0;$row<$rows;$row++) {
2300 $result .= "<tr>";
2301 $result .= "<th>$rowheaders[$row]</th>" if @rowheaders;
2302 for ($column=0;$column<$columns;$column++) {
2303 $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
2304 if defined($elements[$column*$rows + $row]);
2305 }
2306 $result .= "</tr>";
2307 }
2308 $result .= "</table>";
2309 return $result;
2310}
2311END_OF_FUNC
2312
2313
2314#### Method: radio_group
2315# Create a list of logically-linked radio buttons.
2316# Parameters:
2317# $name -> Common name for all the buttons.
2318# $values -> A pointer to a regular array containing the
2319# values for each button in the group.
2320# $default -> (optional) Value of the button to turn on by default. Pass '-'
2321# to turn _nothing_ on.
2322# $linebreak -> (optional) Set to true to place linebreaks
2323# between the buttons.
2324# $labels -> (optional)
2325# A pointer to a hash of labels to print next to each checkbox
2326# in the form $label{'value'}="Long explanatory label".
2327# Otherwise the provided values are used as the labels.
2328# Returns:
2329# An ARRAY containing a series of <input type="radio"> fields
2330####
2331'radio_group' => <<'END_OF_FUNC',
2332sub radio_group {
2333 my($self,@p) = self_or_default(@_);
2334 $self->_box_group('radio',@p);
2335}
2336END_OF_FUNC
2337
2338#### Method: checkbox_group
2339# Create a list of logically-linked checkboxes.
2340# Parameters:
2341# $name -> Common name for all the check boxes
2342# $values -> A pointer to a regular array containing the
2343# values for each checkbox in the group.
2344# $defaults -> (optional)
2345# 1. If a pointer to a regular array of checkbox values,
2346# then this will be used to decide which
2347# checkboxes to turn on by default.
2348# 2. If a scalar, will be assumed to hold the
2349# value of a single checkbox in the group to turn on.
2350# $linebreak -> (optional) Set to true to place linebreaks
2351# between the buttons.
2352# $labels -> (optional)
2353# A pointer to a hash of labels to print next to each checkbox
2354# in the form $label{'value'}="Long explanatory label".
2355# Otherwise the provided values are used as the labels.
2356# Returns:
2357# An ARRAY containing a series of <input type="checkbox"> fields
2358####
2359
2360'checkbox_group' => <<'END_OF_FUNC',
2361sub checkbox_group {
2362 my($self,@p) = self_or_default(@_);
2363 $self->_box_group('checkbox',@p);
2364}
2365END_OF_FUNC
2366
2367'_box_group' => <<'END_OF_FUNC',
2368sub _box_group {
2369 my $self = shift;
2370 my $box_type = shift;
2371
2372 my($name,$values,$defaults,$linebreak,$labels,$labelattributes,
2373 $attributes,$rows,$columns,$rowheaders,$colheaders,
2374 $override,$nolabels,$tabindex,$disabled,@other) =
2375 rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES,
2376 ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER],
2377 [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED
2378 ],@_);
2379
2380
2381 my($result,$checked,@elements,@values);
2382
2383 @values = $self->_set_values_and_labels($values,\$labels,$name);
2384 my %checked = $self->previous_or_default($name,$defaults,$override);
2385
2386 # If no check array is specified, check the first by default
2387 $checked{$values[0]}++ if $box_type eq 'radio' && !%checked;
2388
2389 $name=$self->escapeHTML($name);
2390
2391 my %tabs = ();
2392 if ($TABINDEX && $tabindex) {
2393 if (!ref $tabindex) {
2394 $self->element_tab($tabindex);
2395 } elsif (ref $tabindex eq 'ARRAY') {
2396 %tabs = map {$_=>$self->element_tab} @$tabindex;
2397 } elsif (ref $tabindex eq 'HASH') {
2398 %tabs = %$tabindex;
2399 }
2400 }
2401 %tabs = map {$_=>$self->element_tab} @values unless %tabs;
2402 my $other = @other ? "@other " : '';
2403 my $radio_checked;
2404
2405 # for disabling groups of radio/checkbox buttons
2406 my %disabled;
2407 for (@{$disabled}) {
2408 $disabled{$_}=1;
2409 }
2410
2411 for (@values) {
2412 my $disable="";
2413 if ($disabled{$_}) {
2414 $disable="disabled='1'";
2415 }
2416
2417 my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
2418 : $checked{$_});
2419 my($break);
2420 if ($linebreak) {
2421 $break = $XHTML ? "<br />" : "<br>";
2422 }
2423 else {
2424 $break = '';
2425 }
2426 my($label)='';
2427 unless (defined($nolabels) && $nolabels) {
2428 $label = $_;
2429 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2430 $label = $self->escapeHTML($label,1);
2431 $label = "<span style=\"color:gray\">$label</span>" if $disabled{$_};
2432 }
2433 my $attribs = $self->_set_attributes($_, $attributes);
2434 my $tab = $tabs{$_};
2435 $_=$self->escapeHTML($_);
2436
2437 if ($XHTML) {
2438 push @elements,
2439 CGI::label($labelattributes,
2440 qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break};
2441 } else {
2442 push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs$disable>${label}${break}/);
2443 }
2444 }
2445 $self->register_parameter($name);
2446 return wantarray ? @elements : "@elements"
2447 unless defined($columns) || defined($rows);
2448 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
2449}
2450END_OF_FUNC
2451
2452
2453#### Method: popup_menu
2454# Create a popup menu.
2455# Parameters:
2456# $name -> Name for all the menu
2457# $values -> A pointer to a regular array containing the
2458# text of each menu item.
2459# $default -> (optional) Default item to display
2460# $labels -> (optional)
2461# A pointer to a hash of labels to print next to each checkbox
2462# in the form $label{'value'}="Long explanatory label".
2463# Otherwise the provided values are used as the labels.
2464# Returns:
2465# A string containing the definition of a popup menu.
2466####
2467'popup_menu' => <<'END_OF_FUNC',
2468sub popup_menu {
2469 my($self,@p) = self_or_default(@_);
2470
2471 my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) =
2472 rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
2473 ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
2474 my($result,%selected);
2475
2476 if (!$override && defined($self->param($name))) {
2477 $selected{$self->param($name)}++;
2478 } elsif (defined $default) {
2479 %selected = map {$_=>1} ref($default) eq 'ARRAY'
2480 ? @$default
2481 : $default;
2482 }
2483 $name=$self->escapeHTML($name);
2484 my($other) = @other ? " @other" : '';
2485
2486 my(@values);
2487 @values = $self->_set_values_and_labels($values,\$labels,$name);
2488 $tabindex = $self->element_tab($tabindex);
2489 $result = qq/<select name="$name" $tabindex$other>\n/;
2490 for (@values) {
2491 if (/<optgroup/) {
2492 for my $v (split(/\n/)) {
2493 my $selectit = $XHTML ? 'selected="selected"' : 'selected';
2494 for my $selected (keys %selected) {
2495 $v =~ s/(value="$selected")/$selectit $1/;
2496 }
2497 $result .= "$v\n";
2498 }
2499 }
2500 else {
2501 my $attribs = $self->_set_attributes($_, $attributes);
2502 my($selectit) = $self->_selected($selected{$_});
2503 my($label) = $_;
2504 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2505 my($value) = $self->escapeHTML($_);
2506 $label = $self->escapeHTML($label,1);
2507 $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
2508 }
2509 }
2510
2511 $result .= "</select>";
2512 return $result;
2513}
2514END_OF_FUNC
2515
2516
2517#### Method: optgroup
2518# Create a optgroup.
2519# Parameters:
2520# $name -> Label for the group
2521# $values -> A pointer to a regular array containing the
2522# values for each option line in the group.
2523# $labels -> (optional)
2524# A pointer to a hash of labels to print next to each item
2525# in the form $label{'value'}="Long explanatory label".
2526# Otherwise the provided values are used as the labels.
2527# $labeled -> (optional)
2528# A true value indicates the value should be used as the label attribute
2529# in the option elements.
2530# The label attribute specifies the option label presented to the user.
2531# This defaults to the content of the <option> element, but the label
2532# attribute allows authors to more easily use optgroup without sacrificing
2533# compatibility with browsers that do not support option groups.
2534# $novals -> (optional)
2535# A true value indicates to suppress the val attribute in the option elements
2536# Returns:
2537# A string containing the definition of an option group.
2538####
2539'optgroup' => <<'END_OF_FUNC',
2540sub optgroup {
2541 my($self,@p) = self_or_default(@_);
2542 my($name,$values,$attributes,$labeled,$noval,$labels,@other)
2543 = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p);
2544
2545 my($result,@values);
2546 @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
2547 my($other) = @other ? " @other" : '';
2548
2549 $name=$self->escapeHTML($name);
2550 $result = qq/<optgroup label="$name"$other>\n/;
2551 for (@values) {
2552 if (/<optgroup/) {
2553 for (split(/\n/)) {
2554 my $selectit = $XHTML ? 'selected="selected"' : 'selected';
2555 s/(value="$selected")/$selectit $1/ if defined $selected;
2556 $result .= "$_\n";
2557 }
2558 }
2559 else {
2560 my $attribs = $self->_set_attributes($_, $attributes);
2561 my($label) = $_;
2562 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2563 $label=$self->escapeHTML($label);
2564 my($value)=$self->escapeHTML($_,1);
2565 $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
2566 : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
2567 : $novals ? "<option$attribs>$label</option>\n"
2568 : "<option$attribs value=\"$value\">$label</option>\n";
2569 }
2570 }
2571 $result .= "</optgroup>";
2572 return $result;
2573}
2574END_OF_FUNC
2575
2576
2577#### Method: scrolling_list
2578# Create a scrolling list.
2579# Parameters:
2580# $name -> name for the list
2581# $values -> A pointer to a regular array containing the
2582# values for each option line in the list.
2583# $defaults -> (optional)
2584# 1. If a pointer to a regular array of options,
2585# then this will be used to decide which
2586# lines to turn on by default.
2587# 2. Otherwise holds the value of the single line to turn on.
2588# $size -> (optional) Size of the list.
2589# $multiple -> (optional) If set, allow multiple selections.
2590# $labels -> (optional)
2591# A pointer to a hash of labels to print next to each checkbox
2592# in the form $label{'value'}="Long explanatory label".
2593# Otherwise the provided values are used as the labels.
2594# Returns:
2595# A string containing the definition of a scrolling list.
2596####
2597'scrolling_list' => <<'END_OF_FUNC',
2598sub scrolling_list {
2599 my($self,@p) = self_or_default(@_);
2600 my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other)
2601 = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
2602 SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
2603
2604 my($result,@values);
2605 @values = $self->_set_values_and_labels($values,\$labels,$name);
2606
2607 $size = $size || scalar(@values);
2608
2609 my(%selected) = $self->previous_or_default($name,$defaults,$override);
2610
2611 my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
2612 my($has_size) = $size ? qq/ size="$size"/: '';
2613 my($other) = @other ? " @other" : '';
2614
2615 $name=$self->escapeHTML($name);
2616 $tabindex = $self->element_tab($tabindex);
2617 $result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/;
2618 for (@values) {
2619 my($selectit) = $self->_selected($selected{$_});
2620 my($label) = $_;
2621 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2622 $label=$self->escapeHTML($label);
2623 my($value)=$self->escapeHTML($_,1);
2624 my $attribs = $self->_set_attributes($_, $attributes);
2625 $result .= "<option ${selectit}${attribs}value=\"$value\">$label</option>\n";
2626 }
2627 $result .= "</select>";
2628 $self->register_parameter($name);
2629 return $result;
2630}
2631END_OF_FUNC
2632
2633
2634#### Method: hidden
2635# Parameters:
2636# $name -> Name of the hidden field
2637# @default -> (optional) Initial values of field (may be an array)
2638# or
2639# $default->[initial values of field]
2640# Returns:
2641# A string containing a <input type="hidden" name="name" value="value">
2642####
2643'hidden' => <<'END_OF_FUNC',
2644sub hidden {
2645 my($self,@p) = self_or_default(@_);
2646
2647 # this is the one place where we departed from our standard
2648 # calling scheme, so we have to special-case (darn)
2649 my(@result,@value);
2650 my($name,$default,$override,@other) =
2651 rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
2652
2653 my $do_override = 0;
2654 if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
2655 @value = ref($default) ? @{$default} : $default;
2656 $do_override = $override;
2657 } else {
2658 for ($default,$override,@other) {
2659 push(@value,$_) if defined($_);
2660 }
2661 }
2662
2663 # use previous values if override is not set
2664 my @prev = $self->param($name);
2665 @value = @prev if !$do_override && @prev;
2666
2667 $name=$self->escapeHTML($name);
2668 for (@value) {
2669 $_ = defined($_) ? $self->escapeHTML($_,1) : '';
2670 push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
2671 : qq(<input type="hidden" name="$name" value="$_" @other>);
2672 }
2673 return wantarray ? @result : join('',@result);
2674}
2675END_OF_FUNC
2676
2677
2678#### Method: image_button
2679# Parameters:
2680# $name -> Name of the button
2681# $src -> URL of the image source
2682# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
2683# Returns:
2684# A string containing a <input type="image" name="name" src="url" align="alignment">
2685####
2686'image_button' => <<'END_OF_FUNC',
2687sub image_button {
2688 my($self,@p) = self_or_default(@_);
2689
2690 my($name,$src,$alignment,@other) =
2691 rearrange([NAME,SRC,ALIGN],@p);
2692
2693 my($align) = $alignment ? " align=\L\"$alignment\"" : '';
2694 my($other) = @other ? " @other" : '';
2695 $name=$self->escapeHTML($name);
2696 return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
2697 : qq/<input type="image" name="$name" src="$src"$align$other>/;
2698}
2699END_OF_FUNC
2700
2701
2702#### Method: self_url
2703# Returns a URL containing the current script and all its
2704# param/value pairs arranged as a query. You can use this
2705# to create a link that, when selected, will reinvoke the
2706# script with all its state information preserved.
2707####
2708'self_url' => <<'END_OF_FUNC',
2709sub self_url {
2710 my($self,@p) = self_or_default(@_);
2711 return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
2712}
2713END_OF_FUNC
2714
2715
2716# This is provided as a synonym to self_url() for people unfortunate
2717# enough to have incorporated it into their programs already!
2718'state' => <<'END_OF_FUNC',
2719sub state {
2720 &self_url;
2721}
2722END_OF_FUNC
2723
2724
2725#### Method: url
2726# Like self_url, but doesn't return the query string part of
2727# the URL.
2728####
2729'url' => <<'END_OF_FUNC',
2730sub url {
2731 my($self,@p) = self_or_default(@_);
2732 my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) =
2733 rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p);
2734 my $url = '';
2735 $full++ if $base || !($relative || $absolute);
2736 $rewrite++ unless defined $rewrite;
2737
2738 my $path = $self->path_info;
2739 my $script_name = $self->script_name;
2740 my $request_uri = unescape($self->request_uri) || '';
2741 my $query_str = $self->query_string;
2742
2743 my $rewrite_in_use = $request_uri && $request_uri !~ /^\Q$script_name/;
2744 undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active
2745
2746 my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
2747 $uri =~ s/\?.*$//s; # remove query string
2748 $uri =~ s/\Q$ENV{PATH_INFO}\E$// if defined $ENV{PATH_INFO};
2749# $uri =~ s/\Q$path\E$// if defined $path; # remove path
2750
2751 if ($full) {
2752 my $protocol = $self->protocol();
2753 $url = "$protocol://";
2754 my $vh = http('x_forwarded_host') || http('host') || '';
2755 $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
2756 if ($vh) {
2757 $url .= $vh;
2758 } else {
2759 $url .= server_name();
2760 }
2761 my $port = $self->server_port;
2762 $url .= ":" . $port
2763 unless (lc($protocol) eq 'http' && $port == 80)
2764 || (lc($protocol) eq 'https' && $port == 443);
2765 return $url if $base;
2766 $url .= $uri;
2767 } elsif ($relative) {
2768 ($url) = $uri =~ m!([^/]+)$!;
2769 } elsif ($absolute) {
2770 $url = $uri;
2771 }
2772
2773 $url .= $path if $path_info and defined $path;
2774 $url .= "?$query_str" if $query and $query_str ne '';
2775 $url ||= '';
2776 $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
2777 return $url;
2778}
2779
2780END_OF_FUNC
2781
2782#### Method: cookie
2783# Set or read a cookie from the specified name.
2784# Cookie can then be passed to header().
2785# Usual rules apply to the stickiness of -value.
2786# Parameters:
2787# -name -> name for this cookie (optional)
2788# -value -> value of this cookie (scalar, array or hash)
2789# -path -> paths for which this cookie is valid (optional)
2790# -domain -> internet domain in which this cookie is valid (optional)
2791# -secure -> if true, cookie only passed through secure channel (optional)
2792# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
2793####
2794'cookie' => <<'END_OF_FUNC',
2795sub cookie {
2796 my($self,@p) = self_or_default(@_);
2797 my($name,$value,$path,$domain,$secure,$expires,$httponly) =
2798 rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p);
2799
2800 require CGI::Cookie;
2801
2802 # if no value is supplied, then we retrieve the
2803 # value of the cookie, if any. For efficiency, we cache the parsed
2804 # cookies in our state variables.
2805 unless ( defined($value) ) {
2806 $self->{'.cookies'} = CGI::Cookie->fetch
2807 unless $self->{'.cookies'};
2808
2809 # If no name is supplied, then retrieve the names of all our cookies.
2810 return () unless $self->{'.cookies'};
2811 return keys %{$self->{'.cookies'}} unless $name;
2812 return () unless $self->{'.cookies'}->{$name};
2813 return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
2814 }
2815
2816 # If we get here, we're creating a new cookie
2817 return undef unless defined($name) && $name ne ''; # this is an error
2818
2819 my @param;
2820 push(@param,'-name'=>$name);
2821 push(@param,'-value'=>$value);
2822 push(@param,'-domain'=>$domain) if $domain;
2823 push(@param,'-path'=>$path) if $path;
2824 push(@param,'-expires'=>$expires) if $expires;
2825 push(@param,'-secure'=>$secure) if $secure;
2826 push(@param,'-httponly'=>$httponly) if $httponly;
2827
2828 return new CGI::Cookie(@param);
2829}
2830END_OF_FUNC
2831
2832'parse_keywordlist' => <<'END_OF_FUNC',
2833sub parse_keywordlist {
2834 my($self,$tosplit) = @_;
2835 $tosplit = unescape($tosplit); # unescape the keywords
2836 $tosplit=~tr/+/ /; # pluses to spaces
2837 my(@keywords) = split(/\s+/,$tosplit);
2838 return @keywords;
2839}
2840END_OF_FUNC
2841
2842'param_fetch' => <<'END_OF_FUNC',
2843sub param_fetch {
2844 my($self,@p) = self_or_default(@_);
2845 my($name) = rearrange([NAME],@p);
2846 unless (exists($self->{param}{$name})) {
2847 $self->add_parameter($name);
2848 $self->{param}{$name} = [];
2849 }
2850
2851 return $self->{param}{$name};
2852}
2853END_OF_FUNC
2854
2855###############################################
2856# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
2857###############################################
2858
2859#### Method: path_info
2860# Return the extra virtual path information provided
2861# after the URL (if any)
2862####
2863'path_info' => <<'END_OF_FUNC',
2864sub path_info {
2865 my ($self,$info) = self_or_default(@_);
2866 if (defined($info)) {
2867 $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
2868 $self->{'.path_info'} = $info;
2869 } elsif (! defined($self->{'.path_info'}) ) {
2870 my (undef,$path_info) = $self->_name_and_path_from_env;
2871 $self->{'.path_info'} = $path_info || '';
2872 }
2873 return $self->{'.path_info'};
2874}
2875END_OF_FUNC
2876
2877# This function returns a potentially modified version of SCRIPT_NAME
2878# and PATH_INFO. Some HTTP servers do sanitise the paths in those
2879# variables. It is the case of at least Apache 2. If for instance the
2880# user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set:
2881# REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y
2882# SCRIPT_NAME=/path/to/env.cgi
2883# PATH_INFO=/x/y/x
2884#
2885# This is all fine except that some bogus CGI scripts expect
2886# PATH_INFO=/http://foo when the user requests
2887# http://xxx/script.cgi/http://foo
2888#
2889# Old versions of this module used to accomodate with those scripts, so
2890# this is why we do this here to keep those scripts backward compatible.
2891# Basically, we accomodate with those scripts but within limits, that is
2892# we only try to preserve the number of / that were provided by the user
2893# if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number
2894# of consecutive /.
2895#
2896# So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a
2897# script_name of /x//y/script.cgi and a path_info of /a//b, but in:
2898# http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions
2899# possibly sanitised by the HTTP server, so in the case of Apache 2:
2900# script_name == /foo/x/z/script.cgi and path_info == /b/c.
2901#
2902# Future versions of this module may no longer do that, so one should
2903# avoid relying on the browser, proxy, server, and CGI.pm preserving the
2904# number of consecutive slashes as no guarantee can be made there.
2905'_name_and_path_from_env' => <<'END_OF_FUNC',
2906sub _name_and_path_from_env {
2907 my $self = shift;
2908 my $script_name = $ENV{SCRIPT_NAME} || '';
2909 my $path_info = $ENV{PATH_INFO} || '';
2910 my $uri = $self->request_uri || '';
2911
2912 $uri =~ s/\?.*//s;
2913 $uri = unescape($uri);
2914
2915 if ($uri ne "$script_name$path_info") {
2916 my $script_name_pattern = quotemeta($script_name);
2917 my $path_info_pattern = quotemeta($path_info);
2918 $script_name_pattern =~ s{(?:\\/)+}{/+}g;
2919 $path_info_pattern =~ s{(?:\\/)+}{/+}g;
2920
2921 if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) {
2922 # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the
2923 # numer of consecutive slashes, so we can extract the info from
2924 # REQUEST_URI:
2925 ($script_name, $path_info) = ($1, $2);
2926 }
2927 }
2928 return ($script_name,$path_info);
2929}
2930END_OF_FUNC
2931
2932
2933#### Method: request_method
2934# Returns 'POST', 'GET', 'PUT' or 'HEAD'
2935####
2936'request_method' => <<'END_OF_FUNC',
2937sub request_method {
2938 return $ENV{'REQUEST_METHOD'};
2939}
2940END_OF_FUNC
2941
2942#### Method: content_type
2943# Returns the content_type string
2944####
2945'content_type' => <<'END_OF_FUNC',
2946sub content_type {
2947 return $ENV{'CONTENT_TYPE'};
2948}
2949END_OF_FUNC
2950
2951#### Method: path_translated
2952# Return the physical path information provided
2953# by the URL (if any)
2954####
2955'path_translated' => <<'END_OF_FUNC',
2956sub path_translated {
2957 return $ENV{'PATH_TRANSLATED'};
2958}
2959END_OF_FUNC
2960
2961
2962#### Method: request_uri
2963# Return the literal request URI
2964####
2965'request_uri' => <<'END_OF_FUNC',
2966sub request_uri {
2967 return $ENV{'REQUEST_URI'};
2968}
2969END_OF_FUNC
2970
2971
2972#### Method: query_string
2973# Synthesize a query string from our current
2974# parameters
2975####
2976'query_string' => <<'END_OF_FUNC',
2977sub query_string {
2978 my($self) = self_or_default(@_);
2979 my($param,$value,@pairs);
2980 for $param ($self->param) {
2981 my($eparam) = escape($param);
2982 for $value ($self->param($param)) {
2983 $value = escape($value);
2984 next unless defined $value;
2985 push(@pairs,"$eparam=$value");
2986 }
2987 }
2988 for (keys %{$self->{'.fieldnames'}}) {
2989 push(@pairs,".cgifields=".escape("$_"));
2990 }
2991 return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
2992}
2993END_OF_FUNC
2994
2995
2996#### Method: accept
2997# Without parameters, returns an array of the
2998# MIME types the browser accepts.
2999# With a single parameter equal to a MIME
3000# type, will return undef if the browser won't
3001# accept it, 1 if the browser accepts it but
3002# doesn't give a preference, or a floating point
3003# value between 0.0 and 1.0 if the browser
3004# declares a quantitative score for it.
3005# This handles MIME type globs correctly.
3006####
3007'Accept' => <<'END_OF_FUNC',
3008sub Accept {
3009 my($self,$search) = self_or_CGI(@_);
3010 my(%prefs,$type,$pref,$pat);
3011
3012 my(@accept) = defined $self->http('accept')
3013 ? split(',',$self->http('accept'))
3014 : ();
3015
3016 for (@accept) {
3017 ($pref) = /q=(\d\.\d+|\d+)/;
3018 ($type) = m#(\S+/[^;]+)#;
3019 next unless $type;
3020 $prefs{$type}=$pref || 1;
3021 }
3022
3023 return keys %prefs unless $search;
3024
3025 # if a search type is provided, we may need to
3026 # perform a pattern matching operation.
3027 # The MIME types use a glob mechanism, which
3028 # is easily translated into a perl pattern match
3029
3030 # First return the preference for directly supported
3031 # types:
3032 return $prefs{$search} if $prefs{$search};
3033
3034 # Didn't get it, so try pattern matching.
3035 for (keys %prefs) {
3036 next unless /\*/; # not a pattern match
3037 ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
3038 $pat =~ s/\*/.*/g; # turn it into a pattern
3039 return $prefs{$_} if $search=~/$pat/;
3040 }
3041}
3042END_OF_FUNC
3043
3044
3045#### Method: user_agent
3046# If called with no parameters, returns the user agent.
3047# If called with one parameter, does a pattern match (case
3048# insensitive) on the user agent.
3049####
3050'user_agent' => <<'END_OF_FUNC',
3051sub user_agent {
3052 my($self,$match)=self_or_CGI(@_);
3053 return $self->http('user_agent') unless $match;
3054 return $self->http('user_agent') =~ /$match/i;
3055}
3056END_OF_FUNC
3057
3058
3059#### Method: raw_cookie
3060# Returns the magic cookies for the session.
3061# The cookies are not parsed or altered in any way, i.e.
3062# cookies are returned exactly as given in the HTTP
3063# headers. If a cookie name is given, only that cookie's
3064# value is returned, otherwise the entire raw cookie
3065# is returned.
3066####
3067'raw_cookie' => <<'END_OF_FUNC',
3068sub raw_cookie {
3069 my($self,$key) = self_or_CGI(@_);
3070
3071 require CGI::Cookie;
3072
3073 if (defined($key)) {
3074 $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
3075 unless $self->{'.raw_cookies'};
3076
3077 return () unless $self->{'.raw_cookies'};
3078 return () unless $self->{'.raw_cookies'}->{$key};
3079 return $self->{'.raw_cookies'}->{$key};
3080 }
3081 return $self->http('cookie') || $ENV{'COOKIE'} || '';
3082}
3083END_OF_FUNC
3084
3085#### Method: virtual_host
3086# Return the name of the virtual_host, which
3087# is not always the same as the server
3088######
3089'virtual_host' => <<'END_OF_FUNC',
3090sub virtual_host {
3091 my $vh = http('x_forwarded_host') || http('host') || server_name();
3092 $vh =~ s/:\d+$//; # get rid of port number
3093 return $vh;
3094}
3095END_OF_FUNC
3096
3097#### Method: remote_host
3098# Return the name of the remote host, or its IP
3099# address if unavailable. If this variable isn't
3100# defined, it returns "localhost" for debugging
3101# purposes.
3102####
3103'remote_host' => <<'END_OF_FUNC',
3104sub remote_host {
3105 return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
3106 || 'localhost';
3107}
3108END_OF_FUNC
3109
3110
3111#### Method: remote_addr
3112# Return the IP addr of the remote host.
3113####
3114'remote_addr' => <<'END_OF_FUNC',
3115sub remote_addr {
3116 return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
3117}
3118END_OF_FUNC
3119
3120
3121#### Method: script_name
3122# Return the partial URL to this script for
3123# self-referencing scripts. Also see
3124# self_url(), which returns a URL with all state information
3125# preserved.
3126####
3127'script_name' => <<'END_OF_FUNC',
3128sub script_name {
3129 my ($self,@p) = self_or_default(@_);
3130 if (@p) {
3131 $self->{'.script_name'} = shift @p;
3132 } elsif (!exists $self->{'.script_name'}) {
3133 my ($script_name,$path_info) = $self->_name_and_path_from_env();
3134 $self->{'.script_name'} = $script_name;
3135 }
3136 return $self->{'.script_name'};
3137}
3138END_OF_FUNC
3139
3140
3141#### Method: referer
3142# Return the HTTP_REFERER: useful for generating
3143# a GO BACK button.
3144####
3145'referer' => <<'END_OF_FUNC',
3146sub referer {
3147 my($self) = self_or_CGI(@_);
3148 return $self->http('referer');
3149}
3150END_OF_FUNC
3151
3152
3153#### Method: server_name
3154# Return the name of the server
3155####
3156'server_name' => <<'END_OF_FUNC',
3157sub server_name {
3158 return $ENV{'SERVER_NAME'} || 'localhost';
3159}
3160END_OF_FUNC
3161
3162#### Method: server_software
3163# Return the name of the server software
3164####
3165'server_software' => <<'END_OF_FUNC',
3166sub server_software {
3167 return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
3168}
3169END_OF_FUNC
3170
3171#### Method: virtual_port
3172# Return the server port, taking virtual hosts into account
3173####
3174'virtual_port' => <<'END_OF_FUNC',
3175sub virtual_port {
3176 my($self) = self_or_default(@_);
3177 my $vh = $self->http('x_forwarded_host') || $self->http('host');
3178 my $protocol = $self->protocol;
3179 if ($vh) {
3180 return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80);
3181 } else {
3182 return $self->server_port();
3183 }
3184}
3185END_OF_FUNC
3186
3187#### Method: server_port
3188# Return the tcp/ip port the server is running on
3189####
3190'server_port' => <<'END_OF_FUNC',
3191sub server_port {
3192 return $ENV{'SERVER_PORT'} || 80; # for debugging
3193}
3194END_OF_FUNC
3195
3196#### Method: server_protocol
3197# Return the protocol (usually HTTP/1.0)
3198####
3199'server_protocol' => <<'END_OF_FUNC',
3200sub server_protocol {
3201 return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
3202}
3203END_OF_FUNC
3204
3205#### Method: http
3206# Return the value of an HTTP variable, or
3207# the list of variables if none provided
3208####
3209'http' => <<'END_OF_FUNC',
3210sub http {
3211 my ($self,$parameter) = self_or_CGI(@_);
3212 return $ENV{$parameter} if $parameter=~/^HTTP/;
3213 $parameter =~ tr/-/_/;
3214 return $ENV{"HTTP_\U$parameter\E"} if $parameter;
3215 my(@p);
3216 for (keys %ENV) {
3217 push(@p,$_) if /^HTTP/;
3218 }
3219 return @p;
3220}
3221END_OF_FUNC
3222
3223#### Method: https
3224# Return the value of HTTPS
3225####
3226'https' => <<'END_OF_FUNC',
3227sub https {
3228 local($^W)=0;
3229 my ($self,$parameter) = self_or_CGI(@_);
3230 return $ENV{HTTPS} unless $parameter;
3231 return $ENV{$parameter} if $parameter=~/^HTTPS/;
3232 $parameter =~ tr/-/_/;
3233 return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
3234 my(@p);
3235 for (keys %ENV) {
3236 push(@p,$_) if /^HTTPS/;
3237 }
3238 return @p;
3239}
3240END_OF_FUNC
3241
3242#### Method: protocol
3243# Return the protocol (http or https currently)
3244####
3245'protocol' => <<'END_OF_FUNC',
3246sub protocol {
3247 local($^W)=0;
3248 my $self = shift;
3249 return 'https' if uc($self->https()) eq 'ON';
3250 return 'https' if $self->server_port == 443;
3251 my $prot = $self->server_protocol;
3252 my($protocol,$version) = split('/',$prot);
3253 return "\L$protocol\E";
3254}
3255END_OF_FUNC
3256
3257#### Method: remote_ident
3258# Return the identity of the remote user
3259# (but only if his host is running identd)
3260####
3261'remote_ident' => <<'END_OF_FUNC',
3262sub remote_ident {
3263 return $ENV{'REMOTE_IDENT'};
3264}
3265END_OF_FUNC
3266
3267
3268#### Method: auth_type
3269# Return the type of use verification/authorization in use, if any.
3270####
3271'auth_type' => <<'END_OF_FUNC',
3272sub auth_type {
3273 return $ENV{'AUTH_TYPE'};
3274}
3275END_OF_FUNC
3276
3277
3278#### Method: remote_user
3279# Return the authorization name used for user
3280# verification.
3281####
3282'remote_user' => <<'END_OF_FUNC',
3283sub remote_user {
3284 return $ENV{'REMOTE_USER'};
3285}
3286END_OF_FUNC
3287
3288
3289#### Method: user_name
3290# Try to return the remote user's name by hook or by
3291# crook
3292####
3293'user_name' => <<'END_OF_FUNC',
3294sub user_name {
3295 my ($self) = self_or_CGI(@_);
3296 return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
3297}
3298END_OF_FUNC
3299
3300#### Method: nosticky
3301# Set or return the NOSTICKY global flag
3302####
3303'nosticky' => <<'END_OF_FUNC',
3304sub nosticky {
3305 my ($self,$param) = self_or_CGI(@_);
3306 $CGI::NOSTICKY = $param if defined($param);
3307 return $CGI::NOSTICKY;
3308}
3309END_OF_FUNC
3310
3311#### Method: nph
3312# Set or return the NPH global flag
3313####
3314'nph' => <<'END_OF_FUNC',
3315sub nph {
3316 my ($self,$param) = self_or_CGI(@_);
3317 $CGI::NPH = $param if defined($param);
3318 return $CGI::NPH;
3319}
3320END_OF_FUNC
3321
3322#### Method: private_tempfiles
3323# Set or return the private_tempfiles global flag
3324####
3325'private_tempfiles' => <<'END_OF_FUNC',
3326sub private_tempfiles {
3327 my ($self,$param) = self_or_CGI(@_);
3328 $CGI::PRIVATE_TEMPFILES = $param if defined($param);
3329 return $CGI::PRIVATE_TEMPFILES;
3330}
3331END_OF_FUNC
3332#### Method: close_upload_files
3333# Set or return the close_upload_files global flag
3334####
3335'close_upload_files' => <<'END_OF_FUNC',
3336sub close_upload_files {
3337 my ($self,$param) = self_or_CGI(@_);
3338 $CGI::CLOSE_UPLOAD_FILES = $param if defined($param);
3339 return $CGI::CLOSE_UPLOAD_FILES;
3340}
3341END_OF_FUNC
3342
3343
3344#### Method: default_dtd
3345# Set or return the default_dtd global
3346####
3347'default_dtd' => <<'END_OF_FUNC',
3348sub default_dtd {
3349 my ($self,$param,$param2) = self_or_CGI(@_);
3350 if (defined $param2 && defined $param) {
3351 $CGI::DEFAULT_DTD = [ $param, $param2 ];
3352 } elsif (defined $param) {
3353 $CGI::DEFAULT_DTD = $param;
3354 }
3355 return $CGI::DEFAULT_DTD;
3356}
3357END_OF_FUNC
3358
3359# -------------- really private subroutines -----------------
3360'previous_or_default' => <<'END_OF_FUNC',
3361sub previous_or_default {
3362 my($self,$name,$defaults,$override) = @_;
3363 my(%selected);
3364
3365 if (!$override && ($self->{'.fieldnames'}->{$name} ||
3366 defined($self->param($name)) ) ) {
3367 $selected{$_}++ for $self->param($name);
3368 } elsif (defined($defaults) && ref($defaults) &&
3369 (ref($defaults) eq 'ARRAY')) {
3370 $selected{$_}++ for @{$defaults};
3371 } else {
3372 $selected{$defaults}++ if defined($defaults);
3373 }
3374
3375 return %selected;
3376}
3377END_OF_FUNC
3378
3379'register_parameter' => <<'END_OF_FUNC',
3380sub register_parameter {
3381 my($self,$param) = @_;
3382 $self->{'.parametersToAdd'}->{$param}++;
3383}
3384END_OF_FUNC
3385
3386'get_fields' => <<'END_OF_FUNC',
3387sub get_fields {
3388 my($self) = @_;
3389 return $self->CGI::hidden('-name'=>'.cgifields',
3390 '-values'=>[keys %{$self->{'.parametersToAdd'}}],
3391 '-override'=>1);
3392}
3393END_OF_FUNC
3394
3395'read_from_cmdline' => <<'END_OF_FUNC',
3396sub read_from_cmdline {
3397 my($input,@words);
3398 my($query_string);
3399 my($subpath);
3400 if ($DEBUG && @ARGV) {
3401 @words = @ARGV;
3402 } elsif ($DEBUG > 1) {
3403 require "shellwords.pl";
3404 print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n";
3405 chomp(@lines = <STDIN>); # remove newlines
3406 $input = join(" ",@lines);
3407 @words = &shellwords($input);
3408 }
3409 for (@words) {
3410 s/\\=/%3D/g;
3411 s/\\&/%26/g;
3412 }
3413
3414 if ("@words"=~/=/) {
3415 $query_string = join('&',@words);
3416 } else {
3417 $query_string = join('+',@words);
3418 }
3419 if ($query_string =~ /^(.*?)\?(.*)$/)
3420 {
3421 $query_string = $2;
3422 $subpath = $1;
3423 }
3424 return { 'query_string' => $query_string, 'subpath' => $subpath };
3425}
3426END_OF_FUNC
3427
3428#####
3429# subroutine: read_multipart
3430#
3431# Read multipart data and store it into our parameters.
3432# An interesting feature is that if any of the parts is a file, we
3433# create a temporary file and open up a filehandle on it so that the
3434# caller can read from it if necessary.
3435#####
3436'read_multipart' => <<'END_OF_FUNC',
3437sub read_multipart {
3438 my($self,$boundary,$length) = @_;
3439 my($buffer) = $self->new_MultipartBuffer($boundary,$length);
3440 return unless $buffer;
3441 my(%header,$body);
3442 my $filenumber = 0;
3443 while (!$buffer->eof) {
3444 %header = $buffer->readHeader;
3445
3446 unless (%header) {
3447 $self->cgi_error("400 Bad request (malformed multipart POST)");
3448 return;
3449 }
3450
3451 $header{'Content-Disposition'} ||= ''; # quench uninit variable warning
3452
3453 my($param)= $header{'Content-Disposition'}=~/ name="([^"]*)"/;
3454 $param .= $TAINTED;
3455
3456 # See RFC 1867, 2183, 2045
3457 # NB: File content will be loaded into memory should
3458 # content-disposition parsing fail.
3459 my ($filename) = $header{'Content-Disposition'}
3460 =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i;
3461
3462 $filename ||= ''; # quench uninit variable warning
3463
3464 $filename =~ s/^"([^"]*)"$/$1/;
3465 # Test for Opera's multiple upload feature
3466 my($multipart) = ( defined( $header{'Content-Type'} ) &&
3467 $header{'Content-Type'} =~ /multipart\/mixed/ ) ?
3468 1 : 0;
3469
3470 # add this parameter to our list
3471 $self->add_parameter($param);
3472
3473 # If no filename specified, then just read the data and assign it
3474 # to our parameter list.
3475 if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
3476 my($value) = $buffer->readBody;
3477 $value .= $TAINTED;
3478 push(@{$self->{param}{$param}},$value);
3479 next;
3480 }
3481
3482 my ($tmpfile,$tmp,$filehandle);
3483 UPLOADS: {
3484 # If we get here, then we are dealing with a potentially large
3485 # uploaded form. Save the data to a temporary file, then open
3486 # the file for reading.
3487
3488 # skip the file if uploads disabled
3489 if ($DISABLE_UPLOADS) {
3490 while (defined($data = $buffer->read)) { }
3491 last UPLOADS;
3492 }
3493
3494 # set the filename to some recognizable value
3495 if ( ( !defined($filename) || $filename eq '' ) && $multipart ) {
3496 $filename = "multipart/mixed";
3497 }
3498
3499 # choose a relatively unpredictable tmpfile sequence number
3500 my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
3501 for (my $cnt=10;$cnt>0;$cnt--) {
3502 next unless $tmpfile = new CGITempFile($seqno);
3503 $tmp = $tmpfile->as_string;
3504 last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
3505 $seqno += int rand(100);
3506 }
3507 die "CGI open of tmpfile: $!\n" unless defined $filehandle;
3508 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
3509 && defined fileno($filehandle);
3510
3511 # if this is an multipart/mixed attachment, save the header
3512 # together with the body for later parsing with an external
3513 # MIME parser module
3514 if ( $multipart ) {
3515 for ( keys %header ) {
3516 print $filehandle "$_: $header{$_}${CRLF}";
3517 }
3518 print $filehandle "${CRLF}";
3519 }
3520
3521 my ($data);
3522 local($\) = '';
3523 my $totalbytes = 0;
3524 while (defined($data = $buffer->read)) {
3525 if (defined $self->{'.upload_hook'})
3526 {
3527 $totalbytes += length($data);
3528 &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
3529 }
3530 print $filehandle $data if ($self->{'use_tempfile'});
3531 }
3532
3533 # back up to beginning of file
3534 seek($filehandle,0,0);
3535
3536 ## Close the filehandle if requested this allows a multipart MIME
3537 ## upload to contain many files, and we won't die due to too many
3538 ## open file handles. The user can access the files using the hash
3539 ## below.
3540 close $filehandle if $CLOSE_UPLOAD_FILES;
3541 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
3542
3543 # Save some information about the uploaded file where we can get
3544 # at it later.
3545 # Use the typeglob as the key, as this is guaranteed to be
3546 # unique for each filehandle. Don't use the file descriptor as
3547 # this will be re-used for each filehandle if the
3548 # close_upload_files feature is used.
3549 $self->{'.tmpfiles'}->{$$filehandle}= {
3550 hndl => $filehandle,
3551 name => $tmpfile,
3552 info => {%header},
3553 };
3554 push(@{$self->{param}{$param}},$filehandle);
3555 }
3556 }
3557}
3558END_OF_FUNC
3559
3560#####
3561# subroutine: read_multipart_related
3562#
3563# Read multipart/related data and store it into our parameters. The
3564# first parameter sets the start of the data. The part identified by
3565# this Content-ID will not be stored as a file upload, but will be
3566# returned by this method. All other parts will be available as file
3567# uploads accessible by their Content-ID
3568#####
3569'read_multipart_related' => <<'END_OF_FUNC',
3570sub read_multipart_related {
3571 my($self,$start,$boundary,$length) = @_;
3572 my($buffer) = $self->new_MultipartBuffer($boundary,$length);
3573 return unless $buffer;
3574 my(%header,$body);
3575 my $filenumber = 0;
3576 my $returnvalue;
3577 while (!$buffer->eof) {
3578 %header = $buffer->readHeader;
3579
3580 unless (%header) {
3581 $self->cgi_error("400 Bad request (malformed multipart POST)");
3582 return;
3583 }
3584
3585 my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/;
3586 $param .= $TAINTED;
3587
3588 # If this is the start part, then just read the data and assign it
3589 # to our return variable.
3590 if ( $param eq $start ) {
3591 $returnvalue = $buffer->readBody;
3592 $returnvalue .= $TAINTED;
3593 next;
3594 }
3595
3596 # add this parameter to our list
3597 $self->add_parameter($param);
3598
3599 my ($tmpfile,$tmp,$filehandle);
3600 UPLOADS: {
3601 # If we get here, then we are dealing with a potentially large
3602 # uploaded form. Save the data to a temporary file, then open
3603 # the file for reading.
3604
3605 # skip the file if uploads disabled
3606 if ($DISABLE_UPLOADS) {
3607 while (defined($data = $buffer->read)) { }
3608 last UPLOADS;
3609 }
3610
3611 # choose a relatively unpredictable tmpfile sequence number
3612 my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
3613 for (my $cnt=10;$cnt>0;$cnt--) {
3614 next unless $tmpfile = new CGITempFile($seqno);
3615 $tmp = $tmpfile->as_string;
3616 last if defined($filehandle = Fh->new($param,$tmp,$PRIVATE_TEMPFILES));
3617 $seqno += int rand(100);
3618 }
3619 die "CGI open of tmpfile: $!\n" unless defined $filehandle;
3620 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
3621 && defined fileno($filehandle);
3622
3623 my ($data);
3624 local($\) = '';
3625 my $totalbytes;
3626 while (defined($data = $buffer->read)) {
3627 if (defined $self->{'.upload_hook'})
3628 {
3629 $totalbytes += length($data);
3630 &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'});
3631 }
3632 print $filehandle $data if ($self->{'use_tempfile'});
3633 }
3634
3635 # back up to beginning of file
3636 seek($filehandle,0,0);
3637
3638 ## Close the filehandle if requested this allows a multipart MIME
3639 ## upload to contain many files, and we won't die due to too many
3640 ## open file handles. The user can access the files using the hash
3641 ## below.
3642 close $filehandle if $CLOSE_UPLOAD_FILES;
3643 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
3644
3645 # Save some information about the uploaded file where we can get
3646 # at it later.
3647 # Use the typeglob as the key, as this is guaranteed to be
3648 # unique for each filehandle. Don't use the file descriptor as
3649 # this will be re-used for each filehandle if the
3650 # close_upload_files feature is used.
3651 $self->{'.tmpfiles'}->{$$filehandle}= {
3652 hndl => $filehandle,
3653 name => $tmpfile,
3654 info => {%header},
3655 };
3656 push(@{$self->{param}{$param}},$filehandle);
3657 }
3658 }
3659 return $returnvalue;
3660}
3661END_OF_FUNC
3662
3663
3664'upload' =><<'END_OF_FUNC',
3665sub upload {
3666 my($self,$param_name) = self_or_default(@_);
3667 my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name);
3668 return unless @param;
3669 return wantarray ? @param : $param[0];
3670}
3671END_OF_FUNC
3672
3673'tmpFileName' => <<'END_OF_FUNC',
3674sub tmpFileName {
3675 my($self,$filename) = self_or_default(@_);
3676 return $self->{'.tmpfiles'}->{$$filename}->{name} ?
3677 $self->{'.tmpfiles'}->{$$filename}->{name}->as_string
3678 : '';
3679}
3680END_OF_FUNC
3681
3682'uploadInfo' => <<'END_OF_FUNC',
3683sub uploadInfo {
3684 my($self,$filename) = self_or_default(@_);
3685 return $self->{'.tmpfiles'}->{$$filename}->{info};
3686}
3687END_OF_FUNC
3688
3689# internal routine, don't use
3690'_set_values_and_labels' => <<'END_OF_FUNC',
3691sub _set_values_and_labels {
3692 my $self = shift;
3693 my ($v,$l,$n) = @_;
3694 $$l = $v if ref($v) eq 'HASH' && !ref($$l);
3695 return $self->param($n) if !defined($v);
3696 return $v if !ref($v);
3697 return ref($v) eq 'HASH' ? keys %$v : @$v;
3698}
3699END_OF_FUNC
3700
3701# internal routine, don't use
3702'_set_attributes' => <<'END_OF_FUNC',
3703sub _set_attributes {
3704 my $self = shift;
3705 my($element, $attributes) = @_;
3706 return '' unless defined($attributes->{$element});
3707 $attribs = ' ';
3708 for my $attrib (keys %{$attributes->{$element}}) {
3709 (my $clean_attrib = $attrib) =~ s/^-//;
3710 $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" ";
3711 }
3712 $attribs =~ s/ $//;
3713 return $attribs;
3714}
3715END_OF_FUNC
3716
3717'_compile_all' => <<'END_OF_FUNC',
3718sub _compile_all {
3719 for (@_) {
3720 next if defined(&$_);
3721 $AUTOLOAD = "CGI::$_";
3722 _compile();
3723 }
3724}
3725END_OF_FUNC
3726
3727);
3728END_OF_AUTOLOAD
3729;
3730
3731#########################################################
3732# Globals and stubs for other packages that we use.
3733#########################################################
3734
3735################### Fh -- lightweight filehandle ###############
3736package Fh;
3737
3738use overload
3739129µs186µs
# spent 128µs (42+86) within Fh::BEGIN@3739 which was called: # once (42µs+86µs) by C4::Templates::BEGIN@6 at line 3741
'""' => \&asString,
# spent 86µs making 1 call to overload::import
3740 'cmp' => \&compare,
37412126µs1128µs 'fallback'=>1;
# spent 128µs making 1 call to Fh::BEGIN@3739
3742
37431800ns$FH='fh00000';
3744
374512µs*Fh::AUTOLOAD = \&CGI::AUTOLOAD;
3746
3747sub DESTROY {
3748 my $self = shift;
3749 close $self;
3750}
3751
37521500ns$AUTOLOADED_ROUTINES = ''; # prevent -w error
37531800ns$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3754%SUBS = (
3755'asString' => <<'END_OF_FUNC',
3756sub asString {
3757 my $self = shift;
3758 # get rid of package name
3759 (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
3760 $i =~ s/%(..)/ chr(hex($1)) /eg;
3761 return $i.$CGI::TAINTED;
3762# BEGIN DEAD CODE
3763# This was an extremely clever patch that allowed "use strict refs".
3764# Unfortunately it relied on another bug that caused leaky file descriptors.
3765# The underlying bug has been fixed, so this no longer works. However
3766# "strict refs" still works for some reason.
3767# my $self = shift;
3768# return ${*{$self}{SCALAR}};
3769# END DEAD CODE
3770}
3771END_OF_FUNC
3772
3773'compare' => <<'END_OF_FUNC',
3774sub compare {
3775 my $self = shift;
3776 my $value = shift;
3777 return "$self" cmp $value;
3778}
3779END_OF_FUNC
3780
3781'new' => <<'END_OF_FUNC',
3782sub new {
3783 my($pack,$name,$file,$delete) = @_;
3784 _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
3785 require Fcntl unless defined &Fcntl::O_RDWR;
3786 (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
3787 my $fv = ++$FH . $safename;
3788 my $ref = \*{"Fh::$fv"};
3789 $file =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\~-]+)$! || return;
3790 my $safe = $1;
3791 sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
3792 unlink($safe) if $delete;
3793 CORE::delete $Fh::{$fv};
3794 return bless $ref,$pack;
3795}
3796END_OF_FUNC
3797
3798'handle' => <<'END_OF_FUNC',
3799sub handle {
3800 my $self = shift;
3801 eval "require IO::Handle" unless IO::Handle->can('new_from_fd');
3802 return IO::Handle->new_from_fd(fileno $self,"<");
3803}
3804END_OF_FUNC
3805
3806);
3807END_OF_AUTOLOAD
3808
3809######################## MultipartBuffer ####################
3810package MultipartBuffer;
3811
38123783µs2146µs
# spent 80µs (14+66) within MultipartBuffer::BEGIN@3812 which was called: # once (14µs+66µs) by C4::Templates::BEGIN@6 at line 3812
use constant DEBUG => 0;
# spent 80µs making 1 call to MultipartBuffer::BEGIN@3812 # spent 66µs making 1 call to constant::import
3813
3814# how many bytes to read at a time. We use
3815# a 4K buffer by default.
38161300ns$INITIAL_FILLUNIT = 1024 * 4;
38171200ns$TIMEOUT = 240*60; # 4 hour timeout for big files
38181200ns$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
38191400ns$CRLF=$CGI::CRLF;
3820
3821#reuse the autoload function
38221600ns*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
3823
3824# avoid autoloader warnings
3825sub DESTROY {}
3826
3827###############################################################################
3828################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3829###############################################################################
38301300ns$AUTOLOADED_ROUTINES = ''; # prevent -w error
383115µs$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3832%SUBS = (
3833
3834'new' => <<'END_OF_FUNC',
3835sub new {
3836 my($package,$interface,$boundary,$length) = @_;
3837 $FILLUNIT = $INITIAL_FILLUNIT;
3838 $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always
3839
3840 # If the user types garbage into the file upload field,
3841 # then Netscape passes NOTHING to the server (not good).
3842 # We may hang on this read in that case. So we implement
3843 # a read timeout. If nothing is ready to read
3844 # by then, we return.
3845
3846 # Netscape seems to be a little bit unreliable
3847 # about providing boundary strings.
3848 my $boundary_read = 0;
3849 if ($boundary) {
3850
3851 # Under the MIME spec, the boundary consists of the
3852 # characters "--" PLUS the Boundary string
3853
3854 # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
3855 # the two extra hyphens. We do a special case here on the user-agent!!!!
3856 $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport');
3857
3858 } else { # otherwise we find it ourselves
3859 my($old);
3860 ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
3861 $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl
3862 $length -= length($boundary);
3863 chomp($boundary); # remove the CRLF
3864 $/ = $old; # restore old line separator
3865 $boundary_read++;
3866 }
3867
3868 my $self = {LENGTH=>$length,
3869 CHUNKED=>!$length,
3870 BOUNDARY=>$boundary,
3871 INTERFACE=>$interface,
3872 BUFFER=>'',
3873 };
3874
3875 $FILLUNIT = length($boundary)
3876 if length($boundary) > $FILLUNIT;
3877
3878 my $retval = bless $self,ref $package || $package;
3879
3880 # Read the preamble and the topmost (boundary) line plus the CRLF.
3881 unless ($boundary_read) {
3882 while ($self->read(0)) { }
3883 }
3884 die "Malformed multipart POST: data truncated\n" if $self->eof;
3885
3886 return $retval;
3887}
3888END_OF_FUNC
3889
3890'readHeader' => <<'END_OF_FUNC',
3891sub readHeader {
3892 my($self) = @_;
3893 my($end);
3894 my($ok) = 0;
3895 my($bad) = 0;
3896
3897 local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC;
3898
3899 do {
3900 $self->fillBuffer($FILLUNIT);
3901 $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
3902 $ok++ if $self->{BUFFER} eq '';
3903 $bad++ if !$ok && $self->{LENGTH} <= 0;
3904 # this was a bad idea
3905 # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
3906 } until $ok || $bad;
3907 return () if $bad;
3908
3909 #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines!
3910
3911 my($header) = substr($self->{BUFFER},0,$end+2);
3912 substr($self->{BUFFER},0,$end+4) = '';
3913 my %return;
3914
3915 if ($CGI::EBCDIC) {
3916 warn "untranslated header=$header\n" if DEBUG;
3917 $header = CGI::Util::ascii2ebcdic($header);
3918 warn "translated header=$header\n" if DEBUG;
3919 }
3920
3921 # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
3922 # (Folding Long Header Fields), 3.4.3 (Comments)
3923 # and 3.4.5 (Quoted-Strings).
3924
3925 my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
3926 $header=~s/$CRLF\s+/ /og; # merge continuation lines
3927
3928 while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
3929 my ($field_name,$field_value) = ($1,$2);
3930 $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
3931 $return{$field_name}=$field_value;
3932 }
3933 return %return;
3934}
3935END_OF_FUNC
3936
3937# This reads and returns the body as a single scalar value.
3938'readBody' => <<'END_OF_FUNC',
3939sub readBody {
3940 my($self) = @_;
3941 my($data);
3942 my($returnval)='';
3943
3944 #EBCDIC NOTE: want to translate returnval into EBCDIC HERE
3945
3946 while (defined($data = $self->read)) {
3947 $returnval .= $data;
3948 }
3949
3950 if ($CGI::EBCDIC) {
3951 warn "untranslated body=$returnval\n" if DEBUG;
3952 $returnval = CGI::Util::ascii2ebcdic($returnval);
3953 warn "translated body=$returnval\n" if DEBUG;
3954 }
3955 return $returnval;
3956}
3957END_OF_FUNC
3958
3959# This will read $bytes or until the boundary is hit, whichever happens
3960# first. After the boundary is hit, we return undef. The next read will
3961# skip over the boundary and begin reading again;
3962'read' => <<'END_OF_FUNC',
3963sub read {
3964 my($self,$bytes) = @_;
3965
3966 # default number of bytes to read
3967 $bytes = $bytes || $FILLUNIT;
3968
3969 # Fill up our internal buffer in such a way that the boundary
3970 # is never split between reads.
3971 $self->fillBuffer($bytes);
3972
3973 my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY};
3974 my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--';
3975
3976 # Find the boundary in the buffer (it may not be there).
3977 my $start = index($self->{BUFFER},$boundary_start);
3978
3979 warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG;
3980
3981 # protect against malformed multipart POST operations
3982 die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0);
3983
3984 #EBCDIC NOTE: want to translate boundary search into ASCII here.
3985
3986 # If the boundary begins the data, then skip past it
3987 # and return undef.
3988 if ($start == 0) {
3989
3990 # clear us out completely if we've hit the last boundary.
3991 if (index($self->{BUFFER},$boundary_end)==0) {
3992 $self->{BUFFER}='';
3993 $self->{LENGTH}=0;
3994 return undef;
3995 }
3996
3997 # just remove the boundary.
3998 substr($self->{BUFFER},0,length($boundary_start))='';
3999 $self->{BUFFER} =~ s/^\012\015?//;
4000 return undef;
4001 }
4002
4003 my $bytesToReturn;
4004 if ($start > 0) { # read up to the boundary
4005 $bytesToReturn = $start-2 > $bytes ? $bytes : $start;
4006 } else { # read the requested number of bytes
4007 # leave enough bytes in the buffer to allow us to read
4008 # the boundary. Thanks to Kevin Hendrick for finding
4009 # this one.
4010 $bytesToReturn = $bytes - (length($boundary_start)+1);
4011 }
4012
4013 my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
4014 substr($self->{BUFFER},0,$bytesToReturn)='';
4015
4016 # If we hit the boundary, remove the CRLF from the end.
4017 return ($bytesToReturn==$start)
4018 ? substr($returnval,0,-2) : $returnval;
4019}
4020END_OF_FUNC
4021
4022
4023# This fills up our internal buffer in such a way that the
4024# boundary is never split between reads
4025'fillBuffer' => <<'END_OF_FUNC',
4026sub fillBuffer {
4027 my($self,$bytes) = @_;
4028 return unless $self->{CHUNKED} || $self->{LENGTH};
4029
4030 my($boundaryLength) = length($self->{BOUNDARY});
4031 my($bufferLength) = length($self->{BUFFER});
4032 my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
4033 $bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $self->{LENGTH} < $bytesToRead;
4034
4035 # Try to read some data. We may hang here if the browser is screwed up.
4036 my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER},
4037 $bytesToRead,
4038 $bufferLength);
4039 warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG;
4040 $self->{BUFFER} = '' unless defined $self->{BUFFER};
4041
4042 # An apparent bug in the Apache server causes the read()
4043 # to return zero bytes repeatedly without blocking if the
4044 # remote user aborts during a file transfer. I don't know how
4045 # they manage this, but the workaround is to abort if we get
4046 # more than SPIN_LOOP_MAX consecutive zero reads.
4047 if ($bytesRead <= 0) {
4048 die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
4049 if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
4050 } else {
4051 $self->{ZERO_LOOP_COUNTER}=0;
4052 }
4053
4054 $self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead;
4055}
4056END_OF_FUNC
4057
4058
4059# Return true when we've finished reading
4060'eof' => <<'END_OF_FUNC'
4061sub eof {
4062 my($self) = @_;
4063 return 1 if (length($self->{BUFFER}) == 0)
4064 && ($self->{LENGTH} <= 0);
4065 undef;
4066}
4067END_OF_FUNC
4068
4069);
4070END_OF_AUTOLOAD
4071
4072####################################################################################
4073################################## TEMPORARY FILES #################################
4074####################################################################################
4075package CGITempFile;
4076
4077
# spent 52µs (35+16) within CGITempFile::find_tempdir which was called: # once (35µs+16µs) by C4::Templates::BEGIN@6 at line 4113
sub find_tempdir {
40781600ns $SL = $CGI::SL;
40791600ns $MAC = $CGI::OS eq 'MACINTOSH';
40801800ns my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
40811500ns unless (defined $TMPDIRECTORY) {
408217µs @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
4083 "C:${SL}temp","${SL}tmp","${SL}temp",
4084 "${vol}${SL}Temporary Items",
4085 "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
4086 "C:${SL}system${SL}temp");
4087
40881300ns if( $CGI::OS eq 'WINDOWS' ){
4089 unshift @TEMP,
4090 $ENV{TEMP},
4091 $ENV{TMP},
4092 $ENV{WINDIR} . $SL . 'TEMP';
4093 }
4094
40951700ns unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'};
4096
4097 # this feature was supposed to provide per-user tmpfiles, but
4098 # it is problematic.
4099 # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
4100 # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
4101 # : can generate a 'getpwuid() not implemented' exception, even though
4102 # : it's never called. Found under DOS/Win with the DJGPP perl port.
4103 # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
4104 # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
4105
410611µs for (@TEMP) {
4107438µs316µs do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
# spent 14µs making 2 calls to CGITempFile::CORE:ftdir, avg 7µs/call # spent 2µs making 1 call to CGITempFile::CORE:ftewrite
4108 }
4109 }
411014µs $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
4111}
4112
411313µs152µsfind_tempdir();
# spent 52µs making 1 call to CGITempFile::find_tempdir
4114
41151400ns$MAXTRIES = 5000;
4116
4117# cute feature, but overload implementation broke it
4118# %OVERLOAD = ('""'=>'as_string');
411911µs*CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD;
4120
4121sub DESTROY {
4122 my($self) = @_;
4123 $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\~-]+)$! || return;
4124 my $safe = $1; # untaint operation
4125 unlink $safe; # get rid of the file
4126}
4127
4128###############################################################################
4129################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
4130###############################################################################
41311400ns$AUTOLOADED_ROUTINES = ''; # prevent -w error
41321600ns$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
4133%SUBS = (
4134
4135'new' => <<'END_OF_FUNC',
4136sub new {
4137 my($package,$sequence) = @_;
4138 my $filename;
4139 find_tempdir() unless -w $TMPDIRECTORY;
4140 for (my $i = 0; $i < $MAXTRIES; $i++) {
4141 last if ! -f ($filename = sprintf("\%s${SL}CGItemp%d", $TMPDIRECTORY, $sequence++));
4142 }
4143 # check that it is a more-or-less valid filename
4144 return unless $filename =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\~-]+)$!;
4145 # this used to untaint, now it doesn't
4146 # $filename = $1;
4147 return bless \$filename;
4148}
4149END_OF_FUNC
4150
4151'as_string' => <<'END_OF_FUNC'
4152sub as_string {
4153 my($self) = @_;
4154 return $$self;
4155}
4156END_OF_FUNC
4157
4158);
4159END_OF_AUTOLOAD
4160
4161package CGI;
4162
4163# We get a whole bunch of warnings about "possibly uninitialized variables"
4164# when running with the -w switch. Touch them all once to get rid of the
4165# warnings. This is ugly and I hate it.
416611µsif ($^W) {
4167 $CGI::CGI = '';
4168 $CGI::CGI=<<EOF;
4169 $CGI::VERSION;
4170 $MultipartBuffer::SPIN_LOOP_MAX;
4171 $MultipartBuffer::CRLF;
4172 $MultipartBuffer::TIMEOUT;
4173 $MultipartBuffer::INITIAL_FILLUNIT;
4174EOF
4175 ;
4176}
4177
4178183µs1;
4179
4180__END__
 
# spent 232µs within CGI::CORE:match which was called 75 times, avg 3µs/call: # 23 times (147µs+0s) by CGI::_compile at line 840, avg 6µs/call # 9 times (21µs+0s) by CGI::header at line 31 of (eval 1149)[CGI.pm:869], avg 2µs/call # 7 times (6µs+0s) by C4::Templates::BEGIN@6 at line 145, avg 900ns/call # 4 times (26µs+0s) by CGI::header at line 54 of (eval 1149)[CGI.pm:869], avg 6µs/call # 4 times (3µs+0s) by CGI::http at line 3 of (eval 1136)[CGI.pm:869], avg 675ns/call # 4 times (2µs+0s) by CGI::unescapeHTML at line 6 of (eval 1150)[CGI.pm:869], avg 400ns/call # once (6µs+0s) by CGI::read_from_cmdline at line 19 of (eval 1047)[CGI.pm:869] # once (3µs+0s) by CGI::init at line 686 # once (2µs+0s) by CGI::expand_tags at line 317 # once (2µs+0s) by CGI::_setup_symbols at line 903 # once (1µs+0s) by C4::Templates::BEGIN@6 at line 164 # once (1µs+0s) by CGI::init at line 636 # once (1µs+0s) by CGI::_setup_symbols at line 904 # once (900ns+0s) by CGI::_setup_symbols at line 906 # once (900ns+0s) by CGI::header at line 58 of (eval 1149)[CGI.pm:869] # once (800ns+0s) by CGI::_setup_symbols at line 917 # once (700ns+0s) by CGI::_setup_symbols at line 910 # once (700ns+0s) by CGI::_setup_symbols at line 911 # once (700ns+0s) by CGI::_setup_symbols at line 913 # once (700ns+0s) by CGI::_setup_symbols at line 918 # once (600ns+0s) by CGI::read_from_cmdline at line 24 of (eval 1047)[CGI.pm:869] # once (600ns+0s) by CGI::_setup_symbols at line 916 # once (600ns+0s) by CGI::_setup_symbols at line 907 # once (600ns+0s) by CGI::_setup_symbols at line 909 # once (600ns+0s) by CGI::_setup_symbols at line 914 # once (600ns+0s) by CGI::_setup_symbols at line 908 # once (500ns+0s) by CGI::_setup_symbols at line 912 # once (500ns+0s) by CGI::_setup_symbols at line 921 # once (500ns+0s) by CGI::_setup_symbols at line 905 # once (500ns+0s) by CGI::_setup_symbols at line 915
sub CGI::CORE:match; # opcode
# spent 42µs within CGI::CORE:regcomp which was called 18 times, avg 2µs/call: # 9 times (23µs+0s) by CGI::header at line 31 of (eval 1149)[CGI.pm:869], avg 3µs/call # 9 times (19µs+0s) by CGI::header at line 28 of (eval 1149)[CGI.pm:869], avg 2µs/call
sub CGI::CORE:regcomp; # opcode
# spent 47µs within CGI::CORE:subst which was called 50 times, avg 944ns/call: # 23 times (16µs+0s) by CGI::_compile at line 842, avg 696ns/call # 9 times (9µs+0s) by CGI::header at line 28 of (eval 1149)[CGI.pm:869], avg 956ns/call # 4 times (10µs+0s) by CGI::header at line 55 of (eval 1149)[CGI.pm:869], avg 2µs/call # 4 times (3µs+0s) by CGI::unescapeHTML at line 9 of (eval 1150)[CGI.pm:869], avg 800ns/call # 2 times (3µs+0s) by CGI::url at line 47 of (eval 1127)[CGI.pm:869], avg 1µs/call # 2 times (1µs+0s) by CGI::_name_and_path_from_env at line 7 of (eval 1129)[CGI.pm:869], avg 700ns/call # 2 times (1µs+0s) by CGI::url at line 18 of (eval 1127)[CGI.pm:869], avg 500ns/call # 2 times (700ns+0s) by CGI::url at line 26 of (eval 1127)[CGI.pm:869], avg 350ns/call # once (3µs+0s) by CGI::read_from_cmdline at line 15 of (eval 1047)[CGI.pm:869] # once (300ns+0s) by CGI::read_from_cmdline at line 16 of (eval 1047)[CGI.pm:869]
sub CGI::CORE:subst; # opcode
# spent 10µs within CGI::CORE:substcont which was called 8 times, avg 1µs/call: # 8 times (10µs+0s) by CGI::header at line 55 of (eval 1149)[CGI.pm:869], avg 1µs/call
sub CGI::CORE:substcont; # opcode
# spent 14µs within CGITempFile::CORE:ftdir which was called 2 times, avg 7µs/call: # 2 times (14µs+0s) by CGITempFile::find_tempdir at line 4107, avg 7µs/call
sub CGITempFile::CORE:ftdir; # opcode
# spent 2µs within CGITempFile::CORE:ftewrite which was called: # once (2µs+0s) by CGITempFile::find_tempdir at line 4107
sub CGITempFile::CORE:ftewrite; # opcode
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.