← Index
NYTProf Performance Profile   « line view »
For ./view
  Run on Fri Jul 31 19:05:14 2015
Reported on Fri Jul 31 19:08:09 2015

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