Profile of CGI.pm

Filename	/usr/share/perl5/CGI.pm
Statements	Executed 0 statements in 22µs

Line	State ments	Time on line	Code
1			package CGI;
2			require 5.008001;
3			use if $] >= 5.019, 'deprecate';
4			use Carp 'croak';
5			use CGI::File::Temp;
6
7			$CGI::VERSION='4.09';
8
9			use CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
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
14			use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
15			'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
16
17			{
18			local $^W = 0;
19			$TAINTED = substr("$0$^X",0,0);
20			}
21
22			$MOD_PERL = 0; # no mod_perl by default
23
24			#global settings
25			$POST_MAX = -1; # no limit to uploaded files
26			$DISABLE_UPLOADS = 0;
27			$UNLINK_TMP_FILES = 1;
28			$LIST_CONTEXT_WARN = 1;
29
30			@SAVED_SYMBOLS = ();
31
32			# >>>>> Here are some globals that you might want to adjust <<<<<<
33			sub initialize_globals {
34			# Set this to 1 to enable copious autoloader debugging messages
35			$AUTOLOAD_DEBUG = 0;
36
37			# Set this to 1 to generate XTML-compatible output
38			$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');
42			$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;
49			$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)
56			$NPH = 0;
57
58			# Set this to 1 to enable debugging from @ARGV
59			# Set to 2 to enable debugging from STDIN
60			$DEBUG = 1;
61
62			# Set this to 1 to generate automatic tab indexes
63			$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.
73			$CLOSE_UPLOAD_FILES = 0;
74
75			# Automatically determined -- don't change
76			$EBCDIC = 0;
77
78			# Change this to 1 to suppress redundant HTTP headers
79			$HEADERS_ONCE = 0;
80
81			# separate the name=value pairs by semicolons rather than ampersands
82			$USE_PARAM_SEMICOLONS = 1;
83
84			# Do not include undefined params parsed from query string
85			# use CGI qw(-no_undef_params);
86			$NO_UNDEF_PARAMS = 0;
87
88			# return everything as utf-8
89			$PARAM_UTF8 = 0;
90
91			# make param('PUTDATA') act like file upload
92			$PUTDATA_UPLOAD = 0;
93
94			# Other globals that you shouldn't worry about.
95			undef $Q;
96			$BEEN_THERE = 0;
97			$DTD_PUBLIC_IDENTIFIER = "";
98			undef @QUERY_PARAM;
99			undef %EXPORT;
100			undef $QUERY_CHARSET;
101			undef %QUERY_FIELDNAMES;
102			undef %QUERY_TMPFILES;
103
104			# prevent complaints by mod_perl
105			1;
106			}
107
108			# ------------------ START OF THE LIBRARY ------------
109
110			# make mod_perlhappy
111			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
116			unless ($OS) {
117			unless ($OS = $^O) {
118			require Config;
119			$OS = $Config::Config{'osname'};
120			}
121			}
122			if ($OS =~ /^MSWin/i) {
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 {
139			$OS = 'UNIX';
140			}
141
142			# Some OS logic. Binary mode enabled on DOS, NT and VMS
143			$needs_binmode = $OS=~/^(WINDOWS\|DOS\|OS2\|MSWin\|CYGWIN\|NETWARE)/;
144
145			# This is the default class for the CGI object to use when all else fails.
146			$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
147
148			# This is where to look for autoloaded routines.
149			$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
150
151			# The path separator is a slash, backslash or semicolon, depending
152			# on the platform.
153			$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/;
161			$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
162
163			# Turn on special checking for ActiveState's PerlEx
164			$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
168			if (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.
190			$EBCDIC = "\t" ne "\011";
191			if ($OS eq 'VMS') {
192			$CRLF = "\n";
193			} elsif ($EBCDIC) {
194			$CRLF= "\r\n";
195			} else {
196			$CRLF = "\015\012";
197			}
198
199			_set_binmode() if ($needs_binmode);
200
201			sub _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
226			%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
269			sub 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			sub import {
295			my $self = shift;
296
297			# This causes modules to clash.
298			undef %EXPORT_OK;
299			undef %EXPORT;
300
301			$self->_setup_symbols(@_);
302			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.
306			my @packages = ($self,@{"$self\:\:ISA"});
307			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
320			sub compile {
321			my $pack = shift;
322			$pack->_setup_symbols('-compile',@_);
323			}
324
325			sub 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			sub new {
341			my($class,@initializer) = @_;
342			my $self = {};
343
344			bless $self,ref $class \|\| $class \|\| $DefaultClass;
345
346			# always use a tempfile
347			$self->{'use_tempfile'} = 1;
348
349			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			}
356			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			}
361			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			}
379			$self->_reset_globals if $PERLEX;
380			$self->init(@initializer);
381			return $self;
382			}
383
384			sub r {
385			my $self = shift;
386			my $r = $self->{'.r'};
387			$self->{'.r'} = shift if @_;
388			$r;
389			}
390
391			sub 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			####
419			sub 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			sub param {
427			my($self,@p) = self_or_default(@_);
428
429			return $self->all_parameters unless @p;
430
431			# list context can be dangerous so warn:
432			# http://blog.gerv.net/2014/10/new-class-of-vulnerability-in-perl-web-applications
433			if ( wantarray && $LIST_CONTEXT_WARN ) {
434			my ( $package, $filename, $line ) = caller;
435			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
441			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.
445			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 {
462			$name = $p[0];
463			}
464
465			return unless defined($name) && $self->{param}{$name};
466
467			my @result = @{$self->{param}{$name}};
468
469			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
474			return wantarray ? @result : $result[0];
475			}
476
477			sub _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			sub self_or_default {
489			return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
490			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			}
496			return wantarray ? @_ : $Q;
497			}
498
499			sub 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			sub init {
524			my $self = shift;
525			my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
526
527			my $is_xforms;
528
529			my $initializer = shift; # for backward compatibility
530			local($/) = "\n";
531
532			# set autoescaping on by default
533			$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.)
538			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
555			$meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
556			$content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
557
558			$fh = to_filehandle($initializer) if $initializer;
559
560			# set charset to the safe ISO-8859-1
561			$self->charset('ISO-8859-1');
562
563			METHOD: {
564
565			# avoid unreasonably large postings
566			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.
574			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
599			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.
622			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.
658			if ($is_xforms \|\| $meth=~/^(GET\|HEAD\|DELETE)$/) {
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
665			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.
691			if ($DEBUG)
692			{
693			my $cmdline_ret = read_from_cmdline();
694			$query_string = $cmdline_ret->{'query_string'};
695			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
703			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.
716			if (defined $query_string && length $query_string) {
717			if ($query_string =~ /[&=;]/) {
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.
727			if ($self->param('.defaults')) {
728			$self->delete_all();
729			}
730
731			# hash containing our defined fieldnames
732			$self->{'.fieldnames'} = {};
733			for ($self->param('.cgifields')) {
734			$self->{'.fieldnames'}->{$_}++;
735			}
736
737			# Clear out our default submission button flag if present
738	1	500ns	$self->delete('.submit');
739	1	22µs	$self->delete('.cgifields');
740
741			$self->save_request unless defined $initializer;
742			}
743
744			sub _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
778			sub 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
794			sub put {
795			my($self,@p) = self_or_default(@_);
796			$self->print(@p);
797			}
798
799			# print to standard output (for overriding in mod_perl)
800			sub print {
801			shift;
802			CORE::print(@_);
803			}
804
805			# get/set last cgi_error
806			sub 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			sub save_request {
813			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.
817			@QUERY_PARAM = $self->param; # save list of parameters
818			for (@QUERY_PARAM) {
819			next unless defined $_;
820			$QUERY_PARAM{$_}=$self->{param}{$_};
821			}
822			$QUERY_CHARSET = $self->charset;
823			%QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
824			%QUERY_TMPFILES = %{ $self->{'.tmpfiles'} \|\| {} };
825			}
826
827			sub parse_params {
828			my($self,$tosplit) = @_;
829			my(@pairs) = split(/[&;]/,$tosplit);
830			my($param,$value);
831			for (@pairs) {
832			($param,$value) = split('=',$_,2);
833			next unless defined $param;
834			next if $NO_UNDEF_PARAMS and not defined $value;
835			$value = '' unless defined $value;
836			$param = unescape($param);
837			$value = unescape($value);
838			$self->add_parameter($param);
839			push (@{$self->{param}{$param}},$value);
840			}
841			}
842
843			sub add_parameter {
844			my($self,$param)=@_;
845			return unless defined $param;
846			push (@{$self->{'.parameters'}},$param)
847			unless defined($self->{param}{$param});
848			}
849
850			sub all_parameters {
851			my $self = shift;
852			return () unless defined($self) && $self->{'.parameters'};
853			return () unless @{$self->{'.parameters'}};
854			return @{$self->{'.parameters'}};
855			}
856
857			# put a filehandle into binary mode (DOS)
858			sub binmode {
859			return unless defined($_[1]) && ref ($_[1]) && defined fileno($_[1]);
860			CORE::binmode($_[1]);
861			}
862
863			sub _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			}
889			return $func;
890			}
891
892			sub AUTOLOAD {
893			print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
894			my $func = &_compile;
895			goto &$func;
896			}
897
898			sub _compile {
899			my($func) = $AUTOLOAD;
900			my($pack,$func_name);
901			{
902			local($1,$2); # this fixes an obscure variable suicide problem.
903			$func=~/(.+)::([^:]+)$/;
904			($pack,$func_name) = ($1,$2);
905			$pack=~s/::SUPER$//; # fix another obscure problem
906			$pack = ${"$pack\:\:AutoloadClass"} \|\| $CGI::DefaultClass
907			unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
908
909			my($sub) = \%{"$pack\:\:SUBS"};
910			unless (%$sub) {
911			my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
912			local ($@,$!);
913			eval "package $pack; $$auto";
914			croak("$AUTOLOAD: $@") if $@;
915			$$auto = ''; # Free the unneeded storage (but don't undef it!!!)
916			}
917			my($code) = $sub->{$func_name};
918
919			$code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
920			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			}
930			croak("Undefined subroutine $AUTOLOAD\n") unless $code;
931			local ($@,$!);
932			eval "package $pack; $code"; # spent 328µs executing statements in string eval # includes 691µs spent executing 4 calls to 1 sub defined therein. # spent 316µs executing statements in string eval # includes 709µs spent executing 13 calls to 1 sub defined therein. # spent 71µs executing statements in string eval # spent 35µs executing statements in string eval # includes 105µs spent executing 15 calls to 1 sub defined therein. # spent 21µs executing statements in string eval # includes 56µs spent executing 3 calls to 1 sub defined therein. # spent 10µs executing statements in string eval # includes 737µs spent executing 241 calls to 5 subs defined therein.
933			if ($@) {
934			$@ =~ s/ at .*\n//;
935			croak("$AUTOLOAD: $@");
936			}
937			}
938			CORE::delete($sub->{$func_name}); #free storage
939			return "$pack\:\:$func_name";
940			}
941
942			sub _selected {
943			my $self = shift;
944			my $value = shift;
945			return '' unless $value;
946			return $XHTML ? qq(selected="selected" ) : qq(selected );
947			}
948
949			sub _checked {
950			my $self = shift;
951			my $value = shift;
952			return '' unless $value;
953			return $XHTML ? qq(checked="checked" ) : qq(checked );
954			}
955
956			sub _reset_globals { initialize_globals(); }
957
958			sub _setup_symbols {
959			my $self = shift;
960			my $compile = 0;
961
962			# to avoid reexporting unwanted variables
963			undef %EXPORT;
964
965			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			}
999			_compile_all(keys %EXPORT) if $compile;
1000			@SAVED_SYMBOLS = @_;
1001			}
1002
1003			sub charset {
1004			my ($self,$charset) = self_or_default(@_);
1005			$self->{'.charset'} = $charset if defined $charset;
1006			$self->{'.charset'};
1007			}
1008
1009			sub 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
1015			sub 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			#####
1035			sub 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			###############################################################################
1144			$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
1145			$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
1146
1147			%SUBS = (
1148
1149			'URL_ENCODED'=> <<'END_OF_FUNC',
1150			sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
1151			END_OF_FUNC
1152
1153			'MULTIPART' => <<'END_OF_FUNC',
1154			sub MULTIPART { 'multipart/form-data'; }
1155			END_OF_FUNC
1156
1157			'SERVER_PUSH' => <<'END_OF_FUNC',
1158			sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
1159			END_OF_FUNC
1160
1161			'new_MultipartBuffer' => <<'END_OF_FUNC',
1162			# Create a new multipart buffer
1163			sub new_MultipartBuffer {
1164			my($self,$boundary,$length) = @_;
1165			return MultipartBuffer->new($self,$boundary,$length);
1166			}
1167			END_OF_FUNC
1168
1169			'read_from_client' => <<'END_OF_FUNC',
1170			# Read data from a file handle
1171			sub 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			}
1178			END_OF_FUNC
1179
1180			'delete' => <<'END_OF_FUNC',
1181			#### Method: delete
1182			# Deletes the named parameter entirely.
1183			####
1184			sub 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			}
1198			END_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',
1205			sub 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			}
1229			END_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',
1237			sub 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			}
1244			END_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',
1249			sub Vars {
1250			my $q = shift;
1251			my %in;
1252			tie(%in,CGI,$q);
1253			return %in if wantarray;
1254			return \%in;
1255			}
1256			END_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',
1261			sub 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			}
1272			END_OF_FUNC
1273
1274			'PrintHeader' => <<'END_OF_FUNC',
1275			sub PrintHeader {
1276			my($self) = self_or_default(@_);
1277			return $self->header();
1278			}
1279			END_OF_FUNC
1280
1281			'HtmlTop' => <<'END_OF_FUNC',
1282			sub HtmlTop {
1283			my($self,@p) = self_or_default(@_);
1284			return $self->start_html(@p);
1285			}
1286			END_OF_FUNC
1287
1288			'HtmlBot' => <<'END_OF_FUNC',
1289			sub HtmlBot {
1290			my($self,@p) = self_or_default(@_);
1291			return $self->end_html(@p);
1292			}
1293			END_OF_FUNC
1294
1295			'SplitParam' => <<'END_OF_FUNC',
1296			sub SplitParam {
1297			my ($param) = @_;
1298			my (@params) = split ("\0", $param);
1299			return (wantarray ? @params : $params[0]);
1300			}
1301			END_OF_FUNC
1302
1303			'MethGet' => <<'END_OF_FUNC',
1304			sub MethGet {
1305			return request_method() eq 'GET';
1306			}
1307			END_OF_FUNC
1308
1309			'MethPost' => <<'END_OF_FUNC',
1310			sub MethPost {
1311			return request_method() eq 'POST';
1312			}
1313			END_OF_FUNC
1314
1315			'MethPut' => <<'END_OF_FUNC',
1316			sub MethPut {
1317			return request_method() eq 'PUT';
1318			}
1319			END_OF_FUNC
1320
1321			'TIEHASH' => <<'END_OF_FUNC',
1322			sub 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			}
1330			END_OF_FUNC
1331
1332			'STORE' => <<'END_OF_FUNC',
1333			sub 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			}
1340			END_OF_FUNC
1341
1342			'FETCH' => <<'END_OF_FUNC',
1343			sub FETCH {
1344			return $_[0] if $_[1] eq 'CGI';
1345			return undef unless defined $_[0]->param($_[1]);
1346			return join("\0",$_[0]->param($_[1]));
1347			}
1348			END_OF_FUNC
1349
1350			'FIRSTKEY' => <<'END_OF_FUNC',
1351			sub FIRSTKEY {
1352			$_[0]->{'.iterator'}=0;
1353			$_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1354			}
1355			END_OF_FUNC
1356
1357			'NEXTKEY' => <<'END_OF_FUNC',
1358			sub NEXTKEY {
1359			$_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1360			}
1361			END_OF_FUNC
1362
1363			'EXISTS' => <<'END_OF_FUNC',
1364			sub EXISTS {
1365			exists $_[0]->{param}{$_[1]};
1366			}
1367			END_OF_FUNC
1368
1369			'DELETE' => <<'END_OF_FUNC',
1370			sub DELETE {
1371			my ($self, $param) = @_;
1372			my $value = $self->FETCH($param);
1373			$self->delete($param);
1374			return $value;
1375			}
1376			END_OF_FUNC
1377
1378			'CLEAR' => <<'END_OF_FUNC',
1379			sub CLEAR {
1380			%{$_[0]}=();
1381			}
1382			####
1383			END_OF_FUNC
1384
1385			####
1386			# Append a new value to an existing query
1387			####
1388			'append' => <<'EOF',
1389			sub 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			}
1399			EOF
1400
1401			#### Method: delete_all
1402			# Delete all parameters
1403			####
1404			'delete_all' => <<'EOF',
1405			sub delete_all {
1406			my($self) = self_or_default(@_);
1407			my @param = $self->param();
1408			$self->delete(@param);
1409			}
1410			EOF
1411
1412			'Delete' => <<'EOF',
1413			sub Delete {
1414			my($self,@p) = self_or_default(@_);
1415			$self->delete(@p);
1416			}
1417			EOF
1418
1419			'Delete_all' => <<'EOF',
1420			sub Delete_all {
1421			my($self,@p) = self_or_default(@_);
1422			$self->delete_all(@p);
1423			}
1424			EOF
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',
1430			sub autoEscape {
1431			my($self,$escape) = self_or_default(@_);
1432			my $d = $self->{'escape'};
1433			$self->{'escape'} = $escape;
1434			$d;
1435			}
1436			END_OF_FUNC
1437
1438
1439			#### Method: version
1440			# Return the current version
1441			####
1442			'version' => <<'END_OF_FUNC',
1443			sub version {
1444			return $VERSION;
1445			}
1446			END_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',
1453			sub 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			}
1479			END_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',
1487			sub 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			}
1506			END_OF_FUNC
1507
1508			#### Method as_string
1509			#
1510			# synonym for "dump"
1511			####
1512			'as_string' => <<'END_OF_FUNC',
1513			sub as_string {
1514			&Dump(@_);
1515			}
1516			END_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',
1523			sub 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			}
1542			END_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',
1550			sub save_parameters {
1551			my $fh = shift;
1552			return save(to_filehandle($fh));
1553			}
1554			END_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',
1561			sub restore_parameters {
1562			$Q = $CGI::DefaultClass->new(@_);
1563			}
1564			END_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',
1574			sub 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			}
1595			END_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',
1605			sub 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			}
1627			END_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',
1637			sub multipart_end {
1638			my($self,@p) = self_or_default(@_);
1639			return $self->{'separator'};
1640			}
1641			END_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',
1650			sub 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			}
1654			END_OF_FUNC
1655
1656
1657			#### Method: header
1658			# Return a Content-Type: style header
1659			#
1660			####
1661			'header' => <<'END_OF_FUNC',
1662			sub 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			}
1748			END_OF_FUNC
1749
1750			#### Method: cache
1751			# Control whether header() will produce the no-cache
1752			# Pragma directive.
1753			####
1754			'cache' => <<'END_OF_FUNC',
1755			sub 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			}
1763			END_OF_FUNC
1764
1765
1766			#### Method: redirect
1767			# Return a Location: style header
1768			#
1769			####
1770			'redirect' => <<'END_OF_FUNC',
1771			sub 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			}
1789			END_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',
1812			sub 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>
1907			END
1908			;
1909			my($other) = @other ? " @other" : '';
1910			push(@result,"</head>\n<body$other>\n");
1911			return join("\n",@result);
1912			}
1913			END_OF_FUNC
1914
1915			### Method: _style
1916			# internal method for generating a CSS style section
1917			####
1918			'_style' => <<'END_OF_FUNC',
1919			sub _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			}
1974			END_OF_FUNC
1975
1976			'_script' => <<'END_OF_FUNC',
1977			sub _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			}
2020			END_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',
2027			sub end_html {
2028			return "\n</body>\n</html>";
2029			}
2030			END_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',
2044			sub 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			}
2051			END_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',
2061			sub 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			}
2086			END_OF_FUNC
2087
2088			#### Method: start_multipart_form
2089			'start_multipart_form' => <<'END_OF_FUNC',
2090			sub 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			}
2100			END_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',
2108			sub 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			}
2121			END_OF_FUNC
2122
2123
2124			#### Method: end_multipart_form
2125			# end a multipart form
2126			'end_multipart_form' => <<'END_OF_FUNC',
2127			sub end_multipart_form {
2128			&end_form;
2129			}
2130			END_OF_FUNC
2131
2132
2133			'_textfield' => <<'END_OF_FUNC',
2134			sub _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			}
2154			END_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',
2167			sub textfield {
2168			my($self,@p) = self_or_default(@_);
2169			$self->_textfield('text',@p);
2170			}
2171			END_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',
2183			sub filefield {
2184			my($self,@p) = self_or_default(@_);
2185			$self->_textfield('file',@p);
2186			}
2187			END_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',
2202			sub password_field {
2203			my ($self,@p) = self_or_default(@_);
2204			$self->_textfield('password',@p);
2205			}
2206			END_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',
2219			sub 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			}
2235			END_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',
2249			sub 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			}
2272			END_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',
2285			sub 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			}
2303			END_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',
2314			sub 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			}
2329			END_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',
2344			sub 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			}
2357			END_OF_FUNC
2358
2359
2360			#### Method: comment
2361			# Create an HTML <!-- comment -->
2362			# Parameters: a string
2363			'comment' => <<'END_OF_FUNC',
2364			sub comment {
2365			my($self,@p) = self_or_CGI(@_);
2366			return "<!-- @p -->";
2367			}
2368			END_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',
2383			sub 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			}
2409			END_OF_FUNC
2410
- -
2413			# Escape HTML
2414			'escapeHTML' => <<'END_OF_FUNC',
2415			sub 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{&}{&}gso;
2421			$toencode =~ s{<}{<}gso;
2422			$toencode =~ s{>}{>}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{"}{"}gso;
2428			}
2429			else {
2430			$toencode =~ s{"}{"}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{'}{'}gso;
2438			$toencode =~ s{\x8b}{‹}gso;
2439			$toencode =~ s{\x9b}{›}gso;
2440			if (defined $newlinestoo && $newlinestoo) {
2441			$toencode =~ s{\012}{ }gso;
2442			$toencode =~ s{\015}{ }gso;
2443			}
2444			}
2445			return $toencode;
2446			}
2447			END_OF_FUNC
2448
2449			# unescape HTML -- used internally
2450			'unescapeHTML' => <<'END_OF_FUNC',
2451			sub 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			}
2471			END_OF_FUNC
2472
2473			# Internal procedure - don't use
2474			'_tableize' => <<'END_OF_FUNC',
2475			sub _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			}
2508			END_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',
2529			sub radio_group {
2530			my($self,@p) = self_or_default(@_);
2531			$self->_box_group('radio',@p);
2532			}
2533			END_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',
2558			sub checkbox_group {
2559			my($self,@p) = self_or_default(@_);
2560			$self->_box_group('checkbox',@p);
2561			}
2562			END_OF_FUNC
2563
2564			'_box_group' => <<'END_OF_FUNC',
2565			sub _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			}
2647			END_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',
2665			sub 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			}
2715			END_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',
2741			sub 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			}
2775			END_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',
2799			sub 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			}
2844			END_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',
2857			sub 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			}
2889			END_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',
2901			sub 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			}
2913			END_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',
2923			sub self_url {
2924			my($self,@p) = self_or_default(@_);
2925			return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
2926			}
2927			END_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',
2933			sub state {
2934			&self_url;
2935			}
2936			END_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',
2944			sub 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
3002			END_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',
3017			sub 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			}
3051			END_OF_FUNC
3052
3053			'parse_keywordlist' => <<'END_OF_FUNC',
3054			sub 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			}
3061			END_OF_FUNC
3062
3063			'param_fetch' => <<'END_OF_FUNC',
3064			sub 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			}
3076			END_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',
3087			sub 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			}
3098			END_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',
3129			sub _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			}
3159			END_OF_FUNC
3160
3161
3162			#### Method: request_method
3163			# Returns 'POST', 'GET', 'PUT' or 'HEAD'
3164			####
3165			'request_method' => <<'END_OF_FUNC',
3166			sub request_method {
3167			return (defined $ENV{'REQUEST_METHOD'}) ? $ENV{'REQUEST_METHOD'} : undef;
3168			}
3169			END_OF_FUNC
3170
3171			#### Method: content_type
3172			# Returns the content_type string
3173			####
3174			'content_type' => <<'END_OF_FUNC',
3175			sub content_type {
3176			return (defined $ENV{'CONTENT_TYPE'}) ? $ENV{'CONTENT_TYPE'} : undef;
3177			}
3178			END_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',
3185			sub path_translated {
3186			return (defined $ENV{'PATH_TRANSLATED'}) ? $ENV{'PATH_TRANSLATED'} : undef;
3187			}
3188			END_OF_FUNC
3189
3190
3191			#### Method: request_uri
3192			# Return the literal request URI
3193			####
3194			'request_uri' => <<'END_OF_FUNC',
3195			sub request_uri {
3196			return (defined $ENV{'REQUEST_URI'}) ? $ENV{'REQUEST_URI'} : undef;
3197			}
3198			END_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',
3206			sub 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			}
3222			END_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',
3237			sub 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			}
3271			END_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',
3280			sub 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			}
3286			END_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',
3298			sub 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			}
3313			END_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',
3320			sub 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			}
3325			END_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',
3334			sub remote_host {
3335			return $ENV{'REMOTE_HOST'} \|\| $ENV{'REMOTE_ADDR'}
3336			\|\| 'localhost';
3337			}
3338			END_OF_FUNC
3339
3340
3341			#### Method: remote_addr
3342			# Return the IP addr of the remote host.
3343			####
3344			'remote_addr' => <<'END_OF_FUNC',
3345			sub remote_addr {
3346			return $ENV{'REMOTE_ADDR'} \|\| '127.0.0.1';
3347			}
3348			END_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',
3358			sub 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			}
3368			END_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',
3376			sub referer {
3377			my($self) = self_or_CGI(@_);
3378			return $self->http('referer');
3379			}
3380			END_OF_FUNC
3381
3382
3383			#### Method: server_name
3384			# Return the name of the server
3385			####
3386			'server_name' => <<'END_OF_FUNC',
3387			sub server_name {
3388			return $ENV{'SERVER_NAME'} \|\| 'localhost';
3389			}
3390			END_OF_FUNC
3391
3392			#### Method: server_software
3393			# Return the name of the server software
3394			####
3395			'server_software' => <<'END_OF_FUNC',
3396			sub server_software {
3397			return $ENV{'SERVER_SOFTWARE'} \|\| 'cmdline';
3398			}
3399			END_OF_FUNC
3400
3401			#### Method: virtual_port
3402			# Return the server port, taking virtual hosts into account
3403			####
3404			'virtual_port' => <<'END_OF_FUNC',
3405			sub 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			}
3415			END_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',
3421			sub server_port {
3422			return $ENV{'SERVER_PORT'} \|\| 80; # for debugging
3423			}
3424			END_OF_FUNC
3425
3426			#### Method: server_protocol
3427			# Return the protocol (usually HTTP/1.0)
3428			####
3429			'server_protocol' => <<'END_OF_FUNC',
3430			sub server_protocol {
3431			return $ENV{'SERVER_PROTOCOL'} \|\| 'HTTP/1.0'; # for debugging
3432			}
3433			END_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',
3440			sub 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			}
3451			END_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',
3459			sub 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			}
3472			END_OF_FUNC
3473
3474			#### Method: protocol
3475			# Return the protocol (http or https currently)
3476			####
3477			'protocol' => <<'END_OF_FUNC',
3478			sub 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			}
3487			END_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',
3494			sub remote_ident {
3495			return (defined $ENV{'REMOTE_IDENT'}) ? $ENV{'REMOTE_IDENT'} : undef;
3496			}
3497			END_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',
3504			sub auth_type {
3505			return (defined $ENV{'AUTH_TYPE'}) ? $ENV{'AUTH_TYPE'} : undef;
3506			}
3507			END_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',
3515			sub remote_user {
3516			return (defined $ENV{'REMOTE_USER'}) ? $ENV{'REMOTE_USER'} : undef;
3517			}
3518			END_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',
3526			sub user_name {
3527			my ($self) = self_or_CGI(@_);
3528			return $self->http('from') \|\| $ENV{'REMOTE_IDENT'} \|\| $ENV{'REMOTE_USER'};
3529			}
3530			END_OF_FUNC
3531
3532			#### Method: nosticky
3533			# Set or return the NOSTICKY global flag
3534			####
3535			'nosticky' => <<'END_OF_FUNC',
3536			sub nosticky {
3537			my ($self,$param) = self_or_CGI(@_);
3538			$CGI::NOSTICKY = $param if defined($param);
3539			return $CGI::NOSTICKY;
3540			}
3541			END_OF_FUNC
3542
3543			#### Method: nph
3544			# Set or return the NPH global flag
3545			####
3546			'nph' => <<'END_OF_FUNC',
3547			sub nph {
3548			my ($self,$param) = self_or_CGI(@_);
3549			$CGI::NPH = $param if defined($param);
3550			return $CGI::NPH;
3551			}
3552			END_OF_FUNC
3553
3554			#### Method: private_tempfiles
3555			# Set or return the private_tempfiles global flag
3556			####
3557			'private_tempfiles' => <<'END_OF_FUNC',
3558			sub private_tempfiles {
3559			warn "private_tempfiles has been deprecated";
3560			return 0;
3561			}
3562			END_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',
3567			sub 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			}
3572			END_OF_FUNC
3573
3574
3575			#### Method: default_dtd
3576			# Set or return the default_dtd global
3577			####
3578			'default_dtd' => <<'END_OF_FUNC',
3579			sub 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			}
3588			END_OF_FUNC
3589
3590			# -------------- really private subroutines -----------------
3591			'_maybe_escapeHTML' => <<'END_OF_FUNC',
3592			sub _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			}
3600			END_OF_FUNC
3601
3602			'previous_or_default' => <<'END_OF_FUNC',
3603			sub 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			}
3619			END_OF_FUNC
3620
3621			'register_parameter' => <<'END_OF_FUNC',
3622			sub register_parameter {
3623			my($self,$param) = @_;
3624			$self->{'.parametersToAdd'}->{$param}++;
3625			}
3626			END_OF_FUNC
3627
3628			'get_fields' => <<'END_OF_FUNC',
3629			sub get_fields {
3630			my($self) = @_;
3631			return $self->CGI::hidden('-name'=>'.cgifields',
3632			'-values'=>[keys %{$self->{'.parametersToAdd'}}],
3633			'-override'=>1);
3634			}
3635			END_OF_FUNC
3636
3637			'read_from_cmdline' => <<'END_OF_FUNC',
3638			sub 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			}
3668			END_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',
3679			sub 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			}
3800			END_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',
3812			sub 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			}
3903			END_OF_FUNC
3904
3905
3906			'upload' =><<'END_OF_FUNC',
3907			sub 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			}
3913			END_OF_FUNC
3914
3915			'tmpFileName' => <<'END_OF_FUNC',
3916			sub tmpFileName {
3917			my($self,$filename) = self_or_default(@_);
3918			return $self->{'.tmpfiles'}->{$$filename . $filename}->{name} \|\| '';
3919			}
3920			END_OF_FUNC
3921
3922			'uploadInfo' => <<'END_OF_FUNC',
3923			sub uploadInfo {
3924			my($self,$filename) = self_or_default(@_);
3925			return if ! defined $$filename;
3926			return $self->{'.tmpfiles'}->{$$filename . $filename}->{info};
3927			}
3928			END_OF_FUNC
3929
3930			# internal routine, don't use
3931			'_set_values_and_labels' => <<'END_OF_FUNC',
3932			sub _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			}
3940			END_OF_FUNC
3941
3942			# internal routine, don't use
3943			'_set_attributes' => <<'END_OF_FUNC',
3944			sub _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			}
3956			END_OF_FUNC
3957
3958			'_compile_all' => <<'END_OF_FUNC',
3959			sub _compile_all {
3960			for (@_) {
3961			next if defined(&$_);
3962			$AUTOLOAD = "CGI::$_";
3963			_compile();
3964			}
3965			}
3966			END_OF_FUNC
3967
3968			);
3969			END_OF_AUTOLOAD
3970			;
3971
3972			#########################################################
3973			# Globals and stubs for other packages that we use.
3974			#########################################################
3975
3976			######################## MultipartBuffer ####################
3977			package MultipartBuffer;
3978
3979			use constant DEBUG => 0;
3980
3981			# how many bytes to read at a time. We use
3982			# a 4K buffer by default.
3983			$INITIAL_FILLUNIT = 1024 * 4;
3984			$TIMEOUT = 240*60; # 4 hour timeout for big files
3985			$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
3986			$CRLF=$CGI::CRLF;
3987
3988			#reuse the autoload function
3989			*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
3990
3991			# avoid autoloader warnings
3992			sub DESTROY {}
3993
3994			###############################################################################
3995			################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3996			###############################################################################
3997			$AUTOLOADED_ROUTINES = ''; # prevent -w error
3998			$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3999			%SUBS = (
4000
4001			'new' => <<'END_OF_FUNC',
4002			sub 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			}
4055			END_OF_FUNC
4056
4057			'readHeader' => <<'END_OF_FUNC',
4058			sub 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			}
4102			END_OF_FUNC
4103
4104			# This reads and returns the body as a single scalar value.
4105			'readBody' => <<'END_OF_FUNC',
4106			sub 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			}
4124			END_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',
4130			sub 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			}
4187			END_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',
4193			sub 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			}
4223			END_OF_FUNC
4224
4225
4226			# Return true when we've finished reading
4227			'eof' => <<'END_OF_FUNC'
4228			sub eof {
4229			my($self) = @_;
4230			return 1 if (length($self->{BUFFER}) == 0)
4231			&& ($self->{LENGTH} <= 0);
4232			undef;
4233			}
4234			END_OF_FUNC
4235
4236			);
4237			END_OF_AUTOLOAD
4238
4239			1;
4240
4241			package 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.
4246			if ($^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;
4254			EOF
4255			;
4256			}
4257
4258			1;
4259
4260			__END__
4261
4262			=head1 NAME
4263
4264			CGI - Handle Common Gateway Interface requests and responses
4265
4266			=for html
4267			<a href='https://travis-ci.org/leejo/CGI.pm?branch=master'><img src='https://travis-ci.org/leejo/CGI.pm.svg?branch=master' alt='Build Status' /></a>
4268			<a href='https://coveralls.io/r/leejo/CGI.pm'><img src='https://coveralls.io/repos/leejo/CGI.pm/badge.png?branch=master' alt='Coverage Status' /></a>
4269
4270			=head1 SYNOPSIS
4271
4272			use CGI;
4273
4274			my $q = CGI->new;
4275
4276			# Process an HTTP request
4277			@values = $q->multi_param('form_field');
4278			$value = $q->param('param_name');
4279
4280			$fh = $q->upload('file_field');
4281
4282			$riddle = $query->cookie('riddle_name');
4283			%answers = $query->cookie('answers');
4284
4285			# Prepare various HTTP responses
4286			print $q->header();
4287			print $q->header('application/json');
4288
4289			$cookie1 = $q->cookie(-name=>'riddle_name', -value=>"The Sphynx's Question");
4290			$cookie2 = $q->cookie(-name=>'answers', -value=>\%answers);
4291			print $q->header(
4292			-type => 'image/gif',
4293			-expires => '+3d',
4294			-cookie => [$cookie1,$cookie2]
4295			);
4296
4297			print $q->redirect('http://somewhere.else/in/movie/land');
4298
4299			=head1 DESCRIPTION
4300
4301			CGI.pm is a stable, complete and mature solution for processing and preparing
4302			HTTP requests and responses. Major features including processing form
4303			submissions, file uploads, reading and writing cookies, query string generation
4304			and manipulation, and processing and preparing HTTP headers. Some HTML
4305			generation utilities are included as well.
4306
4307			CGI.pm performs very well in a vanilla CGI.pm environment and also comes
4308			with built-in support for mod_perl and mod_perl2 as well as FastCGI.
4309
4310			It has the benefit of having developed and refined over 10 years with input
4311			from dozens of contributors and being deployed on thousands of websites.
4312			CGI.pm has been included in the Perl distribution since Perl 5.4, and has
4313			become a de-facto standard.
4314
4315			=head1 CGI.pm HAS BEEN REMOVED FROM THE PERL CORE
4316
4317			L<http://perl5.git.perl.org/perl.git/commitdiff/e9fa5a80>
4318
4319			If you upgrade to a new version of perl or if you rely on a
4320			system or vendor perl and get an updated version of perl through a system
4321			update, then you will have to install CGI.pm yourself with cpan/cpanm/a vendor
4322			package/manually. To make this a little easier the L<CGI::Fast> module has been
4323			split into its own distribution, meaning you do not need acces to a compiler
4324			to install CGI.pm
4325
4326			The rational for this decision is that CGI.pm is no longer considered good
4327			practice for developing web applications, B<including> quick prototyping and
4328			small web scripts. There are far better, cleaner, quicker, easier, safer,
4329			more scalable, more extensible, more modern alternatives available at this point
4330			in time. These will be documented with L<CGI::Alternatives>.
4331
4332			For more discussion on the removal of CGI.pm from core please see:
4333
4334			L<http://www.nntp.perl.org/group/perl.perl5.porters/2013/05/msg202130.html>
4335
4336			=head1 HTML Generation functions should no longer be used
4337
4338			B<All> HTML generation functions within CGI.pm are no longer being
4339			maintained. Any issues, bugs, or patches will be rejected unless
4340			they relate to fundamentally broken page rendering.
4341
4342			The rational for this is that the HTML generation functions of CGI.pm
4343			are an obfuscation at best and a maintenance nightmare at worst. You
4344			should be using a template engine for better separation of concerns.
4345			See L<CGI::Alternatives> for an example of using CGI.pm with the
4346			L<Template::Toolkit> module.
4347
4348			These functions, and perldoc for them, will continue to exist in the
4349			v4 releases of CGI.pm but may be deprecated (soft) in v5 and beyond.
4350
4351			=head2 Programming style
4352
4353			There are two styles of programming with CGI.pm, an object-oriented
4354			style and a function-oriented style. In the object-oriented style you
4355			create one or more CGI objects and then use object methods to create
4356			the various elements of the page. Each CGI object starts out with the
4357			list of named parameters that were passed to your CGI script by the
4358			server. You can modify the objects, save them to a file or database
4359			and recreate them. Because each object corresponds to the "state" of
4360			the CGI script, and because each object's parameter list is
4361			independent of the others, this allows you to save the state of the
4362			script and restore it later.
4363
4364			For example, using the object oriented style, here is how you create
4365			a simple "Hello World" HTML page:
4366
4367			#!/usr/local/bin/perl -w
4368			use CGI; # load CGI routines
4369			$q = CGI->new; # create new CGI object
4370			print $q->header, # create the HTTP header
4371			$q->start_html('hello world'), # start the HTML
4372			$q->h1('hello world'), # level 1 header
4373			$q->end_html; # end the HTML
4374
4375			In the function-oriented style, there is one default CGI object that
4376			you rarely deal with directly. Instead you just call functions to
4377			retrieve CGI parameters, create HTML tags, manage cookies, and so
4378			on. This provides you with a cleaner programming interface, but
4379			limits you to using one CGI object at a time. The following example
4380			prints the same page, but uses the function-oriented interface.
4381			The main differences are that we now need to import a set of functions
4382			into our name space (usually the "standard" functions), and we don't
4383			need to create the CGI object.
4384
4385			#!/usr/local/bin/perl
4386			use CGI qw/:standard/; # load standard CGI routines
4387			print header, # create the HTTP header
4388			start_html('hello world'), # start the HTML
4389			h1('hello world'), # level 1 header
4390			end_html; # end the HTML
4391
4392			The examples in this document mainly use the object-oriented style.
4393			See HOW TO IMPORT FUNCTIONS for important information on
4394			function-oriented programming in CGI.pm
4395
4396			=head2 Calling CGI.pm routines
4397
4398			Most CGI.pm routines accept several arguments, sometimes as many as 20
4399			optional ones! To simplify this interface, all routines use a named
4400			argument calling style that looks like this:
4401
4402			print $q->header(-type=>'image/gif',-expires=>'+3d');
4403
4404			Each argument name is preceded by a dash. Neither case nor order
4405			matters in the argument list. -type, -Type, and -TYPE are all
4406			acceptable. In fact, only the first argument needs to begin with a
4407			dash. If a dash is present in the first argument, CGI.pm assumes
4408			dashes for the subsequent ones.
4409
4410			Several routines are commonly called with just one argument. In the
4411			case of these routines you can provide the single argument without an
4412			argument name. header() happens to be one of these routines. In this
4413			case, the single argument is the document type.
4414
4415			print $q->header('text/html');
4416
4417			Other such routines are documented below.
4418
4419			Sometimes named arguments expect a scalar, sometimes a reference to an
4420			array, and sometimes a reference to a hash. Often, you can pass any
4421			type of argument and the routine will do whatever is most appropriate.
4422			For example, the param() routine is used to set a CGI parameter to a
4423			single or a multi-valued value. The two cases are shown below:
4424
4425			$q->param(-name=>'veggie',-value=>'tomato');
4426			$q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']);
4427
4428			A large number of routines in CGI.pm actually aren't specifically
4429			defined in the module, but are generated automatically as needed.
4430			These are the "HTML shortcuts," routines that generate HTML tags for
4431			use in dynamically-generated pages. HTML tags have both attributes
4432			(the attribute="value" pairs within the tag itself) and contents (the
4433			part between the opening and closing pairs.) To distinguish between
4434			attributes and contents, CGI.pm uses the convention of passing HTML
4435			attributes as a hash reference as the first argument, and the
4436			contents, if any, as any subsequent arguments. It works out like
4437			this:
4438
4439			Code Generated HTML
4440			---- --------------
4441			h1() <h1>
4442			h1('some','contents'); <h1>some contents</h1>
4443			h1({-align=>left}); <h1 align="LEFT">
4444			h1({-align=>left},'contents'); <h1 align="LEFT">contents</h1>
4445
4446			HTML tags are described in more detail later.
4447
4448			Many newcomers to CGI.pm are puzzled by the difference between the
4449			calling conventions for the HTML shortcuts, which require curly braces
4450			around the HTML tag attributes, and the calling conventions for other
4451			routines, which manage to generate attributes without the curly
4452			brackets. Don't be confused. As a convenience the curly braces are
4453			optional in all but the HTML shortcuts. If you like, you can use
4454			curly braces when calling any routine that takes named arguments. For
4455			example:
4456
4457			print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
4458
4459			If you use the B<-w> switch, you will be warned that some CGI.pm argument
4460			names conflict with built-in Perl functions. The most frequent of
4461			these is the -values argument, used to create multi-valued menus,
4462			radio button clusters and the like. To get around this warning, you
4463			have several choices:
4464
4465			=over 4
4466
4467			=item 1.
4468
4469			Use another name for the argument, if one is available.
4470			For example, -value is an alias for -values.
4471
4472			=item 2.
4473
4474			Change the capitalization, e.g. -Values
4475
4476			=item 3.
4477
4478			Put quotes around the argument name, e.g. '-values'
4479
4480			=back
4481
4482			Many routines will do something useful with a named argument that it
4483			doesn't recognize. For example, you can produce non-standard HTTP
4484			header fields by providing them as named arguments:
4485
4486			print $q->header(-type => 'text/html',
4487			-cost => 'Three smackers',
4488			-annoyance_level => 'high',
4489			-complaints_to => 'bit bucket');
4490
4491			This will produce the following nonstandard HTTP header:
4492
4493			HTTP/1.0 200 OK
4494			Cost: Three smackers
4495			Annoyance-level: high
4496			Complaints-to: bit bucket
4497			Content-type: text/html
4498
4499			Notice the way that underscores are translated automatically into
4500			hyphens. HTML-generating routines perform a different type of
4501			translation.
4502
4503			This feature allows you to keep up with the rapidly changing HTTP and
4504			HTML "standards".
4505
4506			=head2 Creating a new query object (object-oriented style):
4507
4508			$query = CGI->new;
4509
4510			This will parse the input (from POST, GET and DELETE methods) and store
4511			it into a perl5 object called $query.
4512
4513			Any filehandles from file uploads will have their position reset to
4514			the beginning of the file.
4515
4516			=head2 Creating a new query object from an input file
4517
4518			$query = CGI->new(INPUTFILE);
4519
4520			If you provide a file handle to the new() method, it will read
4521			parameters from the file (or STDIN, or whatever). The file can be in
4522			any of the forms describing below under debugging (i.e. a series of
4523			newline delimited TAG=VALUE pairs will work). Conveniently, this type
4524			of file is created by the save() method (see below). Multiple records
4525			can be saved and restored.
4526
4527			Perl purists will be pleased to know that this syntax accepts
4528			references to file handles, or even references to filehandle globs,
4529			which is the "official" way to pass a filehandle:
4530
4531			$query = CGI->new(\*STDIN);
4532
4533			You can also initialize the CGI object with a FileHandle or IO::File
4534			object.
4535
4536			If you are using the function-oriented interface and want to
4537			initialize CGI state from a file handle, the way to do this is with
4538			B<restore_parameters()>. This will (re)initialize the
4539			default CGI object from the indicated file handle.
4540
4541			open (IN,"test.in") \|\| die;
4542			restore_parameters(IN);
4543			close IN;
4544
4545			You can also initialize the query object from a hash
4546			reference:
4547
4548			$query = CGI->new( {'dinosaur'=>'barney',
4549			'song'=>'I love you',
4550			'friends'=>[qw/Jessica George Nancy/]}
4551			);
4552
4553			or from a properly formatted, URL-escaped query string:
4554
4555			$query = CGI->new('dinosaur=barney&color=purple');
4556
4557			or from a previously existing CGI object (currently this clones the
4558			parameter list, but none of the other object-specific fields, such as
4559			autoescaping):
4560
4561			$old_query = CGI->new;
4562			$new_query = CGI->new($old_query);
4563
4564			To create an empty query, initialize it from an empty string or hash:
4565
4566			$empty_query = CGI->new("");
4567
4568			-or-
4569
4570			$empty_query = CGI->new({});
4571
4572			=head2 Fetching a list of keywords from the query:
4573
4574			@keywords = $query->keywords
4575
4576			If the script was invoked as the result of an <ISINDEX> search, the
4577			parsed keywords can be obtained as an array using the keywords() method.
4578
4579			=head2 Fetching the names of all the parameters passed to your script:
4580
4581			@names = $query->multi_param
4582
4583			@names = $query->param
4584
4585			If the script was invoked with a parameter list
4586			(e.g. "name1=value1&name2=value2&name3=value3"), the param() / multi_param()
4587			methods will return the parameter names as a list. If the script was invoked
4588			as an <ISINDEX> script and contains a string without ampersands
4589			(e.g. "value1+value2+value3") , there will be a single parameter named
4590			"keywords" containing the "+"-delimited keywords.
4591
4592			NOTE: As of version 1.5, the array of parameter names returned will
4593			be in the same order as they were submitted by the browser.
4594			Usually this order is the same as the order in which the
4595			parameters are defined in the form (however, this isn't part
4596			of the spec, and so isn't guaranteed).
4597
4598			=head2 Fetching the value or values of a single named parameter:
4599
4600			@values = $query->multi_param('foo');
4601
4602			-or-
4603
4604			$value = $query->param('foo');
4605
4606			Pass the param() / multi_param() method a single argument to fetch the value
4607			of the named parameter. If the parameter is multivalued (e.g. from multiple
4608			selections in a scrolling list), you can ask to receive an array. Otherwise
4609			the method will return a single value.
4610
4611			B<Warning> - calling param() in list context can lead to vulnerabilities if
4612			you do not sanitise user input as it is possible to inject other param
4613			keys and values into your code. This is why the multi_param() method exists,
4614			to make it clear that a list is being returned, note that param() can stil
4615			be called in list context and will return a list for back compatibility.
4616
4617			The following code is an example of a vulnerability as the call to param will
4618			be evaluated in list context and thus possibly inject extra keys and values
4619			into the hash:
4620
4621			my %user_info = (
4622			id => 1,
4623			name => $query->param('name'),
4624			);
4625
4626			The fix for the above is to force scalar context on the call to ->param by
4627			prefixing it with "scalar"
4628
4629			name => scalar $query->param('name'),
4630
4631			If you call param() in list context with an argument a warning will be raised
4632			by CGI.pm, you can disable this warning by setting $CGI::LIST_CONTEXT_WARN to 0
4633			or by using the multi_param() method instead
4634
4635			If a value is not given in the query string, as in the queries
4636			"name1=&name2=", it will be returned as an empty string.
4637
4638			If the parameter does not exist at all, then param() will return undef
4639			in a scalar context, and the empty list in a list context.
4640
4641			=head2 Setting the value(s) of a named parameter:
4642
4643			$query->param('foo','an','array','of','values');
4644
4645			This sets the value for the named parameter 'foo' to an array of
4646			values. This is one way to change the value of a field AFTER
4647			the script has been invoked once before. (Another way is with
4648			the -override parameter accepted by all methods that generate
4649			form elements.)
4650
4651			param() also recognizes a named parameter style of calling described
4652			in more detail later:
4653
4654			$query->param(-name=>'foo',-values=>['an','array','of','values']);
4655
4656			-or-
4657
4658			$query->param(-name=>'foo',-value=>'the value');
4659
4660			=head2 Appending additional values to a named parameter:
4661
4662			$query->append(-name=>'foo',-values=>['yet','more','values']);
4663
4664			This adds a value or list of values to the named parameter. The
4665			values are appended to the end of the parameter if it already exists.
4666			Otherwise the parameter is created. Note that this method only
4667			recognizes the named argument calling syntax.
4668
4669			=head2 Importing all parameters into a namespace:
4670
4671			$query->import_names('R');
4672
4673			This creates a series of variables in the 'R' namespace. For example,
4674			$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
4675			If no namespace is given, this method will assume 'Q'.
4676			WARNING: don't import anything into 'main'; this is a major security
4677			risk!!!!
4678
4679			NOTE 1: Variable names are transformed as necessary into legal Perl
4680			variable names. All non-legal characters are transformed into
4681			underscores. If you need to keep the original names, you should use
4682			the param() method instead to access CGI variables by name.
4683
4684			NOTE 2: In older versions, this method was called B<import()>. As of version 2.20,
4685			this name has been removed completely to avoid conflict with the built-in
4686			Perl module B<import> operator.
4687
4688			=head2 Deleting a parameter completely:
4689
4690			$query->delete('foo','bar','baz');
4691
4692			This completely clears a list of parameters. It sometimes useful for
4693			resetting parameters that you don't want passed down between script
4694			invocations.
4695
4696			If you are using the function call interface, use "Delete()" instead
4697			to avoid conflicts with Perl's built-in delete operator.
4698
4699			=head2 Deleting all parameters:
4700
4701			$query->delete_all();
4702
4703			This clears the CGI object completely. It might be useful to ensure
4704			that all the defaults are taken when you create a fill-out form.
4705
4706			Use Delete_all() instead if you are using the function call interface.
4707
4708			=head2 Handling non-urlencoded arguments
4709
4710
4711			If POSTed data is not of type application/x-www-form-urlencoded or
4712			multipart/form-data, then the POSTed data will not be processed, but
4713			instead be returned as-is in a parameter named POSTDATA. To retrieve
4714			it, use code like this:
4715
4716			my $data = $query->param('POSTDATA');
4717
4718			Likewise if PUTed data can be retrieved with code like this:
4719
4720			my $data = $query->param('PUTDATA');
4721
4722			(If you don't know what the preceding means, don't worry about it. It
4723			only affects people trying to use CGI for XML processing and other
4724			specialized tasks.)
4725
4726			PUTDATA/POSTDATA are also available via
4727			L<upload_hook\|/Progress bars for file uploads and avoiding temp files>,
4728			and as L<file uploads\|/Processing a file upload field> via L</-putdata_upload>
4729			option.
4730
4731			=head2 Direct access to the parameter list:
4732
4733			$q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
4734			unshift @{$q->param_fetch(-name=>'address')},'George Munster';
4735
4736			If you need access to the parameter list in a way that isn't covered
4737			by the methods given in the previous sections, you can obtain a direct
4738			reference to it by
4739			calling the B<param_fetch()> method with the name of the parameter. This
4740			will return an array reference to the named parameter, which you then
4741			can manipulate in any way you like.
4742
4743			You can also use a named argument style using the B<-name> argument.
4744
4745			=head2 Fetching the parameter list as a hash:
4746
4747			$params = $q->Vars;
4748			print $params->{'address'};
4749			@foo = split("\0",$params->{'foo'});
4750			%params = $q->Vars;
4751
4752			use CGI ':cgi-lib';
4753			$params = Vars;
4754
4755			Many people want to fetch the entire parameter list as a hash in which
4756			the keys are the names of the CGI parameters, and the values are the
4757			parameters' values. The Vars() method does this. Called in a scalar
4758			context, it returns the parameter list as a tied hash reference.
4759			Changing a key changes the value of the parameter in the underlying
4760			CGI parameter list. Called in a list context, it returns the
4761			parameter list as an ordinary hash. This allows you to read the
4762			contents of the parameter list, but not to change it.
4763
4764			When using this, the thing you must watch out for are multivalued CGI
4765			parameters. Because a hash cannot distinguish between scalar and
4766			list context, multivalued parameters will be returned as a packed
4767			string, separated by the "\0" (null) character. You must split this
4768			packed string in order to get at the individual values. This is the
4769			convention introduced long ago by Steve Brenner in his cgi-lib.pl
4770			module for Perl version 4.
4771
4772			If you wish to use Vars() as a function, import the I<:cgi-lib> set of
4773			function calls (also see the section on CGI-LIB compatibility).
4774
4775			=head2 Saving the state of the script to a file:
4776
4777			$query->save(\*FILEHANDLE)
4778
4779			This will write the current state of the form to the provided
4780			filehandle. You can read it back in by providing a filehandle
4781			to the new() method. Note that the filehandle can be a file, a pipe,
4782			or whatever!
4783
4784			The format of the saved file is:
4785
4786			NAME1=VALUE1
4787			NAME1=VALUE1'
4788			NAME2=VALUE2
4789			NAME3=VALUE3
4790			=
4791
4792			Both name and value are URL escaped. Multi-valued CGI parameters are
4793			represented as repeated names. A session record is delimited by a
4794			single = symbol. You can write out multiple records and read them
4795			back in with several calls to B<new>. You can do this across several
4796			sessions by opening the file in append mode, allowing you to create
4797			primitive guest books, or to keep a history of users' queries. Here's
4798			a short example of creating multiple session records:
4799
4800			use CGI;
4801
4802			open (OUT,'>>','test.out') \|\| die;
4803			$records = 5;
4804			for (0..$records) {
4805			my $q = CGI->new;
4806			$q->param(-name=>'counter',-value=>$_);
4807			$q->save(\*OUT);
4808			}
4809			close OUT;
4810
4811			# reopen for reading
4812			open (IN,'<','test.out') \|\| die;
4813			while (!eof(IN)) {
4814			my $q = CGI->new(\*IN);
4815			print $q->param('counter'),"\n";
4816			}
4817
4818			The file format used for save/restore is identical to that used by the
4819			Whitehead Genome Center's data exchange format "Boulderio", and can be
4820			manipulated and even databased using Boulderio utilities. See
4821
4822			L<Boulder>
4823
4824			for further details.
4825
4826			If you wish to use this method from the function-oriented (non-OO)
4827			interface, the exported name for this method is B<save_parameters()>.
4828
4829			=head2 Retrieving cgi errors
4830
4831			Errors can occur while processing user input, particularly when
4832			processing uploaded files. When these errors occur, CGI will stop
4833			processing and return an empty parameter list. You can test for
4834			the existence and nature of errors using the I<cgi_error()> function.
4835			The error messages are formatted as HTTP status codes. You can either
4836			incorporate the error text into an HTML page, or use it as the value
4837			of the HTTP status:
4838
4839			my $error = $q->cgi_error;
4840			if ($error) {
4841			print $q->header(-status=>$error),
4842			$q->start_html('Problems'),
4843			$q->h2('Request not processed'),
4844			$q->strong($error);
4845			exit 0;
4846			}
4847
4848			When using the function-oriented interface (see the next section),
4849			errors may only occur the first time you call I<param()>. Be ready
4850			for this!
4851
4852			=head2 Using the function-oriented interface
4853
4854			To use the function-oriented interface, you must specify which CGI.pm
4855			routines or sets of routines to import into your script's namespace.
4856			There is a small overhead associated with this importation, but it
4857			isn't much.
4858
4859			use CGI <list of methods>;
4860
4861			The listed methods will be imported into the current package; you can
4862			call them directly without creating a CGI object first. This example
4863			shows how to import the B<param()> and B<header()>
4864			methods, and then use them directly:
4865
4866			use CGI 'param','header';
4867			print header('text/plain');
4868			$zipcode = param('zipcode');
4869
4870			More frequently, you'll import common sets of functions by referring
4871			to the groups by name. All function sets are preceded with a ":"
4872			character as in ":html3" (for tags defined in the HTML 3 standard).
4873
4874			Here is a list of the function sets you can import:
4875
4876			=over 4
4877
4878			=item B<:cgi>
4879
4880			Import all CGI-handling methods, such as B<param()>, B<path_info()>
4881			and the like.
4882
4883			=item B<:form>
4884
4885			Import all fill-out form generating methods, such as B<textfield()>.
4886
4887			=item B<:html2>
4888
4889			Import all methods that generate HTML 2.0 standard elements.
4890
4891			=item B<:html3>
4892
4893			Import all methods that generate HTML 3.0 elements (such as
4894			<table>, <super> and <sub>).
4895
4896			=item B<:html4>
4897
4898			Import all methods that generate HTML 4 elements (such as
4899			<abbrev>, <acronym> and <thead>).
4900
4901			=item B<:netscape>
4902
4903			Import the <blink>, <fontsize> and <center> tags.
4904
4905			=item B<:html>
4906
4907			Import all HTML-generating shortcuts (i.e. 'html2', 'html3', 'html4' and 'netscape')
4908
4909			=item B<:standard>
4910
4911			Import "standard" features, 'html2', 'html3', 'html4', 'ssl', 'form' and 'cgi'.
4912
4913			=item B<:all>
4914
4915			Import all the available methods. For the full list, see the CGI.pm
4916			code, where the variable %EXPORT_TAGS is defined. (N.B. the :cgi-lib
4917			imports will B<not> be included in the :all import, you will have to
4918			import :cgi-lib to get those)
4919
4920			=back
4921
4922			If you import a function name that is not part of CGI.pm, the module
4923			will treat it as a new HTML tag and generate the appropriate
4924			subroutine. You can then use it like any other HTML tag. This is to
4925			provide for the rapidly-evolving HTML "standard." For example, say
4926			Microsoft comes out with a new tag called <gradient> (which causes the
4927			user's desktop to be flooded with a rotating gradient fill until his
4928			machine reboots). You don't need to wait for a new version of CGI.pm
4929			to start using it immediately:
4930
4931			use CGI qw/:standard :html3 gradient/;
4932			print gradient({-start=>'red',-end=>'blue'});
4933
4934			Note that in the interests of execution speed CGI.pm does B<not> use
4935			the standard L<Exporter> syntax for specifying load symbols. This may
4936			change in the future.
4937
4938			If you import any of the state-maintaining CGI or form-generating
4939			methods, a default CGI object will be created and initialized
4940			automatically the first time you use any of the methods that require
4941			one to be present. This includes B<param()>, B<textfield()>,
4942			B<submit()> and the like. (If you need direct access to the CGI
4943			object, you can find it in the global variable B<$CGI::Q>). By
4944			importing CGI.pm methods, you can create visually elegant scripts:
4945
4946			use CGI qw/:standard/;
4947			print
4948			header,
4949			start_html('Simple Script'),
4950			h1('Simple Script'),
4951			start_form,
4952			"What's your name? ",textfield('name'),p,
4953			"What's the combination?",
4954			checkbox_group(-name=>'words',
4955			-values=>['eenie','meenie','minie','moe'],
4956			-defaults=>['eenie','moe']),p,
4957			"What's your favorite color?",
4958			popup_menu(-name=>'color',
4959			-values=>['red','green','blue','chartreuse']),p,
4960			submit,
4961			end_form,
4962			hr,"\n";
4963
4964			if (param) {
4965			print
4966			"Your name is ",em(param('name')),p,
4967			"The keywords are: ",em(join(", ",param('words'))),p,
4968			"Your favorite color is ",em(param('color')),".\n";
4969			}
4970			print end_html;
4971
4972			=head2 Pragmas
4973
4974			In addition to the function sets, there are a number of pragmas that
4975			you can import. Pragmas, which are always preceded by a hyphen,
4976			change the way that CGI.pm functions in various ways. Pragmas,
4977			function sets, and individual functions can all be imported in the
4978			same use() line. For example, the following use statement imports the
4979			standard set of functions and enables debugging mode (pragma
4980			-debug):
4981
4982			use CGI qw/:standard -debug/;
4983
4984			The current list of pragmas is as follows:
4985
4986			=over 4
4987
4988			=item -any
4989
4990			When you I<use CGI -any>, then any method that the query object
4991			doesn't recognize will be interpreted as a new HTML tag. This allows
4992			you to support the next I<ad hoc> HTML
4993			extension. This lets you go wild with new and unsupported tags:
4994
4995			use CGI qw(-any);
4996			$q=CGI->new;
4997			print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
4998
4999			Since using <cite>any</cite> causes any mistyped method name
5000			to be interpreted as an HTML tag, use it with care or not at
5001			all.
5002
5003			=item -compile
5004
5005			This causes the indicated autoloaded methods to be compiled up front,
5006			rather than deferred to later. This is useful for scripts that run
5007			for an extended period of time under FastCGI or mod_perl, and for
5008			those destined to be crunched by Malcolm Beattie's Perl compiler. Use
5009			it in conjunction with the methods or method families you plan to use.
5010
5011			use CGI qw(-compile :standard :html3);
5012
5013			or even
5014
5015			use CGI qw(-compile :all);
5016
5017			Note that using the -compile pragma in this way will always have
5018			the effect of importing the compiled functions into the current
5019			namespace. If you want to compile without importing use the
5020			compile() method instead:
5021
5022			use CGI();
5023			CGI->compile();
5024
5025			This is particularly useful in a mod_perl environment, in which you
5026			might want to precompile all CGI routines in a startup script, and
5027			then import the functions individually in each mod_perl script.
5028
5029			=item -nosticky
5030
5031			By default the CGI module implements a state-preserving behavior
5032			called "sticky" fields. The way this works is that if you are
5033			regenerating a form, the methods that generate the form field values
5034			will interrogate param() to see if similarly-named parameters are
5035			present in the query string. If they find a like-named parameter, they
5036			will use it to set their default values.
5037
5038			Sometimes this isn't what you want. The B<-nosticky> pragma prevents
5039			this behavior. You can also selectively change the sticky behavior in
5040			each element that you generate.
5041
5042			=item -tabindex
5043
5044			Automatically add tab index attributes to each form field. With this
5045			option turned off, you can still add tab indexes manually by passing a
5046			-tabindex option to each field-generating method.
5047
5048			=item -no_undef_params
5049
5050			This keeps CGI.pm from including undef params in the parameter list.
5051
5052			=item -no_xhtml
5053
5054			By default, CGI.pm versions 2.69 and higher emit XHTML
5055			(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this
5056			feature. Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this
5057			feature.
5058
5059			If start_html()'s -dtd parameter specifies an HTML 2.0,
5060			3.2, 4.0 or 4.01 DTD,
5061			XHTML will automatically be disabled without needing to use this
5062			pragma.
5063
5064			=item -utf8
5065
5066			This makes CGI.pm treat all parameters as text strings rather than binary
5067			strings (see L<perlunitut> for the distinction), assuming UTF-8 for the
5068			encoding.
5069
5070			CGI.pm does the decoding from the UTF-8 encoded input data, restricting this
5071			decoding to input text as distinct from binary upload data which are left
5072			untouched. Therefore, a ':utf8' layer must B<not> be used on STDIN.
5073
5074			If you do not use this option you can manually select which fields are
5075			expected to return utf-8 strings and convert them using code like this:
5076
5077			use Encode;
5078			my $arg = decode utf8=>param('foo');
5079
5080			=item -putdata_upload
5081
5082			Makes C<<< $query->param('PUTDATA'); >>> and C<<< $query->param('POSTDATA'); >>>
5083			act like file uploads named PUTDATA and POSTDATA. See
5084			L</Handling non-urlencoded arguments> and L</Processing a file upload field>
5085			PUTDATA/POSTDATA are also available via
5086			L<upload_hook\|/Progress bars for file uploads and avoiding temp files>.
5087
5088			=item -nph
5089
5090			This makes CGI.pm produce a header appropriate for an NPH (no
5091			parsed header) script. You may need to do other things as well
5092			to tell the server that the script is NPH. See the discussion
5093			of NPH scripts below.
5094
5095			=item -newstyle_urls
5096
5097			Separate the name=value pairs in CGI parameter query strings with
5098			semicolons rather than ampersands. For example:
5099
5100			?name=fred;age=24;favorite_color=3
5101
5102			Semicolon-delimited query strings are always accepted, and will be emitted by
5103			self_url() and query_string(). newstyle_urls became the default in version
5104			2.64.
5105
5106			=item -oldstyle_urls
5107
5108			Separate the name=value pairs in CGI parameter query strings with
5109			ampersands rather than semicolons. This is no longer the default.
5110
5111			=item -autoload
5112
5113			This overrides the autoloader so that any function in your program
5114			that is not recognized is referred to CGI.pm for possible evaluation.
5115			This allows you to use all the CGI.pm functions without adding them to
5116			your symbol table, which is of concern for mod_perl users who are
5117			worried about memory consumption. I<Warning:> when
5118			I<-autoload> is in effect, you cannot use "poetry mode"
5119			(functions without the parenthesis). Use I<hr()> rather
5120			than I<hr>, or add something like I<use subs qw/hr p header/>
5121			to the top of your script.
5122
5123			=item -no_debug
5124
5125			This turns off the command-line processing features. If you want to
5126			run a CGI.pm script from the command line to produce HTML, and you
5127			don't want it to read CGI parameters from the command line or STDIN,
5128			then use this pragma:
5129
5130			use CGI qw(-no_debug :standard);
5131
5132			=item -debug
5133
5134			This turns on full debugging. In addition to reading CGI arguments
5135			from the command-line processing, CGI.pm will pause and try to read
5136			arguments from STDIN, producing the message "(offline mode: enter
5137			name=value pairs on standard input)" features.
5138
5139			See the section on debugging for more details.
5140
5141			=back
5142
5143			=head2 Special forms for importing HTML-tag functions
5144
5145			Many of the methods generate HTML tags. As described below, tag
5146			functions automatically generate both the opening and closing tags.
5147			For example:
5148
5149			print h1('Level 1 Header');
5150
5151			produces
5152
5153			<h1>Level 1 Header</h1>
5154
5155			There will be some times when you want to produce the start and end
5156			tags yourself. In this case, you can use the form start_I<tag_name>
5157			and end_I<tag_name>, as in:
5158
5159			print start_h1,'Level 1 Header',end_h1;
5160
5161			With a few exceptions (described below), start_I<tag_name> and
5162			end_I<tag_name> functions are not generated automatically when you
5163			I<use CGI>. However, you can specify the tags you want to generate
5164			I<start/end> functions for by putting an asterisk in front of their
5165			name, or, alternatively, requesting either "start_I<tag_name>" or
5166			"end_I<tag_name>" in the import list.
5167
5168			Example:
5169
5170			use CGI qw/:standard *table start_ul/;
5171
5172			In this example, the following functions are generated in addition to
5173			the standard ones:
5174
5175			=over 4
5176
5177			=item 1. start_table() (generates a <table> tag)
5178
5179			=item 2. end_table() (generates a </table> tag)
5180
5181			=item 3. start_ul() (generates a <ul> tag)
5182
5183			=item 4. end_ul() (generates a </ul> tag)
5184
5185			=back
5186
5187			=head1 GENERATING DYNAMIC DOCUMENTS
5188
5189			Most of CGI.pm's functions deal with creating documents on the fly.
5190			Generally you will produce the HTTP header first, followed by the
5191			document itself. CGI.pm provides functions for generating HTTP
5192			headers of various types as well as for generating HTML. For creating
5193			GIF images, see the GD.pm module.
5194
5195			Each of these functions produces a fragment of HTML or HTTP which you
5196			can print out directly so that it displays in the browser window,
5197			append to a string, or save to a file for later use.
5198
5199			=head2 Creating a standard http header:
5200
5201			Normally the first thing you will do in any CGI script is print out an
5202			HTTP header. This tells the browser what type of document to expect,
5203			and gives other optional information, such as the language, expiration
5204			date, and whether to cache the document. The header can also be
5205			manipulated for special purposes, such as server push and pay per view
5206			pages.
5207
5208			print header;
5209
5210			-or-
5211
5212			print header('image/gif');
5213
5214			-or-
5215
5216			print header('text/html','204 No response');
5217
5218			-or-
5219
5220			print header(-type=>'image/gif',
5221			-nph=>1,
5222			-status=>'402 Payment required',
5223			-expires=>'+3d',
5224			-cookie=>$cookie,
5225			-charset=>'utf-7',
5226			-attachment=>'foo.gif',
5227			-Cost=>'$2.00');
5228
5229			header() returns the Content-type: header. You can provide your own
5230			MIME type if you choose, otherwise it defaults to text/html. An
5231			optional second parameter specifies the status code and a human-readable
5232			message. For example, you can specify 204, "No response" to create a
5233			script that tells the browser to do nothing at all. Note that RFC 2616 expects
5234			the human-readable phase to be there as well as the numeric status code.
5235
5236			The last example shows the named argument style for passing arguments
5237			to the CGI methods using named parameters. Recognized parameters are
5238			B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named
5239			parameters will be stripped of their initial hyphens and turned into
5240			header fields, allowing you to specify any HTTP header you desire.
5241			Internal underscores will be turned into hyphens:
5242
5243			print header(-Content_length=>3002);
5244
5245			Most browsers will not cache the output from CGI scripts. Every time
5246			the browser reloads the page, the script is invoked anew. You can
5247			change this behavior with the B<-expires> parameter. When you specify
5248			an absolute or relative expiration interval with this parameter, some
5249			browsers and proxy servers will cache the script's output until the
5250			indicated expiration date. The following forms are all valid for the
5251			-expires field:
5252
5253			+30s 30 seconds from now
5254			+10m ten minutes from now
5255			+1h one hour from now
5256			-1d yesterday (i.e. "ASAP!")
5257			now immediately
5258			+3M in three months
5259			+10y in ten years time
5260			Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date
5261
5262			The B<-cookie> parameter generates a header that tells the browser to provide
5263			a "magic cookie" during all subsequent transactions with your script.
5264			Some cookies have a special format that includes interesting attributes
5265			such as expiration time. Use the cookie() method to create and retrieve
5266			session cookies.
5267
5268			The B<-nph> parameter, if set to a true value, will issue the correct
5269			headers to work with a NPH (no-parse-header) script. This is important
5270			to use with certain servers that expect all their scripts to be NPH.
5271
5272			The B<-charset> parameter can be used to control the character set
5273			sent to the browser. If not provided, defaults to ISO-8859-1. As a
5274			side effect, this sets the charset() method as well. B<Note> that the
5275			default being ISO-8859-1 may not make sense for all content types, e.g.:
5276
5277			Content-Type: image/gif; charset=ISO-8859-1
5278
5279			In the above case you need to pass -charset => '' to prevent the default
5280			being used.
5281
5282			The B<-attachment> parameter can be used to turn the page into an
5283			attachment. Instead of displaying the page, some browsers will prompt
5284			the user to save it to disk. The value of the argument is the
5285			suggested name for the saved file. In order for this to work, you may
5286			have to set the B<-type> to "application/octet-stream".
5287
5288			The B<-p3p> parameter will add a P3P tag to the outgoing header. The
5289			parameter can be an arrayref or a space-delimited string of P3P tags.
5290			For example:
5291
5292			print header(-p3p=>[qw(CAO DSP LAW CURa)]);
5293			print header(-p3p=>'CAO DSP LAW CURa');
5294
5295			In either case, the outgoing header will be formatted as:
5296
5297			P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"
5298
5299			CGI.pm will accept valid multi-line headers when each line is separated with a
5300			CRLF value ("\r\n" on most platforms) followed by at least one space. For example:
5301
5302			print header( -ingredients => "ham\r\n\seggs\r\n\sbacon" );
5303
5304			Invalid multi-line header input will trigger in an exception. When multi-line headers
5305			are received, CGI.pm will always output them back as a single line, according to the
5306			folding rules of RFC 2616: the newlines will be removed, while the white space remains.
5307
5308			=head2 Generating a redirection header
5309
5310			print $q->redirect('http://somewhere.else/in/movie/land');
5311
5312			Sometimes you don't want to produce a document yourself, but simply
5313			redirect the browser elsewhere, perhaps choosing a URL based on the
5314			time of day or the identity of the user.
5315
5316			The redirect() method redirects the browser to a different URL. If
5317			you use redirection like this, you should B<not> print out a header as
5318			well.
5319
5320			You should always use full URLs (including the http: or ftp: part) in
5321			redirection requests. Relative URLs will not work correctly.
5322
5323			You can also use named arguments:
5324
5325			print $q->redirect(
5326			-uri=>'http://somewhere.else/in/movie/land',
5327			-nph=>1,
5328			-status=>'301 Moved Permanently');
5329
5330			All names arguments recognized by header() are also recognized by
5331			redirect(). However, most HTTP headers, including those generated by
5332			-cookie and -target, are ignored by the browser.
5333
5334			The B<-nph> parameter, if set to a true value, will issue the correct
5335			headers to work with a NPH (no-parse-header) script. This is important
5336			to use with certain servers, such as Microsoft IIS, which
5337			expect all their scripts to be NPH.
5338
5339			The B<-status> parameter will set the status of the redirect. HTTP
5340			defines three different possible redirection status codes:
5341
5342			301 Moved Permanently
5343			302 Found
5344			303 See Other
5345
5346			The default if not specified is 302, which means "moved temporarily."
5347			You may change the status to another status code if you wish. Be
5348			advised that changing the status to anything other than 301, 302 or
5349			303 will probably break redirection.
5350
5351			Note that the human-readable phrase is also expected to be present to conform
5352			with RFC 2616, section 6.1.
5353
5354			=head2 Creating the HTML document header
5355
5356			print start_html(-title=>'Secrets of the Pyramids',
5357			-author=>'fred@capricorn.org',
5358			-base=>'true',
5359			-target=>'_blank',
5360			-meta=>{'keywords'=>'pharaoh secret mummy',
5361			'copyright'=>'copyright 1996 King Tut'},
5362			-style=>{'src'=>'/styles/style1.css'},
5363			-BGCOLOR=>'blue');
5364
5365			The start_html() routine creates the top of the
5366			page, along with a lot of optional information that controls the
5367			page's appearance and behavior.
5368
5369			This method returns a canned HTML header and the opening <body> tag.
5370			All parameters are optional. In the named parameter form, recognized
5371			parameters are -title, -author, -base, -xbase, -dtd, -lang and -target
5372			(see below for the explanation). Any additional parameters you
5373			provide, such as the unofficial BGCOLOR attribute, are added
5374			to the <body> tag. Additional parameters must be proceeded by a
5375			hyphen.
5376
5377			The argument B<-xbase> allows you to provide an HREF for the <base> tag
5378			different from the current location, as in
5379
5380			-xbase=>"http://home.mcom.com/"
5381
5382			All relative links will be interpreted relative to this tag.
5383
5384			The argument B<-target> allows you to provide a default target frame
5385			for all the links and fill-out forms on the page. B<This is a
5386			non-standard HTTP feature which only works with some browsers!>
5387
5388			-target=>"answer_window"
5389
5390			All relative links will be interpreted relative to this tag.
5391			You add arbitrary meta information to the header with the B<-meta>
5392			argument. This argument expects a reference to a hash
5393			containing name/value pairs of meta information. These will be turned
5394			into a series of header <meta> tags that look something like this:
5395
5396			<meta name="keywords" content="pharaoh secret mummy">
5397			<meta name="description" content="copyright 1996 King Tut">
5398
5399			To create an HTTP-EQUIV type of <meta> tag, use B<-head>, described
5400			below.
5401
5402			The B<-style> argument is used to incorporate cascading stylesheets
5403			into your code. See the section on CASCADING STYLESHEETS for more
5404			information.
5405
5406			The B<-lang> argument is used to incorporate a language attribute into
5407			the <html> tag. For example:
5408
5409			print $q->start_html(-lang=>'fr-CA');
5410
5411			The default if not specified is "en-US" for US English, unless the
5412			-dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the
5413			lang attribute is left off. You can force the lang attribute to left
5414			off in other cases by passing an empty string (-lang=>'').
5415
5416			The B<-encoding> argument can be used to specify the character set for
5417			XHTML. It defaults to iso-8859-1 if not specified.
5418
5419			The B<-dtd> argument can be used to specify a public DTD identifier string. For example:
5420
5421			-dtd => '-//W3C//DTD HTML 4.01 Transitional//EN')
5422
5423			Alternatively, it can take public and system DTD identifiers as an array:
5424
5425			dtd => [ '-//W3C//DTD HTML 4.01 Transitional//EN', 'http://www.w3.org/TR/html4/loose.dtd' ]
5426
5427			For the public DTD identifier to be considered, it must be valid. Otherwise it
5428			will be replaced by the default DTD. If the public DTD contains 'XHTML', CGI.pm
5429			will emit XML.
5430
5431			The B<-declare_xml> argument, when used in conjunction with XHTML,
5432			will put a <?xml> declaration at the top of the HTML header. The sole
5433			purpose of this declaration is to declare the character set
5434			encoding. In the absence of -declare_xml, the output HTML will contain
5435			a <meta> tag that specifies the encoding, allowing the HTML to pass
5436			most validators. The default for -declare_xml is false.
5437
5438			You can place other arbitrary HTML elements to the <head> section with the
5439			B<-head> tag. For example, to place a <link> element in the
5440			head section, use this:
5441
5442			print start_html(-head=>Link({-rel=>'shortcut icon',
5443			-href=>'favicon.ico'}));
5444
5445			To incorporate multiple HTML elements into the <head> section, just pass an
5446			array reference:
5447
5448			print start_html(-head=>[
5449			Link({-rel=>'next',
5450			-href=>'http://www.capricorn.com/s2.html'}),
5451			Link({-rel=>'previous',
5452			-href=>'http://www.capricorn.com/s1.html'})
5453			]
5454			);
5455
5456			And here's how to create an HTTP-EQUIV <meta> tag:
5457
5458			print start_html(-head=>meta({-http_equiv => 'Content-Type',
5459			-content => 'text/html'}))
5460
5461
5462			JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
5463			B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
5464			to add JavaScript calls to your pages. B<-script> should
5465			point to a block of text containing JavaScript function definitions.
5466			This block will be placed within a <script> block inside the HTML (not
5467			HTTP) header. The block is placed in the header in order to give your
5468			page a fighting chance of having all its JavaScript functions in place
5469			even if the user presses the stop button before the page has loaded
5470			completely. CGI.pm attempts to format the script in such a way that
5471			JavaScript-naive browsers will not choke on the code: unfortunately
5472			there are some browsers, such as Chimera for Unix, that get confused
5473			by it nevertheless.
5474
5475			The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
5476			code to execute when the page is respectively opened and closed by the
5477			browser. Usually these parameters are calls to functions defined in the
5478			B<-script> field:
5479
5480			$query = CGI->new;
5481			print header;
5482			$JSCRIPT=<<END;
5483			// Ask a silly question
5484			function riddle_me_this() {
5485			var r = prompt("What walks on four legs in the morning, " +
5486			"two legs in the afternoon, " +
5487			"and three legs in the evening?");
5488			response(r);
5489			}
5490			// Get a silly answer
5491			function response(answer) {
5492			if (answer == "man")
5493			alert("Right you are!");
5494			else
5495			alert("Wrong! Guess again.");
5496			}
5497			END
5498			print start_html(-title=>'The Riddle of the Sphinx',
5499			-script=>$JSCRIPT);
5500
5501			Use the B<-noScript> parameter to pass some HTML text that will be displayed on
5502			browsers that do not have JavaScript (or browsers where JavaScript is turned
5503			off).
5504
5505			The <script> tag, has several attributes including "type", "charset" and "src".
5506			"src" allows you to keep JavaScript code in an external file. To use these
5507			attributes pass a HASH reference in the B<-script> parameter containing one or
5508			more of -type, -src, or -code:
5509
5510			print $q->start_html(-title=>'The Riddle of the Sphinx',
5511			-script=>{-type=>'JAVASCRIPT',
5512			-src=>'/javascript/sphinx.js'}
5513			);
5514
5515			print $q->(-title=>'The Riddle of the Sphinx',
5516			-script=>{-type=>'PERLSCRIPT',
5517			-code=>'print "hello world!\n;"'}
5518			);
5519
5520
5521			A final feature allows you to incorporate multiple <script> sections into the
5522			header. Just pass the list of script sections as an array reference.
5523			this allows you to specify different source files for different dialects
5524			of JavaScript. Example:
5525
5526			print $q->start_html(-title=>'The Riddle of the Sphinx',
5527			-script=>[
5528			{ -type => 'text/javascript',
5529			-src => '/javascript/utilities10.js'
5530			},
5531			{ -type => 'text/javascript',
5532			-src => '/javascript/utilities11.js'
5533			},
5534			{ -type => 'text/jscript',
5535			-src => '/javascript/utilities12.js'
5536			},
5537			{ -type => 'text/ecmascript',
5538			-src => '/javascript/utilities219.js'
5539			}
5540			]
5541			);
5542
5543			The option "-language" is a synonym for -type, and is supported for
5544			backwards compatibility.
5545
5546			The old-style positional parameters are as follows:
5547
5548			B<Parameters:>
5549
5550			=over 4
5551
5552			=item 1.
5553
5554			The title
5555
5556			=item 2.
5557
5558			The author's e-mail address (will create a <link rev="MADE"> tag if present
5559
5560			=item 3.
5561
5562			A 'true' flag if you want to include a <base> tag in the header. This
5563			helps resolve relative addresses to absolute ones when the document is moved,
5564			but makes the document hierarchy non-portable. Use with care!
5565
5566			=back
5567
5568			Other parameters you want to include in the <body> tag may be appended
5569			to these. This is a good place to put HTML extensions, such as colors and
5570			wallpaper patterns.
5571
5572			=head2 Ending the Html document:
5573
5574			print $q->end_html;
5575
5576			This ends an HTML document by printing the </body></html> tags.
5577
5578			=head2 Creating a self-referencing url that preserves state information:
5579
5580			$myself = $q->self_url;
5581			print q(<a href="$myself">I'm talking to myself.</a>);
5582
5583			self_url() will return a URL, that, when selected, will reinvoke
5584			this script with all its state information intact. This is most
5585			useful when you want to jump around within the document using
5586			internal anchors but you don't want to disrupt the current contents
5587			of the form(s). Something like this will do the trick.
5588
5589			$myself = $q->self_url;
5590			print "<a href=\"$myself#table1\">See table 1</a>";
5591			print "<a href=\"$myself#table2\">See table 2</a>";
5592			print "<a href=\"$myself#yourself\">See for yourself</a>";
5593
5594			If you want more control over what's returned, using the B<url()>
5595			method instead.
5596
5597			You can also retrieve a query string representation of the current object
5598			state with query_string():
5599
5600			$the_string = $q->query_string();
5601
5602			The behavior of calling query_string is currently undefined when the HTTP method is
5603			something other than GET.
5604
5605			=head2 Obtaining the script's url
5606
5607			$full_url = url();
5608			$full_url = url(-full=>1); #alternative syntax
5609			$relative_url = url(-relative=>1);
5610			$absolute_url = url(-absolute=>1);
5611			$url_with_path = url(-path_info=>1);
5612			$url_with_path_and_query = url(-path_info=>1,-query=>1);
5613			$netloc = url(-base => 1);
5614
5615			B<url()> returns the script's URL in a variety of formats. Called
5616			without any arguments, it returns the full form of the URL, including
5617			host name and port number
5618
5619			http://your.host.com/path/to/script.cgi
5620
5621			You can modify this format with the following named arguments:
5622
5623			=over 4
5624
5625			=item B<-absolute>
5626
5627			If true, produce an absolute URL, e.g.
5628
5629			/path/to/script.cgi
5630
5631			=item B<-relative>
5632
5633			Produce a relative URL. This is useful if you want to reinvoke your
5634			script with different parameters. For example:
5635
5636			script.cgi
5637
5638			=item B<-full>
5639
5640			Produce the full URL, exactly as if called without any arguments.
5641			This overrides the -relative and -absolute arguments.
5642
5643			=item B<-path> (B<-path_info>)
5644
5645			Append the additional path information to the URL. This can be
5646			combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info>
5647			is provided as a synonym.
5648
5649			=item B<-query> (B<-query_string>)
5650
5651			Append the query string to the URL. This can be combined with
5652			B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
5653			as a synonym.
5654
5655			=item B<-base>
5656
5657			Generate just the protocol and net location, as in http://www.foo.com:8000
5658
5659			=item B<-rewrite>
5660
5661			If Apache's mod_rewrite is turned on, then the script name and path
5662			info probably won't match the request that the user sent. Set
5663			-rewrite=>1 (default) to return URLs that match what the user sent
5664			(the original request URI). Set -rewrite=>0 to return URLs that match
5665			the URL after mod_rewrite's rules have run.
5666
5667			=back
5668
5669			=head2 Mixing post and url parameters
5670
5671			$color = url_param('color');
5672
5673			It is possible for a script to receive CGI parameters in the URL as
5674			well as in the fill-out form by creating a form that POSTs to a URL
5675			containing a query string (a "?" mark followed by arguments). The
5676			B<param()> method will always return the contents of the POSTed
5677			fill-out form, ignoring the URL's query string. To retrieve URL
5678			parameters, call the B<url_param()> method. Use it in the same way as
5679			B<param()>. The main difference is that it allows you to read the
5680			parameters, but not set them.
5681
5682
5683			Under no circumstances will the contents of the URL query string
5684			interfere with similarly-named CGI parameters in POSTed forms. If you
5685			try to mix a URL query string with a form submitted with the GET
5686			method, the results will not be what you expect.
5687
5688			=head1 CREATING STANDARD HTML ELEMENTS:
5689
5690			CGI.pm defines general HTML shortcut methods for many HTML tags. HTML shortcuts are named after a single
5691			HTML element and return a fragment of HTML text. Example:
5692
5693			print $q->blockquote(
5694			"Many years ago on the island of",
5695			$q->a({href=>"http://crete.org/"},"Crete"),
5696			"there lived a Minotaur named",
5697			$q->strong("Fred."),
5698			),
5699			$q->hr;
5700
5701			This results in the following HTML code (extra newlines have been
5702			added for readability):
5703
5704			<blockquote>
5705			Many years ago on the island of
5706			<a href="http://crete.org/">Crete</a> there lived
5707			a minotaur named <strong>Fred.</strong>
5708			</blockquote>
5709			<hr>
5710
5711			If you find the syntax for calling the HTML shortcuts awkward, you can
5712			import them into your namespace and dispense with the object syntax
5713			completely (see the next section for more details):
5714
5715			use CGI ':standard';
5716			print blockquote(
5717			"Many years ago on the island of",
5718			a({href=>"http://crete.org/"},"Crete"),
5719			"there lived a minotaur named",
5720			strong("Fred."),
5721			),
5722			hr;
5723
5724			=head2 Providing arguments to HTML shortcuts
5725
5726			The HTML methods will accept zero, one or multiple arguments. If you
5727			provide no arguments, you get a single tag:
5728
5729			print hr; # <hr>
5730
5731			If you provide one or more string arguments, they are concatenated
5732			together with spaces and placed between opening and closing tags:
5733
5734			print h1("Chapter","1"); # <h1>Chapter 1</h1>"
5735
5736			If the first argument is a hash reference, then the keys
5737			and values of the hash become the HTML tag's attributes:
5738
5739			print a({-href=>'fred.html',-target=>'_new'},
5740			"Open a new frame");
5741
5742			<a href="fred.html",target="_new">Open a new frame</a>
5743
5744			You may dispense with the dashes in front of the attribute names if
5745			you prefer:
5746
5747			print img {src=>'fred.gif',align=>'LEFT'};
5748
5749			<img align="LEFT" src="fred.gif">
5750
5751			Sometimes an HTML tag attribute has no argument. For example, ordered
5752			lists can be marked as COMPACT. The syntax for this is an argument that
5753			that points to an undef string:
5754
5755			print ol({compact=>undef},li('one'),li('two'),li('three'));
5756
5757			Prior to CGI.pm version 2.41, providing an empty ('') string as an
5758			attribute argument was the same as providing undef. However, this has
5759			changed in order to accommodate those who want to create tags of the form
5760			<img alt="">. The difference is shown in these two pieces of code:
5761
5762			CODE RESULT
5763			img({alt=>undef}) <img alt>
5764			img({alt=>''}) <img alt="">
5765
5766			=head2 The distributive property of HTML shortcuts
5767
5768			One of the cool features of the HTML shortcuts is that they are
5769			distributive. If you give them an argument consisting of a
5770			B<reference> to a list, the tag will be distributed across each
5771			element of the list. For example, here's one way to make an ordered
5772			list:
5773
5774			print ul(
5775			li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy'])
5776			);
5777
5778			This example will result in HTML output that looks like this:
5779
5780			<ul>
5781			<li type="disc">Sneezy</li>
5782			<li type="disc">Doc</li>
5783			<li type="disc">Sleepy</li>
5784			<li type="disc">Happy</li>
5785			</ul>
5786
5787			This is extremely useful for creating tables. For example:
5788
5789			print table({-border=>undef},
5790			caption('When Should You Eat Your Vegetables?'),
5791			Tr({-align=>'CENTER',-valign=>'TOP'},
5792			[
5793			th(['Vegetable', 'Breakfast','Lunch','Dinner']),
5794			td(['Tomatoes' , 'no', 'yes', 'yes']),
5795			td(['Broccoli' , 'no', 'no', 'yes']),
5796			td(['Onions' , 'yes','yes', 'yes'])
5797			]
5798			)
5799			);
5800
5801			=head2 HTML shortcuts and list interpolation
5802
5803			Consider this bit of code:
5804
5805			print blockquote(em('Hi'),'mom!'));
5806
5807			It will ordinarily return the string that you probably expect, namely:
5808
5809			<blockquote><em>Hi</em> mom!</blockquote>
5810
5811			Note the space between the element "Hi" and the element "mom!".
5812			CGI.pm puts the extra space there using array interpolation, which is
5813			controlled by the magic $" variable. Sometimes this extra space is
5814			not what you want, for example, when you are trying to align a series
5815			of images. In this case, you can simply change the value of $" to an
5816			empty string.
5817
5818			{
5819			local($") = '';
5820			print blockquote(em('Hi'),'mom!'));
5821			}
5822
5823			I suggest you put the code in a block as shown here. Otherwise the
5824			change to $" will affect all subsequent code until you explicitly
5825			reset it.
5826
5827			=head2 Non-standard HTML shortcuts
5828
5829			A few HTML tags don't follow the standard pattern for various
5830			reasons.
5831
5832			B<comment()> generates an HTML comment (<!-- comment -->). Call it
5833			like
5834
5835			print comment('here is my comment');
5836
5837			Because of conflicts with built-in Perl functions, the following functions
5838			begin with initial caps:
5839
5840			Select
5841			Tr
5842			Link
5843			Delete
5844			Accept
5845			Sub
5846
5847			In addition, start_html(), end_html(), start_form(), end_form(),
5848			start_multipart_form() and all the fill-out form tags are special.
5849			See their respective sections.
5850
5851			=head2 Autoescaping HTML
5852
5853			By default, all HTML that is emitted by the form-generating functions
5854			is passed through a function called escapeHTML():
5855
5856			=over 4
5857
5858			=item $escaped_string = escapeHTML("unescaped string");
5859
5860			Escape HTML formatting characters in a string.
5861
5862			=back
5863
5864			Provided that you have specified a character set of ISO-8859-1 (the
5865			default), the standard HTML escaping rules will be used. The "<"
5866			character becomes "<", ">" becomes ">", "&" becomes "&", and
5867			the quote character becomes """. In addition, the hexadecimal
5868			0x8b and 0x9b characters, which some browsers incorrectly interpret
5869			as the left and right angle-bracket characters, are replaced by their
5870			numeric character entities ("&#8249" and "›").
5871
5872			C<escapeHTML()> expects the supplied string to be a character string. This means you
5873			should Encode::decode data received from "outside" and Encode::encode your
5874			strings before sending them back outside. If your source code UTF-8 encoded and
5875			you want to upgrade string literals in your source to character strings, you
5876			can use "use utf8". See L<perlunitut>, L<perlunifaq> and L<perlunicode> for more
5877			information on how Perl handles the difference between bytes and characters.
5878
5879			The automatic escaping does not apply to other shortcuts, such as
5880			h1(). You should call escapeHTML() yourself on untrusted data in
5881			order to protect your pages against nasty tricks that people may enter
5882			into guestbooks, etc.. To change the character set, use charset().
5883			To turn autoescaping off completely, use autoEscape(0):
5884
5885			=over 4
5886
5887			=item $charset = charset([$charset]);
5888
5889			Get or set the current character set.
5890
5891			=item $flag = autoEscape([$flag]);
5892
5893			Get or set the value of the autoescape flag.
5894
5895			=back
5896
5897			=head2 Pretty-printing HTML
5898
5899			By default, all the HTML produced by these functions comes out as one
5900			long line without carriage returns or indentation. This is yuck, but
5901			it does reduce the size of the documents by 10-20%. To get
5902			pretty-printed output, please use L<CGI::Pretty>, a subclass
5903			contributed by Brian Paulsen.
5904
5905			=head1 CREATING FILL-OUT FORMS:
5906
5907			I<General note> The various form-creating methods all return strings
5908			to the caller, containing the tag or tags that will create the requested
5909			form element. You are responsible for actually printing out these strings.
5910			It's set up this way so that you can place formatting tags
5911			around the form elements.
5912
5913			I<Another note> The default values that you specify for the forms are only
5914			used the B<first> time the script is invoked (when there is no query
5915			string). On subsequent invocations of the script (when there is a query
5916			string), the former values are used even if they are blank.
5917
5918			If you want to change the value of a field from its previous value, you have two
5919			choices:
5920
5921			(1) call the param() method to set it.
5922
5923			(2) use the -override (alias -force) parameter (a new feature in version 2.15).
5924			This forces the default value to be used, regardless of the previous value:
5925
5926			print textfield(-name=>'field_name',
5927			-default=>'starting value',
5928			-override=>1,
5929			-size=>50,
5930			-maxlength=>80);
5931
5932			I<Yet another note> By default, the text and labels of form elements are
5933			escaped according to HTML rules. This means that you can safely use
5934			"<CLICK ME>" as the label for a button. However, it also interferes with
5935			your ability to incorporate special HTML character sequences, such as Á,
5936			into your fields. If you wish to turn off automatic escaping, call the
5937			autoEscape() method with a false value immediately after creating the CGI object:
5938
5939			$query = CGI->new;
5940			$query->autoEscape(0);
5941
5942			Note that autoEscape() is exclusively used to effect the behavior of how some
5943			CGI.pm HTML generation functions handle escaping. Calling escapeHTML()
5944			explicitly will always escape the HTML.
5945
5946			I<A Lurking Trap!> Some of the form-element generating methods return
5947			multiple tags. In a scalar context, the tags will be concatenated
5948			together with spaces, or whatever is the current value of the $"
5949			global. In a list context, the methods will return a list of
5950			elements, allowing you to modify them if you wish. Usually you will
5951			not notice this behavior, but beware of this:
5952
5953			printf("%s\n",end_form())
5954
5955			end_form() produces several tags, and only the first of them will be
5956			printed because the format only expects one value.
5957
5958			<p>
5959
5960
5961			=head2 Creating an isindex tag
5962
5963			print isindex(-action=>$action);
5964
5965			-or-
5966
5967			print isindex($action);
5968
5969			Prints out an <isindex> tag. Not very exciting. The parameter
5970			-action specifies the URL of the script to process the query. The
5971			default is to process the query with the current script.
5972
5973			=head2 Starting and ending a form
5974
5975			print start_form(-method=>$method,
5976			-action=>$action,
5977			-enctype=>$encoding);
5978			<... various form stuff ...>
5979			print end_form;
5980
5981			-or-
5982
5983			print start_form($method,$action,$encoding);
5984			<... various form stuff ...>
5985			print end_form;
5986
5987			start_form() will return a <form> tag with the optional method,
5988			action and form encoding that you specify. The defaults are:
5989
5990			method: POST
5991			action: this script
5992			enctype: application/x-www-form-urlencoded for non-XHTML
5993			multipart/form-data for XHTML, see multipart/form-data below.
5994
5995			end_form() returns the closing </form> tag.
5996
5997			start_form()'s enctype argument tells the browser how to package the various
5998			fields of the form before sending the form to the server. Two
5999			values are possible:
6000
6001			=over 4
6002
6003			=item B<application/x-www-form-urlencoded>
6004
6005			This is the older type of encoding. It is compatible with many CGI scripts and is
6006			suitable for short fields containing text data. For your
6007			convenience, CGI.pm stores the name of this encoding
6008			type in B<&CGI::URL_ENCODED>.
6009
6010			=item B<multipart/form-data>
6011
6012			This is the newer type of encoding.
6013			It is suitable for forms that contain very large fields or that
6014			are intended for transferring binary data. Most importantly,
6015			it enables the "file upload" feature. For
6016			your convenience, CGI.pm stores the name of this encoding type
6017			in B<&CGI::MULTIPART>
6018
6019			Forms that use this type of encoding are not easily interpreted
6020			by CGI scripts unless they use CGI.pm or another library designed
6021			to handle them.
6022
6023			If XHTML is activated (the default), then forms will be automatically
6024			created using this type of encoding.
6025
6026			=back
6027
6028			The start_form() method uses the older form of encoding by
6029			default unless XHTML is requested. If you want to use the
6030			newer form of encoding by default, you can call
6031			B<start_multipart_form()> instead of B<start_form()>. The
6032			method B<end_multipart_form()> is an alias to B<end_form()>.
6033
6034			JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
6035			for use with JavaScript. The -name parameter gives the
6036			form a name so that it can be identified and manipulated by
6037			JavaScript functions. -onSubmit should point to a JavaScript
6038			function that will be executed just before the form is submitted to your
6039			server. You can use this opportunity to check the contents of the form
6040			for consistency and completeness. If you find something wrong, you
6041			can put up an alert box or maybe fix things up yourself. You can
6042			abort the submission by returning false from this function.
6043
6044			Usually the bulk of JavaScript functions are defined in a <script>
6045			block in the HTML header and -onSubmit points to one of these function
6046			call. See start_html() for details.
6047
6048			=head2 Form elements
6049
6050			After starting a form, you will typically create one or more
6051			textfields, popup menus, radio groups and other form elements. Each
6052			of these elements takes a standard set of named arguments. Some
6053			elements also have optional arguments. The standard arguments are as
6054			follows:
6055
6056			=over 4
6057
6058			=item B<-name>
6059
6060			The name of the field. After submission this name can be used to
6061			retrieve the field's value using the param() method.
6062
6063			=item B<-value>, B<-values>
6064
6065			The initial value of the field which will be returned to the script
6066			after form submission. Some form elements, such as text fields, take
6067			a single scalar -value argument. Others, such as popup menus, take a
6068			reference to an array of values. The two arguments are synonyms.
6069
6070			=item B<-tabindex>
6071
6072			A numeric value that sets the order in which the form element receives
6073			focus when the user presses the tab key. Elements with lower values
6074			receive focus first.
6075
6076			=item B<-id>
6077
6078			A string identifier that can be used to identify this element to
6079			JavaScript and DHTML.
6080
6081			=item B<-override>
6082
6083			A boolean, which, if true, forces the element to take on the value
6084			specified by B<-value>, overriding the sticky behavior described
6085			earlier for the B<-nosticky> pragma.
6086
6087			=item B<-onChange>, B<-onFocus>, B<-onBlur>, B<-onMouseOver>, B<-onMouseOut>, B<-onSelect>
6088
6089			These are used to assign JavaScript event handlers. See the
6090			JavaScripting section for more details.
6091
6092			=back
6093
6094			Other common arguments are described in the next section. In addition
6095			to these, all attributes described in the HTML specifications are
6096			supported.
6097
6098			=head2 Creating a text field
6099
6100			print textfield(-name=>'field_name',
6101			-value=>'starting value',
6102			-size=>50,
6103			-maxlength=>80);
6104			-or-
6105
6106			print textfield('field_name','starting value',50,80);
6107
6108			textfield() will return a text input field.
6109
6110			B<Parameters>
6111
6112			=over 4
6113
6114			=item 1.
6115
6116			The first parameter is the required name for the field (-name).
6117
6118			=item 2.
6119
6120			The optional second parameter is the default starting value for the field
6121			contents (-value, formerly known as -default).
6122
6123			=item 3.
6124
6125			The optional third parameter is the size of the field in
6126			characters (-size).
6127
6128			=item 4.
6129
6130			The optional fourth parameter is the maximum number of characters the
6131			field will accept (-maxlength).
6132
6133			=back
6134
6135			As with all these methods, the field will be initialized with its
6136			previous contents from earlier invocations of the script.
6137			When the form is processed, the value of the text field can be
6138			retrieved with:
6139
6140			$value = param('foo');
6141
6142			If you want to reset it from its initial value after the script has been
6143			called once, you can do so like this:
6144
6145			param('foo',"I'm taking over this value!");
6146
6147			=head2 Creating a big text field
6148
6149			print textarea(-name=>'foo',
6150			-default=>'starting value',
6151			-rows=>10,
6152			-columns=>50);
6153
6154			-or
6155
6156			print textarea('foo','starting value',10,50);
6157
6158			textarea() is just like textfield, but it allows you to specify
6159			rows and columns for a multiline text entry box. You can provide
6160			a starting value for the field, which can be long and contain
6161			multiple lines.
6162
6163			=head2 Creating a password field
6164
6165			print password_field(-name=>'secret',
6166			-value=>'starting value',
6167			-size=>50,
6168			-maxlength=>80);
6169			-or-
6170
6171			print password_field('secret','starting value',50,80);
6172
6173			password_field() is identical to textfield(), except that its contents
6174			will be starred out on the web page.
6175
6176			=head2 Creating a file upload field
6177
6178			print filefield(-name=>'uploaded_file',
6179			-default=>'starting value',
6180			-size=>50,
6181			-maxlength=>80);
6182			-or-
6183
6184			print filefield('uploaded_file','starting value',50,80);
6185
6186			filefield() will return a file upload field.
6187			In order to take full advantage of this I<you must use the new
6188			multipart encoding scheme> for the form. You can do this either
6189			by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>,
6190			or by calling the new method B<start_multipart_form()> instead of
6191			vanilla B<start_form()>.
6192
6193			B<Parameters>
6194
6195			=over 4
6196
6197			=item 1.
6198
6199			The first parameter is the required name for the field (-name).
6200
6201			=item 2.
6202
6203			The optional second parameter is the starting value for the field contents
6204			to be used as the default file name (-default).
6205
6206			For security reasons, browsers don't pay any attention to this field,
6207			and so the starting value will always be blank. Worse, the field
6208			loses its "sticky" behavior and forgets its previous contents. The
6209			starting value field is called for in the HTML specification, however,
6210			and possibly some browser will eventually provide support for it.
6211
6212			=item 3.
6213
6214			The optional third parameter is the size of the field in
6215			characters (-size).
6216
6217			=item 4.
6218
6219			The optional fourth parameter is the maximum number of characters the
6220			field will accept (-maxlength).
6221
6222			=back
6223
6224			JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
6225			B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
6226			recognized. See textfield() for details.
6227
6228			=head2 Processing a file upload field
6229
6230			=head3 Basics
6231
6232			When the form is processed, you can retrieve an L<IO::File> compatible
6233			handle for a file upload field like this:
6234
6235			# undef may be returned if it's not a valid file handle
6236			if ( my $io_handle = $q->upload('field_name') ) {
6237			open (OUTFILE,'>>','/usr/local/web/users/feedback');
6238			while ($bytesread = $io_handle->read($buffer,1024)) {
6239			print OUTFILE $buffer;
6240			}
6241			}
6242
6243			In a list context, upload() will return an array of filehandles.
6244			This makes it possible to process forms that use the same name for
6245			multiple upload fields.
6246
6247			If you want the entered file name for the file, you can just call param():
6248
6249			$filename = $q->param('field_name');
6250
6251			Different browsers will return slightly different things for the
6252			name. Some browsers return the filename only. Others return the full
6253			path to the file, using the path conventions of the user's machine.
6254			Regardless, the name returned is always the name of the file on the
6255			I<user's> machine, and is unrelated to the name of the temporary file
6256			that CGI.pm creates during upload spooling (see below).
6257
6258			When a file is uploaded the browser usually sends along some
6259			information along with it in the format of headers. The information
6260			usually includes the MIME content type. To
6261			retrieve this information, call uploadInfo(). It returns a reference to
6262			a hash containing all the document headers.
6263
6264			$filename = $q->param('uploaded_file');
6265			$type = $q->uploadInfo($filename)->{'Content-Type'};
6266			unless ($type eq 'text/html') {
6267			die "HTML FILES ONLY!";
6268			}
6269
6270			Note that you must use ->param to get the filename to pass into uploadInfo
6271			as internally this is represented as a File::Temp object (which is what will be
6272			returned by ->param). When using ->Vars you will get the literal filename
6273			rather than the File::Temp object, which will not return anything when passed to
6274			uploadInfo. So don't use ->Vars.
6275
6276			If you are using a machine that recognizes "text" and "binary" data
6277			modes, be sure to understand when and how to use them (see the Camel book).
6278			Otherwise you may find that binary files are corrupted during file
6279			uploads.
6280
6281			=head3 Accessing the temp files directly
6282
6283			When processing an uploaded file, CGI.pm creates a temporary file on your hard
6284			disk and passes you a file handle to that file. After you are finished with the
6285			file handle, CGI.pm unlinks (deletes) the temporary file. If you need to you
6286			can access the temporary file directly. You can access the temp file for a file
6287			upload by passing the file name to the tmpFileName() method:
6288
6289			$filename = $query->param('uploaded_file');
6290			$tmpfilename = $query->tmpFileName($filename);
6291
6292			The temporary file will be deleted automatically when your program exits unless
6293			you manually rename it or set $CGI::UNLINK_TMP_FILES to 0. On some operating
6294			systems (such as Windows NT), you will need to close the temporary file's
6295			filehandle before your program exits. Otherwise the attempt to delete the
6296			temporary file will fail.
6297
6298			=head3 Changes in temporary file handling (v4.05+)
6299
6300			CGI.pm had its temporary file handling significantly refactored. this logic is
6301			now all deferred to File::Temp (which is wrapped in a compatibility object,
6302			CGI::File::Temp - B<DO NOT USE THIS PACKAGE DIRECTLY>). As a consequence the
6303			PRIVATE_TEMPFILES variable has been removed along with deprecation of the
6304			private_tempfiles routine and B<complete> removal of the CGITempFile package.
6305			The $CGITempFile::TMPDIRECTORY is no longer used to set the temp directory,
6306			refer to the perldoc for File::Temp is you want to override the default
6307			settings in that package (the TMPDIR env variable is still available on some
6308			platforms). For Windows platforms the temporary directory order remains
6309			as before: TEMP > TMP > WINDIR ( > TMPDIR ) so if you have any of these in
6310			use in existing scripts they should still work.
6311
6312			The Fh package still exists but does nothing, the CGI::File::Temp class is
6313			a subclass of both File::Temp and the empty Fh package, so if you have any
6314			code that checks that the filehandle isa Fh this should still work.
6315
6316			When you get the internal file handle you will receive a File::Temp object,
6317			this should be transparent as File::Temp isa IO::Handle and isa IO::Seekable
6318			meaning it behaves as previously. if you are doing anything out of the ordinary
6319			with regards to temp files you should test your code before deploying this update
6320			and refer to the File::Temp documentation for more information.
6321
6322			=head3 Handling interrupted file uploads
6323
6324			There are occasionally problems involving parsing the uploaded file.
6325			This usually happens when the user presses "Stop" before the upload is
6326			finished. In this case, CGI.pm will return undef for the name of the
6327			uploaded file and set I<cgi_error()> to the string "400 Bad request
6328			(malformed multipart POST)". This error message is designed so that
6329			you can incorporate it into a status code to be sent to the browser.
6330			Example:
6331
6332			$file = $q->upload('uploaded_file');
6333			if (!$file && $q->cgi_error) {
6334			print $q->header(-status=>$q->cgi_error);
6335			exit 0;
6336			}
6337
6338			You are free to create a custom HTML page to complain about the error,
6339			if you wish.
6340
6341			=head3 Progress bars for file uploads and avoiding temp files
6342
6343			CGI.pm gives you low-level access to file upload management through
6344			a file upload hook. You can use this feature to completely turn off
6345			the temp file storage of file uploads, or potentially write your own
6346			file upload progress meter.
6347
6348			This is much like the UPLOAD_HOOK facility available in L<Apache::Request>, with
6349			the exception that the first argument to the callback is an L<Apache::Upload>
6350			object, here it's the remote filename.
6351
6352			$q = CGI->new(\&hook [,$data [,$use_tempfile]]);
6353
6354			sub hook {
6355			my ($filename, $buffer, $bytes_read, $data) = @_;
6356			print "Read $bytes_read bytes of $filename\n";
6357			}
6358
6359			The C<< $data >> field is optional; it lets you pass configuration
6360			information (e.g. a database handle) to your hook callback.
6361
6362			The C<< $use_tempfile >> field is a flag that lets you turn on and off
6363			CGI.pm's use of a temporary disk-based file during file upload. If you
6364			set this to a FALSE value (default true) then $q->param('uploaded_file')
6365			will no longer work, and the only way to get at the uploaded data is
6366			via the hook you provide.
6367
6368			If using the function-oriented interface, call the CGI::upload_hook()
6369			method before calling param() or any other CGI functions:
6370
6371			CGI::upload_hook(\&hook [,$data [,$use_tempfile]]);
6372
6373			This method is not exported by default. You will have to import it
6374			explicitly if you wish to use it without the CGI:: prefix.
6375
6376			=head3 Troubleshooting file uploads on Windows
6377
6378			If you are using CGI.pm on a Windows platform and find that binary
6379			files get slightly larger when uploaded but that text files remain the
6380			same, then you have forgotten to activate binary mode on the output
6381			filehandle. Be sure to call binmode() on any handle that you create
6382			to write the uploaded file to disk.
6383
6384			=head3 Older ways to process file uploads
6385
6386			( This section is here for completeness. if you are building a new application with CGI.pm, you can skip it. )
6387
6388			The original way to process file uploads with CGI.pm was to use param(). The
6389			value it returns has a dual nature as both a file name and a lightweight
6390			filehandle. This dual nature is problematic if you following the recommended
6391			practice of having C<use strict> in your code. Perl will complain when you try
6392			to use a string as a filehandle. More seriously, it is possible for the remote
6393			user to type garbage into the upload field, in which case what you get from
6394			param() is not a filehandle at all, but a string.
6395
6396			To solve this problem the upload() method was added, which always returns a
6397			lightweight filehandle. This generally works well, but will have trouble
6398			interoperating with some other modules because the file handle is not derived
6399			from L<IO::File>. So that brings us to current recommendation given above,
6400			which is to call the handle() method on the file handle returned by upload().
6401			That upgrades the handle to an IO::File. It's a big win for compatibility for
6402			a small penalty of loading IO::File the first time you call it.
6403
6404
6405			=head2 Creating a popup menu
6406
6407			print popup_menu('menu_name',
6408			['eenie','meenie','minie'],
6409			'meenie');
6410
6411			-or-
6412
6413			%labels = ('eenie'=>'your first choice',
6414			'meenie'=>'your second choice',
6415			'minie'=>'your third choice');
6416			%attributes = ('eenie'=>{'class'=>'class of first choice'});
6417			print popup_menu('menu_name',
6418			['eenie','meenie','minie'],
6419			'meenie',\%labels,\%attributes);
6420
6421			-or (named parameter style)-
6422
6423			print popup_menu(-name=>'menu_name',
6424			-values=>['eenie','meenie','minie'],
6425			-default=>['meenie','minie'],
6426			-labels=>\%labels,
6427			-attributes=>\%attributes);
6428
6429			popup_menu() creates a menu. Please note that the -multiple option will be
6430			ignored if passed - use scrolling_list() if you want to create a menu that
6431			supports multiple selections
6432
6433			=over 4
6434
6435			=item 1.
6436
6437			The required first argument is the menu's name (-name).
6438
6439			=item 2.
6440
6441			The required second argument (-values) is an array B<reference>
6442			containing the list of menu items in the menu. You can pass the
6443			method an anonymous array, as shown in the example, or a reference to
6444			a named array, such as "\@foo".
6445
6446			=item 3.
6447
6448			The optional third parameter (-default) is the name of the default
6449			menu choice. If not specified, the first item will be the default.
6450			The values of the previous choice will be maintained across
6451			queries. Pass an array reference to select multiple defaults.
6452
6453			=item 4.
6454
6455			The optional fourth parameter (-labels) is provided for people who
6456			want to use different values for the user-visible label inside the
6457			popup menu and the value returned to your script. It's a pointer to an
6458			hash relating menu values to user-visible labels. If you
6459			leave this parameter blank, the menu values will be displayed by
6460			default. (You can also leave a label undefined if you want to).
6461
6462			=item 5.
6463
6464			The optional fifth parameter (-attributes) is provided to assign
6465			any of the common HTML attributes to an individual menu item. It's
6466			a pointer to a hash relating menu values to another
6467			hash with the attribute's name as the key and the
6468			attribute's value as the value.
6469
6470			=back
6471
6472			When the form is processed, the selected value of the popup menu can
6473			be retrieved using:
6474
6475			$popup_menu_value = param('menu_name');
6476
6477			=head2 Creating an option group
6478
6479			Named parameter style
6480
6481			print popup_menu(-name=>'menu_name',
6482			-values=>[qw/eenie meenie minie/,
6483			optgroup(-name=>'optgroup_name',
6484			-values => ['moe','catch'],
6485			-attributes=>{'catch'=>{'class'=>'red'}})],
6486			-labels=>{'eenie'=>'one',
6487			'meenie'=>'two',
6488			'minie'=>'three'},
6489			-default=>'meenie');
6490
6491			Old style
6492			print popup_menu('menu_name',
6493			['eenie','meenie','minie',
6494			optgroup('optgroup_name', ['moe', 'catch'],
6495			{'catch'=>{'class'=>'red'}})],'meenie',
6496			{'eenie'=>'one','meenie'=>'two','minie'=>'three'});
6497
6498			optgroup() creates an option group within a popup menu.
6499
6500			=over 4
6501
6502			=item 1.
6503
6504			The required first argument (B<-name>) is the label attribute of the
6505			optgroup and is B<not> inserted in the parameter list of the query.
6506
6507			=item 2.
6508
6509			The required second argument (B<-values>) is an array reference
6510			containing the list of menu items in the menu. You can pass the
6511			method an anonymous array, as shown in the example, or a reference
6512			to a named array, such as \@foo. If you pass a HASH reference,
6513			the keys will be used for the menu values, and the values will be
6514			used for the menu labels (see -labels below).
6515
6516			=item 3.
6517
6518			The optional third parameter (B<-labels>) allows you to pass a reference
6519			to a hash containing user-visible labels for one or more
6520			of the menu items. You can use this when you want the user to see one
6521			menu string, but have the browser return your program a different one.
6522			If you don't specify this, the value string will be used instead
6523			("eenie", "meenie" and "minie" in this example). This is equivalent
6524			to using a hash reference for the -values parameter.
6525
6526			=item 4.
6527
6528			An optional fourth parameter (B<-labeled>) can be set to a true value
6529			and indicates that the values should be used as the label attribute
6530			for each option element within the optgroup.
6531
6532			=item 5.
6533
6534			An optional fifth parameter (-novals) can be set to a true value and
6535			indicates to suppress the val attribute in each option element within
6536			the optgroup.
6537
6538			See the discussion on optgroup at W3C
6539			(http://www.w3.org/TR/REC-html40/interact/forms.html#edef-OPTGROUP)
6540			for details.
6541
6542			=item 6.
6543
6544			An optional sixth parameter (-attributes) is provided to assign
6545			any of the common HTML attributes to an individual menu item. It's
6546			a pointer to a hash relating menu values to another
6547			hash with the attribute's name as the key and the
6548			attribute's value as the value.
6549
6550			=back
6551
6552			=head2 Creating a scrolling list
6553
6554			print scrolling_list('list_name',
6555			['eenie','meenie','minie','moe'],
6556			['eenie','moe'],5,'true',{'moe'=>{'class'=>'red'}});
6557			-or-
6558
6559			print scrolling_list('list_name',
6560			['eenie','meenie','minie','moe'],
6561			['eenie','moe'],5,'true',
6562			\%labels,%attributes);
6563
6564			-or-
6565
6566			print scrolling_list(-name=>'list_name',
6567			-values=>['eenie','meenie','minie','moe'],
6568			-default=>['eenie','moe'],
6569			-size=>5,
6570			-multiple=>'true',
6571			-labels=>\%labels,
6572			-attributes=>\%attributes);
6573
6574			scrolling_list() creates a scrolling list.
6575
6576			B<Parameters:>
6577
6578			=over 4
6579
6580			=item 1.
6581
6582			The first and second arguments are the list name (-name) and values
6583			(-values). As in the popup menu, the second argument should be an
6584			array reference.
6585
6586			=item 2.
6587
6588			The optional third argument (-default) can be either a reference to a
6589			list containing the values to be selected by default, or can be a
6590			single value to select. If this argument is missing or undefined,
6591			then nothing is selected when the list first appears. In the named
6592			parameter version, you can use the synonym "-defaults" for this
6593			parameter.
6594
6595			=item 3.
6596
6597			The optional fourth argument is the size of the list (-size).
6598
6599			=item 4.
6600
6601			The optional fifth argument can be set to true to allow multiple
6602			simultaneous selections (-multiple). Otherwise only one selection
6603			will be allowed at a time.
6604
6605			=item 5.
6606
6607			The optional sixth argument is a pointer to a hash
6608			containing long user-visible labels for the list items (-labels).
6609			If not provided, the values will be displayed.
6610
6611			=item 6.
6612
6613			The optional sixth parameter (-attributes) is provided to assign
6614			any of the common HTML attributes to an individual menu item. It's
6615			a pointer to a hash relating menu values to another
6616			hash with the attribute's name as the key and the
6617			attribute's value as the value.
6618
6619			When this form is processed, all selected list items will be returned as
6620			a list under the parameter name 'list_name'. The values of the
6621			selected items can be retrieved with:
6622
6623			@selected = param('list_name');
6624
6625			=back
6626
6627			=head2 Creating a group of related checkboxes
6628
6629			print checkbox_group(-name=>'group_name',
6630			-values=>['eenie','meenie','minie','moe'],
6631			-default=>['eenie','moe'],
6632			-linebreak=>'true',
6633			-disabled => ['moe'],
6634			-labels=>\%labels,
6635			-attributes=>\%attributes);
6636
6637			print checkbox_group('group_name',
6638			['eenie','meenie','minie','moe'],
6639			['eenie','moe'],'true',\%labels,
6640			{'moe'=>{'class'=>'red'}});
6641
6642			HTML3-COMPATIBLE BROWSERS ONLY:
6643
6644			print checkbox_group(-name=>'group_name',
6645			-values=>['eenie','meenie','minie','moe'],
6646			-rows=2,-columns=>2);
6647
6648
6649			checkbox_group() creates a list of checkboxes that are related
6650			by the same name.
6651
6652			B<Parameters:>
6653
6654			=over 4
6655
6656			=item 1.
6657
6658			The first and second arguments are the checkbox name and values,
6659			respectively (-name and -values). As in the popup menu, the second
6660			argument should be an array reference. These values are used for the
6661			user-readable labels printed next to the checkboxes as well as for the
6662			values passed to your script in the query string.
6663
6664			=item 2.
6665
6666			The optional third argument (-default) can be either a reference to a
6667			list containing the values to be checked by default, or can be a
6668			single value to checked. If this argument is missing or undefined,
6669			then nothing is selected when the list first appears.
6670
6671			=item 3.
6672
6673			The optional fourth argument (-linebreak) can be set to true to place
6674			line breaks between the checkboxes so that they appear as a vertical
6675			list. Otherwise, they will be strung together on a horizontal line.
6676
6677			=back
6678
6679			The optional B<-labels> argument is a pointer to a hash
6680			relating the checkbox values to the user-visible labels that will be
6681			printed next to them. If not provided, the values will be used as the
6682			default.
6683
6684
6685			The optional parameters B<-rows>, and B<-columns> cause
6686			checkbox_group() to return an HTML3 compatible table containing the
6687			checkbox group formatted with the specified number of rows and
6688			columns. You can provide just the -columns parameter if you wish;
6689			checkbox_group will calculate the correct number of rows for you.
6690
6691			The option B<-disabled> takes an array of checkbox values and disables
6692			them by greying them out (this may not be supported by all browsers).
6693
6694			The optional B<-attributes> argument is provided to assign any of the
6695			common HTML attributes to an individual menu item. It's a pointer to
6696			a hash relating menu values to another hash
6697			with the attribute's name as the key and the attribute's value as the
6698			value.
6699
6700			The optional B<-tabindex> argument can be used to control the order in which
6701			radio buttons receive focus when the user presses the tab button. If
6702			passed a scalar numeric value, the first element in the group will
6703			receive this tab index and subsequent elements will be incremented by
6704			one. If given a reference to an array of radio button values, then
6705			the indexes will be jiggered so that the order specified in the array
6706			will correspond to the tab order. You can also pass a reference to a
6707			hash in which the hash keys are the radio button values and the values
6708			are the tab indexes of each button. Examples:
6709
6710			-tabindex => 100 # this group starts at index 100 and counts up
6711			-tabindex => ['moe','minie','eenie','meenie'] # tab in this order
6712			-tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
6713
6714			The optional B<-labelattributes> argument will contain attributes
6715			attached to the <label> element that surrounds each button.
6716
6717			When the form is processed, all checked boxes will be returned as
6718			a list under the parameter name 'group_name'. The values of the
6719			"on" checkboxes can be retrieved with:
6720
6721			@turned_on = param('group_name');
6722
6723			The value returned by checkbox_group() is actually an array of button
6724			elements. You can capture them and use them within tables, lists,
6725			or in other creative ways:
6726
6727			@h = checkbox_group(-name=>'group_name',-values=>\@values);
6728			&use_in_creative_way(@h);
6729
6730			=head2 Creating a standalone checkbox
6731
6732			print checkbox(-name=>'checkbox_name',
6733			-checked=>1,
6734			-value=>'ON',
6735			-label=>'CLICK ME');
6736
6737			-or-
6738
6739			print checkbox('checkbox_name','checked','ON','CLICK ME');
6740
6741			checkbox() is used to create an isolated checkbox that isn't logically
6742			related to any others.
6743
6744			B<Parameters:>
6745
6746			=over 4
6747
6748			=item 1.
6749
6750			The first parameter is the required name for the checkbox (-name). It
6751			will also be used for the user-readable label printed next to the
6752			checkbox.
6753
6754			=item 2.
6755
6756			The optional second parameter (-checked) specifies that the checkbox
6757			is turned on by default. Synonyms are -selected and -on.
6758
6759			=item 3.
6760
6761			The optional third parameter (-value) specifies the value of the
6762			checkbox when it is checked. If not provided, the word "on" is
6763			assumed.
6764
6765			=item 4.
6766
6767			The optional fourth parameter (-label) is the user-readable label to
6768			be attached to the checkbox. If not provided, the checkbox name is
6769			used.
6770
6771			=back
6772
6773			The value of the checkbox can be retrieved using:
6774
6775			$turned_on = param('checkbox_name');
6776
6777			=head2 Creating a radio button group
6778
6779			print radio_group(-name=>'group_name',
6780			-values=>['eenie','meenie','minie'],
6781			-default=>'meenie',
6782			-linebreak=>'true',
6783			-labels=>\%labels,
6784			-attributes=>\%attributes);
6785
6786			-or-
6787
6788			print radio_group('group_name',['eenie','meenie','minie'],
6789			'meenie','true',\%labels,\%attributes);
6790
6791
6792			HTML3-COMPATIBLE BROWSERS ONLY:
6793
6794			print radio_group(-name=>'group_name',
6795			-values=>['eenie','meenie','minie','moe'],
6796			-rows=2,-columns=>2);
6797
6798			radio_group() creates a set of logically-related radio buttons
6799			(turning one member of the group on turns the others off)
6800
6801			B<Parameters:>
6802
6803			=over 4
6804
6805			=item 1.
6806
6807			The first argument is the name of the group and is required (-name).
6808
6809			=item 2.
6810
6811			The second argument (-values) is the list of values for the radio
6812			buttons. The values and the labels that appear on the page are
6813			identical. Pass an array I<reference> in the second argument, either
6814			using an anonymous array, as shown, or by referencing a named array as
6815			in "\@foo".
6816
6817			=item 3.
6818
6819			The optional third parameter (-default) is the name of the default
6820			button to turn on. If not specified, the first item will be the
6821			default. You can provide a nonexistent button name, such as "-" to
6822			start up with no buttons selected.
6823
6824			=item 4.
6825
6826			The optional fourth parameter (-linebreak) can be set to 'true' to put
6827			line breaks between the buttons, creating a vertical list.
6828
6829			=item 5.
6830
6831			The optional fifth parameter (-labels) is a pointer to an associative
6832			array relating the radio button values to user-visible labels to be
6833			used in the display. If not provided, the values themselves are
6834			displayed.
6835
6836			=back
6837
6838			All modern browsers can take advantage of the optional parameters
6839			B<-rows>, and B<-columns>. These parameters cause radio_group() to
6840			return an HTML3 compatible table containing the radio group formatted
6841			with the specified number of rows and columns. You can provide just
6842			the -columns parameter if you wish; radio_group will calculate the
6843			correct number of rows for you.
6844
6845			To include row and column headings in the returned table, you
6846			can use the B<-rowheaders> and B<-colheaders> parameters. Both
6847			of these accept a pointer to an array of headings to use.
6848			The headings are just decorative. They don't reorganize the
6849			interpretation of the radio buttons -- they're still a single named
6850			unit.
6851
6852			The optional B<-tabindex> argument can be used to control the order in which
6853			radio buttons receive focus when the user presses the tab button. If
6854			passed a scalar numeric value, the first element in the group will
6855			receive this tab index and subsequent elements will be incremented by
6856			one. If given a reference to an array of radio button values, then
6857			the indexes will be jiggered so that the order specified in the array
6858			will correspond to the tab order. You can also pass a reference to a
6859			hash in which the hash keys are the radio button values and the values
6860			are the tab indexes of each button. Examples:
6861
6862			-tabindex => 100 # this group starts at index 100 and counts up
6863			-tabindex => ['moe','minie','eenie','meenie'] # tab in this order
6864			-tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
6865
6866
6867			The optional B<-attributes> argument is provided to assign any of the
6868			common HTML attributes to an individual menu item. It's a pointer to
6869			a hash relating menu values to another hash
6870			with the attribute's name as the key and the attribute's value as the
6871			value.
6872
6873			The optional B<-labelattributes> argument will contain attributes
6874			attached to the <label> element that surrounds each button.
6875
6876			When the form is processed, the selected radio button can
6877			be retrieved using:
6878
6879			$which_radio_button = param('group_name');
6880
6881			The value returned by radio_group() is actually an array of button
6882			elements. You can capture them and use them within tables, lists,
6883			or in other creative ways:
6884
6885			@h = radio_group(-name=>'group_name',-values=>\@values);
6886			&use_in_creative_way(@h);
6887
6888			=head2 Creating a submit button
6889
6890			print submit(-name=>'button_name',
6891			-value=>'value');
6892
6893			-or-
6894
6895			print submit('button_name','value');
6896
6897			submit() will create the query submission button. Every form
6898			should have one of these.
6899
6900			B<Parameters:>
6901
6902			=over 4
6903
6904			=item 1.
6905
6906			The first argument (-name) is optional. You can give the button a
6907			name if you have several submission buttons in your form and you want
6908			to distinguish between them.
6909
6910			=item 2.
6911
6912			The second argument (-value) is also optional. This gives the button
6913			a value that will be passed to your script in the query string. The
6914			name will also be used as the user-visible label.
6915
6916			=item 3.
6917
6918			You can use -label as an alias for -value. I always get confused
6919			about which of -name and -value changes the user-visible label on the
6920			button.
6921
6922			=back
6923
6924			You can figure out which button was pressed by using different
6925			values for each one:
6926
6927			$which_one = param('button_name');
6928
6929			=head2 Creating a reset button
6930
6931			print reset
6932
6933			reset() creates the "reset" button. Note that it restores the
6934			form to its value from the last time the script was called,
6935			NOT necessarily to the defaults.
6936
6937			Note that this conflicts with the Perl reset() built-in. Use
6938			CORE::reset() to get the original reset function.
6939
6940			=head2 Creating a default button
6941
6942			print defaults('button_label')
6943
6944			defaults() creates a button that, when invoked, will cause the
6945			form to be completely reset to its defaults, wiping out all the
6946			changes the user ever made.
6947
6948			=head2 Creating a hidden field
6949
6950			print hidden(-name=>'hidden_name',
6951			-default=>['value1','value2'...]);
6952
6953			-or-
6954
6955			print hidden('hidden_name','value1','value2'...);
6956
6957			hidden() produces a text field that can't be seen by the user. It
6958			is useful for passing state variable information from one invocation
6959			of the script to the next.
6960
6961			B<Parameters:>
6962
6963			=over 4
6964
6965			=item 1.
6966
6967			The first argument is required and specifies the name of this
6968			field (-name).
6969
6970			=item 2.
6971
6972			The second argument is also required and specifies its value
6973			(-default). In the named parameter style of calling, you can provide
6974			a single value here or a reference to a whole list
6975
6976			=back
6977
6978			Fetch the value of a hidden field this way:
6979
6980			$hidden_value = param('hidden_name');
6981
6982			Note, that just like all the other form elements, the value of a
6983			hidden field is "sticky". If you want to replace a hidden field with
6984			some other values after the script has been called once you'll have to
6985			do it manually:
6986
6987			param('hidden_name','new','values','here');
6988
6989			=head2 Creating a clickable image button
6990
6991			print image_button(-name=>'button_name',
6992			-src=>'/source/URL',
6993			-align=>'MIDDLE');
6994
6995			-or-
6996
6997			print image_button('button_name','/source/URL','MIDDLE');
6998
6999			image_button() produces a clickable image. When it's clicked on the
7000			position of the click is returned to your script as "button_name.x"
7001			and "button_name.y", where "button_name" is the name you've assigned
7002			to it.
7003
7004			B<Parameters:>
7005
7006			=over 4
7007
7008			=item 1.
7009
7010			The first argument (-name) is required and specifies the name of this
7011			field.
7012
7013			=item 2.
7014
7015			The second argument (-src) is also required and specifies the URL
7016
7017			=item 3.
7018
7019			The third option (-align, optional) is an alignment type, and may be
7020			TOP, BOTTOM or MIDDLE
7021
7022			=back
7023
7024			Fetch the value of the button this way:
7025			$x = param('button_name.x');
7026			$y = param('button_name.y');
7027
7028			=head2 Creating a javascript action button
7029
7030			print button(-name=>'button_name',
7031			-value=>'user visible label',
7032			-onClick=>"do_something()");
7033
7034			-or-
7035
7036			print button('button_name',"user visible value","do_something()");
7037
7038			button() produces an C<< <input> >> tag with C<type="button">. When it's
7039			pressed the fragment of JavaScript code pointed to by the B<-onClick> parameter
7040			will be executed.
7041
7042			=head1 HTTP COOKIES
7043
7044			Browsers support a so-called "cookie" designed to help maintain state
7045			within a browser session. CGI.pm has several methods that support
7046			cookies.
7047
7048			A cookie is a name=value pair much like the named parameters in a CGI
7049			query string. CGI scripts create one or more cookies and send
7050			them to the browser in the HTTP header. The browser maintains a list
7051			of cookies that belong to a particular Web server, and returns them
7052			to the CGI script during subsequent interactions.
7053
7054			In addition to the required name=value pair, each cookie has several
7055			optional attributes:
7056
7057			=over 4
7058
7059			=item 1. an expiration time
7060
7061			This is a time/date string (in a special GMT format) that indicates
7062			when a cookie expires. The cookie will be saved and returned to your
7063			script until this expiration date is reached if the user exits
7064			the browser and restarts it. If an expiration date isn't specified, the cookie
7065			will remain active until the user quits the browser.
7066
7067			=item 2. a domain
7068
7069			This is a partial or complete domain name for which the cookie is
7070			valid. The browser will return the cookie to any host that matches
7071			the partial domain name. For example, if you specify a domain name
7072			of ".capricorn.com", then the browser will return the cookie to
7073			Web servers running on any of the machines "www.capricorn.com",
7074			"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
7075			must contain at least two periods to prevent attempts to match
7076			on top level domains like ".edu". If no domain is specified, then
7077			the browser will only return the cookie to servers on the host the
7078			cookie originated from.
7079
7080			=item 3. a path
7081
7082			If you provide a cookie path attribute, the browser will check it
7083			against your script's URL before returning the cookie. For example,
7084			if you specify the path "/cgi-bin", then the cookie will be returned
7085			to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
7086			and "/cgi-bin/customer_service/complain.pl", but not to the script
7087			"/cgi-private/site_admin.pl". By default, path is set to "/", which
7088			causes the cookie to be sent to any CGI script on your site.
7089
7090			=item 4. a "secure" flag
7091
7092			If the "secure" attribute is set, the cookie will only be sent to your
7093			script if the CGI request is occurring on a secure channel, such as SSL.
7094
7095			=back
7096
7097			The interface to HTTP cookies is the B<cookie()> method:
7098
7099			$cookie = cookie(-name=>'sessionID',
7100			-value=>'xyzzy',
7101			-expires=>'+1h',
7102			-path=>'/cgi-bin/database',
7103			-domain=>'.capricorn.org',
7104			-secure=>1);
7105			print header(-cookie=>$cookie);
7106
7107			B<cookie()> creates a new cookie. Its parameters include:
7108
7109			=over 4
7110
7111			=item B<-name>
7112
7113			The name of the cookie (required). This can be any string at all.
7114			Although browsers limit their cookie names to non-whitespace
7115			alphanumeric characters, CGI.pm removes this restriction by escaping
7116			and unescaping cookies behind the scenes.
7117
7118			=item B<-value>
7119
7120			The value of the cookie. This can be any scalar value,
7121			array reference, or even hash reference. For example,
7122			you can store an entire hash into a cookie this way:
7123
7124			$cookie=cookie(-name=>'family information',
7125			-value=>\%childrens_ages);
7126
7127			=item B<-path>
7128
7129			The optional partial path for which this cookie will be valid, as described
7130			above.
7131
7132			=item B<-domain>
7133
7134			The optional partial domain for which this cookie will be valid, as described
7135			above.
7136
7137			=item B<-expires>
7138
7139			The optional expiration date for this cookie. The format is as described
7140			in the section on the B<header()> method:
7141
7142			"+1h" one hour from now
7143
7144			=item B<-secure>
7145
7146			If set to true, this cookie will only be used within a secure
7147			SSL session.
7148
7149			=back
7150
7151			The cookie created by cookie() must be incorporated into the HTTP
7152			header within the string returned by the header() method:
7153
7154			use CGI ':standard';
7155			print header(-cookie=>$my_cookie);
7156
7157			To create multiple cookies, give header() an array reference:
7158
7159			$cookie1 = cookie(-name=>'riddle_name',
7160			-value=>"The Sphynx's Question");
7161			$cookie2 = cookie(-name=>'answers',
7162			-value=>\%answers);
7163			print header(-cookie=>[$cookie1,$cookie2]);
7164
7165			To retrieve a cookie, request it by name by calling cookie() method
7166			without the B<-value> parameter. This example uses the object-oriented
7167			form:
7168
7169			use CGI;
7170			$query = CGI->new;
7171			$riddle = $query->cookie('riddle_name');
7172			%answers = $query->cookie('answers');
7173
7174			Cookies created with a single scalar value, such as the "riddle_name"
7175			cookie, will be returned in that form. Cookies with array and hash
7176			values can also be retrieved.
7177
7178			The cookie and CGI namespaces are separate. If you have a parameter
7179			named 'answers' and a cookie named 'answers', the values retrieved by
7180			param() and cookie() are independent of each other. However, it's
7181			simple to turn a CGI parameter into a cookie, and vice-versa:
7182
7183			# turn a CGI parameter into a cookie
7184			$c=cookie(-name=>'answers',-value=>[param('answers')]);
7185			# vice-versa
7186			param(-name=>'answers',-value=>[cookie('answers')]);
7187
7188			If you call cookie() without any parameters, it will return a list of
7189			the names of all cookies passed to your script:
7190
7191			@cookies = cookie();
7192
7193			See the B<cookie.cgi> example script for some ideas on how to use
7194			cookies effectively.
7195
7196			=head1 WORKING WITH FRAMES
7197
7198			It's possible for CGI.pm scripts to write into several browser panels
7199			and windows using the HTML 4 frame mechanism. There are three
7200			techniques for defining new frames programmatically:
7201
7202			=over 4
7203
7204			=item 1. Create a <Frameset> document
7205
7206			After writing out the HTTP header, instead of creating a standard
7207			HTML document using the start_html() call, create a <frameset>
7208			document that defines the frames on the page. Specify your script(s)
7209			(with appropriate parameters) as the SRC for each of the frames.
7210
7211			There is no specific support for creating <frameset> sections
7212			in CGI.pm, but the HTML is very simple to write.
7213
7214			=item 2. Specify the destination for the document in the HTTP header
7215
7216			You may provide a B<-target> parameter to the header() method:
7217
7218			print header(-target=>'ResultsWindow');
7219
7220			This will tell the browser to load the output of your script into the
7221			frame named "ResultsWindow". If a frame of that name doesn't already
7222			exist, the browser will pop up a new window and load your script's
7223			document into that. There are a number of magic names that you can
7224			use for targets. See the HTML C<< <frame> >> documentation for details.
7225
7226			=item 3. Specify the destination for the document in the <form> tag
7227
7228			You can specify the frame to load in the FORM tag itself. With
7229			CGI.pm it looks like this:
7230
7231			print start_form(-target=>'ResultsWindow');
7232
7233			When your script is reinvoked by the form, its output will be loaded
7234			into the frame named "ResultsWindow". If one doesn't already exist
7235			a new window will be created.
7236
7237			=back
7238
7239			The script "frameset.cgi" in the examples directory shows one way to
7240			create pages in which the fill-out form and the response live in
7241			side-by-side frames.
7242
7243			=head1 SUPPORT FOR JAVASCRIPT
7244
7245			The usual way to use JavaScript is to define a set of functions in a
7246			<SCRIPT> block inside the HTML header and then to register event
7247			handlers in the various elements of the page. Events include such
7248			things as the mouse passing over a form element, a button being
7249			clicked, the contents of a text field changing, or a form being
7250			submitted. When an event occurs that involves an element that has
7251			registered an event handler, its associated JavaScript code gets
7252			called.
7253
7254			The elements that can register event handlers include the <BODY> of an
7255			HTML document, hypertext links, all the various elements of a fill-out
7256			form, and the form itself. There are a large number of events, and
7257			each applies only to the elements for which it is relevant. Here is a
7258			partial list:
7259
7260			=over 4
7261
7262			=item B<onLoad>
7263
7264			The browser is loading the current document. Valid in:
7265
7266			+ The HTML <BODY> section only.
7267
7268			=item B<onUnload>
7269
7270			The browser is closing the current page or frame. Valid for:
7271
7272			+ The HTML <BODY> section only.
7273
7274			=item B<onSubmit>
7275
7276			The user has pressed the submit button of a form. This event happens
7277			just before the form is submitted, and your function can return a
7278			value of false in order to abort the submission. Valid for:
7279
7280			+ Forms only.
7281
7282			=item B<onClick>
7283
7284			The mouse has clicked on an item in a fill-out form. Valid for:
7285
7286			+ Buttons (including submit, reset, and image buttons)
7287			+ Checkboxes
7288			+ Radio buttons
7289
7290			=item B<onChange>
7291
7292			The user has changed the contents of a field. Valid for:
7293
7294			+ Text fields
7295			+ Text areas
7296			+ Password fields
7297			+ File fields
7298			+ Popup Menus
7299			+ Scrolling lists
7300
7301			=item B<onFocus>
7302
7303			The user has selected a field to work with. Valid for:
7304
7305			+ Text fields
7306			+ Text areas
7307			+ Password fields
7308			+ File fields
7309			+ Popup Menus
7310			+ Scrolling lists
7311
7312			=item B<onBlur>
7313
7314			The user has deselected a field (gone to work somewhere else). Valid
7315			for:
7316
7317			+ Text fields
7318			+ Text areas
7319			+ Password fields
7320			+ File fields
7321			+ Popup Menus
7322			+ Scrolling lists
7323
7324			=item B<onSelect>
7325
7326			The user has changed the part of a text field that is selected. Valid
7327			for:
7328
7329			+ Text fields
7330			+ Text areas
7331			+ Password fields
7332			+ File fields
7333
7334			=item B<onMouseOver>
7335
7336			The mouse has moved over an element.
7337
7338			+ Text fields
7339			+ Text areas
7340			+ Password fields
7341			+ File fields
7342			+ Popup Menus
7343			+ Scrolling lists
7344
7345			=item B<onMouseOut>
7346
7347			The mouse has moved off an element.
7348
7349			+ Text fields
7350			+ Text areas
7351			+ Password fields
7352			+ File fields
7353			+ Popup Menus
7354			+ Scrolling lists
7355
7356			=back
7357
7358			In order to register a JavaScript event handler with an HTML element,
7359			just use the event name as a parameter when you call the corresponding
7360			CGI method. For example, to have your validateAge() JavaScript code
7361			executed every time the textfield named "age" changes, generate the
7362			field like this:
7363
7364			print textfield(-name=>'age',-onChange=>"validateAge(this)");
7365
7366			This example assumes that you've already declared the validateAge()
7367			function by incorporating it into a <SCRIPT> block. The CGI.pm
7368			start_html() method provides a convenient way to create this section.
7369
7370			Similarly, you can create a form that checks itself over for
7371			consistency and alerts the user if some essential value is missing by
7372			creating it this way:
7373			print start_form(-onSubmit=>"validateMe(this)");
7374
7375			See the javascript.cgi script for a demonstration of how this all
7376			works.
7377
7378
7379			=head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
7380
7381			CGI.pm has limited support for HTML3's cascading style sheets (css).
7382			To incorporate a stylesheet into your document, pass the
7383			start_html() method a B<-style> parameter. The value of this
7384			parameter may be a scalar, in which case it is treated as the source
7385			URL for the stylesheet, or it may be a hash reference. In the latter
7386			case you should provide the hash with one or more of B<-src> or
7387			B<-code>. B<-src> points to a URL where an externally-defined
7388			stylesheet can be found. B<-code> points to a scalar value to be
7389			incorporated into a <style> section. Style definitions in B<-code>
7390			override similarly-named ones in B<-src>, hence the name "cascading."
7391
7392			You may also specify the type of the stylesheet by adding the optional
7393			B<-type> parameter to the hash pointed to by B<-style>. If not
7394			specified, the style defaults to 'text/css'.
7395
7396			To refer to a style within the body of your document, add the
7397			B<-class> parameter to any HTML element:
7398
7399			print h1({-class=>'Fancy'},'Welcome to the Party');
7400
7401			Or define styles on the fly with the B<-style> parameter:
7402
7403			print h1({-style=>'Color: red;'},'Welcome to Hell');
7404
7405			You may also use the new B<span()> element to apply a style to a
7406			section of text:
7407
7408			print span({-style=>'Color: red;'},
7409			h1('Welcome to Hell'),
7410			"Where did that handbasket get to?"
7411			);
7412
7413			Note that you must import the ":html3" definitions to have the
7414			B<span()> method available. Here's a quick and dirty example of using
7415			CSS's. See the CSS specification at
7416			http://www.w3.org/Style/CSS/ for more information.
7417
7418			use CGI qw/:standard :html3/;
7419
7420			#here's a stylesheet incorporated directly into the page
7421			$newStyle=<<END;
7422			<!--
7423			P.Tip {
7424			margin-right: 50pt;
7425			margin-left: 50pt;
7426			color: red;
7427			}
7428			P.Alert {
7429			font-size: 30pt;
7430			font-family: sans-serif;
7431			color: red;
7432			}
7433			-->
7434			END
7435			print header();
7436			print start_html( -title=>'CGI with Style',
7437			-style=>{-src=>'http://www.capricorn.com/style/st1.css',
7438			-code=>$newStyle}
7439			);
7440			print h1('CGI with Style'),
7441			p({-class=>'Tip'},
7442			"Better read the cascading style sheet spec before playing with this!"),
7443			span({-style=>'color: magenta'},
7444			"Look Mom, no hands!",
7445			p(),
7446			"Whooo wee!"
7447			);
7448			print end_html;
7449
7450			Pass an array reference to B<-code> or B<-src> in order to incorporate
7451			multiple stylesheets into your document.
7452
7453			Should you wish to incorporate a verbatim stylesheet that includes
7454			arbitrary formatting in the header, you may pass a -verbatim tag to
7455			the -style hash, as follows:
7456
7457			print start_html (-style => {-verbatim => '@import url("/server-common/css/'.$cssFile.'");',
7458			-src => '/server-common/css/core.css'});
7459
7460
7461			This will generate an HTML header that contains this:
7462
7463			<link rel="stylesheet" type="text/css" href="/server-common/css/core.css">
7464			<style type="text/css">
7465			@import url("/server-common/css/main.css");
7466			</style>
7467
7468			Any additional arguments passed in the -style value will be
7469			incorporated into the <link> tag. For example:
7470
7471			start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'],
7472			-media => 'all'});
7473
7474			This will give:
7475
7476			<link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/>
7477			<link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/>
7478
7479			<p>
7480
7481			To make more complicated <link> tags, use the Link() function
7482			and pass it to start_html() in the -head argument, as in:
7483
7484			@h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}),
7485			Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'}));
7486			print start_html({-head=>\@h})
7487
7488			To create primary and "alternate" stylesheet, use the B<-alternate> option:
7489
7490			start_html(-style=>{-src=>[
7491			{-src=>'/styles/print.css'},
7492			{-src=>'/styles/alt.css',-alternate=>1}
7493			]
7494			});
7495
7496			=head1 DEBUGGING
7497
7498			If you are running the script from the command line or in the perl
7499			debugger, you can pass the script a list of keywords or
7500			parameter=value pairs on the command line or from standard input (you
7501			don't have to worry about tricking your script into reading from
7502			environment variables). You can pass keywords like this:
7503
7504			your_script.pl keyword1 keyword2 keyword3
7505
7506			or this:
7507
7508			your_script.pl keyword1+keyword2+keyword3
7509
7510			or this:
7511
7512			your_script.pl name1=value1 name2=value2
7513
7514			or this:
7515
7516			your_script.pl name1=value1&name2=value2
7517
7518			To turn off this feature, use the -no_debug pragma.
7519
7520			To test the POST method, you may enable full debugging with the -debug
7521			pragma. This will allow you to feed newline-delimited name=value
7522			pairs to the script on standard input.
7523
7524			When debugging, you can use quotes and backslashes to escape
7525			characters in the familiar shell manner, letting you place
7526			spaces and other funny characters in your parameter=value
7527			pairs:
7528
7529			your_script.pl "name1='I am a long value'" "name2=two\ words"
7530
7531			Finally, you can set the path info for the script by prefixing the first
7532			name/value parameter with the path followed by a question mark (?):
7533
7534			your_script.pl /your/path/here?name1=value1&name2=value2
7535
7536			=head2 Dumping out all the name/value pairs
7537
7538			The Dump() method produces a string consisting of all the query's
7539			name/value pairs formatted nicely as a nested list. This is useful
7540			for debugging purposes:
7541
7542			print Dump
7543
7544
7545			Produces something that looks like:
7546
7547			<ul>
7548			<li>name1
7549			<ul>
7550			<li>value1
7551			<li>value2
7552			</ul>
7553			<li>name2
7554			<ul>
7555			<li>value1
7556			</ul>
7557			</ul>
7558
7559			As a shortcut, you can interpolate the entire CGI object into a string
7560			and it will be replaced with the a nice HTML dump shown above:
7561
7562			$query=CGI->new;
7563			print "<h2>Current Values</h2> $query\n";
7564
7565			=head1 FETCHING ENVIRONMENT VARIABLES
7566
7567			Some of the more useful environment variables can be fetched
7568			through this interface. The methods are as follows:
7569
7570			=over 4
7571
7572			=item B<Accept()>
7573
7574			Return a list of MIME types that the remote browser accepts. If you
7575			give this method a single argument corresponding to a MIME type, as in
7576			Accept('text/html'), it will return a floating point value
7577			corresponding to the browser's preference for this type from 0.0
7578			(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept
7579			list are handled correctly.
7580
7581			Note that the capitalization changed between version 2.43 and 2.44 in
7582			order to avoid conflict with Perl's accept() function.
7583
7584			=item B<raw_cookie()>
7585
7586			Returns the HTTP_COOKIE variable. Cookies have a special format, and
7587			this method call just returns the raw form (?cookie dough). See
7588			cookie() for ways of setting and retrieving cooked cookies.
7589
7590			Called with no parameters, raw_cookie() returns the packed cookie
7591			structure. You can separate it into individual cookies by splitting
7592			on the character sequence "; ". Called with the name of a cookie,
7593			retrieves the B<unescaped> form of the cookie. You can use the
7594			regular cookie() method to get the names, or use the raw_fetch()
7595			method from the CGI::Cookie module.
7596
7597			=item B<user_agent()>
7598
7599			Returns the HTTP_USER_AGENT variable. If you give
7600			this method a single argument, it will attempt to
7601			pattern match on it, allowing you to do something
7602			like user_agent(Mozilla);
7603
7604			=item B<path_info()>
7605
7606			Returns additional path information from the script URL.
7607			E.G. fetching /cgi-bin/your_script/additional/stuff will result in
7608			path_info() returning "/additional/stuff".
7609
7610			NOTE: The Microsoft Internet Information Server
7611			is broken with respect to additional path information. If
7612			you use the Perl DLL library, the IIS server will attempt to
7613			execute the additional path information as a Perl script.
7614			If you use the ordinary file associations mapping, the
7615			path information will be present in the environment,
7616			but incorrect. The best thing to do is to avoid using additional
7617			path information in CGI scripts destined for use with IIS. A
7618			best attempt has been made to make CGI.pm do the right thing.
7619
7620			=item B<path_translated()>
7621
7622			As per path_info() but returns the additional
7623			path information translated into a physical path, e.g.
7624			"/usr/local/etc/httpd/htdocs/additional/stuff".
7625
7626			The Microsoft IIS is broken with respect to the translated
7627			path as well.
7628
7629			=item B<remote_host()>
7630
7631			Returns either the remote host name or IP address.
7632			if the former is unavailable.
7633
7634			=item B<remote_addr()>
7635
7636			Returns the remote host IP address, or
7637			127.0.0.1 if the address is unavailable.
7638
7639			=item B<script_name()>
7640			Return the script name as a partial URL, for self-referring
7641			scripts.
7642
7643			=item B<referer()>
7644
7645			Return the URL of the page the browser was viewing
7646			prior to fetching your script. Not available for all
7647			browsers.
7648
7649			=item B<auth_type ()>
7650
7651			Return the authorization/verification method in use for this
7652			script, if any.
7653
7654			=item B<server_name ()>
7655
7656			Returns the name of the server, usually the machine's host
7657			name.
7658
7659			=item B<virtual_host ()>
7660
7661			When using virtual hosts, returns the name of the host that
7662			the browser attempted to contact
7663
7664			=item B<server_port ()>
7665
7666			Return the port that the server is listening on.
7667
7668			=item B<virtual_port ()>
7669
7670			Like server_port() except that it takes virtual hosts into account.
7671			Use this when running with virtual hosts.
7672
7673			=item B<server_software ()>
7674
7675			Returns the server software and version number.
7676
7677			=item B<remote_user ()>
7678
7679			Return the authorization/verification name used for user
7680			verification, if this script is protected.
7681
7682			=item B<user_name ()>
7683
7684			Attempt to obtain the remote user's name, using a variety of different
7685			techniques. This only works with older browsers such as Mosaic.
7686			Newer browsers do not report the user name for privacy reasons!
7687
7688			=item B<request_method()>
7689
7690			Returns the method used to access your script, usually
7691			one of 'POST', 'GET' or 'HEAD'.
7692
7693			=item B<content_type()>
7694
7695			Returns the content_type of data submitted in a POST, generally
7696			multipart/form-data or application/x-www-form-urlencoded
7697
7698			=item B<http()>
7699
7700			Called with no arguments returns the list of HTTP environment
7701			variables, including such things as HTTP_USER_AGENT,
7702			HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the
7703			like-named HTTP header fields in the request. Called with the name of
7704			an HTTP header field, returns its value. Capitalization and the use
7705			of hyphens versus underscores are not significant.
7706
7707			For example, all three of these examples are equivalent:
7708
7709			$requested_language = http('Accept-language');
7710			$requested_language = http('Accept_language');
7711			$requested_language = http('HTTP_ACCEPT_LANGUAGE');
7712
7713			=item B<https()>
7714
7715			The same as I<http()>, but operates on the HTTPS environment variables
7716			present when the SSL protocol is in effect. Can be used to determine
7717			whether SSL is turned on.
7718
7719			=back
7720
7721			=head1 USING NPH SCRIPTS
7722
7723			NPH, or "no-parsed-header", scripts bypass the server completely by
7724			sending the complete HTTP header directly to the browser. This has
7725			slight performance benefits, but is of most use for taking advantage
7726			of HTTP extensions that are not directly supported by your server,
7727			such as server push and PICS headers.
7728
7729			Servers use a variety of conventions for designating CGI scripts as
7730			NPH. Many Unix servers look at the beginning of the script's name for
7731			the prefix "nph-". The Macintosh WebSTAR server and Microsoft's
7732			Internet Information Server, in contrast, try to decide whether a
7733			program is an NPH script by examining the first line of script output.
7734
7735
7736			CGI.pm supports NPH scripts with a special NPH mode. When in this
7737			mode, CGI.pm will output the necessary extra header information when
7738			the header() and redirect() methods are
7739			called.
7740
7741			The Microsoft Internet Information Server requires NPH mode. As of
7742			version 2.30, CGI.pm will automatically detect when the script is
7743			running under IIS and put itself into this mode. You do not need to
7744			do this manually, although it won't hurt anything if you do. However,
7745			note that if you have applied Service Pack 6, much of the
7746			functionality of NPH scripts, including the ability to redirect while
7747			setting a cookie, B<do not work at all> on IIS without a special patch
7748			from Microsoft. See
7749			http://web.archive.org/web/20010812012030/http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP
7750			Non-Parsed Headers Stripped From CGI Applications That Have nph-
7751			Prefix in Name.
7752
7753			=over 4
7754
7755			=item In the B<use> statement
7756
7757			Simply add the "-nph" pragma to the list of symbols to be imported into
7758			your script:
7759
7760			use CGI qw(:standard -nph)
7761
7762			=item By calling the B<nph()> method:
7763
7764			Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
7765
7766			CGI->nph(1)
7767
7768			=item By using B<-nph> parameters
7769
7770			in the B<header()> and B<redirect()> statements:
7771
7772			print header(-nph=>1);
7773
7774			=back
7775
7776			=head1 SERVER PUSH
7777
7778			CGI.pm provides four simple functions for producing multipart
7779			documents of the type needed to implement server push. These
7780			functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To
7781			import these into your namespace, you must import the ":push" set.
7782			You are also advised to put the script into NPH mode and to set $\| to
7783			1 to avoid buffering problems.
7784
7785			Here is a simple script that demonstrates server push:
7786
7787			#!/usr/local/bin/perl
7788			use CGI qw/:push -nph/;
7789			$\| = 1;
7790			print multipart_init(-boundary=>'----here we go!');
7791			for (0 .. 4) {
7792			print multipart_start(-type=>'text/plain'),
7793			"The current time is ",scalar(localtime),"\n";
7794			if ($_ < 4) {
7795			print multipart_end;
7796			} else {
7797			print multipart_final;
7798			}
7799			sleep 1;
7800			}
7801
7802			This script initializes server push by calling B<multipart_init()>.
7803			It then enters a loop in which it begins a new multipart section by
7804			calling B<multipart_start()>, prints the current local time,
7805			and ends a multipart section with B<multipart_end()>. It then sleeps
7806			a second, and begins again. On the final iteration, it ends the
7807			multipart section with B<multipart_final()> rather than with
7808			B<multipart_end()>.
7809
7810			=over 4
7811
7812			=item multipart_init()
7813
7814			multipart_init(-boundary=>$boundary, -charset=>$charset);
7815
7816			Initialize the multipart system. The -boundary argument specifies
7817			what MIME boundary string to use to separate parts of the document.
7818			If not provided, CGI.pm chooses a reasonable boundary for you.
7819
7820			The -charset provides the character set, if not provided this will
7821			default to ISO-8859-1
7822
7823			=item multipart_start()
7824
7825			multipart_start(-type=>$type, -charset=>$charset)
7826
7827			Start a new part of the multipart document using the specified MIME
7828			type and charset. If not specified, text/html ISO-8859-1 is assumed.
7829
7830			=item multipart_end()
7831
7832			multipart_end()
7833
7834			End a part. You must remember to call multipart_end() once for each
7835			multipart_start(), except at the end of the last part of the multipart
7836			document when multipart_final() should be called instead of multipart_end().
7837
7838			=item multipart_final()
7839
7840			multipart_final()
7841
7842			End all parts. You should call multipart_final() rather than
7843			multipart_end() at the end of the last part of the multipart document.
7844
7845			=back
7846
7847			Users interested in server push applications should also have a look
7848			at the CGI::Push module.
7849
7850			=head1 AVOIDING DENIAL OF SERVICE ATTACKS
7851
7852			A potential problem with CGI.pm is that, by default, it attempts to
7853			process form POSTings no matter how large they are. A wily hacker
7854			could attack your site by sending a CGI script a huge POST of many
7855			megabytes. CGI.pm will attempt to read the entire POST into a
7856			variable, growing hugely in size until it runs out of memory. While
7857			the script attempts to allocate the memory the system may slow down
7858			dramatically. This is a form of denial of service attack.
7859
7860			Another possible attack is for the remote user to force CGI.pm to
7861			accept a huge file upload. CGI.pm will accept the upload and store it
7862			in a temporary directory even if your script doesn't expect to receive
7863			an uploaded file. CGI.pm will delete the file automatically when it
7864			terminates, but in the meantime the remote user may have filled up the
7865			server's disk space, causing problems for other programs.
7866
7867			The best way to avoid denial of service attacks is to limit the amount
7868			of memory, CPU time and disk space that CGI scripts can use. Some Web
7869			servers come with built-in facilities to accomplish this. In other
7870			cases, you can use the shell I<limit> or I<ulimit>
7871			commands to put ceilings on CGI resource usage.
7872
7873
7874			CGI.pm also has some simple built-in protections against denial of
7875			service attacks, but you must activate them before you can use them.
7876			These take the form of two global variables in the CGI name space:
7877
7878			=over 4
7879
7880			=item B<$CGI::POST_MAX>
7881
7882			If set to a non-negative integer, this variable puts a ceiling
7883			on the size of POSTings, in bytes. If CGI.pm detects a POST
7884			that is greater than the ceiling, it will immediately exit with an error
7885			message. This value will affect both ordinary POSTs and
7886			multipart POSTs, meaning that it limits the maximum size of file
7887			uploads as well. You should set this to a reasonably high
7888			value, such as 1 megabyte.
7889
7890			=item B<$CGI::DISABLE_UPLOADS>
7891
7892			If set to a non-zero value, this will disable file uploads
7893			completely. Other fill-out form values will work as usual.
7894
7895			=back
7896
7897			You can use these variables in either of two ways.
7898
7899			=over 4
7900
7901			=item B<1. On a script-by-script basis>
7902
7903			Set the variable at the top of the script, right after the "use" statement:
7904
7905			use CGI qw/:standard/;
7906			use CGI::Carp 'fatalsToBrowser';
7907			$CGI::POST_MAX=1024 * 100; # max 100K posts
7908			$CGI::DISABLE_UPLOADS = 1; # no uploads
7909
7910			=item B<2. Globally for all scripts>
7911
7912			Open up CGI.pm, find the definitions for $POST_MAX and
7913			$DISABLE_UPLOADS, and set them to the desired values. You'll
7914			find them towards the top of the file in a subroutine named
7915			initialize_globals().
7916
7917			=back
7918
7919			An attempt to send a POST larger than $POST_MAX bytes will cause
7920			I<param()> to return an empty CGI parameter list. You can test for
7921			this event by checking I<cgi_error()>, either after you create the CGI
7922			object or, if you are using the function-oriented interface, call
7923			<param()> for the first time. If the POST was intercepted, then
7924			cgi_error() will return the message "413 POST too large".
7925
7926			This error message is actually defined by the HTTP protocol, and is
7927			designed to be returned to the browser as the CGI script's status
7928			code. For example:
7929
7930			$uploaded_file = param('upload');
7931			if (!$uploaded_file && cgi_error()) {
7932			print header(-status=>cgi_error());
7933			exit 0;
7934			}
7935
7936			However it isn't clear that any browser currently knows what to do
7937			with this status code. It might be better just to create an
7938			HTML page that warns the user of the problem.
7939
7940			=head1 COMPATIBILITY WITH CGI-LIB.PL
7941
7942			To make it easier to port existing programs that use cgi-lib.pl the
7943			compatibility routine "ReadParse" is provided. Porting is simple:
7944
7945			OLD VERSION
7946
7947			require "cgi-lib.pl";
7948			&ReadParse;
7949			print "The value of the antique is $in{antique}.\n";
7950
7951			NEW VERSION
7952
7953			use CGI;
7954			CGI::ReadParse();
7955			print "The value of the antique is $in{antique}.\n";
7956
7957			CGI.pm's ReadParse() routine creates a tied variable named %in,
7958			which can be accessed to obtain the query variables. Like
7959			ReadParse, you can also provide your own variable. Infrequently
7960			used features of ReadParse, such as the creation of @in and $in
7961			variables, are not supported.
7962
7963			Once you use ReadParse, you can retrieve the query object itself
7964			this way:
7965
7966			$q = $in{CGI};
7967			print $q->textfield(-name=>'wow',
7968			-value=>'does this really work?');
7969
7970			This allows you to start using the more interesting features
7971			of CGI.pm without rewriting your old scripts from scratch.
7972
7973			An even simpler way to mix cgi-lib calls with CGI.pm calls is to import both the
7974			C<:cgi-lib> and C<:standard> method:
7975
7976			use CGI qw(:cgi-lib :standard);
7977			&ReadParse;
7978			print "The price of your purchase is $in{price}.\n";
7979			print textfield(-name=>'price', -default=>'$1.99');
7980
7981			=head2 Cgi-lib functions that are available in CGI.pm
7982
7983			In compatibility mode, the following cgi-lib.pl functions are
7984			available for your use:
7985
7986			ReadParse()
7987			PrintHeader()
7988			HtmlTop()
7989			HtmlBot()
7990			SplitParam()
7991			MethGet()
7992			MethPost()
7993
7994			=head2 Cgi-lib functions that are not available in CGI.pm
7995
7996			* Extended form of ReadParse()
7997			The extended form of ReadParse() that provides for file upload
7998			spooling, is not available.
7999
8000			* MyBaseURL()
8001			This function is not available. Use CGI.pm's url() method instead.
8002
8003			* MyFullURL()
8004			This function is not available. Use CGI.pm's self_url() method
8005			instead.
8006
8007			* CgiError(), CgiDie()
8008			These functions are not supported. Look at CGI::Carp for the way I
8009			prefer to handle error messages.
8010
8011			* PrintVariables()
8012			This function is not available. To achieve the same effect,
8013			just print out the CGI object:
8014
8015			use CGI qw(:standard);
8016			$q = CGI->new;
8017			print h1("The Variables Are"),$q;
8018
8019			* PrintEnv()
8020			This function is not available. You'll have to roll your own if you really need it.
8021
8022			=head1 LICENSE
8023
8024			The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is
8025			distributed under GPL and the Artistic License 2.0. It is currently
8026			maintained by Lee Johnson (LEEJO) with help from many contributors.
8027
8028			=head1 CREDITS
8029
8030			Thanks very much to:
8031
8032			=over 4
8033
8034			=item Mark Stosberg (mark@stosberg.com)
8035
8036			=item Matt Heffron (heffron@falstaff.css.beckman.com)
8037
8038			=item James Taylor (james.taylor@srs.gov)
8039
8040			=item Scott Anguish <sanguish@digifix.com>
8041
8042			=item Mike Jewell (mlj3u@virginia.edu)
8043
8044			=item Timothy Shimmin (tes@kbs.citri.edu.au)
8045
8046			=item Joergen Haegg (jh@axis.se)
8047
8048			=item Laurent Delfosse (delfosse@delfosse.com)
8049
8050			=item Richard Resnick (applepi1@aol.com)
8051
8052			=item Craig Bishop (csb@barwonwater.vic.gov.au)
8053
8054			=item Tony Curtis (tc@vcpc.univie.ac.at)
8055
8056			=item Tim Bunce (Tim.Bunce@ig.co.uk)
8057
8058			=item Tom Christiansen (tchrist@convex.com)
8059
8060			=item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
8061
8062			=item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
8063
8064			=item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
8065
8066			=item Stephen Dahmen (joyfire@inxpress.net)
8067
8068			=item Ed Jordan (ed@fidalgo.net)
8069
8070			=item David Alan Pisoni (david@cnation.com)
8071
8072			=item Doug MacEachern (dougm@opengroup.org)
8073
8074			=item Robin Houston (robin@oneworld.org)
8075
8076			=item ...and many many more...
8077
8078			for suggestions and bug fixes.
8079
8080			=back
8081
8082			=head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
8083
8084
8085			#!/usr/local/bin/perl
8086
8087			use CGI ':standard';
8088
8089			print header;
8090			print start_html("Example CGI.pm Form");
8091			print "<h1> Example CGI.pm Form</h1>\n";
8092			print_prompt();
8093			do_work();
8094			print_tail();
8095			print end_html;
8096
8097			sub print_prompt {
8098			print start_form;
8099			print "<em>What's your name?</em><br>";
8100			print textfield('name');
8101			print checkbox('Not my real name');
8102
8103			print "<p><em>Where can you find English Sparrows?</em><br>";
8104			print checkbox_group(
8105			-name=>'Sparrow locations',
8106			-values=>[England,France,Spain,Asia,Hoboken],
8107			-linebreak=>'yes',
8108			-defaults=>[England,Asia]);
8109
8110			print "<p><em>How far can they fly?</em><br>",
8111			radio_group(
8112			-name=>'how far',
8113			-values=>['10 ft','1 mile','10 miles','real far'],
8114			-default=>'1 mile');
8115
8116			print "<p><em>What's your favorite color?</em> ";
8117			print popup_menu(-name=>'Color',
8118			-values=>['black','brown','red','yellow'],
8119			-default=>'red');
8120
8121			print hidden('Reference','Monty Python and the Holy Grail');
8122
8123			print "<p><em>What have you got there?</em><br>";
8124			print scrolling_list(
8125			-name=>'possessions',
8126			-values=>['A Coconut','A Grail','An Icon',
8127			'A Sword','A Ticket'],
8128			-size=>5,
8129			-multiple=>'true');
8130
8131			print "<p><em>Any parting comments?</em><br>";
8132			print textarea(-name=>'Comments',
8133			-rows=>10,
8134			-columns=>50);
8135
8136			print "<p>",reset;
8137			print submit('Action','Shout');
8138			print submit('Action','Scream');
8139			print end_form;
8140			print "<hr>\n";
8141			}
8142
8143			sub do_work {
8144
8145			print "<h2>Here are the current settings in this form</h2>";
8146
8147			for my $key (param) {
8148			print "<strong>$key</strong> -> ";
8149			my @values = param($key);
8150			print join(", ",@values),"<br>\n";
8151			}
8152			}
8153
8154			sub print_tail {
8155			print <<END;
8156			<hr>
8157			<address>Lincoln D. Stein</address><br>
8158			<a href="/">Home Page</a>
8159			END
8160			}
8161
8162			=head1 BUGS
8163
8164			Address bug reports and comments to: L<https://github.com/leejo/CGI.pm/issues>
8165
8166			The original bug tracker can be found at: L<https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm>
8167
8168			When sending bug reports, please provide the version of CGI.pm, the version of
8169			Perl, the name and version of your Web server, and the name and version of the
8170			operating system you are using. If the problem is even remotely browser
8171			dependent, please provide information about the affected browsers as well.
8172
8173			=head1 SEE ALSO
8174
8175			L<CGI::Carp> - provides a L<Carp> implementation tailored to the CGI environment.
8176
8177			L<CGI::Fast> - supports running CGI applications under FastCGI
8178
8179			L<CGI::Pretty> - pretty prints HTML generated by CGI.pm (with a performance penalty)
8180
8181			=cut
8182