← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/local/src/github.com/foswiki/core/bin/view
  Run on Sun Dec 4 17:17:59 2011
Reported on Sun Dec 4 17:26:32 2011

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