← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:50 2015

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