NYTProf Profile: /usr/share/perl/5.10/CGI.pm

File	/usr/share/perl/5.10/CGI.pm
Statements Executed	462
Total Time	0.0176795 seconds

Subroutines — ordered by exclusive time
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
7	1	1	7.26ms	7.26ms	CGI::::_compile CGI::_compile
22	7	6	150µs	150µs	CGI::::self_or_default CGI::self_or_default
7	7	4	80µs	7.34ms	CGI::::AUTOLOAD CGI::AUTOLOAD
1	1	1	78µs	5.89ms	CGI::::init CGI::init
7	6	3	76µs	132µs	CGI::::param CGI::param
3	3	3	68µs	98µs	CGI::::import CGI::import
1	1	1	51µs	5.94ms	CGI::::new CGI::new
1	1	1	51µs	51µs	CGITempFile::::find_tempdir CGITempFile::find_tempdir
3	3	2	31µs	53µs	CGI::::charset CGI::charset
3	1	1	30µs	30µs	CGI::::_setup_symbols CGI::_setup_symbols
2	1	1	19µs	19µs	CGI::::self_or_CGI CGI::self_or_CGI
3	1	1	18µs	18µs	CGI::::all_parameters CGI::all_parameters
1	1	1	17µs	17µs	CGI::::initialize_globals CGI::initialize_globals
1	1	1	16µs	43µs	CGI::::save_request CGI::save_request
0	0	0	0s	0s	CGI::::BEGIN CGI::BEGIN
0	0	0	0s	0s	CGI::::DESTROY CGI::DESTROY
0	0	0	0s	0s	CGI::::__ANON__[:924] CGI::__ANON__[:924]
0	0	0	0s	0s	CGI::::_checked CGI::_checked
0	0	0	0s	0s	CGI::::_make_tag_func CGI::_make_tag_func
0	0	0	0s	0s	CGI::::_reset_globals CGI::_reset_globals
0	0	0	0s	0s	CGI::::_selected CGI::_selected
0	0	0	0s	0s	CGI::::add_parameter CGI::add_parameter
0	0	0	0s	0s	CGI::::binmode CGI::binmode
0	0	0	0s	0s	CGI::::can CGI::can
0	0	0	0s	0s	CGI::::cgi_error CGI::cgi_error
0	0	0	0s	0s	CGI::::compile CGI::compile
0	0	0	0s	0s	CGI::::element_id CGI::element_id
0	0	0	0s	0s	CGI::::element_tab CGI::element_tab
0	0	0	0s	0s	CGI::::expand_tags CGI::expand_tags
0	0	0	0s	0s	CGI::::parse_params CGI::parse_params
0	0	0	0s	0s	CGI::::print CGI::print
0	0	0	0s	0s	CGI::::put CGI::put
0	0	0	0s	0s	CGI::::r CGI::r
0	0	0	0s	0s	CGI::::to_filehandle CGI::to_filehandle
0	0	0	0s	0s	CGI::::upload_hook CGI::upload_hook
0	0	0	0s	0s	CGITempFile::::DESTROY CGITempFile::DESTROY
0	0	0	0s	0s	Fh::::BEGIN Fh::BEGIN
0	0	0	0s	0s	Fh::::DESTROY Fh::DESTROY
0	0	0	0s	0s	MultipartBuffer::::BEGINMultipartBuffer::BEGIN
0	0	0	0s	0s	MultipartBuffer::::DESTROYMultipartBuffer::DESTROY

Line	Stmts.	Exclusive Time	Avg.	Code
1				package CGI;
2	1	60µs	60µs	require 5.004;
3	3	479µs	160µs	use Carp 'croak'; # spent 62µs making 1 call to Exporter::import
4
5				# See the bottom of this file for the POD documentation. Search for the
6				# string '=head'.
7
8				# You can run this file through either pod2man or pod2html to produce pretty
9				# documentation in manual or html file format (these utilities are part of the
10				# Perl 5 distribution).
11
12				# Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
13				# It may be used and modified freely, but I do request that this copyright
14				# notice remain attached to the file. You may modify this module as you
15				# wish, but if you redistribute a modified version, please attach a note
16				# listing the modifications you have made.
17
18				# The most recent version and complete docs are available at:
19				# http://stein.cshl.org/WWW/software/CGI/
20
21	1	900ns	900ns	$CGI::revision = '$Id: CGI.pm,v 1.234 2007/04/16 16:58:46 lstein Exp $';
22	1	400ns	400ns	$CGI::VERSION='3.29';
23
24				# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
25				# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
26				# $CGITempFile::TMPDIRECTORY = '/usr/tmp';
27	3	146µs	49µs	use CGI::Util qw(rearrange make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic); # spent 95µs making 1 call to Exporter::import
28
29				#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
30				# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
31
32				use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN', # spent 72µs making 1 call to constant::import
33	3	6.68ms	2.23ms	'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
34
35				{
36	3	8µs	3µs	local $^W = 0;
37				$TAINTED = substr("$0$^X",0,0);
38				}
39
40	1	400ns	400ns	$MOD_PERL = 0; # no mod_perl by default
41	1	800ns	800ns	@SAVED_SYMBOLS = ();
42
43
44				# >>>>> Here are some globals that you might want to adjust <<<<<<
45				# spent 17µs within CGI::initialize_globals which was called # once (17µs+0s) at line 133 sub initialize_globals {
46				# Set this to 1 to enable copious autoloader debugging messages
47	24	10µs	433ns	$AUTOLOAD_DEBUG = 0;
48
49				# Set this to 1 to generate XTML-compatible output
50				$XHTML = 1;
51
52				# Change this to the preferred DTD to print in start_html()
53				# or use default_dtd('text of DTD to use');
54				$DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
55				'http://www.w3.org/TR/html4/loose.dtd' ] ;
56
57				# Set this to 1 to enable NOSTICKY scripts
58				# or:
59				# 1) use CGI qw(-nosticky)
60				# 2) $CGI::nosticky(1)
61				$NOSTICKY = 0;
62
63				# Set this to 1 to enable NPH scripts
64				# or:
65				# 1) use CGI qw(-nph)
66				# 2) CGI::nph(1)
67				# 3) print header(-nph=>1)
68				$NPH = 0;
69
70				# Set this to 1 to enable debugging from @ARGV
71				# Set to 2 to enable debugging from STDIN
72				$DEBUG = 1;
73
74				# Set this to 1 to make the temporary files created
75				# during file uploads safe from prying eyes
76				# or do...
77				# 1) use CGI qw(:private_tempfiles)
78				# 2) CGI::private_tempfiles(1);
79				$PRIVATE_TEMPFILES = 0;
80
81				# Set this to 1 to generate automatic tab indexes
82				$TABINDEX = 0;
83
84				# Set this to 1 to cause files uploaded in multipart documents
85				# to be closed, instead of caching the file handle
86				# or:
87				# 1) use CGI qw(:close_upload_files)
88				# 2) $CGI::close_upload_files(1);
89				# Uploads with many files run out of file handles.
90				# Also, for performance, since the file is already on disk,
91				# it can just be renamed, instead of read and written.
92				$CLOSE_UPLOAD_FILES = 0;
93
94				# Set this to a positive value to limit the size of a POSTing
95				# to a certain number of bytes:
96				$POST_MAX = -1;
97
98				# Change this to 1 to disable uploads entirely:
99				$DISABLE_UPLOADS = 0;
100
101				# Automatically determined -- don't change
102				$EBCDIC = 0;
103
104				# Change this to 1 to suppress redundant HTTP headers
105				$HEADERS_ONCE = 0;
106
107				# separate the name=value pairs by semicolons rather than ampersands
108				$USE_PARAM_SEMICOLONS = 1;
109
110				# Do not include undefined params parsed from query string
111				# use CGI qw(-no_undef_params);
112				$NO_UNDEF_PARAMS = 0;
113
114				# Other globals that you shouldn't worry about.
115				undef $Q;
116				$BEEN_THERE = 0;
117				$DTD_PUBLIC_IDENTIFIER = "";
118				undef @QUERY_PARAM;
119				undef %EXPORT;
120				undef $QUERY_CHARSET;
121				undef %QUERY_FIELDNAMES;
122				undef %QUERY_TMPFILES;
123
124				# prevent complaints by mod_perl
125				1;
126				}
127
128				# ------------------ START OF THE LIBRARY ------------
129
130	1	7µs	7µs	*end_form = \&endform;
131
132				# make mod_perlhappy
133	1	7µs	7µs	initialize_globals(); # spent 17µs making 1 call to CGI::initialize_globals
134
135				# FIGURE OUT THE OS WE'RE RUNNING UNDER
136				# Some systems support the $^O variable. If not
137				# available then require() the Config library
138	2	2µs	1µs	unless ($OS) {
139				unless ($OS = $^O) {
140				require Config;
141				$OS = $Config::Config{'osname'};
142				}
143				}
144	2	4µs	2µs	if ($OS =~ /^MSWin/i) {
145				$OS = 'WINDOWS';
146				} elsif ($OS =~ /^VMS/i) {
147				$OS = 'VMS';
148				} elsif ($OS =~ /^dos/i) {
149				$OS = 'DOS';
150				} elsif ($OS =~ /^MacOS/i) {
151				$OS = 'MACINTOSH';
152				} elsif ($OS =~ /^os2/i) {
153				$OS = 'OS2';
154				} elsif ($OS =~ /^epoc/i) {
155				$OS = 'EPOC';
156				} elsif ($OS =~ /^cygwin/i) {
157				$OS = 'CYGWIN';
158				} else {
159				$OS = 'UNIX';
160				}
161
162				# Some OS logic. Binary mode enabled on DOS, NT and VMS
163	1	800ns	800ns	$needs_binmode = $OS=~/^(WINDOWS\|DOS\|OS2\|MSWin\|CYGWIN)/;
164
165				# This is the default class for the CGI object to use when all else fails.
166	1	600ns	600ns	$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
167
168				# This is where to look for autoloaded routines.
169	1	400ns	400ns	$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
170
171				# The path separator is a slash, backslash or semicolon, depending
172				# on the paltform.
173	1	7µs	7µs	$SL = {
174				UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/',
175				WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
176				}->{$OS};
177
178				# This no longer seems to be necessary
179				# Turn on NPH scripts by default when running under IIS server!
180				# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
181	1	800ns	800ns	$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
182
183				# Turn on special checking for Doug MacEachern's modperl
184	1	700ns	700ns	if (exists $ENV{MOD_PERL}) {
185				# mod_perl handlers may run system() on scripts using CGI.pm;
186				# Make sure so we don't get fooled by inherited $ENV{MOD_PERL}
187				if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
188				$MOD_PERL = 2;
189				require Apache2::Response;
190				require Apache2::RequestRec;
191				require Apache2::RequestUtil;
192				require Apache2::RequestIO;
193				require APR::Pool;
194				} else {
195				$MOD_PERL = 1;
196				require Apache;
197				}
198				}
199
200				# Turn on special checking for ActiveState's PerlEx
201	1	400ns	400ns	$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
202
203				# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
204				# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
205				# and sometimes CR). The most popular VMS web server
206				# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
207				# use ASCII, so \015\012 means something different. I find this all
208				# really annoying.
209	1	500ns	500ns	$EBCDIC = "\t" ne "\011";
210	2	1µs	650ns	if ($OS eq 'VMS') {
211				$CRLF = "\n";
212				} elsif ($EBCDIC) {
213				$CRLF= "\r\n";
214				} else {
215				$CRLF = "\015\012";
216				}
217
218	1	200ns	200ns	if ($needs_binmode) {
219				$CGI::DefaultClass->binmode(\*main::STDOUT);
220				$CGI::DefaultClass->binmode(\*main::STDIN);
221				$CGI::DefaultClass->binmode(\*main::STDERR);
222				}
223
224				%EXPORT_TAGS = (
225	1	52µs	52µs	':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
226				tt u i b blockquote pre img a address cite samp dfn html head
227				base body Link nextid title meta kbd start_html end_html
228				input Select option comment charset escapeHTML/],
229				':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param
230				embed basefont style span layer ilayer font frameset frame script small big Area Map/],
231				':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
232				ins label legend noframes noscript object optgroup Q
233				thead tbody tfoot/],
234				':netscape'=>[qw/blink fontsize center/],
235				':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
236				submit reset defaults radio_group popup_menu button autoEscape
237				scrolling_list image_button start_form end_form startform endform
238				start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
239				':cgi'=>[qw/param upload path_info path_translated request_uri url self_url script_name
240				cookie Dump
241				raw_cookie request_method query_string Accept user_agent remote_host content_type
242				remote_addr referer server_name server_software server_port server_protocol virtual_port
243				virtual_host remote_ident auth_type http append
244				save_parameters restore_parameters param_fetch
245				remote_user user_name header redirect import_names put
246				Delete Delete_all url_param cgi_error/],
247				':ssl' => [qw/https/],
248				':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
249				':html' => [qw/:html2 :html3 :html4 :netscape/],
250				':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
251				':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
252				':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/]
253				);
254
255				# Custom 'can' method for both autoloaded and non-autoloaded subroutines.
256				# Author: Cees Hek <cees@sitesuite.com.au>
257
258				sub can {
259				my($class, $method) = @_;
260
261				# See if UNIVERSAL::can finds it.
262
263				if (my $func = $class -> SUPER::can($method) ){
264				return $func;
265				}
266
267				# Try to compile the function.
268
269				eval {
270				# _compile looks at $AUTOLOAD for the function name.
271
272				local $AUTOLOAD = join "::", $class, $method;
273				&_compile;
274				};
275
276				# Now that the function is loaded (if it exists)
277				# just use UNIVERSAL::can again to do the work.
278
279				return $class -> SUPER::can($method);
280				}
281
282				# to import symbols into caller
283				# spent 98µs (68+30) within CGI::import which was called 3 times, avg 33µs/call: # once (26µs+9µs) at line 21 of /home/chris/git/koha.git/opac/opac-main.pl # once (21µs+11µs) at line 22 of /home/chris/git/koha.git/C4/Suggestions.pm # once (21µs+10µs) at line 19 of /usr/share/perl/5.10/CGI/Cookie.pm sub import {
284	21	59µs	3µs	my $self = shift;
285
286				# This causes modules to clash.
287				undef %EXPORT_OK;
288				undef %EXPORT;
289
290				$self->_setup_symbols(@_); # spent 30µs making 3 calls to CGI::_setup_symbols, avg 10µs/call
291				my ($callpack, $callfile, $callline) = caller;
292
293				# To allow overriding, search through the packages
294				# Till we find one in which the correct subroutine is defined.
295				my @packages = ($self,@{"$self\:\:ISA"});
296				foreach $sym (keys %EXPORT) {
297				my $pck;
298				my $def = ${"$self\:\:AutoloadClass"} \|\| $DefaultClass;
299				foreach $pck (@packages) {
300				if (defined(&{"$pck\:\:$sym"})) {
301				$def = $pck;
302				last;
303				}
304				}
305				*{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
306				}
307				}
308
309				sub compile {
310				my $pack = shift;
311				$pack->_setup_symbols('-compile',@_);
312				}
313
314				sub expand_tags {
315				my($tag) = @_;
316				return ("start_$1","end_$1") if $tag=~/^(?:\*\|start_\|end_)(.+)/;
317				my(@r);
318				return ($tag) unless $EXPORT_TAGS{$tag};
319				foreach (@{$EXPORT_TAGS{$tag}}) {
320				push(@r,&expand_tags($_));
321				}
322				return @r;
323				}
324
325				#### Method: new
326				# The new routine. This will check the current environment
327				# for an existing query string, and initialize itself, if so.
328				####
329				# spent 5.94ms (51µs+5.89) within CGI::new which was called # once (51µs+5.89ms) at line 22 of /home/chris/git/koha.git/opac/opac-main.pl sub new {
330	10	33µs	3µs	my($class,@initializer) = @_;
331				my $self = {};
332
333				bless $self,ref $class \|\| $class \|\| $DefaultClass;
334
335				# always use a tempfile
336				$self->{'use_tempfile'} = 1;
337
338				if (ref($initializer[0])
339				&& (UNIVERSAL::isa($initializer[0],'Apache')
340				\|\|
341				UNIVERSAL::isa($initializer[0],'Apache2::RequestRec')
342				)) {
343				$self->r(shift @initializer);
344				}
345				if (ref($initializer[0])
346				&& (UNIVERSAL::isa($initializer[0],'CODE'))) {
347				$self->upload_hook(shift @initializer, shift @initializer);
348				$self->{'use_tempfile'} = shift @initializer if (@initializer > 0);
349				}
350				if ($MOD_PERL) {
351				if ($MOD_PERL == 1) {
352				$self->r(Apache->request) unless $self->r;
353				my $r = $self->r;
354				$r->register_cleanup(\&CGI::_reset_globals);
355				}
356				else {
357				# XXX: once we have the new API
358				# will do a real PerlOptions -SetupEnv check
359				$self->r(Apache2::RequestUtil->request) unless $self->r;
360				my $r = $self->r;
361				$r->subprocess_env unless exists $ENV{REQUEST_METHOD};
362				$r->pool->cleanup_register(\&CGI::_reset_globals);
363				}
364				undef $NPH;
365				}
366				$self->_reset_globals if $PERLEX;
367				$self->init(@initializer); # spent 5.89ms making 1 call to CGI::init
368				return $self;
369				}
370
371				# We provide a DESTROY method so that we can ensure that
372				# temporary files are closed (via Fh->DESTROY) before they
373				# are unlinked (via CGITempFile->DESTROY) because it is not
374				# possible to unlink an open file on Win32. We explicitly
375				# call DESTROY on each, rather than just undefing them and
376				# letting Perl DESTROY them by garbage collection, in case the
377				# user is still holding any reference to them as well.
378				sub DESTROY {
379	2	2µs	1µs	my $self = shift;
380				if ($OS eq 'WINDOWS') {
381				foreach my $href (values %{$self->{'.tmpfiles'}}) {
382				$href->{hndl}->DESTROY if defined $href->{hndl};
383				$href->{name}->DESTROY if defined $href->{name};
384				}
385				}
386				}
387
388				sub r {
389				my $self = shift;
390				my $r = $self->{'.r'};
391				$self->{'.r'} = shift if @_;
392				$r;
393				}
394
395				sub upload_hook {
396				my $self;
397				if (ref $_[0] eq 'CODE') {
398				$CGI::Q = $self = $CGI::DefaultClass->new(@_);
399				} else {
400				$self = shift;
401				}
402				my ($hook,$data,$use_tempfile) = @_;
403				$self->{'.upload_hook'} = $hook;
404				$self->{'.upload_data'} = $data;
405				$self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile;
406				}
407
408				#### Method: param
409				# Returns the value(s)of a named parameter.
410				# If invoked in a list context, returns the
411				# entire list. Otherwise returns the first
412				# member of the list.
413				# If name is not provided, return a list of all
414				# the known parameters names available.
415				# If more than one argument is provided, the
416				# second and subsequent arguments are used to
417				# set the value of the parameter.
418				####
419				# spent 132µs (76+56) within CGI::param which was called 7 times, avg 19µs/call: # 2 times (14µs+22µs) by CGI::delete at line 15 of (eval 0)[/usr/share/perl/5.10/CGI.pm:867] at line 867, avg 18µs/call # once (16µs+9µs) by C4::Auth::checkauth at line 531 of /home/chris/git/koha.git/C4/Auth.pm # once (16µs+8µs) by CGI::init at line 694 # once (14µs+5µs) by C4::Auth::checkauth at line 622 of /home/chris/git/koha.git/C4/Auth.pm # once (7µs+8µs) by CGI::save_request at line 752 # once (9µs+5µs) by CGI::init at line 700 sub param {
420	26	63µs	2µs	my($self,@p) = self_or_default(@_); # spent 38µs making 7 calls to CGI::self_or_default, avg 5µs/call
421				return $self->all_parameters unless @p; # spent 18µs making 3 calls to CGI::all_parameters, avg 6µs/call
422				my($name,$value,@other);
423
424				# For compatibility between old calling style and use_named_parameters() style,
425				# we have to special case for a single parameter present.
426	4	2µs	625ns	if (@p > 1) {
427				($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
428				my(@values);
429
430				if (substr($p[0],0,1) eq '-') {
431				@values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
432				} else {
433				foreach ($value,@other) {
434				push(@values,$_) if defined($_);
435				}
436				}
437				# If values is provided, then we set it.
438				if (@values or defined $value) {
439				$self->add_parameter($name);
440				$self->{$name}=[@values];
441				}
442				} else {
443				$name = $p[0];
444				}
445
446				return unless defined($name) && $self->{$name};
447
448				my $charset = $self->charset \|\| '';
449				my $utf8 = $charset eq 'utf-8';
450				if ($utf8) {
451				eval "require Encode; 1;" if $utf8 && !Encode->can('decode'); # bring in these functions
452				return wantarray ? map {Encode::decode(utf8=>$_) } @{$self->{$name}}
453				: Encode::decode(utf8=>$self->{$name}->[0]);
454				} else {
455				return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
456				}
457				}
458
459				# spent 150µs within CGI::self_or_default which was called 22 times, avg 7µs/call: # 7 times (38µs+0s) by CGI::param at line 420, avg 5µs/call # 4 times (34µs+0s) by CGI::cookie at line 2 of (eval 0)[/usr/share/perl/5.10/CGI.pm:867] at line 867, avg 8µs/call # 4 times (22µs+0s) by CGI::unescapeHTML at line 4 of (eval 0)[/usr/share/perl/5.10/CGI.pm:867] at line 867, avg 5µs/call # 3 times (22µs+0s) by CGI::charset at line 938, avg 7µs/call # 2 times (13µs+0s) by CGI::delete at line 5 of (eval 0)[/usr/share/perl/5.10/CGI.pm:867] at line 867, avg 6µs/call # once (12µs+0s) by CGI::header at line 2 of (eval 0)[/usr/share/perl/5.10/CGI.pm:867] at line 867 # once (9µs+0s) by CGI::cache at line 2 of (eval 0)[/usr/share/perl/5.10/CGI.pm:867] at line 867 sub self_or_default {
460	66	83µs	1µs	return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
461				unless (defined($_[0]) &&
462				(ref($_[0]) eq 'CGI' \|\| UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
463				) {
464				$Q = $CGI::DefaultClass->new unless defined($Q);
465				unshift(@_,$Q);
466				}
467				return wantarray ? @_ : $Q;
468				}
469
470				# spent 19µs within CGI::self_or_CGI which was called 2 times, avg 10µs/call: # 2 times (19µs+0s) by CGI::https at line 3 of (eval 0)[/usr/share/perl/5.10/CGI.pm:867] at line 867, avg 10µs/call sub self_or_CGI {
471	4	10µs	2µs	local $^W=0; # prevent a warning
472				if (defined($_[0]) &&
473				(substr(ref($_[0]),0,3) eq 'CGI'
474				\|\| UNIVERSAL::isa($_[0],'CGI'))) {
475				return @_;
476				} else {
477				return ($DefaultClass,@_);
478				}
479				}
480
481				########################################
482				# THESE METHODS ARE MORE OR LESS PRIVATE
483				# GO TO THE __DATA__ SECTION TO SEE MORE
484				# PUBLIC METHODS
485				########################################
486
487				# Initialize the query object from the environment.
488				# If a parameter list is found, this object will be set
489				# to an associative array in which parameter names are keys
490				# and the values are stored as lists
491				# If a keyword list is found, this method creates a bogus
492				# parameter list with the single parameter 'keywords'.
493
494				# spent 5.89ms (78µs+5.81) within CGI::init which was called # once (78µs+5.81ms) by CGI::new at line 367 sub init {
495	20	68µs	3µs	my $self = shift;
496				my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
497
498				my $is_xforms;
499
500				my $initializer = shift; # for backward compatibility
501				local($/) = "\n";
502
503				# set autoescaping on by default
504				$self->{'escape'} = 1;
505
506				# if we get called more than once, we want to initialize
507				# ourselves from the original query (which may be gone
508				# if it was read from STDIN originally.)
509				if (defined(@QUERY_PARAM) && !defined($initializer)) {
510				for my $name (@QUERY_PARAM) {
511				my $val = $QUERY_PARAM{$name}; # always an arrayref;
512				$self->param('-name'=>$name,'-value'=> $val);
513				if (defined $val and ref $val eq 'ARRAY') {
514				for my $fh (grep {defined(fileno($_))} @$val) {
515				seek($fh,0,0); # reset the filehandle.
516				}
517
518				}
519				}
520				$self->charset($QUERY_CHARSET);
521				$self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
522				$self->{'.tmpfiles'} = {%QUERY_TMPFILES};
523				return;
524				}
525
526				$meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
527				$content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
528
529				$fh = to_filehandle($initializer) if $initializer;
530
531				# set charset to the safe ISO-8859-1
532				$self->charset('ISO-8859-1'); # spent 25µs making 1 call to CGI::charset
533
534				METHOD: {
535
536				# avoid unreasonably large postings
537	7	6µs	886ns	if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
538				#discard the post, unread
539				$self->cgi_error("413 Request entity too large");
540				last METHOD;
541				}
542
543				# Process multipart postings, but only if the initializer is
544				# not defined.
545				if ($meth eq 'POST'
546				&& defined($ENV{'CONTENT_TYPE'})
547				&& $ENV{'CONTENT_TYPE'}=~m\|^multipart/form-data\|
548				&& !defined($initializer)
549				) {
550				my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
551				$self->read_multipart($boundary,$content_length);
552				last METHOD;
553				}
554
555				# Process XForms postings. We know that we have XForms in the
556				# following cases:
557				# method eq 'POST' && content-type eq 'application/xml'
558				# method eq 'POST' && content-type =~ /multipart\/related.+start=/
559				# There are more cases, actually, but for now, we don't support other
560				# methods for XForm posts.
561				# In a XForm POST, the QUERY_STRING is parsed normally.
562				# If the content-type is 'application/xml', we just set the param
563				# XForms:Model (referring to the xml syntax) param containing the
564				# unparsed XML data.
565				# In the case of multipart/related we set XForms:Model as above, but
566				# the other parts are available as uploads with the Content-ID as the
567				# the key.
568				# See the URL below for XForms specs on this issue.
569				# http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options
570				if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) {
571				if ($ENV{'CONTENT_TYPE'} eq 'application/xml') {
572				my($param) = 'XForms:Model';
573				my($value) = '';
574				$self->add_parameter($param);
575				$self->read_from_client(\$value,$content_length,0)
576				if $content_length > 0;
577				push (@{$self->{$param}},$value);
578				$is_xforms = 1;
579				} elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\<?([^\"\>]+)\>?\"?/) {
580				my($boundary,$start) = ($1,$2);
581				my($param) = 'XForms:Model';
582				$self->add_parameter($param);
583				my($value) = $self->read_multipart_related($start,$boundary,$content_length,0);
584				push (@{$self->{$param}},$value);
585				if ($MOD_PERL) {
586				$query_string = $self->r->args;
587				} else {
588				$query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
589				$query_string \|\|= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
590				}
591				$is_xforms = 1;
592				}
593				}
594
595
596				# If initializer is defined, then read parameters
597				# from it.
598				if (!$is_xforms && defined($initializer)) {
599				if (UNIVERSAL::isa($initializer,'CGI')) {
600				$query_string = $initializer->query_string;
601				last METHOD;
602				}
603				if (ref($initializer) && ref($initializer) eq 'HASH') {
604				foreach (keys %$initializer) {
605				$self->param('-name'=>$_,'-value'=>$initializer->{$_});
606				}
607				last METHOD;
608				}
609
610				if (defined($fh) && ($fh ne '')) {
611				while (<$fh>) {
612				chomp;
613				last if /^=/;
614				push(@lines,$_);
615				}
616				# massage back into standard format
617				if ("@lines" =~ /=/) {
618				$query_string=join("&",@lines);
619				} else {
620				$query_string=join("+",@lines);
621				}
622				last METHOD;
623				}
624
625				# last chance -- treat it as a string
626				$initializer = $$initializer if ref($initializer) eq 'SCALAR';
627				$query_string = $initializer;
628
629				last METHOD;
630				}
631
632				# If method is GET or HEAD, fetch the query from
633				# the environment.
634				if ($is_xforms \|\| $meth=~/^(GET\|HEAD)$/) {
635				if ($MOD_PERL) {
636				$query_string = $self->r->args;
637				} else {
638				$query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
639				$query_string \|\|= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
640				}
641				last METHOD;
642				}
643
644				if ($meth eq 'POST') {
645				$self->read_from_client(\$query_string,$content_length,0)
646				if $content_length > 0;
647				# Some people want to have their cake and eat it too!
648				# Uncomment this line to have the contents of the query string
649				# APPENDED to the POST data.
650				# $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
651				last METHOD;
652				}
653
654				# If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
655				# Check the command line and then the standard input for data.
656				# We use the shellwords package in order to behave the way that
657				# UN*X programmers expect.
658	3	12µs	4µs	if ($DEBUG)
659				{
660				my $cmdline_ret = read_from_cmdline(); # spent 5.44ms making 1 call to CGI::AUTOLOAD
661				$query_string = $cmdline_ret->{'query_string'};
662				if (defined($cmdline_ret->{'subpath'}))
663				{
664				$self->path_info($cmdline_ret->{'subpath'});
665				}
666				}
667				}
668
669				# YL: Begin Change for XML handler 10/19/2001
670				if (!$is_xforms && $meth eq 'POST'
671				&& defined($ENV{'CONTENT_TYPE'})
672				&& $ENV{'CONTENT_TYPE'} !~ m\|^application/x-www-form-urlencoded\|
673				&& $ENV{'CONTENT_TYPE'} !~ m\|^multipart/form-data\| ) {
674				my($param) = 'POSTDATA' ;
675				$self->add_parameter($param) ;
676				push (@{$self->{$param}},$query_string);
677				undef $query_string ;
678				}
679				# YL: End Change for XML handler 10/19/2001
680
681				# We now have the query string in hand. We do slightly
682				# different things for keyword lists and parameter lists.
683				if (defined $query_string && length $query_string) {
684				if ($query_string =~ /[&=;]/) {
685				$self->parse_params($query_string);
686				} else {
687				$self->add_parameter('keywords');
688				$self->{'keywords'} = [$self->parse_keywordlist($query_string)];
689				}
690				}
691
692				# Special case. Erase everything if there is a field named
693				# .defaults.
694				if ($self->param('.defaults')) { # spent 24µs making 1 call to CGI::param
695				$self->delete_all();
696				}
697
698				# Associative array containing our defined fieldnames
699				$self->{'.fieldnames'} = {};
700				foreach ($self->param('.cgifields')) { # spent 14µs making 1 call to CGI::param
701				$self->{'.fieldnames'}->{$_}++;
702				}
703
704				# Clear out our default submission button flag if present
705				$self->delete('.submit'); # spent 178µs making 1 call to CGI::AUTOLOAD
706				$self->delete('.cgifields'); # spent 43µs making 1 call to CGI::delete
707
708				$self->save_request unless defined $initializer; # spent 43µs making 1 call to CGI::save_request
709				}
710
711				# FUNCTIONS TO OVERRIDE:
712				# Turn a string into a filehandle
713				sub to_filehandle {
714				my $thingy = shift;
715				return undef unless $thingy;
716				return $thingy if UNIVERSAL::isa($thingy,'GLOB');
717				return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
718				if (!ref($thingy)) {
719				my $caller = 1;
720				while (my $package = caller($caller++)) {
721				my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
722				return $tmp if defined(fileno($tmp));
723				}
724				}
725				return undef;
726				}
727
728				# send output to the browser
729				sub put {
730				my($self,@p) = self_or_default(@_);
731				$self->print(@p);
732				}
733
734				# print to standard output (for overriding in mod_perl)
735				sub print {
736				shift;
737				CORE::print(@_);
738				}
739
740				# get/set last cgi_error
741				sub cgi_error {
742				my ($self,$err) = self_or_default(@_);
743				$self->{'.cgi_error'} = $err if defined $err;
744				return $self->{'.cgi_error'};
745				}
746
747				# spent 43µs (16+27) within CGI::save_request which was called # once (16µs+27µs) by CGI::init at line 708 sub save_request {
748	6	18µs	3µs	my($self) = @_;
749				# We're going to play with the package globals now so that if we get called
750				# again, we initialize ourselves in exactly the same way. This allows
751				# us to have several of these objects.
752				@QUERY_PARAM = $self->param; # save list of parameters # spent 15µs making 1 call to CGI::param
753				foreach (@QUERY_PARAM) {
754				next unless defined $_;
755				$QUERY_PARAM{$_}=$self->{$_};
756				}
757				$QUERY_CHARSET = $self->charset; # spent 12µs making 1 call to CGI::charset
758				%QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
759				%QUERY_TMPFILES = %{ $self->{'.tmpfiles'} \|\| {} };
760				}
761
762				sub parse_params {
763				my($self,$tosplit) = @_;
764				my(@pairs) = split(/[&;]/,$tosplit);
765				my($param,$value);
766				foreach (@pairs) {
767				($param,$value) = split('=',$_,2);
768				next unless defined $param;
769				next if $NO_UNDEF_PARAMS and not defined $value;
770				$value = '' unless defined $value;
771				$param = unescape($param);
772				$value = unescape($value);
773				$self->add_parameter($param);
774				push (@{$self->{$param}},$value);
775				}
776				}
777
778				sub add_parameter {
779				my($self,$param)=@_;
780				return unless defined $param;
781				push (@{$self->{'.parameters'}},$param)
782				unless defined($self->{$param});
783				}
784
785				# spent 18µs within CGI::all_parameters which was called 3 times, avg 6µs/call: # 3 times (18µs+0s) by CGI::param at line 421, avg 6µs/call sub all_parameters {
786	8	9µs	1µs	my $self = shift;
787				return () unless defined($self) && $self->{'.parameters'};
788				return () unless @{$self->{'.parameters'}};
789				return @{$self->{'.parameters'}};
790				}
791
792				# put a filehandle into binary mode (DOS)
793				sub binmode {
794				return unless defined($_[1]) && defined fileno($_[1]);
795				CORE::binmode($_[1]);
796				}
797
798				sub _make_tag_func {
799				my ($self,$tagname) = @_;
800				my $func = qq(
801				sub $tagname {
802				my (\$q,\$a,\@rest) = self_or_default(\@_);
803				my(\$attr) = '';
804				if (ref(\$a) && ref(\$a) eq 'HASH') {
805				my(\@attr) = make_attributes(\$a,\$q->{'escape'});
806				\$attr = " \@attr" if \@attr;
807				} else {
808				unshift \@rest,\$a if defined \$a;
809				}
810				);
811				if ($tagname=~/start_(\w+)/i) {
812				$func .= qq! return "<\L$1\E\$attr>";} !;
813				} elsif ($tagname=~/end_(\w+)/i) {
814				$func .= qq! return "<\L/$1\E>"; } !;
815				} else {
816				$func .= qq#
817				return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest;
818				my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
819				my \@result = map { "\$tag\$_\$untag" }
820				(ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
821				return "\@result";
822				}#;
823				}
824				return $func;
825				}
826
827				# spent 7.34ms (80µs+7.26) within CGI::AUTOLOAD which was called 7 times, avg 1.05ms/call: # once (14µs+5.42ms) by CGI::init at line 660 # once (12µs+748µs) by C4::Output::output_with_http_headers at line 395 of /home/chris/git/koha.git/C4/Output.pm # once (8µs+282µs) by CGI::header at line 29 of (eval 0)[/usr/share/perl/5.10/CGI.pm:867] at line 867 # once (13µs+270µs) by C4::Auth::get_template_and_user at line 327 of /home/chris/git/koha.git/C4/Auth.pm # once (9µs+255µs) by C4::Output::themelanguage at line 144 of /home/chris/git/koha.git/C4/Output.pm # once (8µs+170µs) by CGI::init at line 705 # once (16µs+116µs) by CGI::header at line 63 of (eval 0)[/usr/share/perl/5.10/CGI.pm:867] at line 867 sub AUTOLOAD {
828	21	50µs	2µs	print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
829				my $func = &_compile; # spent 7.26ms making 7 calls to CGI::_compile, avg 1.04ms/call
830				goto &$func;
831				}
832
833				# spent 7.26ms within CGI::_compile which was called 7 times, avg 1.04ms/call: # 7 times (7.26ms+0s) by CGI::AUTOLOAD at line 829, avg 1.04ms/call sub _compile {
834	35	37µs	1µs	my($func) = $AUTOLOAD;
835				my($pack,$func_name);
836				{
837	98	2.11ms	22µs	local($1,$2); # this fixes an obscure variable suicide problem.
838				$func=~/(.+)::([^:]+)$/;
839				($pack,$func_name) = ($1,$2);
840				$pack=~s/::SUPER$//; # fix another obscure problem
841				$pack = ${"$pack\:\:AutoloadClass"} \|\| $CGI::DefaultClass
842				unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
843
844				my($sub) = \%{"$pack\:\:SUBS"};
845	5	4.91ms	983µs	unless (%$sub) {
846				my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
847				local ($@,$!);
848	1	187µs	187µs	eval "package $pack; $$auto";
849				croak("$AUTOLOAD: $@") if $@;
850				$$auto = ''; # Free the unneeded storage (but don't undef it!!!)
851				}
852				my($code) = $sub->{$func_name};
853
854				$code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
855				if (!$code) {
856				(my $base = $func_name) =~ s/^(start_\|end_)//i;
857				if ($EXPORT{':any'} \|\|
858				$EXPORT{'-any'} \|\|
859				$EXPORT{$base} \|\|
860				(%EXPORT_OK \|\| grep(++$EXPORT_OK{$_},&expand_tags(':html')))
861				&& $EXPORT_OK{$base}) {
862				$code = $CGI::DefaultClass->_make_tag_func($func_name);
863				}
864				}
865				croak("Undefined subroutine $AUTOLOAD\n") unless $code;
866				local ($@,$!);
867	1	580µs	580µs	eval "package $pack; $code"; # spent 423µs making 2 calls to CGI::AUTOLOAD, avg 211µs/call # spent 221µs making 7 calls to CGI::Util::rearrange, avg 32µs/call # spent 132µs making 1 call to CGI::Cookie::new # spent 90µs making 12 calls to CGI::self_or_default, avg 7µs/call # spent 82µs making 1 call to CGI::Cookie::as_string # spent 52µs making 3 calls to CGI::Cookie::fetch, avg 17µs/call # spent 47µs making 1 call to CGI::Util::expires # spent 40µs making 3 calls to CGI::unescapeHTML, avg 13µs/call # spent 36µs making 2 calls to CGI::param, avg 18µs/call # spent 19µs making 2 calls to CGI::self_or_CGI, avg 10µs/call # spent 16µs making 1 call to CGI::charset # spent 9µs making 1 call to UNIVERSAL::isa
868				if ($@) {
869				$@ =~ s/ at .*\n//;
870				croak("$AUTOLOAD: $@");
871				}
872				}
873				CORE::delete($sub->{$func_name}); #free storage
874				return "$pack\:\:$func_name";
875				}
876
877				sub _selected {
878				my $self = shift;
879				my $value = shift;
880				return '' unless $value;
881				return $XHTML ? qq(selected="selected" ) : qq(selected );
882				}
883
884				sub _checked {
885				my $self = shift;
886				my $value = shift;
887				return '' unless $value;
888				return $XHTML ? qq(checked="checked" ) : qq(checked );
889				}
890
891				sub _reset_globals { initialize_globals(); }
892
893				# spent 30µs within CGI::_setup_symbols which was called 3 times, avg 10µs/call: # 3 times (30µs+0s) by CGI::import at line 290, avg 10µs/call sub _setup_symbols {
894	18	17µs	956ns	my $self = shift;
895				my $compile = 0;
896
897				# to avoid reexporting unwanted variables
898				undef %EXPORT;
899
900				foreach (@_) {
901				$HEADERS_ONCE++, next if /^[:-]unique_headers$/;
902				$NPH++, next if /^[:-]nph$/;
903				$NOSTICKY++, next if /^[:-]nosticky$/;
904				$DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
905				$DEBUG=2, next if /^[:-][Dd]ebug$/;
906				$USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
907				$XHTML++, next if /^[:-]xhtml$/;
908				$XHTML=0, next if /^[:-]no_?xhtml$/;
909				$USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
910				$PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
911				$TABINDEX++, next if /^[:-]tabindex$/;
912				$CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
913				$EXPORT{$_}++, next if /^[:-]any$/;
914				$compile++, next if /^[:-]compile$/;
915				$NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
916
917				# This is probably extremely evil code -- to be deleted some day.
918				if (/^[-]autoload$/) {
919				my($pkg) = caller(1);
920				*{"${pkg}::AUTOLOAD"} = sub {
921				my($routine) = $AUTOLOAD;
922				$routine =~ s/^.*::/CGI::/;
923				&$routine;
924				};
925				next;
926				}
927
928				foreach (&expand_tags($_)) {
929				tr/a-zA-Z0-9_//cd; # don't allow weird function names
930				$EXPORT{$_}++;
931				}
932				}
933				_compile_all(keys %EXPORT) if $compile;
934				@SAVED_SYMBOLS = @_;
935				}
936
937				# spent 53µs (31+22) within CGI::charset which was called 3 times, avg 18µs/call: # once (12µs+13µs) by CGI::init at line 532 # once (11µs+5µs) by CGI::header at line 17 of (eval 0)[/usr/share/perl/5.10/CGI.pm:867] at line 867 # once (8µs+4µs) by CGI::save_request at line 757 sub charset {
938	9	24µs	3µs	my ($self,$charset) = self_or_default(@_); # spent 22µs making 3 calls to CGI::self_or_default, avg 7µs/call
939				$self->{'.charset'} = $charset if defined $charset;
940				$self->{'.charset'};
941				}
942
943				sub element_id {
944				my ($self,$new_value) = self_or_default(@_);
945				$self->{'.elid'} = $new_value if defined $new_value;
946				sprintf('%010d',$self->{'.elid'}++);
947				}
948
949				sub element_tab {
950				my ($self,$new_value) = self_or_default(@_);
951				$self->{'.etab'} \|\|= 1;
952				$self->{'.etab'} = $new_value if defined $new_value;
953				my $tab = $self->{'.etab'}++;
954				return '' unless $TABINDEX or defined $new_value;
955				return qq(tabindex="$tab" );
956				}
957
958				###############################################################################
959				################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
960				###############################################################################
961	1	400ns	400ns	$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
962	1	83µs	83µs	$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
963
964				%SUBS = (
965
966				'URL_ENCODED'=> <<'END_OF_FUNC',
967				sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
968				END_OF_FUNC
969
970				'MULTIPART' => <<'END_OF_FUNC',
971				sub MULTIPART { 'multipart/form-data'; }
972				END_OF_FUNC
973
974				'SERVER_PUSH' => <<'END_OF_FUNC',
975				sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
976				END_OF_FUNC
977
978				'new_MultipartBuffer' => <<'END_OF_FUNC',
979				# Create a new multipart buffer
980				sub new_MultipartBuffer {
981				my($self,$boundary,$length) = @_;
982				return MultipartBuffer->new($self,$boundary,$length);
983				}
984				END_OF_FUNC
985
986				'read_from_client' => <<'END_OF_FUNC',
987				# Read data from a file handle
988				sub read_from_client {
989				my($self, $buff, $len, $offset) = @_;
990				local $^W=0; # prevent a warning
991				return $MOD_PERL
992				? $self->r->read($$buff, $len, $offset)
993				: read(\*STDIN, $$buff, $len, $offset);
994				}
995				END_OF_FUNC
996
997				'delete' => <<'END_OF_FUNC',
998				#### Method: delete
999				# Deletes the named parameter entirely.
1000				####
1001				sub delete {
1002				my($self,@p) = self_or_default(@_);
1003				my(@names) = rearrange([NAME],@p);
1004				my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
1005				my %to_delete;
1006				foreach my $name (@to_delete)
1007				{
1008				CORE::delete $self->{$name};
1009				CORE::delete $self->{'.fieldnames'}->{$name};
1010				$to_delete{$name}++;
1011				}
1012				@{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
1013				return;
1014				}
1015				END_OF_FUNC
1016
1017				#### Method: import_names
1018				# Import all parameters into the given namespace.
1019				# Assumes namespace 'Q' if not specified
1020				####
1021				'import_names' => <<'END_OF_FUNC',
1022				sub import_names {
1023				my($self,$namespace,$delete) = self_or_default(@_);
1024				$namespace = 'Q' unless defined($namespace);
1025				die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
1026				if ($delete \|\| $MOD_PERL \|\| exists $ENV{'FCGI_ROLE'}) {
1027				# can anyone find an easier way to do this?
1028				foreach (keys %{"${namespace}::"}) {
1029				local *symbol = "${namespace}::${_}";
1030				undef $symbol;
1031				undef @symbol;
1032				undef %symbol;
1033				}
1034				}
1035				my($param,@value,$var);
1036				foreach $param ($self->param) {
1037				# protect against silly names
1038				($var = $param)=~tr/a-zA-Z0-9_/_/c;
1039				$var =~ s/^(?=\d)/_/;
1040				local *symbol = "${namespace}::$var";
1041				@value = $self->param($param);
1042				@symbol = @value;
1043				$symbol = $value[0];
1044				}
1045				}
1046				END_OF_FUNC
1047
1048				#### Method: keywords
1049				# Keywords acts a bit differently. Calling it in a list context
1050				# returns the list of keywords.
1051				# Calling it in a scalar context gives you the size of the list.
1052				####
1053				'keywords' => <<'END_OF_FUNC',
1054				sub keywords {
1055				my($self,@values) = self_or_default(@_);
1056				# If values is provided, then we set it.
1057				$self->{'keywords'}=[@values] if @values;
1058				my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
1059				@result;
1060				}
1061				END_OF_FUNC
1062
1063				# These are some tie() interfaces for compatibility
1064				# with Steve Brenner's cgi-lib.pl routines
1065				'Vars' => <<'END_OF_FUNC',
1066				sub Vars {
1067				my $q = shift;
1068				my %in;
1069				tie(%in,CGI,$q);
1070				return %in if wantarray;
1071				return \%in;
1072				}
1073				END_OF_FUNC
1074
1075				# These are some tie() interfaces for compatibility
1076				# with Steve Brenner's cgi-lib.pl routines
1077				'ReadParse' => <<'END_OF_FUNC',
1078				sub ReadParse {
1079				local(*in);
1080				if (@_) {
1081				*in = $_[0];
1082				} else {
1083				my $pkg = caller();
1084				in={"${pkg}::in"};
1085				}
1086				tie(%in,CGI);
1087				return scalar(keys %in);
1088				}
1089				END_OF_FUNC
1090
1091				'PrintHeader' => <<'END_OF_FUNC',
1092				sub PrintHeader {
1093				my($self) = self_or_default(@_);
1094				return $self->header();
1095				}
1096				END_OF_FUNC
1097
1098				'HtmlTop' => <<'END_OF_FUNC',
1099				sub HtmlTop {
1100				my($self,@p) = self_or_default(@_);
1101				return $self->start_html(@p);
1102				}
1103				END_OF_FUNC
1104
1105				'HtmlBot' => <<'END_OF_FUNC',
1106				sub HtmlBot {
1107				my($self,@p) = self_or_default(@_);
1108				return $self->end_html(@p);
1109				}
1110				END_OF_FUNC
1111
1112				'SplitParam' => <<'END_OF_FUNC',
1113				sub SplitParam {
1114				my ($param) = @_;
1115				my (@params) = split ("\0", $param);
1116				return (wantarray ? @params : $params[0]);
1117				}
1118				END_OF_FUNC
1119
1120				'MethGet' => <<'END_OF_FUNC',
1121				sub MethGet {
1122				return request_method() eq 'GET';
1123				}
1124				END_OF_FUNC
1125
1126				'MethPost' => <<'END_OF_FUNC',
1127				sub MethPost {
1128				return request_method() eq 'POST';
1129				}
1130				END_OF_FUNC
1131
1132				'TIEHASH' => <<'END_OF_FUNC',
1133				sub TIEHASH {
1134				my $class = shift;
1135				my $arg = $_[0];
1136				if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
1137				return $arg;
1138				}
1139				return $Q \|\|= $class->new(@_);
1140				}
1141				END_OF_FUNC
1142
1143				'STORE' => <<'END_OF_FUNC',
1144				sub STORE {
1145				my $self = shift;
1146				my $tag = shift;
1147				my $vals = shift;
1148				my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
1149				$self->param(-name=>$tag,-value=>\@vals);
1150				}
1151				END_OF_FUNC
1152
1153				'FETCH' => <<'END_OF_FUNC',
1154				sub FETCH {
1155				return $_[0] if $_[1] eq 'CGI';
1156				return undef unless defined $_[0]->param($_[1]);
1157				return join("\0",$_[0]->param($_[1]));
1158				}
1159				END_OF_FUNC
1160
1161				'FIRSTKEY' => <<'END_OF_FUNC',
1162				sub FIRSTKEY {
1163				$_[0]->{'.iterator'}=0;
1164				$_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1165				}
1166				END_OF_FUNC
1167
1168				'NEXTKEY' => <<'END_OF_FUNC',
1169				sub NEXTKEY {
1170				$_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1171				}
1172				END_OF_FUNC
1173
1174				'EXISTS' => <<'END_OF_FUNC',
1175				sub EXISTS {
1176				exists $_[0]->{$_[1]};
1177				}
1178				END_OF_FUNC
1179
1180				'DELETE' => <<'END_OF_FUNC',
1181				sub DELETE {
1182				$_[0]->delete($_[1]);
1183				}
1184				END_OF_FUNC
1185
1186				'CLEAR' => <<'END_OF_FUNC',
1187				sub CLEAR {
1188				%{$_[0]}=();
1189				}
1190				####
1191				END_OF_FUNC
1192
1193				####
1194				# Append a new value to an existing query
1195				####
1196				'append' => <<'EOF',
1197				sub append {
1198				my($self,@p) = self_or_default(@_);
1199				my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
1200				my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
1201				if (@values) {
1202				$self->add_parameter($name);
1203				push(@{$self->{$name}},@values);
1204				}
1205				return $self->param($name);
1206				}
1207				EOF
1208
1209				#### Method: delete_all
1210				# Delete all parameters
1211				####
1212				'delete_all' => <<'EOF',
1213				sub delete_all {
1214				my($self) = self_or_default(@_);
1215				my @param = $self->param();
1216				$self->delete(@param);
1217				}
1218				EOF
1219
1220				'Delete' => <<'EOF',
1221				sub Delete {
1222				my($self,@p) = self_or_default(@_);
1223				$self->delete(@p);
1224				}
1225				EOF
1226
1227				'Delete_all' => <<'EOF',
1228				sub Delete_all {
1229				my($self,@p) = self_or_default(@_);
1230				$self->delete_all(@p);
1231				}
1232				EOF
1233
1234				#### Method: autoescape
1235				# If you want to turn off the autoescaping features,
1236				# call this method with undef as the argument
1237				'autoEscape' => <<'END_OF_FUNC',
1238				sub autoEscape {
1239				my($self,$escape) = self_or_default(@_);
1240				my $d = $self->{'escape'};
1241				$self->{'escape'} = $escape;
1242				$d;
1243				}
1244				END_OF_FUNC
1245
1246
1247				#### Method: version
1248				# Return the current version
1249				####
1250				'version' => <<'END_OF_FUNC',
1251				sub version {
1252				return $VERSION;
1253				}
1254				END_OF_FUNC
1255
1256				#### Method: url_param
1257				# Return a parameter in the QUERY_STRING, regardless of
1258				# whether this was a POST or a GET
1259				####
1260				'url_param' => <<'END_OF_FUNC',
1261				sub url_param {
1262				my ($self,@p) = self_or_default(@_);
1263				my $name = shift(@p);
1264				return undef unless exists($ENV{QUERY_STRING});
1265				unless (exists($self->{'.url_param'})) {
1266				$self->{'.url_param'}={}; # empty hash
1267				if ($ENV{QUERY_STRING} =~ /=/) {
1268				my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
1269				my($param,$value);
1270				foreach (@pairs) {
1271				($param,$value) = split('=',$_,2);
1272				$param = unescape($param);
1273				$value = unescape($value);
1274				push(@{$self->{'.url_param'}->{$param}},$value);
1275				}
1276				} else {
1277				$self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
1278				}
1279				}
1280				return keys %{$self->{'.url_param'}} unless defined($name);
1281				return () unless $self->{'.url_param'}->{$name};
1282				return wantarray ? @{$self->{'.url_param'}->{$name}}
1283				: $self->{'.url_param'}->{$name}->[0];
1284				}
1285				END_OF_FUNC
1286
1287				#### Method: Dump
1288				# Returns a string in which all the known parameter/value
1289				# pairs are represented as nested lists, mainly for the purposes
1290				# of debugging.
1291				####
1292				'Dump' => <<'END_OF_FUNC',
1293				sub Dump {
1294				my($self) = self_or_default(@_);
1295				my($param,$value,@result);
1296				return '<ul></ul>' unless $self->param;
1297				push(@result,"<ul>");
1298				foreach $param ($self->param) {
1299				my($name)=$self->escapeHTML($param);
1300				push(@result,"<li><strong>$param</strong></li>");
1301				push(@result,"<ul>");
1302				foreach $value ($self->param($param)) {
1303				$value = $self->escapeHTML($value);
1304				$value =~ s/\n/<br \/>\n/g;
1305				push(@result,"<li>$value</li>");
1306				}
1307				push(@result,"</ul>");
1308				}
1309				push(@result,"</ul>");
1310				return join("\n",@result);
1311				}
1312				END_OF_FUNC
1313
1314				#### Method as_string
1315				#
1316				# synonym for "dump"
1317				####
1318				'as_string' => <<'END_OF_FUNC',
1319				sub as_string {
1320				&Dump(@_);
1321				}
1322				END_OF_FUNC
1323
1324				#### Method: save
1325				# Write values out to a filehandle in such a way that they can
1326				# be reinitialized by the filehandle form of the new() method
1327				####
1328				'save' => <<'END_OF_FUNC',
1329				sub save {
1330				my($self,$filehandle) = self_or_default(@_);
1331				$filehandle = to_filehandle($filehandle);
1332				my($param);
1333				local($,) = ''; # set print field separator back to a sane value
1334				local($\) = ''; # set output line separator to a sane value
1335				foreach $param ($self->param) {
1336				my($escaped_param) = escape($param);
1337				my($value);
1338				foreach $value ($self->param($param)) {
1339				print $filehandle "$escaped_param=",escape("$value"),"\n";
1340				}
1341				}
1342				foreach (keys %{$self->{'.fieldnames'}}) {
1343				print $filehandle ".cgifields=",escape("$_"),"\n";
1344				}
1345				print $filehandle "=\n"; # end of record
1346				}
1347				END_OF_FUNC
1348
1349
1350				#### Method: save_parameters
1351				# An alias for save() that is a better name for exportation.
1352				# Only intended to be used with the function (non-OO) interface.
1353				####
1354				'save_parameters' => <<'END_OF_FUNC',
1355				sub save_parameters {
1356				my $fh = shift;
1357				return save(to_filehandle($fh));
1358				}
1359				END_OF_FUNC
1360
1361				#### Method: restore_parameters
1362				# A way to restore CGI parameters from an initializer.
1363				# Only intended to be used with the function (non-OO) interface.
1364				####
1365				'restore_parameters' => <<'END_OF_FUNC',
1366				sub restore_parameters {
1367				$Q = $CGI::DefaultClass->new(@_);
1368				}
1369				END_OF_FUNC
1370
1371				#### Method: multipart_init
1372				# Return a Content-Type: style header for server-push
1373				# This has to be NPH on most web servers, and it is advisable to set $\| = 1
1374				#
1375				# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1376				# contribution, updated by Andrew Benham (adsb@bigfoot.com)
1377				####
1378				'multipart_init' => <<'END_OF_FUNC',
1379				sub multipart_init {
1380				my($self,@p) = self_or_default(@_);
1381				my($boundary,@other) = rearrange([BOUNDARY],@p);
1382				$boundary = $boundary \|\| '------- =_aaaaaaaaaa0';
1383				$self->{'separator'} = "$CRLF--$boundary$CRLF";
1384				$self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
1385				$type = SERVER_PUSH($boundary);
1386				return $self->header(
1387				-nph => 0,
1388				-type => $type,
1389				(map { split "=", $_, 2 } @other),
1390				) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
1391				}
1392				END_OF_FUNC
1393
1394
1395				#### Method: multipart_start
1396				# Return a Content-Type: style header for server-push, start of section
1397				#
1398				# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1399				# contribution, updated by Andrew Benham (adsb@bigfoot.com)
1400				####
1401				'multipart_start' => <<'END_OF_FUNC',
1402				sub multipart_start {
1403				my(@header);
1404				my($self,@p) = self_or_default(@_);
1405				my($type,@other) = rearrange([TYPE],@p);
1406				$type = $type \|\| 'text/html';
1407				push(@header,"Content-Type: $type");
1408
1409				# rearrange() was designed for the HTML portion, so we
1410				# need to fix it up a little.
1411				foreach (@other) {
1412				# Don't use \s because of perl bug 21951
1413				next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
1414				($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
1415				}
1416				push(@header,@other);
1417				my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1418				return $header;
1419				}
1420				END_OF_FUNC
1421
1422
1423				#### Method: multipart_end
1424				# Return a MIME boundary separator for server-push, end of section
1425				#
1426				# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1427				# contribution
1428				####
1429				'multipart_end' => <<'END_OF_FUNC',
1430				sub multipart_end {
1431				my($self,@p) = self_or_default(@_);
1432				return $self->{'separator'};
1433				}
1434				END_OF_FUNC
1435
1436
1437				#### Method: multipart_final
1438				# Return a MIME boundary separator for server-push, end of all sections
1439				#
1440				# Contributed by Andrew Benham (adsb@bigfoot.com)
1441				####
1442				'multipart_final' => <<'END_OF_FUNC',
1443				sub multipart_final {
1444				my($self,@p) = self_or_default(@_);
1445				return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
1446				}
1447				END_OF_FUNC
1448
1449
1450				#### Method: header
1451				# Return a Content-Type: style header
1452				#
1453				####
1454				'header' => <<'END_OF_FUNC',
1455				sub header {
1456				my($self,@p) = self_or_default(@_);
1457				my(@header);
1458
1459				return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
1460
1461				my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
1462				rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
1463				'STATUS',['COOKIE','COOKIES'],'TARGET',
1464				'EXPIRES','NPH','CHARSET',
1465				'ATTACHMENT','P3P'],@p);
1466
1467				$nph \|\|= $NPH;
1468
1469				$type \|\|= 'text/html' unless defined($type);
1470
1471				if (defined $charset) {
1472				$self->charset($charset);
1473				} else {
1474				$charset = $self->charset if $type =~ /^text\//;
1475				}
1476				$charset \|\|= '';
1477
1478				# rearrange() was designed for the HTML portion, so we
1479				# need to fix it up a little.
1480				foreach (@other) {
1481				# Don't use \s because of perl bug 21951
1482				next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
1483				($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
1484				}
1485
1486				$type .= "; charset=$charset"
1487				if $type ne ''
1488				and $type !~ /\bcharset\b/
1489				and defined $charset
1490				and $charset ne '';
1491
1492				# Maybe future compatibility. Maybe not.
1493				my $protocol = $ENV{SERVER_PROTOCOL} \|\| 'HTTP/1.0';
1494				push(@header,$protocol . ' ' . ($status \|\| '200 OK')) if $nph;
1495				push(@header,"Server: " . &server_software()) if $nph;
1496
1497				push(@header,"Status: $status") if $status;
1498				push(@header,"Window-Target: $target") if $target;
1499				if ($p3p) {
1500				$p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
1501				push(@header,qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p"));
1502				}
1503				# push all the cookies -- there may be several
1504				if ($cookie) {
1505				my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
1506				foreach (@cookie) {
1507				my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
1508				push(@header,"Set-Cookie: $cs") if $cs ne '';
1509				}
1510				}
1511				# if the user indicates an expiration time, then we need
1512				# both an Expires and a Date header (so that the browser is
1513				# uses OUR clock)
1514				push(@header,"Expires: " . expires($expires,'http'))
1515				if $expires;
1516				push(@header,"Date: " . expires(0,'http')) if $expires \|\| $cookie \|\| $nph;
1517				push(@header,"Pragma: no-cache") if $self->cache();
1518				push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
1519				push(@header,map {ucfirst $_} @other);
1520				push(@header,"Content-Type: $type") if $type ne '';
1521				my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1522				if ($MOD_PERL and not $nph) {
1523				$self->r->send_cgi_header($header);
1524				return '';
1525				}
1526				return $header;
1527				}
1528				END_OF_FUNC
1529
1530
1531				#### Method: cache
1532				# Control whether header() will produce the no-cache
1533				# Pragma directive.
1534				####
1535				'cache' => <<'END_OF_FUNC',
1536				sub cache {
1537				my($self,$new_value) = self_or_default(@_);
1538				$new_value = '' unless $new_value;
1539				if ($new_value ne '') {
1540				$self->{'cache'} = $new_value;
1541				}
1542				return $self->{'cache'};
1543				}
1544				END_OF_FUNC
1545
1546
1547				#### Method: redirect
1548				# Return a Location: style header
1549				#
1550				####
1551				'redirect' => <<'END_OF_FUNC',
1552				sub redirect {
1553				my($self,@p) = self_or_default(@_);
1554				my($url,$target,$status,$cookie,$nph,@other) =
1555				rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p);
1556				$status = '302 Found' unless defined $status;
1557				$url \|\|= $self->self_url;
1558				my(@o);
1559				foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
1560				unshift(@o,
1561				'-Status' => $status,
1562				'-Location'=> $url,
1563				'-nph' => $nph);
1564				unshift(@o,'-Target'=>$target) if $target;
1565				unshift(@o,'-Type'=>'');
1566				my @unescaped;
1567				unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
1568				return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
1569				}
1570				END_OF_FUNC
1571
1572
1573				#### Method: start_html
1574				# Canned HTML header
1575				#
1576				# Parameters:
1577				# $title -> (optional) The title for this HTML document (-title)
1578				# $author -> (optional) e-mail address of the author (-author)
1579				# $base -> (optional) if set to true, will enter the BASE address of this document
1580				# for resolving relative references (-base)
1581				# $xbase -> (optional) alternative base at some remote location (-xbase)
1582				# $target -> (optional) target window to load all links into (-target)
1583				# $script -> (option) Javascript code (-script)
1584				# $no_script -> (option) Javascript <noscript> tag (-noscript)
1585				# $meta -> (optional) Meta information tags
1586				# $head -> (optional) any other elements you'd like to incorporate into the <head> tag
1587				# (a scalar or array ref)
1588				# $style -> (optional) reference to an external style sheet
1589				# @other -> (optional) any other named parameters you'd like to incorporate into
1590				# the <body> tag.
1591				####
1592				'start_html' => <<'END_OF_FUNC',
1593				sub start_html {
1594				my($self,@p) = &self_or_default(@_);
1595				my($title,$author,$base,$xbase,$script,$noscript,
1596				$target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) =
1597				rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,
1598				META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p);
1599
1600				$self->element_id(0);
1601				$self->element_tab(0);
1602
1603				$encoding = lc($self->charset) unless defined $encoding;
1604
1605				# Need to sort out the DTD before it's okay to call escapeHTML().
1606				my(@result,$xml_dtd);
1607				if ($dtd) {
1608				if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
1609				$dtd = $DEFAULT_DTD unless $dtd->[0] =~ m\|^-//\|;
1610				} else {
1611				$dtd = $DEFAULT_DTD unless $dtd =~ m\|^-//\|;
1612				}
1613				} else {
1614				$dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
1615				}
1616
1617				$xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
1618				$xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
1619				push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml;
1620
1621				if (ref($dtd) && ref($dtd) eq 'ARRAY') {
1622				push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
1623				$DTD_PUBLIC_IDENTIFIER = $dtd->[0];
1624				} else {
1625				push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
1626				$DTD_PUBLIC_IDENTIFIER = $dtd;
1627				}
1628
1629				# Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
1630				# call escapeHTML(). Strangely enough, the title needs to be escaped as
1631				# HTML while the author needs to be escaped as a URL.
1632				$title = $self->escapeHTML($title \|\| 'Untitled Document');
1633				$author = $self->escape($author);
1634
1635				if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0\|3\.2)/i) {
1636				$lang = "" unless defined $lang;
1637				$XHTML = 0;
1638				}
1639				else {
1640				$lang = 'en-US' unless defined $lang;
1641				}
1642
1643				my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : '';
1644				my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />)
1645				if $XHTML && $encoding && !$declare_xml;
1646
1647				push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>)
1648				: ($lang ? qq(<html lang="$lang">) : "<html>")
1649				. "<head><title>$title</title>");
1650				if (defined $author) {
1651				push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
1652				: "<link rev=\"made\" href=\"mailto:$author\">");
1653				}
1654
1655				if ($base \|\| $xbase \|\| $target) {
1656				my $href = $xbase \|\| $self->url('-path'=>1);
1657				my $t = $target ? qq/ target="$target"/ : '';
1658				push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
1659				}
1660
1661				if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
1662				foreach (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
1663				: qq(<meta name="$_" content="$meta->{$_}">)); }
1664				}
1665
1666				push(@result,ref($head) ? @$head : $head) if $head;
1667
1668				# handle the infrequently-used -style and -script parameters
1669				push(@result,$self->_style($style)) if defined $style;
1670				push(@result,$self->_script($script)) if defined $script;
1671				push(@result,$meta_bits) if defined $meta_bits;
1672
1673				# handle -noscript parameter
1674				push(@result,<<END) if $noscript;
1675				<noscript>
1676				$noscript
1677				</noscript>
1678				END
1679				;
1680				my($other) = @other ? " @other" : '';
1681				push(@result,"</head>\n<body$other>\n");
1682				return join("\n",@result);
1683				}
1684				END_OF_FUNC
1685
1686				### Method: _style
1687				# internal method for generating a CSS style section
1688				####
1689				'_style' => <<'END_OF_FUNC',
1690				sub _style {
1691				my ($self,$style) = @_;
1692				my (@result);
1693
1694				my $type = 'text/css';
1695				my $rel = 'stylesheet';
1696
1697
1698				my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
1699				my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
1700
1701				my @s = ref($style) eq 'ARRAY' ? @$style : $style;
1702
1703				for my $s (@s) {
1704				if (ref($s)) {
1705				my($src,$code,$verbatim,$stype,$alternate,$foo,@other) =
1706				rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)],
1707				('-foo'=>'bar',
1708				ref($s) eq 'ARRAY' ? @$s : %$s));
1709				my $type = defined $stype ? $stype : 'text/css';
1710				my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet';
1711				my $other = @other ? join ' ',@other : '';
1712
1713				if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
1714				{ # If it is, push a LINK tag for each one
1715				foreach $src (@$src)
1716				{
1717				push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
1718				: qq(<link rel="$rel" type="$type" href="$src"$other>)) if $src;
1719				}
1720				}
1721				else
1722				{ # Otherwise, push the single -src, if it exists.
1723				push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
1724				: qq(<link rel="$rel" type="$type" href="$src"$other>)
1725				) if $src;
1726				}
1727				if ($verbatim) {
1728				my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim;
1729				push(@result, "<style type=\"text/css\">\n$_\n</style>") foreach @v;
1730				}
1731				my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code;
1732				push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) foreach @c;
1733
1734				} else {
1735				my $src = $s;
1736				push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
1737				: qq(<link rel="$rel" type="$type" href="$src"$other>));
1738				}
1739				}
1740				@result;
1741				}
1742				END_OF_FUNC
1743
1744				'_script' => <<'END_OF_FUNC',
1745				sub _script {
1746				my ($self,$script) = @_;
1747				my (@result);
1748
1749				my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
1750				foreach $script (@scripts) {
1751				my($src,$code,$language);
1752				if (ref($script)) { # script is a hash
1753				($src,$code,$type) =
1754				rearrange(['SRC','CODE',['LANGUAGE','TYPE']],
1755				'-foo'=>'bar', # a trick to allow the '-' to be omitted
1756				ref($script) eq 'ARRAY' ? @$script : %$script);
1757				$type \|\|= 'text/javascript';
1758				unless ($type =~ m!\w+/\w+!) {
1759				$type =~ s/[\d.]+$//;
1760				$type = "text/$type";
1761				}
1762				} else {
1763				($src,$code,$type) = ('',$script, 'text/javascript');
1764				}
1765
1766				my $comment = '//'; # javascript by default
1767				$comment = '#' if $type=~/perl\|tcl/i;
1768				$comment = "'" if $type=~/vbscript/i;
1769
1770				my ($cdata_start,$cdata_end);
1771				if ($XHTML) {
1772				$cdata_start = "$comment<![CDATA[\n";
1773				$cdata_end .= "\n$comment]]>";
1774				} else {
1775				$cdata_start = "\n<!-- Hide script\n";
1776				$cdata_end = $comment;
1777				$cdata_end .= " End script hiding -->\n";
1778				}
1779				my(@satts);
1780				push(@satts,'src'=>$src) if $src;
1781				push(@satts,'type'=>$type);
1782				$code = $cdata_start . $code . $cdata_end if defined $code;
1783				push(@result,$self->script({@satts},$code \|\| ''));
1784				}
1785				@result;
1786				}
1787				END_OF_FUNC
1788
1789				#### Method: end_html
1790				# End an HTML document.
1791				# Trivial method for completeness. Just returns "</body>"
1792				####
1793				'end_html' => <<'END_OF_FUNC',
1794				sub end_html {
1795				return "\n</body>\n</html>";
1796				}
1797				END_OF_FUNC
1798
1799
1800				################################
1801				# METHODS USED IN BUILDING FORMS
1802				################################
1803
1804				#### Method: isindex
1805				# Just prints out the isindex tag.
1806				# Parameters:
1807				# $action -> optional URL of script to run
1808				# Returns:
1809				# A string containing a <isindex> tag
1810				'isindex' => <<'END_OF_FUNC',
1811				sub isindex {
1812				my($self,@p) = self_or_default(@_);
1813				my($action,@other) = rearrange([ACTION],@p);
1814				$action = qq/ action="$action"/ if $action;
1815				my($other) = @other ? " @other" : '';
1816				return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>";
1817				}
1818				END_OF_FUNC
1819
1820
1821				#### Method: startform
1822				# Start a form
1823				# Parameters:
1824				# $method -> optional submission method to use (GET or POST)
1825				# $action -> optional URL of script to run
1826				# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1827				'startform' => <<'END_OF_FUNC',
1828				sub startform {
1829				my($self,@p) = self_or_default(@_);
1830
1831				my($method,$action,$enctype,@other) =
1832				rearrange([METHOD,ACTION,ENCTYPE],@p);
1833
1834				$method = $self->escapeHTML(lc($method) \|\| 'post');
1835				$enctype = $self->escapeHTML($enctype \|\| &URL_ENCODED);
1836				if (defined $action) {
1837				$action = $self->escapeHTML($action);
1838				}
1839				else {
1840				$action = $self->escapeHTML($self->request_uri \|\| $self->self_url);
1841				}
1842				$action = qq(action="$action");
1843				my($other) = @other ? " @other" : '';
1844				$self->{'.parametersToAdd'}={};
1845				return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
1846				}
1847				END_OF_FUNC
1848
1849
1850				#### Method: start_form
1851				# synonym for startform
1852				'start_form' => <<'END_OF_FUNC',
1853				sub start_form {
1854				$XHTML ? &start_multipart_form : &startform;
1855				}
1856				END_OF_FUNC
1857
1858				'end_multipart_form' => <<'END_OF_FUNC',
1859				sub end_multipart_form {
1860				&endform;
1861				}
1862				END_OF_FUNC
1863
1864				#### Method: start_multipart_form
1865				# synonym for startform
1866				'start_multipart_form' => <<'END_OF_FUNC',
1867				sub start_multipart_form {
1868				my($self,@p) = self_or_default(@_);
1869				if (defined($p[0]) && substr($p[0],0,1) eq '-') {
1870				return $self->startform(-enctype=>&MULTIPART,@p);
1871				} else {
1872				my($method,$action,@other) =
1873				rearrange([METHOD,ACTION],@p);
1874				return $self->startform($method,$action,&MULTIPART,@other);
1875				}
1876				}
1877				END_OF_FUNC
1878
1879
1880				#### Method: endform
1881				# End a form
1882				'endform' => <<'END_OF_FUNC',
1883				sub endform {
1884				my($self,@p) = self_or_default(@_);
1885				if ( $NOSTICKY ) {
1886				return wantarray ? ("</form>") : "\n</form>";
1887				} else {
1888				if (my @fields = $self->get_fields) {
1889				return wantarray ? ("<div>",@fields,"</div>","</form>")
1890				: "<div>".(join '',@fields)."</div>\n</form>";
1891				} else {
1892				return "</form>";
1893				}
1894				}
1895				}
1896				END_OF_FUNC
1897
1898
1899				'_textfield' => <<'END_OF_FUNC',
1900				sub _textfield {
1901				my($self,$tag,@p) = self_or_default(@_);
1902				my($name,$default,$size,$maxlength,$override,$tabindex,@other) =
1903				rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p);
1904
1905				my $current = $override ? $default :
1906				(defined($self->param($name)) ? $self->param($name) : $default);
1907
1908				$current = defined($current) ? $self->escapeHTML($current,1) : '';
1909				$name = defined($name) ? $self->escapeHTML($name) : '';
1910				my($s) = defined($size) ? qq/ size="$size"/ : '';
1911				my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
1912				my($other) = @other ? " @other" : '';
1913				# this entered at cristy's request to fix problems with file upload fields
1914				# and WebTV -- not sure it won't break stuff
1915				my($value) = $current ne '' ? qq(value="$current") : '';
1916				$tabindex = $self->element_tab($tabindex);
1917				return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />)
1918				: qq(<input type="$tag" name="$name" $value$s$m$other>);
1919				}
1920				END_OF_FUNC
1921
1922				#### Method: textfield
1923				# Parameters:
1924				# $name -> Name of the text field
1925				# $default -> Optional default value of the field if not
1926				# already defined.
1927				# $size -> Optional width of field in characaters.
1928				# $maxlength -> Optional maximum number of characters.
1929				# Returns:
1930				# A string containing a <input type="text"> field
1931				#
1932				'textfield' => <<'END_OF_FUNC',
1933				sub textfield {
1934				my($self,@p) = self_or_default(@_);
1935				$self->_textfield('text',@p);
1936				}
1937				END_OF_FUNC
1938
1939
1940				#### Method: filefield
1941				# Parameters:
1942				# $name -> Name of the file upload field
1943				# $size -> Optional width of field in characaters.
1944				# $maxlength -> Optional maximum number of characters.
1945				# Returns:
1946				# A string containing a <input type="file"> field
1947				#
1948				'filefield' => <<'END_OF_FUNC',
1949				sub filefield {
1950				my($self,@p) = self_or_default(@_);
1951				$self->_textfield('file',@p);
1952				}
1953				END_OF_FUNC
1954
1955
1956				#### Method: password
1957				# Create a "secret password" entry field
1958				# Parameters:
1959				# $name -> Name of the field
1960				# $default -> Optional default value of the field if not
1961				# already defined.
1962				# $size -> Optional width of field in characters.
1963				# $maxlength -> Optional maximum characters that can be entered.
1964				# Returns:
1965				# A string containing a <input type="password"> field
1966				#
1967				'password_field' => <<'END_OF_FUNC',
1968				sub password_field {
1969				my ($self,@p) = self_or_default(@_);
1970				$self->_textfield('password',@p);
1971				}
1972				END_OF_FUNC
1973
1974				#### Method: textarea
1975				# Parameters:
1976				# $name -> Name of the text field
1977				# $default -> Optional default value of the field if not
1978				# already defined.
1979				# $rows -> Optional number of rows in text area
1980				# $columns -> Optional number of columns in text area
1981				# Returns:
1982				# A string containing a <textarea></textarea> tag
1983				#
1984				'textarea' => <<'END_OF_FUNC',
1985				sub textarea {
1986				my($self,@p) = self_or_default(@_);
1987				my($name,$default,$rows,$cols,$override,$tabindex,@other) =
1988				rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p);
1989
1990				my($current)= $override ? $default :
1991				(defined($self->param($name)) ? $self->param($name) : $default);
1992
1993				$name = defined($name) ? $self->escapeHTML($name) : '';
1994				$current = defined($current) ? $self->escapeHTML($current) : '';
1995				my($r) = $rows ? qq/ rows="$rows"/ : '';
1996				my($c) = $cols ? qq/ cols="$cols"/ : '';
1997				my($other) = @other ? " @other" : '';
1998				$tabindex = $self->element_tab($tabindex);
1999				return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>};
2000				}
2001				END_OF_FUNC
2002
2003
2004				#### Method: button
2005				# Create a javascript button.
2006				# Parameters:
2007				# $name -> (optional) Name for the button. (-name)
2008				# $value -> (optional) Value of the button when selected (and visible name) (-value)
2009				# $onclick -> (optional) Text of the JavaScript to run when the button is
2010				# clicked.
2011				# Returns:
2012				# A string containing a <input type="button"> tag
2013				####
2014				'button' => <<'END_OF_FUNC',
2015				sub button {
2016				my($self,@p) = self_or_default(@_);
2017
2018				my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],
2019				[ONCLICK,SCRIPT],TABINDEX],@p);
2020
2021				$label=$self->escapeHTML($label);
2022				$value=$self->escapeHTML($value,1);
2023				$script=$self->escapeHTML($script);
2024
2025				my($name) = '';
2026				$name = qq/ name="$label"/ if $label;
2027				$value = $value \|\| $label;
2028				my($val) = '';
2029				$val = qq/ value="$value"/ if $value;
2030				$script = qq/ onclick="$script"/ if $script;
2031				my($other) = @other ? " @other" : '';
2032				$tabindex = $self->element_tab($tabindex);
2033				return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />)
2034				: qq(<input type="button"$name$val$script$other>);
2035				}
2036				END_OF_FUNC
2037
2038
2039				#### Method: submit
2040				# Create a "submit query" button.
2041				# Parameters:
2042				# $name -> (optional) Name for the button.
2043				# $value -> (optional) Value of the button when selected (also doubles as label).
2044				# $label -> (optional) Label printed on the button(also doubles as the value).
2045				# Returns:
2046				# A string containing a <input type="submit"> tag
2047				####
2048				'submit' => <<'END_OF_FUNC',
2049				sub submit {
2050				my($self,@p) = self_or_default(@_);
2051
2052				my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p);
2053
2054				$label=$self->escapeHTML($label);
2055				$value=$self->escapeHTML($value,1);
2056
2057				my $name = $NOSTICKY ? '' : 'name=".submit" ';
2058				$name = qq/name="$label" / if defined($label);
2059				$value = defined($value) ? $value : $label;
2060				my $val = '';
2061				$val = qq/value="$value" / if defined($value);
2062				$tabindex = $self->element_tab($tabindex);
2063				my($other) = @other ? "@other " : '';
2064				return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>)
2065				: qq(<input type="submit" $name$val$other>);
2066				}
2067				END_OF_FUNC
2068
2069
2070				#### Method: reset
2071				# Create a "reset" button.
2072				# Parameters:
2073				# $name -> (optional) Name for the button.
2074				# Returns:
2075				# A string containing a <input type="reset"> tag
2076				####
2077				'reset' => <<'END_OF_FUNC',
2078				sub reset {
2079				my($self,@p) = self_or_default(@_);
2080				my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p);
2081				$label=$self->escapeHTML($label);
2082				$value=$self->escapeHTML($value,1);
2083				my ($name) = ' name=".reset"';
2084				$name = qq/ name="$label"/ if defined($label);
2085				$value = defined($value) ? $value : $label;
2086				my($val) = '';
2087				$val = qq/ value="$value"/ if defined($value);
2088				my($other) = @other ? " @other" : '';
2089				$tabindex = $self->element_tab($tabindex);
2090				return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />)
2091				: qq(<input type="reset"$name$val$other>);
2092				}
2093				END_OF_FUNC
2094
2095
2096				#### Method: defaults
2097				# Create a "defaults" button.
2098				# Parameters:
2099				# $name -> (optional) Name for the button.
2100				# Returns:
2101				# A string containing a <input type="submit" name=".defaults"> tag
2102				#
2103				# Note: this button has a special meaning to the initialization script,
2104				# and tells it to ERASE the current query string so that your defaults
2105				# are used again!
2106				####
2107				'defaults' => <<'END_OF_FUNC',
2108				sub defaults {
2109				my($self,@p) = self_or_default(@_);
2110
2111				my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p);
2112
2113				$label=$self->escapeHTML($label,1);
2114				$label = $label \|\| "Defaults";
2115				my($value) = qq/ value="$label"/;
2116				my($other) = @other ? " @other" : '';
2117				$tabindex = $self->element_tab($tabindex);
2118				return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />)
2119				: qq/<input type="submit" NAME=".defaults"$value$other>/;
2120				}
2121				END_OF_FUNC
2122
2123
2124				#### Method: comment
2125				# Create an HTML <!-- comment -->
2126				# Parameters: a string
2127				'comment' => <<'END_OF_FUNC',
2128				sub comment {
2129				my($self,@p) = self_or_CGI(@_);
2130				return "<!-- @p -->";
2131				}
2132				END_OF_FUNC
2133
2134				#### Method: checkbox
2135				# Create a checkbox that is not logically linked to any others.
2136				# The field value is "on" when the button is checked.
2137				# Parameters:
2138				# $name -> Name of the checkbox
2139				# $checked -> (optional) turned on by default if true
2140				# $value -> (optional) value of the checkbox, 'on' by default
2141				# $label -> (optional) a user-readable label printed next to the box.
2142				# Otherwise the checkbox name is used.
2143				# Returns:
2144				# A string containing a <input type="checkbox"> field
2145				####
2146				'checkbox' => <<'END_OF_FUNC',
2147				sub checkbox {
2148				my($self,@p) = self_or_default(@_);
2149
2150				my($name,$checked,$value,$label,$override,$tabindex,@other) =
2151				rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE],TABINDEX],@p);
2152
2153				$value = defined $value ? $value : 'on';
2154
2155				if (!$override && ($self->{'.fieldnames'}->{$name} \|\|
2156				defined $self->param($name))) {
2157				$checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
2158				} else {
2159				$checked = $self->_checked($checked);
2160				}
2161				my($the_label) = defined $label ? $label : $name;
2162				$name = $self->escapeHTML($name);
2163				$value = $self->escapeHTML($value,1);
2164				$the_label = $self->escapeHTML($the_label);
2165				my($other) = @other ? "@other " : '';
2166				$tabindex = $self->element_tab($tabindex);
2167				$self->register_parameter($name);
2168				return $XHTML ? CGI::label(qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
2169				: qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
2170				}
2171				END_OF_FUNC
2172
2173
2174
2175				# Escape HTML -- used internally
2176				'escapeHTML' => <<'END_OF_FUNC',
2177				sub escapeHTML {
2178				# hack to work around earlier hacks
2179				push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
2180				my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
2181				return undef unless defined($toencode);
2182				return $toencode if ref($self) && !$self->{'escape'};
2183				$toencode =~ s{&}{&}gso;
2184				$toencode =~ s{<}{<}gso;
2185				$toencode =~ s{>}{>}gso;
2186				if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
2187				# $quot; was accidentally omitted from the HTML 3.2 DTD -- see
2188				# <http://validator.w3.org/docs/errors.html#bad-entity> /
2189				# <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
2190				$toencode =~ s{"}{"}gso;
2191				}
2192				else {
2193				$toencode =~ s{"}{"}gso;
2194				}
2195				my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' \|\|
2196				uc $self->{'.charset'} eq 'WINDOWS-1252';
2197				if ($latin) { # bug in some browsers
2198				$toencode =~ s{'}{'}gso;
2199				$toencode =~ s{\x8b}{‹}gso;
2200				$toencode =~ s{\x9b}{›}gso;
2201				if (defined $newlinestoo && $newlinestoo) {
2202				$toencode =~ s{\012}{ }gso;
2203				$toencode =~ s{\015}{ }gso;
2204				}
2205				}
2206				return $toencode;
2207				}
2208				END_OF_FUNC
2209
2210				# unescape HTML -- used internally
2211				'unescapeHTML' => <<'END_OF_FUNC',
2212				sub unescapeHTML {
2213				# hack to work around earlier hacks
2214				push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
2215				my ($self,$string) = CGI::self_or_default(@_);
2216				return undef unless defined($string);
2217				my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1\|WINDOWS-1252)$/i
2218				: 1;
2219				# thanks to Randal Schwartz for the correct solution to this one
2220				$string=~ s[&(.*?);]{
2221				local $_ = $1;
2222				/^amp$/i ? "&" :
2223				/^quot$/i ? '"' :
2224				/^gt$/i ? ">" :
2225				/^lt$/i ? "<" :
2226				/^#(\d+)$/ && $latin ? chr($1) :
2227				/^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
2228				$_
2229				}gex;
2230				return $string;
2231				}
2232				END_OF_FUNC
2233
2234				# Internal procedure - don't use
2235				'_tableize' => <<'END_OF_FUNC',
2236				sub _tableize {
2237				my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
2238				my @rowheaders = $rowheaders ? @$rowheaders : ();
2239				my @colheaders = $colheaders ? @$colheaders : ();
2240				my($result);
2241
2242				if (defined($columns)) {
2243				$rows = int(0.99 + @elements/$columns) unless defined($rows);
2244				}
2245				if (defined($rows)) {
2246				$columns = int(0.99 + @elements/$rows) unless defined($columns);
2247				}
2248
2249				# rearrange into a pretty table
2250				$result = "<table>";
2251				my($row,$column);
2252				unshift(@colheaders,'') if @colheaders && @rowheaders;
2253				$result .= "<tr>" if @colheaders;
2254				foreach (@colheaders) {
2255				$result .= "<th>$_</th>";
2256				}
2257				for ($row=0;$row<$rows;$row++) {
2258				$result .= "<tr>";
2259				$result .= "<th>$rowheaders[$row]</th>" if @rowheaders;
2260				for ($column=0;$column<$columns;$column++) {
2261				$result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
2262				if defined($elements[$column*$rows + $row]);
2263				}
2264				$result .= "</tr>";
2265				}
2266				$result .= "</table>";
2267				return $result;
2268				}
2269				END_OF_FUNC
2270
2271
2272				#### Method: radio_group
2273				# Create a list of logically-linked radio buttons.
2274				# Parameters:
2275				# $name -> Common name for all the buttons.
2276				# $values -> A pointer to a regular array containing the
2277				# values for each button in the group.
2278				# $default -> (optional) Value of the button to turn on by default. Pass '-'
2279				# to turn _nothing_ on.
2280				# $linebreak -> (optional) Set to true to place linebreaks
2281				# between the buttons.
2282				# $labels -> (optional)
2283				# A pointer to an associative array of labels to print next to each checkbox
2284				# in the form $label{'value'}="Long explanatory label".
2285				# Otherwise the provided values are used as the labels.
2286				# Returns:
2287				# An ARRAY containing a series of <input type="radio"> fields
2288				####
2289				'radio_group' => <<'END_OF_FUNC',
2290				sub radio_group {
2291				my($self,@p) = self_or_default(@_);
2292				$self->_box_group('radio',@p);
2293				}
2294				END_OF_FUNC
2295
2296				#### Method: checkbox_group
2297				# Create a list of logically-linked checkboxes.
2298				# Parameters:
2299				# $name -> Common name for all the check boxes
2300				# $values -> A pointer to a regular array containing the
2301				# values for each checkbox in the group.
2302				# $defaults -> (optional)
2303				# 1. If a pointer to a regular array of checkbox values,
2304				# then this will be used to decide which
2305				# checkboxes to turn on by default.
2306				# 2. If a scalar, will be assumed to hold the
2307				# value of a single checkbox in the group to turn on.
2308				# $linebreak -> (optional) Set to true to place linebreaks
2309				# between the buttons.
2310				# $labels -> (optional)
2311				# A pointer to an associative array of labels to print next to each checkbox
2312				# in the form $label{'value'}="Long explanatory label".
2313				# Otherwise the provided values are used as the labels.
2314				# Returns:
2315				# An ARRAY containing a series of <input type="checkbox"> fields
2316				####
2317
2318				'checkbox_group' => <<'END_OF_FUNC',
2319				sub checkbox_group {
2320				my($self,@p) = self_or_default(@_);
2321				$self->_box_group('checkbox',@p);
2322				}
2323				END_OF_FUNC
2324
2325				'_box_group' => <<'END_OF_FUNC',
2326				sub _box_group {
2327				my $self = shift;
2328				my $box_type = shift;
2329
2330				my($name,$values,$defaults,$linebreak,$labels,$attributes,
2331				$rows,$columns,$rowheaders,$colheaders,
2332				$override,$nolabels,$tabindex,$disabled,@other) =
2333				rearrange([ NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,ATTRIBUTES,
2334				ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER],
2335				[OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED
2336				],@_);
2337
2338				my($result,$checked,@elements,@values);
2339
2340				@values = $self->_set_values_and_labels($values,\$labels,$name);
2341				my %checked = $self->previous_or_default($name,$defaults,$override);
2342
2343				# If no check array is specified, check the first by default
2344				$checked{$values[0]}++ if $box_type eq 'radio' && !%checked;
2345
2346				$name=$self->escapeHTML($name);
2347
2348				my %tabs = ();
2349				if ($TABINDEX && $tabindex) {
2350				if (!ref $tabindex) {
2351				$self->element_tab($tabindex);
2352				} elsif (ref $tabindex eq 'ARRAY') {
2353				%tabs = map {$_=>$self->element_tab} @$tabindex;
2354				} elsif (ref $tabindex eq 'HASH') {
2355				%tabs = %$tabindex;
2356				}
2357				}
2358				%tabs = map {$_=>$self->element_tab} @values unless %tabs;
2359				my $other = @other ? "@other " : '';
2360				my $radio_checked;
2361
2362				# for disabling groups of radio/checkbox buttons
2363				my %disabled;
2364				foreach (@{$disabled}) {
2365				$disabled{$_}=1;
2366				}
2367
2368				foreach (@values) {
2369				my $disable="";
2370				if ($disabled{$_}) {
2371				$disable="disabled='1'";
2372				}
2373
2374				my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
2375				: $checked{$_});
2376				my($break);
2377				if ($linebreak) {
2378				$break = $XHTML ? "<br />" : "<br>";
2379				}
2380				else {
2381				$break = '';
2382				}
2383				my($label)='';
2384				unless (defined($nolabels) && $nolabels) {
2385				$label = $_;
2386				$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2387				$label = $self->escapeHTML($label,1);
2388				$label = "<span style=\"color:gray\">$label</span>" if $disabled{$_};
2389				}
2390				my $attribs = $self->_set_attributes($_, $attributes);
2391				my $tab = $tabs{$_};
2392				$_=$self->escapeHTML($_);
2393
2394				if ($XHTML) {
2395				push @elements,
2396				CGI::label(
2397				qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break};
2398				} else {
2399				push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs$disable>${label}${break}/);
2400				}
2401				}
2402				$self->register_parameter($name);
2403				return wantarray ? @elements : "@elements"
2404				unless defined($columns) \|\| defined($rows);
2405				return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
2406				}
2407				END_OF_FUNC
2408
2409
2410				#### Method: popup_menu
2411				# Create a popup menu.
2412				# Parameters:
2413				# $name -> Name for all the menu
2414				# $values -> A pointer to a regular array containing the
2415				# text of each menu item.
2416				# $default -> (optional) Default item to display
2417				# $labels -> (optional)
2418				# A pointer to an associative array of labels to print next to each checkbox
2419				# in the form $label{'value'}="Long explanatory label".
2420				# Otherwise the provided values are used as the labels.
2421				# Returns:
2422				# A string containing the definition of a popup menu.
2423				####
2424				'popup_menu' => <<'END_OF_FUNC',
2425				sub popup_menu {
2426				my($self,@p) = self_or_default(@_);
2427
2428				my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) =
2429				rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
2430				ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
2431				my($result,$selected);
2432
2433				if (!$override && defined($self->param($name))) {
2434				$selected = $self->param($name);
2435				} else {
2436				$selected = $default;
2437				}
2438				$name=$self->escapeHTML($name);
2439				my($other) = @other ? " @other" : '';
2440
2441				my(@values);
2442				@values = $self->_set_values_and_labels($values,\$labels,$name);
2443				$tabindex = $self->element_tab($tabindex);
2444				$result = qq/<select name="$name" $tabindex$other>\n/;
2445				foreach (@values) {
2446				if (/<optgroup/) {
2447				foreach (split(/\n/)) {
2448				my $selectit = $XHTML ? 'selected="selected"' : 'selected';
2449				s/(value="$selected")/$selectit $1/ if defined $selected;
2450				$result .= "$_\n";
2451				}
2452				}
2453				else {
2454				my $attribs = $self->_set_attributes($_, $attributes);
2455				my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : '';
2456				my($label) = $_;
2457				$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2458				my($value) = $self->escapeHTML($_);
2459				$label=$self->escapeHTML($label,1);
2460				$result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
2461				}
2462				}
2463
2464				$result .= "</select>";
2465				return $result;
2466				}
2467				END_OF_FUNC
2468
2469
2470				#### Method: optgroup
2471				# Create a optgroup.
2472				# Parameters:
2473				# $name -> Label for the group
2474				# $values -> A pointer to a regular array containing the
2475				# values for each option line in the group.
2476				# $labels -> (optional)
2477				# A pointer to an associative array of labels to print next to each item
2478				# in the form $label{'value'}="Long explanatory label".
2479				# Otherwise the provided values are used as the labels.
2480				# $labeled -> (optional)
2481				# A true value indicates the value should be used as the label attribute
2482				# in the option elements.
2483				# The label attribute specifies the option label presented to the user.
2484				# This defaults to the content of the <option> element, but the label
2485				# attribute allows authors to more easily use optgroup without sacrificing
2486				# compatibility with browsers that do not support option groups.
2487				# $novals -> (optional)
2488				# A true value indicates to suppress the val attribute in the option elements
2489				# Returns:
2490				# A string containing the definition of an option group.
2491				####
2492				'optgroup' => <<'END_OF_FUNC',
2493				sub optgroup {
2494				my($self,@p) = self_or_default(@_);
2495				my($name,$values,$attributes,$labeled,$noval,$labels,@other)
2496				= rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p);
2497
2498				my($result,@values);
2499				@values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
2500				my($other) = @other ? " @other" : '';
2501
2502				$name=$self->escapeHTML($name);
2503				$result = qq/<optgroup label="$name"$other>\n/;
2504				foreach (@values) {
2505				if (/<optgroup/) {
2506				foreach (split(/\n/)) {
2507				my $selectit = $XHTML ? 'selected="selected"' : 'selected';
2508				s/(value="$selected")/$selectit $1/ if defined $selected;
2509				$result .= "$_\n";
2510				}
2511				}
2512				else {
2513				my $attribs = $self->_set_attributes($_, $attributes);
2514				my($label) = $_;
2515				$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2516				$label=$self->escapeHTML($label);
2517				my($value)=$self->escapeHTML($_,1);
2518				$result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
2519				: "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
2520				: $novals ? "<option$attribs>$label</option>\n"
2521				: "<option$attribs value=\"$value\">$label</option>\n";
2522				}
2523				}
2524				$result .= "</optgroup>";
2525				return $result;
2526				}
2527				END_OF_FUNC
2528
2529
2530				#### Method: scrolling_list
2531				# Create a scrolling list.
2532				# Parameters:
2533				# $name -> name for the list
2534				# $values -> A pointer to a regular array containing the
2535				# values for each option line in the list.
2536				# $defaults -> (optional)
2537				# 1. If a pointer to a regular array of options,
2538				# then this will be used to decide which
2539				# lines to turn on by default.
2540				# 2. Otherwise holds the value of the single line to turn on.
2541				# $size -> (optional) Size of the list.
2542				# $multiple -> (optional) If set, allow multiple selections.
2543				# $labels -> (optional)
2544				# A pointer to an associative array of labels to print next to each checkbox
2545				# in the form $label{'value'}="Long explanatory label".
2546				# Otherwise the provided values are used as the labels.
2547				# Returns:
2548				# A string containing the definition of a scrolling list.
2549				####
2550				'scrolling_list' => <<'END_OF_FUNC',
2551				sub scrolling_list {
2552				my($self,@p) = self_or_default(@_);
2553				my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other)
2554				= rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
2555				SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
2556
2557				my($result,@values);
2558				@values = $self->_set_values_and_labels($values,\$labels,$name);
2559
2560				$size = $size \|\| scalar(@values);
2561
2562				my(%selected) = $self->previous_or_default($name,$defaults,$override);
2563				my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
2564				my($has_size) = $size ? qq/ size="$size"/: '';
2565				my($other) = @other ? " @other" : '';
2566
2567				$name=$self->escapeHTML($name);
2568				$tabindex = $self->element_tab($tabindex);
2569				$result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/;
2570				foreach (@values) {
2571				my($selectit) = $self->_selected($selected{$_});
2572				my($label) = $_;
2573				$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2574				$label=$self->escapeHTML($label);
2575				my($value)=$self->escapeHTML($_,1);
2576				my $attribs = $self->_set_attributes($_, $attributes);
2577				$result .= "<option ${selectit}${attribs}value=\"$value\">$label</option>\n";
2578				}
2579				$result .= "</select>";
2580				$self->register_parameter($name);
2581				return $result;
2582				}
2583				END_OF_FUNC
2584
2585
2586				#### Method: hidden
2587				# Parameters:
2588				# $name -> Name of the hidden field
2589				# @default -> (optional) Initial values of field (may be an array)
2590				# or
2591				# $default->[initial values of field]
2592				# Returns:
2593				# A string containing a <input type="hidden" name="name" value="value">
2594				####
2595				'hidden' => <<'END_OF_FUNC',
2596				sub hidden {
2597				my($self,@p) = self_or_default(@_);
2598
2599				# this is the one place where we departed from our standard
2600				# calling scheme, so we have to special-case (darn)
2601				my(@result,@value);
2602				my($name,$default,$override,@other) =
2603				rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
2604
2605				my $do_override = 0;
2606				if ( ref($p[0]) \|\| substr($p[0],0,1) eq '-') {
2607				@value = ref($default) ? @{$default} : $default;
2608				$do_override = $override;
2609				} else {
2610				foreach ($default,$override,@other) {
2611				push(@value,$_) if defined($_);
2612				}
2613				}
2614
2615				# use previous values if override is not set
2616				my @prev = $self->param($name);
2617				@value = @prev if !$do_override && @prev;
2618
2619				$name=$self->escapeHTML($name);
2620				foreach (@value) {
2621				$_ = defined($_) ? $self->escapeHTML($_,1) : '';
2622				push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
2623				: qq(<input type="hidden" name="$name" value="$_" @other>);
2624				}
2625				return wantarray ? @result : join('',@result);
2626				}
2627				END_OF_FUNC
2628
2629
2630				#### Method: image_button
2631				# Parameters:
2632				# $name -> Name of the button
2633				# $src -> URL of the image source
2634				# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
2635				# Returns:
2636				# A string containing a <input type="image" name="name" src="url" align="alignment">
2637				####
2638				'image_button' => <<'END_OF_FUNC',
2639				sub image_button {
2640				my($self,@p) = self_or_default(@_);
2641
2642				my($name,$src,$alignment,@other) =
2643				rearrange([NAME,SRC,ALIGN],@p);
2644
2645				my($align) = $alignment ? " align=\L\"$alignment\"" : '';
2646				my($other) = @other ? " @other" : '';
2647				$name=$self->escapeHTML($name);
2648				return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
2649				: qq/<input type="image" name="$name" src="$src"$align$other>/;
2650				}
2651				END_OF_FUNC
2652
2653
2654				#### Method: self_url
2655				# Returns a URL containing the current script and all its
2656				# param/value pairs arranged as a query. You can use this
2657				# to create a link that, when selected, will reinvoke the
2658				# script with all its state information preserved.
2659				####
2660				'self_url' => <<'END_OF_FUNC',
2661				sub self_url {
2662				my($self,@p) = self_or_default(@_);
2663				return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
2664				}
2665				END_OF_FUNC
2666
2667
2668				# This is provided as a synonym to self_url() for people unfortunate
2669				# enough to have incorporated it into their programs already!
2670				'state' => <<'END_OF_FUNC',
2671				sub state {
2672				&self_url;
2673				}
2674				END_OF_FUNC
2675
2676
2677				#### Method: url
2678				# Like self_url, but doesn't return the query string part of
2679				# the URL.
2680				####
2681				'url' => <<'END_OF_FUNC',
2682				sub url {
2683				my($self,@p) = self_or_default(@_);
2684				my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) =
2685				rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p);
2686				my $url = '';
2687				$full++ if $base \|\| !($relative \|\| $absolute);
2688				$rewrite++ unless defined $rewrite;
2689
2690				my $path = $self->path_info;
2691				my $script_name = $self->script_name;
2692				my $request_uri = unescape($self->request_uri) \|\| '';
2693				my $query_str = $self->query_string;
2694
2695				my $rewrite_in_use = $request_uri && $request_uri !~ /^$script_name/;
2696				undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active
2697
2698				my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
2699				$uri =~ s/\?.*$//; # remove query string
2700				$uri =~ s/\Q$path\E$// if defined $path; # remove path
2701
2702				if ($full) {
2703				my $protocol = $self->protocol();
2704				$url = "$protocol://";
2705				my $vh = http('x_forwarded_host') \|\| http('host') \|\| '';
2706				$vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
2707				if ($vh) {
2708				$url .= $vh;
2709				} else {
2710				$url .= server_name();
2711				}
2712				my $port = $self->server_port;
2713				$url .= ":" . $port
2714				unless (lc($protocol) eq 'http' && $port == 80)
2715				\|\| (lc($protocol) eq 'https' && $port == 443);
2716				return $url if $base;
2717				$url .= $uri;
2718				} elsif ($relative) {
2719				($url) = $uri =~ m!([^/]+)$!;
2720				} elsif ($absolute) {
2721				$url = $uri;
2722				}
2723
2724				$url .= $path if $path_info and defined $path;
2725				$url .= "?$query_str" if $query and $query_str ne '';
2726				$url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
2727				return $url;
2728				}
2729
2730				END_OF_FUNC
2731
2732				#### Method: cookie
2733				# Set or read a cookie from the specified name.
2734				# Cookie can then be passed to header().
2735				# Usual rules apply to the stickiness of -value.
2736				# Parameters:
2737				# -name -> name for this cookie (optional)
2738				# -value -> value of this cookie (scalar, array or hash)
2739				# -path -> paths for which this cookie is valid (optional)
2740				# -domain -> internet domain in which this cookie is valid (optional)
2741				# -secure -> if true, cookie only passed through secure channel (optional)
2742				# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
2743				####
2744				'cookie' => <<'END_OF_FUNC',
2745				sub cookie {
2746				my($self,@p) = self_or_default(@_);
2747				my($name,$value,$path,$domain,$secure,$expires,$httponly) =
2748				rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p);
2749
2750				require CGI::Cookie;
2751
2752				# if no value is supplied, then we retrieve the
2753				# value of the cookie, if any. For efficiency, we cache the parsed
2754				# cookies in our state variables.
2755				unless ( defined($value) ) {
2756				$self->{'.cookies'} = CGI::Cookie->fetch
2757				unless $self->{'.cookies'};
2758
2759				# If no name is supplied, then retrieve the names of all our cookies.
2760				return () unless $self->{'.cookies'};
2761				return keys %{$self->{'.cookies'}} unless $name;
2762				return () unless $self->{'.cookies'}->{$name};
2763				return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
2764				}
2765
2766				# If we get here, we're creating a new cookie
2767				return undef unless defined($name) && $name ne ''; # this is an error
2768
2769				my @param;
2770				push(@param,'-name'=>$name);
2771				push(@param,'-value'=>$value);
2772				push(@param,'-domain'=>$domain) if $domain;
2773				push(@param,'-path'=>$path) if $path;
2774				push(@param,'-expires'=>$expires) if $expires;
2775				push(@param,'-secure'=>$secure) if $secure;
2776				push(@param,'-httponly'=>$httponly) if $httponly;
2777
2778				return new CGI::Cookie(@param);
2779				}
2780				END_OF_FUNC
2781
2782				'parse_keywordlist' => <<'END_OF_FUNC',
2783				sub parse_keywordlist {
2784				my($self,$tosplit) = @_;
2785				$tosplit = unescape($tosplit); # unescape the keywords
2786				$tosplit=~tr/+/ /; # pluses to spaces
2787				my(@keywords) = split(/\s+/,$tosplit);
2788				return @keywords;
2789				}
2790				END_OF_FUNC
2791
2792				'param_fetch' => <<'END_OF_FUNC',
2793				sub param_fetch {
2794				my($self,@p) = self_or_default(@_);
2795				my($name) = rearrange([NAME],@p);
2796				unless (exists($self->{$name})) {
2797				$self->add_parameter($name);
2798				$self->{$name} = [];
2799				}
2800
2801				return $self->{$name};
2802				}
2803				END_OF_FUNC
2804
2805				###############################################
2806				# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
2807				###############################################
2808
2809				#### Method: path_info
2810				# Return the extra virtual path information provided
2811				# after the URL (if any)
2812				####
2813				'path_info' => <<'END_OF_FUNC',
2814				sub path_info {
2815				my ($self,$info) = self_or_default(@_);
2816				if (defined($info)) {
2817				$info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
2818				$self->{'.path_info'} = $info;
2819				} elsif (! defined($self->{'.path_info'}) ) {
2820				my (undef,$path_info) = $self->_name_and_path_from_env;
2821				$self->{'.path_info'} = $path_info \|\| '';
2822				}
2823				return $self->{'.path_info'};
2824				}
2825				END_OF_FUNC
2826
2827				# WE USE THIS TO COMPENSATE FOR A BUG IN APACHE 2 PRESENT AT LEAST UP THROUGH 2.0.54
2828				'_name_and_path_from_env' => <<'END_OF_FUNC',
2829				sub _name_and_path_from_env {
2830				my $self = shift;
2831				my $raw_script_name = $ENV{SCRIPT_NAME} \|\| '';
2832				my $raw_path_info = $ENV{PATH_INFO} \|\| '';
2833				my $uri = unescape($self->request_uri) \|\| '';
2834
2835				my $protected = quotemeta($raw_path_info);
2836				$raw_script_name =~ s/$protected$//;
2837
2838				my @uri_double_slashes = $uri =~ m^(/{2,}?)^g;
2839				my @path_double_slashes = "$raw_script_name $raw_path_info" =~ m^(/{2,}?)^g;
2840
2841				my $apache_bug = @uri_double_slashes != @path_double_slashes;
2842				return ($raw_script_name,$raw_path_info) unless $apache_bug;
2843
2844				my $path_info_search = quotemeta($raw_path_info);
2845				$path_info_search =~ s!/!/+!g;
2846				if ($uri =~ m/^(.+)($path_info_search)/) {
2847				return ($1,$2);
2848				} else {
2849				return ($raw_script_name,$raw_path_info);
2850				}
2851				}
2852				END_OF_FUNC
2853
2854
2855				#### Method: request_method
2856				# Returns 'POST', 'GET', 'PUT' or 'HEAD'
2857				####
2858				'request_method' => <<'END_OF_FUNC',
2859				sub request_method {
2860				return $ENV{'REQUEST_METHOD'};
2861				}
2862				END_OF_FUNC
2863
2864				#### Method: content_type
2865				# Returns the content_type string
2866				####
2867				'content_type' => <<'END_OF_FUNC',
2868				sub content_type {
2869				return $ENV{'CONTENT_TYPE'};
2870				}
2871				END_OF_FUNC
2872
2873				#### Method: path_translated
2874				# Return the physical path information provided
2875				# by the URL (if any)
2876				####
2877				'path_translated' => <<'END_OF_FUNC',
2878				sub path_translated {
2879				return $ENV{'PATH_TRANSLATED'};
2880				}
2881				END_OF_FUNC
2882
2883
2884				#### Method: request_uri
2885				# Return the literal request URI
2886				####
2887				'request_uri' => <<'END_OF_FUNC',
2888				sub request_uri {
2889				return $ENV{'REQUEST_URI'};
2890				}
2891				END_OF_FUNC
2892
2893
2894				#### Method: query_string
2895				# Synthesize a query string from our current
2896				# parameters
2897				####
2898				'query_string' => <<'END_OF_FUNC',
2899				sub query_string {
2900				my($self) = self_or_default(@_);
2901				my($param,$value,@pairs);
2902				foreach $param ($self->param) {
2903				my($eparam) = escape($param);
2904				foreach $value ($self->param($param)) {
2905				$value = escape($value);
2906				next unless defined $value;
2907				push(@pairs,"$eparam=$value");
2908				}
2909				}
2910				foreach (keys %{$self->{'.fieldnames'}}) {
2911				push(@pairs,".cgifields=".escape("$_"));
2912				}
2913				return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
2914				}
2915				END_OF_FUNC
2916
2917
2918				#### Method: accept
2919				# Without parameters, returns an array of the
2920				# MIME types the browser accepts.
2921				# With a single parameter equal to a MIME
2922				# type, will return undef if the browser won't
2923				# accept it, 1 if the browser accepts it but
2924				# doesn't give a preference, or a floating point
2925				# value between 0.0 and 1.0 if the browser
2926				# declares a quantitative score for it.
2927				# This handles MIME type globs correctly.
2928				####
2929				'Accept' => <<'END_OF_FUNC',
2930				sub Accept {
2931				my($self,$search) = self_or_CGI(@_);
2932				my(%prefs,$type,$pref,$pat);
2933
2934				my(@accept) = split(',',$self->http('accept'));
2935
2936				foreach (@accept) {
2937				($pref) = /q=(\d\.\d+\|\d+)/;
2938				($type) = m#(\S+/[^;]+)#;
2939				next unless $type;
2940				$prefs{$type}=$pref \|\| 1;
2941				}
2942
2943				return keys %prefs unless $search;
2944
2945				# if a search type is provided, we may need to
2946				# perform a pattern matching operation.
2947				# The MIME types use a glob mechanism, which
2948				# is easily translated into a perl pattern match
2949
2950				# First return the preference for directly supported
2951				# types:
2952				return $prefs{$search} if $prefs{$search};
2953
2954				# Didn't get it, so try pattern matching.
2955				foreach (keys %prefs) {
2956				next unless /\*/; # not a pattern match
2957				($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2958				$pat =~ s/\/./g; # turn it into a pattern
2959				return $prefs{$_} if $search=~/$pat/;
2960				}
2961				}
2962				END_OF_FUNC
2963
2964
2965				#### Method: user_agent
2966				# If called with no parameters, returns the user agent.
2967				# If called with one parameter, does a pattern match (case
2968				# insensitive) on the user agent.
2969				####
2970				'user_agent' => <<'END_OF_FUNC',
2971				sub user_agent {
2972				my($self,$match)=self_or_CGI(@_);
2973				return $self->http('user_agent') unless $match;
2974				return $self->http('user_agent') =~ /$match/i;
2975				}
2976				END_OF_FUNC
2977
2978
2979				#### Method: raw_cookie
2980				# Returns the magic cookies for the session.
2981				# The cookies are not parsed or altered in any way, i.e.
2982				# cookies are returned exactly as given in the HTTP
2983				# headers. If a cookie name is given, only that cookie's
2984				# value is returned, otherwise the entire raw cookie
2985				# is returned.
2986				####
2987				'raw_cookie' => <<'END_OF_FUNC',
2988				sub raw_cookie {
2989				my($self,$key) = self_or_CGI(@_);
2990
2991				require CGI::Cookie;
2992
2993				if (defined($key)) {
2994				$self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
2995				unless $self->{'.raw_cookies'};
2996
2997				return () unless $self->{'.raw_cookies'};
2998				return () unless $self->{'.raw_cookies'}->{$key};
2999				return $self->{'.raw_cookies'}->{$key};
3000				}
3001				return $self->http('cookie') \|\| $ENV{'COOKIE'} \|\| '';
3002				}
3003				END_OF_FUNC
3004
3005				#### Method: virtual_host
3006				# Return the name of the virtual_host, which
3007				# is not always the same as the server
3008				######
3009				'virtual_host' => <<'END_OF_FUNC',
3010				sub virtual_host {
3011				my $vh = http('x_forwarded_host') \|\| http('host') \|\| server_name();
3012				$vh =~ s/:\d+$//; # get rid of port number
3013				return $vh;
3014				}
3015				END_OF_FUNC
3016
3017				#### Method: remote_host
3018				# Return the name of the remote host, or its IP
3019				# address if unavailable. If this variable isn't
3020				# defined, it returns "localhost" for debugging
3021				# purposes.
3022				####
3023				'remote_host' => <<'END_OF_FUNC',
3024				sub remote_host {
3025				return $ENV{'REMOTE_HOST'} \|\| $ENV{'REMOTE_ADDR'}
3026				\|\| 'localhost';
3027				}
3028				END_OF_FUNC
3029
3030
3031				#### Method: remote_addr
3032				# Return the IP addr of the remote host.
3033				####
3034				'remote_addr' => <<'END_OF_FUNC',
3035				sub remote_addr {
3036				return $ENV{'REMOTE_ADDR'} \|\| '127.0.0.1';
3037				}
3038				END_OF_FUNC
3039
3040
3041				#### Method: script_name
3042				# Return the partial URL to this script for
3043				# self-referencing scripts. Also see
3044				# self_url(), which returns a URL with all state information
3045				# preserved.
3046				####
3047				'script_name' => <<'END_OF_FUNC',
3048				sub script_name {
3049				my ($self,@p) = self_or_default(@_);
3050				if (@p) {
3051				$self->{'.script_name'} = shift @p;
3052				} elsif (!exists $self->{'.script_name'}) {
3053				my ($script_name,$path_info) = $self->_name_and_path_from_env();
3054				$self->{'.script_name'} = $script_name;
3055				}
3056				return $self->{'.script_name'};
3057				}
3058				END_OF_FUNC
3059
3060
3061				#### Method: referer
3062				# Return the HTTP_REFERER: useful for generating
3063				# a GO BACK button.
3064				####
3065				'referer' => <<'END_OF_FUNC',
3066				sub referer {
3067				my($self) = self_or_CGI(@_);
3068				return $self->http('referer');
3069				}
3070				END_OF_FUNC
3071
3072
3073				#### Method: server_name
3074				# Return the name of the server
3075				####
3076				'server_name' => <<'END_OF_FUNC',
3077				sub server_name {
3078				return $ENV{'SERVER_NAME'} \|\| 'localhost';
3079				}
3080				END_OF_FUNC
3081
3082				#### Method: server_software
3083				# Return the name of the server software
3084				####
3085				'server_software' => <<'END_OF_FUNC',
3086				sub server_software {
3087				return $ENV{'SERVER_SOFTWARE'} \|\| 'cmdline';
3088				}
3089				END_OF_FUNC
3090
3091				#### Method: virtual_port
3092				# Return the server port, taking virtual hosts into account
3093				####
3094				'virtual_port' => <<'END_OF_FUNC',
3095				sub virtual_port {
3096				my($self) = self_or_default(@_);
3097				my $vh = $self->http('x_forwarded_host') \|\| $self->http('host');
3098				my $protocol = $self->protocol;
3099				if ($vh) {
3100				return ($vh =~ /:(\d+)$/)[0] \|\| ($protocol eq 'https' ? 443 : 80);
3101				} else {
3102				return $self->server_port();
3103				}
3104				}
3105				END_OF_FUNC
3106
3107				#### Method: server_port
3108				# Return the tcp/ip port the server is running on
3109				####
3110				'server_port' => <<'END_OF_FUNC',
3111				sub server_port {
3112				return $ENV{'SERVER_PORT'} \|\| 80; # for debugging
3113				}
3114				END_OF_FUNC
3115
3116				#### Method: server_protocol
3117				# Return the protocol (usually HTTP/1.0)
3118				####
3119				'server_protocol' => <<'END_OF_FUNC',
3120				sub server_protocol {
3121				return $ENV{'SERVER_PROTOCOL'} \|\| 'HTTP/1.0'; # for debugging
3122				}
3123				END_OF_FUNC
3124
3125				#### Method: http
3126				# Return the value of an HTTP variable, or
3127				# the list of variables if none provided
3128				####
3129				'http' => <<'END_OF_FUNC',
3130				sub http {
3131				my ($self,$parameter) = self_or_CGI(@_);
3132				return $ENV{$parameter} if $parameter=~/^HTTP/;
3133				$parameter =~ tr/-/_/;
3134				return $ENV{"HTTP_\U$parameter\E"} if $parameter;
3135				my(@p);
3136				foreach (keys %ENV) {
3137				push(@p,$_) if /^HTTP/;
3138				}
3139				return @p;
3140				}
3141				END_OF_FUNC
3142
3143				#### Method: https
3144				# Return the value of HTTPS
3145				####
3146				'https' => <<'END_OF_FUNC',
3147				sub https {
3148				local($^W)=0;
3149				my ($self,$parameter) = self_or_CGI(@_);
3150				return $ENV{HTTPS} unless $parameter;
3151				return $ENV{$parameter} if $parameter=~/^HTTPS/;
3152				$parameter =~ tr/-/_/;
3153				return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
3154				my(@p);
3155				foreach (keys %ENV) {
3156				push(@p,$_) if /^HTTPS/;
3157				}
3158				return @p;
3159				}
3160				END_OF_FUNC
3161
3162				#### Method: protocol
3163				# Return the protocol (http or https currently)
3164				####
3165				'protocol' => <<'END_OF_FUNC',
3166				sub protocol {
3167				local($^W)=0;
3168				my $self = shift;
3169				return 'https' if uc($self->https()) eq 'ON';
3170				return 'https' if $self->server_port == 443;
3171				my $prot = $self->server_protocol;
3172				my($protocol,$version) = split('/',$prot);
3173				return "\L$protocol\E";
3174				}
3175				END_OF_FUNC
3176
3177				#### Method: remote_ident
3178				# Return the identity of the remote user
3179				# (but only if his host is running identd)
3180				####
3181				'remote_ident' => <<'END_OF_FUNC',
3182				sub remote_ident {
3183				return $ENV{'REMOTE_IDENT'};
3184				}
3185				END_OF_FUNC
3186
3187
3188				#### Method: auth_type
3189				# Return the type of use verification/authorization in use, if any.
3190				####
3191				'auth_type' => <<'END_OF_FUNC',
3192				sub auth_type {
3193				return $ENV{'AUTH_TYPE'};
3194				}
3195				END_OF_FUNC
3196
3197
3198				#### Method: remote_user
3199				# Return the authorization name used for user
3200				# verification.
3201				####
3202				'remote_user' => <<'END_OF_FUNC',
3203				sub remote_user {
3204				return $ENV{'REMOTE_USER'};
3205				}
3206				END_OF_FUNC
3207
3208
3209				#### Method: user_name
3210				# Try to return the remote user's name by hook or by
3211				# crook
3212				####
3213				'user_name' => <<'END_OF_FUNC',
3214				sub user_name {
3215				my ($self) = self_or_CGI(@_);
3216				return $self->http('from') \|\| $ENV{'REMOTE_IDENT'} \|\| $ENV{'REMOTE_USER'};
3217				}
3218				END_OF_FUNC
3219
3220				#### Method: nosticky
3221				# Set or return the NOSTICKY global flag
3222				####
3223				'nosticky' => <<'END_OF_FUNC',
3224				sub nosticky {
3225				my ($self,$param) = self_or_CGI(@_);
3226				$CGI::NOSTICKY = $param if defined($param);
3227				return $CGI::NOSTICKY;
3228				}
3229				END_OF_FUNC
3230
3231				#### Method: nph
3232				# Set or return the NPH global flag
3233				####
3234				'nph' => <<'END_OF_FUNC',
3235				sub nph {
3236				my ($self,$param) = self_or_CGI(@_);
3237				$CGI::NPH = $param if defined($param);
3238				return $CGI::NPH;
3239				}
3240				END_OF_FUNC
3241
3242				#### Method: private_tempfiles
3243				# Set or return the private_tempfiles global flag
3244				####
3245				'private_tempfiles' => <<'END_OF_FUNC',
3246				sub private_tempfiles {
3247				my ($self,$param) = self_or_CGI(@_);
3248				$CGI::PRIVATE_TEMPFILES = $param if defined($param);
3249				return $CGI::PRIVATE_TEMPFILES;
3250				}
3251				END_OF_FUNC
3252				#### Method: close_upload_files
3253				# Set or return the close_upload_files global flag
3254				####
3255				'close_upload_files' => <<'END_OF_FUNC',
3256				sub close_upload_files {
3257				my ($self,$param) = self_or_CGI(@_);
3258				$CGI::CLOSE_UPLOAD_FILES = $param if defined($param);
3259				return $CGI::CLOSE_UPLOAD_FILES;
3260				}
3261				END_OF_FUNC
3262
3263
3264				#### Method: default_dtd
3265				# Set or return the default_dtd global
3266				####
3267				'default_dtd' => <<'END_OF_FUNC',
3268				sub default_dtd {
3269				my ($self,$param,$param2) = self_or_CGI(@_);
3270				if (defined $param2 && defined $param) {
3271				$CGI::DEFAULT_DTD = [ $param, $param2 ];
3272				} elsif (defined $param) {
3273				$CGI::DEFAULT_DTD = $param;
3274				}
3275				return $CGI::DEFAULT_DTD;
3276				}
3277				END_OF_FUNC
3278
3279				# -------------- really private subroutines -----------------
3280				'previous_or_default' => <<'END_OF_FUNC',
3281				sub previous_or_default {
3282				my($self,$name,$defaults,$override) = @_;
3283				my(%selected);
3284
3285				if (!$override && ($self->{'.fieldnames'}->{$name} \|\|
3286				defined($self->param($name)) ) ) {
3287				grep($selected{$_}++,$self->param($name));
3288				} elsif (defined($defaults) && ref($defaults) &&
3289				(ref($defaults) eq 'ARRAY')) {
3290				grep($selected{$_}++,@{$defaults});
3291				} else {
3292				$selected{$defaults}++ if defined($defaults);
3293				}
3294
3295				return %selected;
3296				}
3297				END_OF_FUNC
3298
3299				'register_parameter' => <<'END_OF_FUNC',
3300				sub register_parameter {
3301				my($self,$param) = @_;
3302				$self->{'.parametersToAdd'}->{$param}++;
3303				}
3304				END_OF_FUNC
3305
3306				'get_fields' => <<'END_OF_FUNC',
3307				sub get_fields {
3308				my($self) = @_;
3309				return $self->CGI::hidden('-name'=>'.cgifields',
3310				'-values'=>[keys %{$self->{'.parametersToAdd'}}],
3311				'-override'=>1);
3312				}
3313				END_OF_FUNC
3314
3315				'read_from_cmdline' => <<'END_OF_FUNC',
3316				sub read_from_cmdline {
3317				my($input,@words);
3318				my($query_string);
3319				my($subpath);
3320				if ($DEBUG && @ARGV) {
3321				@words = @ARGV;
3322				} elsif ($DEBUG > 1) {
3323				require "shellwords.pl";
3324				print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n";
3325				chomp(@lines = <STDIN>); # remove newlines
3326				$input = join(" ",@lines);
3327				@words = &shellwords($input);
3328				}
3329				foreach (@words) {
3330				s/\\=/%3D/g;
3331				s/\\&/%26/g;
3332				}
3333
3334				if ("@words"=~/=/) {
3335				$query_string = join('&',@words);
3336				} else {
3337				$query_string = join('+',@words);
3338				}
3339				if ($query_string =~ /^(.?)\?(.)$/)
3340				{
3341				$query_string = $2;
3342				$subpath = $1;
3343				}
3344				return { 'query_string' => $query_string, 'subpath' => $subpath };
3345				}
3346				END_OF_FUNC
3347
3348				#####
3349				# subroutine: read_multipart
3350				#
3351				# Read multipart data and store it into our parameters.
3352				# An interesting feature is that if any of the parts is a file, we
3353				# create a temporary file and open up a filehandle on it so that the
3354				# caller can read from it if necessary.
3355				#####
3356				'read_multipart' => <<'END_OF_FUNC',
3357				sub read_multipart {
3358				my($self,$boundary,$length) = @_;
3359				my($buffer) = $self->new_MultipartBuffer($boundary,$length);
3360				return unless $buffer;
3361				my(%header,$body);
3362				my $filenumber = 0;
3363				while (!$buffer->eof) {
3364				%header = $buffer->readHeader;
3365
3366				unless (%header) {
3367				$self->cgi_error("400 Bad request (malformed multipart POST)");
3368				return;
3369				}
3370
3371				my($param)= $header{'Content-Disposition'}=~/ name="([^"]*)"/;
3372				$param .= $TAINTED;
3373
3374				# Bug: Netscape doesn't escape quotation marks in file names!!!
3375				my($filename) = $header{'Content-Disposition'}=~/ filename="([^"]*)"/;
3376				# Test for Opera's multiple upload feature
3377				my($multipart) = ( defined( $header{'Content-Type'} ) &&
3378				$header{'Content-Type'} =~ /multipart\/mixed/ ) ?
3379				1 : 0;
3380
3381				# add this parameter to our list
3382				$self->add_parameter($param);
3383
3384				# If no filename specified, then just read the data and assign it
3385				# to our parameter list.
3386				if ( ( !defined($filename) \|\| $filename eq '' ) && !$multipart ) {
3387				my($value) = $buffer->readBody;
3388				$value .= $TAINTED;
3389				push(@{$self->{$param}},$value);
3390				next;
3391				}
3392
3393				my ($tmpfile,$tmp,$filehandle);
3394				UPLOADS: {
3395				# If we get here, then we are dealing with a potentially large
3396				# uploaded form. Save the data to a temporary file, then open
3397				# the file for reading.
3398
3399				# skip the file if uploads disabled
3400				if ($DISABLE_UPLOADS) {
3401				while (defined($data = $buffer->read)) { }
3402				last UPLOADS;
3403				}
3404
3405				# set the filename to some recognizable value
3406				if ( ( !defined($filename) \|\| $filename eq '' ) && $multipart ) {
3407				$filename = "multipart/mixed";
3408				}
3409
3410				# choose a relatively unpredictable tmpfile sequence number
3411				my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
3412				for (my $cnt=10;$cnt>0;$cnt--) {
3413				next unless $tmpfile = new CGITempFile($seqno);
3414				$tmp = $tmpfile->as_string;
3415				last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
3416				$seqno += int rand(100);
3417				}
3418				die "CGI open of tmpfile: $!\n" unless defined $filehandle;
3419				$CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
3420				&& defined fileno($filehandle);
3421
3422				# if this is an multipart/mixed attachment, save the header
3423				# together with the body for later parsing with an external
3424				# MIME parser module
3425				if ( $multipart ) {
3426				foreach ( keys %header ) {
3427				print $filehandle "$_: $header{$_}${CRLF}";
3428				}
3429				print $filehandle "${CRLF}";
3430				}
3431
3432				my ($data);
3433				local($\) = '';
3434				my $totalbytes;
3435				while (defined($data = $buffer->read)) {
3436				if (defined $self->{'.upload_hook'})
3437				{
3438				$totalbytes += length($data);
3439				&{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
3440				}
3441				print $filehandle $data if ($self->{'use_tempfile'});
3442				}
3443
3444				# back up to beginning of file
3445				seek($filehandle,0,0);
3446
3447				## Close the filehandle if requested this allows a multipart MIME
3448				## upload to contain many files, and we won't die due to too many
3449				## open file handles. The user can access the files using the hash
3450				## below.
3451				close $filehandle if $CLOSE_UPLOAD_FILES;
3452				$CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
3453
3454				# Save some information about the uploaded file where we can get
3455				# at it later.
3456				# Use the typeglob as the key, as this is guaranteed to be
3457				# unique for each filehandle. Don't use the file descriptor as
3458				# this will be re-used for each filehandle if the
3459				# close_upload_files feature is used.
3460				$self->{'.tmpfiles'}->{$$filehandle}= {
3461				hndl => $filehandle,
3462				name => $tmpfile,
3463				info => {%header},
3464				};
3465				push(@{$self->{$param}},$filehandle);
3466				}
3467				}
3468				}
3469				END_OF_FUNC
3470
3471				#####
3472				# subroutine: read_multipart_related
3473				#
3474				# Read multipart/related data and store it into our parameters. The
3475				# first parameter sets the start of the data. The part identified by
3476				# this Content-ID will not be stored as a file upload, but will be
3477				# returned by this method. All other parts will be available as file
3478				# uploads accessible by their Content-ID
3479				#####
3480				'read_multipart_related' => <<'END_OF_FUNC',
3481				sub read_multipart_related {
3482				my($self,$start,$boundary,$length) = @_;
3483				my($buffer) = $self->new_MultipartBuffer($boundary,$length);
3484				return unless $buffer;
3485				my(%header,$body);
3486				my $filenumber = 0;
3487				my $returnvalue;
3488				while (!$buffer->eof) {
3489				%header = $buffer->readHeader;
3490
3491				unless (%header) {
3492				$self->cgi_error("400 Bad request (malformed multipart POST)");
3493				return;
3494				}
3495
3496				my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/;
3497				$param .= $TAINTED;
3498
3499				# If this is the start part, then just read the data and assign it
3500				# to our return variable.
3501				if ( $param eq $start ) {
3502				$returnvalue = $buffer->readBody;
3503				$returnvalue .= $TAINTED;
3504				next;
3505				}
3506
3507				# add this parameter to our list
3508				$self->add_parameter($param);
3509
3510				my ($tmpfile,$tmp,$filehandle);
3511				UPLOADS: {
3512				# If we get here, then we are dealing with a potentially large
3513				# uploaded form. Save the data to a temporary file, then open
3514				# the file for reading.
3515
3516				# skip the file if uploads disabled
3517				if ($DISABLE_UPLOADS) {
3518				while (defined($data = $buffer->read)) { }
3519				last UPLOADS;
3520				}
3521
3522				# choose a relatively unpredictable tmpfile sequence number
3523				my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
3524				for (my $cnt=10;$cnt>0;$cnt--) {
3525				next unless $tmpfile = new CGITempFile($seqno);
3526				$tmp = $tmpfile->as_string;
3527				last if defined($filehandle = Fh->new($param,$tmp,$PRIVATE_TEMPFILES));
3528				$seqno += int rand(100);
3529				}
3530				die "CGI open of tmpfile: $!\n" unless defined $filehandle;
3531				$CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
3532				&& defined fileno($filehandle);
3533
3534				my ($data);
3535				local($\) = '';
3536				my $totalbytes;
3537				while (defined($data = $buffer->read)) {
3538				if (defined $self->{'.upload_hook'})
3539				{
3540				$totalbytes += length($data);
3541				&{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'});
3542				}
3543				print $filehandle $data if ($self->{'use_tempfile'});
3544				}
3545
3546				# back up to beginning of file
3547				seek($filehandle,0,0);
3548
3549				## Close the filehandle if requested this allows a multipart MIME
3550				## upload to contain many files, and we won't die due to too many
3551				## open file handles. The user can access the files using the hash
3552				## below.
3553				close $filehandle if $CLOSE_UPLOAD_FILES;
3554				$CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
3555
3556				# Save some information about the uploaded file where we can get
3557				# at it later.
3558				# Use the typeglob as the key, as this is guaranteed to be
3559				# unique for each filehandle. Don't use the file descriptor as
3560				# this will be re-used for each filehandle if the
3561				# close_upload_files feature is used.
3562				$self->{'.tmpfiles'}->{$$filehandle}= {
3563				hndl => $filehandle,
3564				name => $tmpfile,
3565				info => {%header},
3566				};
3567				push(@{$self->{$param}},$filehandle);
3568				}
3569				}
3570				return $returnvalue;
3571				}
3572				END_OF_FUNC
3573
3574
3575				'upload' =><<'END_OF_FUNC',
3576				sub upload {
3577				my($self,$param_name) = self_or_default(@_);
3578				my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name);
3579				return unless @param;
3580				return wantarray ? @param : $param[0];
3581				}
3582				END_OF_FUNC
3583
3584				'tmpFileName' => <<'END_OF_FUNC',
3585				sub tmpFileName {
3586				my($self,$filename) = self_or_default(@_);
3587				return $self->{'.tmpfiles'}->{$$filename}->{name} ?
3588				$self->{'.tmpfiles'}->{$$filename}->{name}->as_string
3589				: '';
3590				}
3591				END_OF_FUNC
3592
3593				'uploadInfo' => <<'END_OF_FUNC',
3594				sub uploadInfo {
3595				my($self,$filename) = self_or_default(@_);
3596				return $self->{'.tmpfiles'}->{$$filename}->{info};
3597				}
3598				END_OF_FUNC
3599
3600				# internal routine, don't use
3601				'_set_values_and_labels' => <<'END_OF_FUNC',
3602				sub _set_values_and_labels {
3603				my $self = shift;
3604				my ($v,$l,$n) = @_;
3605				$$l = $v if ref($v) eq 'HASH' && !ref($$l);
3606				return $self->param($n) if !defined($v);
3607				return $v if !ref($v);
3608				return ref($v) eq 'HASH' ? keys %$v : @$v;
3609				}
3610				END_OF_FUNC
3611
3612				# internal routine, don't use
3613				'_set_attributes' => <<'END_OF_FUNC',
3614				sub _set_attributes {
3615				my $self = shift;
3616				my($element, $attributes) = @_;
3617				return '' unless defined($attributes->{$element});
3618				$attribs = ' ';
3619				foreach my $attrib (keys %{$attributes->{$element}}) {
3620				(my $clean_attrib = $attrib) =~ s/^-//;
3621				$attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" ";
3622				}
3623				$attribs =~ s/ $//;
3624				return $attribs;
3625				}
3626				END_OF_FUNC
3627
3628				'_compile_all' => <<'END_OF_FUNC',
3629				sub _compile_all {
3630				foreach (@_) {
3631				next if defined(&$_);
3632				$AUTOLOAD = "CGI::$_";
3633				_compile();
3634				}
3635				}
3636				END_OF_FUNC
3637
3638				);
3639				END_OF_AUTOLOAD
3640				;
3641
3642				#########################################################
3643				# Globals and stubs for other packages that we use.
3644				#########################################################
3645
3646				################### Fh -- lightweight filehandle ###############
3647				package Fh;
3648				use overload
3649				'""' => \&asString, # spent 51µs making 1 call to overload::import
3650				'cmp' => \&compare,
3651	3	994µs	331µs	'fallback'=>1;
3652
3653	1	400ns	400ns	$FH='fh00000';
3654
3655	1	1µs	1µs	*Fh::AUTOLOAD = \&CGI::AUTOLOAD;
3656
3657				sub DESTROY {
3658				my $self = shift;
3659				close $self;
3660				}
3661
3662	1	500ns	500ns	$AUTOLOADED_ROUTINES = ''; # prevent -w error
3663	1	1µs	1µs	$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3664				%SUBS = (
3665				'asString' => <<'END_OF_FUNC',
3666				sub asString {
3667				my $self = shift;
3668				# get rid of package name
3669				(my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
3670				$i =~ s/%(..)/ chr(hex($1)) /eg;
3671				return $i.$CGI::TAINTED;
3672				# BEGIN DEAD CODE
3673				# This was an extremely clever patch that allowed "use strict refs".
3674				# Unfortunately it relied on another bug that caused leaky file descriptors.
3675				# The underlying bug has been fixed, so this no longer works. However
3676				# "strict refs" still works for some reason.
3677				# my $self = shift;
3678				# return ${*{$self}{SCALAR}};
3679				# END DEAD CODE
3680				}
3681				END_OF_FUNC
3682
3683				'compare' => <<'END_OF_FUNC',
3684				sub compare {
3685				my $self = shift;
3686				my $value = shift;
3687				return "$self" cmp $value;
3688				}
3689				END_OF_FUNC
3690
3691				'new' => <<'END_OF_FUNC',
3692				sub new {
3693				my($pack,$name,$file,$delete) = @_;
3694				_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
3695				require Fcntl unless defined &Fcntl::O_RDWR;
3696				(my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
3697				my $fv = ++$FH . $safename;
3698				my $ref = \*{"Fh::$fv"};
3699				$file =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! \|\| return;
3700				my $safe = $1;
3701				sysopen($ref,$safe,Fcntl::O_RDWR()\|Fcntl::O_CREAT()\|Fcntl::O_EXCL(),0600) \|\| return;
3702				unlink($safe) if $delete;
3703				CORE::delete $Fh::{$fv};
3704				return bless $ref,$pack;
3705				}
3706				END_OF_FUNC
3707
3708				);
3709				END_OF_AUTOLOAD
3710
3711				######################## MultipartBuffer ####################
3712				package MultipartBuffer;
3713
3714	3	671µs	224µs	use constant DEBUG => 0; # spent 55µs making 1 call to constant::import
3715
3716				# how many bytes to read at a time. We use
3717				# a 4K buffer by default.
3718	1	200ns	200ns	$INITIAL_FILLUNIT = 1024 * 4;
3719	1	200ns	200ns	$TIMEOUT = 240*60; # 4 hour timeout for big files
3720	1	200ns	200ns	$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
3721	1	300ns	300ns	$CRLF=$CGI::CRLF;
3722
3723				#reuse the autoload function
3724	1	900ns	900ns	*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
3725
3726				# avoid autoloader warnings
3727				sub DESTROY {}
3728
3729				###############################################################################
3730				################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3731				###############################################################################
3732	1	400ns	400ns	$AUTOLOADED_ROUTINES = ''; # prevent -w error
3733	1	7µs	7µs	$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3734				%SUBS = (
3735
3736				'new' => <<'END_OF_FUNC',
3737				sub new {
3738				my($package,$interface,$boundary,$length) = @_;
3739				$FILLUNIT = $INITIAL_FILLUNIT;
3740				$CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always
3741
3742				# If the user types garbage into the file upload field,
3743				# then Netscape passes NOTHING to the server (not good).
3744				# We may hang on this read in that case. So we implement
3745				# a read timeout. If nothing is ready to read
3746				# by then, we return.
3747
3748				# Netscape seems to be a little bit unreliable
3749				# about providing boundary strings.
3750				my $boundary_read = 0;
3751				if ($boundary) {
3752
3753				# Under the MIME spec, the boundary consists of the
3754				# characters "--" PLUS the Boundary string
3755
3756				# BUG: IE 3.01 on the Macintosh uses just the boundary -- not
3757				# the two extra hyphens. We do a special case here on the user-agent!!!!
3758				$boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac\|DreamPassport');
3759
3760				} else { # otherwise we find it ourselves
3761				my($old);
3762				($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
3763				$boundary = <STDIN>; # BUG: This won't work correctly under mod_perl
3764				$length -= length($boundary);
3765				chomp($boundary); # remove the CRLF
3766				$/ = $old; # restore old line separator
3767				$boundary_read++;
3768				}
3769
3770				my $self = {LENGTH=>$length,
3771				CHUNKED=>!defined $length,
3772				BOUNDARY=>$boundary,
3773				INTERFACE=>$interface,
3774				BUFFER=>'',
3775				};
3776
3777				$FILLUNIT = length($boundary)
3778				if length($boundary) > $FILLUNIT;
3779
3780				my $retval = bless $self,ref $package \|\| $package;
3781
3782				# Read the preamble and the topmost (boundary) line plus the CRLF.
3783				unless ($boundary_read) {
3784				while ($self->read(0)) { }
3785				}
3786				die "Malformed multipart POST: data truncated\n" if $self->eof;
3787
3788				return $retval;
3789				}
3790				END_OF_FUNC
3791
3792				'readHeader' => <<'END_OF_FUNC',
3793				sub readHeader {
3794				my($self) = @_;
3795				my($end);
3796				my($ok) = 0;
3797				my($bad) = 0;
3798
3799				local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' \|\| $CGI::EBCDIC;
3800
3801				do {
3802				$self->fillBuffer($FILLUNIT);
3803				$ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
3804				$ok++ if $self->{BUFFER} eq '';
3805				$bad++ if !$ok && $self->{LENGTH} <= 0;
3806				# this was a bad idea
3807				# $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
3808				} until $ok \|\| $bad;
3809				return () if $bad;
3810
3811				#EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines!
3812
3813				my($header) = substr($self->{BUFFER},0,$end+2);
3814				substr($self->{BUFFER},0,$end+4) = '';
3815				my %return;
3816
3817				if ($CGI::EBCDIC) {
3818				warn "untranslated header=$header\n" if DEBUG;
3819				$header = CGI::Util::ascii2ebcdic($header);
3820				warn "translated header=$header\n" if DEBUG;
3821				}
3822
3823				# See RFC 2045 Appendix A and RFC 822 sections 3.4.8
3824				# (Folding Long Header Fields), 3.4.3 (Comments)
3825				# and 3.4.5 (Quoted-Strings).
3826
3827				my $token = '[-\w!\#$%&\'*+.^_\`\|{}~]';
3828				$header=~s/$CRLF\s+/ /og; # merge continuation lines
3829
3830				while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
3831				my ($field_name,$field_value) = ($1,$2);
3832				$field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
3833				$return{$field_name}=$field_value;
3834				}
3835				return %return;
3836				}
3837				END_OF_FUNC
3838
3839				# This reads and returns the body as a single scalar value.
3840				'readBody' => <<'END_OF_FUNC',
3841				sub readBody {
3842				my($self) = @_;
3843				my($data);
3844				my($returnval)='';
3845
3846				#EBCDIC NOTE: want to translate returnval into EBCDIC HERE
3847
3848				while (defined($data = $self->read)) {
3849				$returnval .= $data;
3850				}
3851
3852				if ($CGI::EBCDIC) {
3853				warn "untranslated body=$returnval\n" if DEBUG;
3854				$returnval = CGI::Util::ascii2ebcdic($returnval);
3855				warn "translated body=$returnval\n" if DEBUG;
3856				}
3857				return $returnval;
3858				}
3859				END_OF_FUNC
3860
3861				# This will read $bytes or until the boundary is hit, whichever happens
3862				# first. After the boundary is hit, we return undef. The next read will
3863				# skip over the boundary and begin reading again;
3864				'read' => <<'END_OF_FUNC',
3865				sub read {
3866				my($self,$bytes) = @_;
3867
3868				# default number of bytes to read
3869				$bytes = $bytes \|\| $FILLUNIT;
3870
3871				# Fill up our internal buffer in such a way that the boundary
3872				# is never split between reads.
3873				$self->fillBuffer($bytes);
3874
3875				my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY};
3876				my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--';
3877
3878				# Find the boundary in the buffer (it may not be there).
3879				my $start = index($self->{BUFFER},$boundary_start);
3880
3881				warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG;
3882
3883				# protect against malformed multipart POST operations
3884				die "Malformed multipart POST\n" unless $self->{CHUNKED} \|\| ($start >= 0 \|\| $self->{LENGTH} > 0);
3885
3886				#EBCDIC NOTE: want to translate boundary search into ASCII here.
3887
3888				# If the boundary begins the data, then skip past it
3889				# and return undef.
3890				if ($start == 0) {
3891
3892				# clear us out completely if we've hit the last boundary.
3893				if (index($self->{BUFFER},$boundary_end)==0) {
3894				$self->{BUFFER}='';
3895				$self->{LENGTH}=0;
3896				return undef;
3897				}
3898
3899				# just remove the boundary.
3900				substr($self->{BUFFER},0,length($boundary_start))='';
3901				$self->{BUFFER} =~ s/^\012\015?//;
3902				return undef;
3903				}
3904
3905				my $bytesToReturn;
3906				if ($start > 0) { # read up to the boundary
3907				$bytesToReturn = $start-2 > $bytes ? $bytes : $start;
3908				} else { # read the requested number of bytes
3909				# leave enough bytes in the buffer to allow us to read
3910				# the boundary. Thanks to Kevin Hendrick for finding
3911				# this one.
3912				$bytesToReturn = $bytes - (length($boundary_start)+1);
3913				}
3914
3915				my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
3916				substr($self->{BUFFER},0,$bytesToReturn)='';
3917
3918				# If we hit the boundary, remove the CRLF from the end.
3919				return ($bytesToReturn==$start)
3920				? substr($returnval,0,-2) : $returnval;
3921				}
3922				END_OF_FUNC
3923
3924
3925				# This fills up our internal buffer in such a way that the
3926				# boundary is never split between reads
3927				'fillBuffer' => <<'END_OF_FUNC',
3928				sub fillBuffer {
3929				my($self,$bytes) = @_;
3930				return unless $self->{CHUNKED} \|\| $self->{LENGTH};
3931
3932				my($boundaryLength) = length($self->{BOUNDARY});
3933				my($bufferLength) = length($self->{BUFFER});
3934				my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
3935				$bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $self->{LENGTH} < $bytesToRead;
3936
3937				# Try to read some data. We may hang here if the browser is screwed up.
3938				my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER},
3939				$bytesToRead,
3940				$bufferLength);
3941				warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG;
3942				$self->{BUFFER} = '' unless defined $self->{BUFFER};
3943
3944				# An apparent bug in the Apache server causes the read()
3945				# to return zero bytes repeatedly without blocking if the
3946				# remote user aborts during a file transfer. I don't know how
3947				# they manage this, but the workaround is to abort if we get
3948				# more than SPIN_LOOP_MAX consecutive zero reads.
3949				if ($bytesRead <= 0) {
3950				die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
3951				if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
3952				} else {
3953				$self->{ZERO_LOOP_COUNTER}=0;
3954				}
3955
3956				$self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead;
3957				}
3958				END_OF_FUNC
3959
3960
3961				# Return true when we've finished reading
3962				'eof' => <<'END_OF_FUNC'
3963				sub eof {
3964				my($self) = @_;
3965				return 1 if (length($self->{BUFFER}) == 0)
3966				&& ($self->{LENGTH} <= 0);
3967				undef;
3968				}
3969				END_OF_FUNC
3970
3971				);
3972				END_OF_AUTOLOAD
3973
3974				####################################################################################
3975				################################## TEMPORARY FILES #################################
3976				####################################################################################
3977				package CGITempFile;
3978
3979				# spent 51µs within CGITempFile::find_tempdir which was called # once (51µs+0s) at line 4007 sub find_tempdir {
3980	5	5µs	940ns	$SL = $CGI::SL;
3981				$MAC = $CGI::OS eq 'MACINTOSH';
3982				my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
3983	3	10µs	3µs	unless (defined $TMPDIRECTORY) {
3984				@TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
3985				"C:${SL}temp","${SL}tmp","${SL}temp",
3986				"${vol}${SL}Temporary Items",
3987				"${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
3988				"C:${SL}system${SL}temp");
3989				unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'};
3990
3991				# this feature was supposed to provide per-user tmpfiles, but
3992				# it is problematic.
3993				# unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
3994				# Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
3995				# : can generate a 'getpwuid() not implemented' exception, even though
3996				# : it's never called. Found under DOS/Win with the DJGPP perl port.
3997				# : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
3998				# unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
3999
4000				foreach (@TEMP) {
4001	4	30µs	7µs	do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
4002				}
4003				}
4004				$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
4005				}
4006
4007	1	7µs	7µs	find_tempdir(); # spent 51µs making 1 call to CGITempFile::find_tempdir
4008
4009	1	400ns	400ns	$MAXTRIES = 5000;
4010
4011				# cute feature, but overload implementation broke it
4012				# %OVERLOAD = ('""'=>'as_string');
4013	1	1µs	1µs	*CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD;
4014
4015				sub DESTROY {
4016				my($self) = @_;
4017				$$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! \|\| return;
4018				my $safe = $1; # untaint operation
4019				unlink $safe; # get rid of the file
4020				}
4021
4022				###############################################################################
4023				################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
4024				###############################################################################
4025	1	500ns	500ns	$AUTOLOADED_ROUTINES = ''; # prevent -w error
4026	1	700ns	700ns	$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
4027				%SUBS = (
4028
4029				'new' => <<'END_OF_FUNC',
4030				sub new {
4031				my($package,$sequence) = @_;
4032				my $filename;
4033				find_tempdir() unless -w $TMPDIRECTORY;
4034				for (my $i = 0; $i < $MAXTRIES; $i++) {
4035				last if ! -f ($filename = sprintf("\%s${SL}CGItemp%d",$TMPDIRECTORY,$sequence++));
4036				}
4037				# check that it is a more-or-less valid filename
4038				return unless $filename =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$!;
4039				# this used to untaint, now it doesn't
4040				# $filename = $1;
4041				return bless \$filename;
4042				}
4043				END_OF_FUNC
4044
4045				'as_string' => <<'END_OF_FUNC'
4046				sub as_string {
4047				my($self) = @_;
4048				return $$self;
4049				}
4050				END_OF_FUNC
4051
4052				);
4053				END_OF_AUTOLOAD
4054
4055				package CGI;
4056
4057				# We get a whole bunch of warnings about "possibly uninitialized variables"
4058				# when running with the -w switch. Touch them all once to get rid of the
4059				# warnings. This is ugly and I hate it.
4060	1	1µs	1µs	if ($^W) {
4061				$CGI::CGI = '';
4062				$CGI::CGI=<<EOF;
4063				$CGI::VERSION;
4064				$MultipartBuffer::SPIN_LOOP_MAX;
4065				$MultipartBuffer::CRLF;
4066				$MultipartBuffer::TIMEOUT;
4067				$MultipartBuffer::INITIAL_FILLUNIT;
4068				EOF
4069				;
4070				}
4071
4072	1	102µs	102µs	1;
4073
4074				__END__
4075
4076				=head1 NAME
4077
4078				CGI - Simple Common Gateway Interface Class
4079
4080				=head1 SYNOPSIS
4081
4082				# CGI script that creates a fill-out form
4083				# and echoes back its values.
4084
4085				use CGI qw/:standard/;
4086				print header,
4087				start_html('A Simple Example'),
4088				h1('A Simple Example'),
4089				start_form,
4090				"What's your name? ",textfield('name'),p,
4091				"What's the combination?", p,
4092				checkbox_group(-name=>'words',
4093				-values=>['eenie','meenie','minie','moe'],
4094				-defaults=>['eenie','minie']), p,
4095				"What's your favorite color? ",
4096				popup_menu(-name=>'color',
4097				-values=>['red','green','blue','chartreuse']),p,
4098				submit,
4099				end_form,
4100				hr;
4101
4102				if (param()) {
4103				my $name = param('name');
4104				my $keywords = join ', ',param('words');
4105				my $color = param('color');
4106				print "Your name is",em(escapeHTML($name)),p,
4107				"The keywords are: ",em(escapeHTML($keywords)),p,
4108				"Your favorite color is ",em(escapeHTML($color)),
4109				hr;
4110				}
4111
4112				print end_html;
4113
4114				=head1 ABSTRACT
4115
4116				This perl library uses perl5 objects to make it easy to create Web
4117				fill-out forms and parse their contents. This package defines CGI
4118				objects, entities that contain the values of the current query string
4119				and other state variables. Using a CGI object's methods, you can
4120				examine keywords and parameters passed to your script, and create
4121				forms whose initial values are taken from the current query (thereby
4122				preserving state information). The module provides shortcut functions
4123				that produce boilerplate HTML, reducing typing and coding errors. It
4124				also provides functionality for some of the more advanced features of
4125				CGI scripting, including support for file uploads, cookies, cascading
4126				style sheets, server push, and frames.
4127
4128				CGI.pm also provides a simple function-oriented programming style for
4129				those who don't need its object-oriented features.
4130
4131				The current version of CGI.pm is available at
4132
4133				http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
4134				ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
4135
4136				=head1 DESCRIPTION
4137
4138				=head2 PROGRAMMING STYLE
4139
4140				There are two styles of programming with CGI.pm, an object-oriented
4141				style and a function-oriented style. In the object-oriented style you
4142				create one or more CGI objects and then use object methods to create
4143				the various elements of the page. Each CGI object starts out with the
4144				list of named parameters that were passed to your CGI script by the
4145				server. You can modify the objects, save them to a file or database
4146				and recreate them. Because each object corresponds to the "state" of
4147				the CGI script, and because each object's parameter list is
4148				independent of the others, this allows you to save the state of the
4149				script and restore it later.
4150
4151				For example, using the object oriented style, here is how you create
4152				a simple "Hello World" HTML page:
4153
4154				#!/usr/local/bin/perl -w
4155				use CGI; # load CGI routines
4156				$q = new CGI; # create new CGI object
4157				print $q->header, # create the HTTP header
4158				$q->start_html('hello world'), # start the HTML
4159				$q->h1('hello world'), # level 1 header
4160				$q->end_html; # end the HTML
4161
4162				In the function-oriented style, there is one default CGI object that
4163				you rarely deal with directly. Instead you just call functions to
4164				retrieve CGI parameters, create HTML tags, manage cookies, and so
4165				on. This provides you with a cleaner programming interface, but
4166				limits you to using one CGI object at a time. The following example
4167				prints the same page, but uses the function-oriented interface.
4168				The main differences are that we now need to import a set of functions
4169				into our name space (usually the "standard" functions), and we don't
4170				need to create the CGI object.
4171
4172				#!/usr/local/bin/perl
4173				use CGI qw/:standard/; # load standard CGI routines
4174				print header, # create the HTTP header
4175				start_html('hello world'), # start the HTML
4176				h1('hello world'), # level 1 header
4177				end_html; # end the HTML
4178
4179				The examples in this document mainly use the object-oriented style.
4180				See HOW TO IMPORT FUNCTIONS for important information on
4181				function-oriented programming in CGI.pm
4182
4183				=head2 CALLING CGI.PM ROUTINES
4184
4185				Most CGI.pm routines accept several arguments, sometimes as many as 20
4186				optional ones! To simplify this interface, all routines use a named
4187				argument calling style that looks like this:
4188
4189				print $q->header(-type=>'image/gif',-expires=>'+3d');
4190
4191				Each argument name is preceded by a dash. Neither case nor order
4192				matters in the argument list. -type, -Type, and -TYPE are all
4193				acceptable. In fact, only the first argument needs to begin with a
4194				dash. If a dash is present in the first argument, CGI.pm assumes
4195				dashes for the subsequent ones.
4196
4197				Several routines are commonly called with just one argument. In the
4198				case of these routines you can provide the single argument without an
4199				argument name. header() happens to be one of these routines. In this
4200				case, the single argument is the document type.
4201
4202				print $q->header('text/html');
4203
4204				Other such routines are documented below.
4205
4206				Sometimes named arguments expect a scalar, sometimes a reference to an
4207				array, and sometimes a reference to a hash. Often, you can pass any
4208				type of argument and the routine will do whatever is most appropriate.
4209				For example, the param() routine is used to set a CGI parameter to a
4210				single or a multi-valued value. The two cases are shown below:
4211
4212				$q->param(-name=>'veggie',-value=>'tomato');
4213				$q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']);
4214
4215				A large number of routines in CGI.pm actually aren't specifically
4216				defined in the module, but are generated automatically as needed.
4217				These are the "HTML shortcuts," routines that generate HTML tags for
4218				use in dynamically-generated pages. HTML tags have both attributes
4219				(the attribute="value" pairs within the tag itself) and contents (the
4220				part between the opening and closing pairs.) To distinguish between
4221				attributes and contents, CGI.pm uses the convention of passing HTML
4222				attributes as a hash reference as the first argument, and the
4223				contents, if any, as any subsequent arguments. It works out like
4224				this:
4225
4226				Code Generated HTML
4227				---- --------------
4228				h1() <h1>
4229				h1('some','contents'); <h1>some contents</h1>
4230				h1({-align=>left}); <h1 align="LEFT">
4231				h1({-align=>left},'contents'); <h1 align="LEFT">contents</h1>
4232
4233				HTML tags are described in more detail later.
4234
4235				Many newcomers to CGI.pm are puzzled by the difference between the
4236				calling conventions for the HTML shortcuts, which require curly braces
4237				around the HTML tag attributes, and the calling conventions for other
4238				routines, which manage to generate attributes without the curly
4239				brackets. Don't be confused. As a convenience the curly braces are
4240				optional in all but the HTML shortcuts. If you like, you can use
4241				curly braces when calling any routine that takes named arguments. For
4242				example:
4243
4244				print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
4245
4246				If you use the B<-w> switch, you will be warned that some CGI.pm argument
4247				names conflict with built-in Perl functions. The most frequent of
4248				these is the -values argument, used to create multi-valued menus,
4249				radio button clusters and the like. To get around this warning, you
4250				have several choices:
4251
4252				=over 4
4253
4254				=item 1.
4255
4256				Use another name for the argument, if one is available.
4257				For example, -value is an alias for -values.
4258
4259				=item 2.
4260
4261				Change the capitalization, e.g. -Values
4262
4263				=item 3.
4264
4265				Put quotes around the argument name, e.g. '-values'
4266
4267				=back
4268
4269				Many routines will do something useful with a named argument that it
4270				doesn't recognize. For example, you can produce non-standard HTTP
4271				header fields by providing them as named arguments:
4272
4273				print $q->header(-type => 'text/html',
4274				-cost => 'Three smackers',
4275				-annoyance_level => 'high',
4276				-complaints_to => 'bit bucket');
4277
4278				This will produce the following nonstandard HTTP header:
4279
4280				HTTP/1.0 200 OK
4281				Cost: Three smackers
4282				Annoyance-level: high
4283				Complaints-to: bit bucket
4284				Content-type: text/html
4285
4286				Notice the way that underscores are translated automatically into
4287				hyphens. HTML-generating routines perform a different type of
4288				translation.
4289
4290				This feature allows you to keep up with the rapidly changing HTTP and
4291				HTML "standards".
4292
4293				=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
4294
4295				$query = new CGI;
4296
4297				This will parse the input (from both POST and GET methods) and store
4298				it into a perl5 object called $query.
4299
4300				Any filehandles from file uploads will have their position reset to
4301				the beginning of the file.
4302
4303				=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
4304
4305				$query = new CGI(INPUTFILE);
4306
4307				If you provide a file handle to the new() method, it will read
4308				parameters from the file (or STDIN, or whatever). The file can be in
4309				any of the forms describing below under debugging (i.e. a series of
4310				newline delimited TAG=VALUE pairs will work). Conveniently, this type
4311				of file is created by the save() method (see below). Multiple records
4312				can be saved and restored.
4313
4314				Perl purists will be pleased to know that this syntax accepts
4315				references to file handles, or even references to filehandle globs,
4316				which is the "official" way to pass a filehandle:
4317
4318				$query = new CGI(\*STDIN);
4319
4320				You can also initialize the CGI object with a FileHandle or IO::File
4321				object.
4322
4323				If you are using the function-oriented interface and want to
4324				initialize CGI state from a file handle, the way to do this is with
4325				B<restore_parameters()>. This will (re)initialize the
4326				default CGI object from the indicated file handle.
4327
4328				open (IN,"test.in") \|\| die;
4329				restore_parameters(IN);
4330				close IN;
4331
4332				You can also initialize the query object from an associative array
4333				reference:
4334
4335				$query = new CGI( {'dinosaur'=>'barney',
4336				'song'=>'I love you',
4337				'friends'=>[qw/Jessica George Nancy/]}
4338				);
4339
4340				or from a properly formatted, URL-escaped query string:
4341
4342				$query = new CGI('dinosaur=barney&color=purple');
4343
4344				or from a previously existing CGI object (currently this clones the
4345				parameter list, but none of the other object-specific fields, such as
4346				autoescaping):
4347
4348				$old_query = new CGI;
4349				$new_query = new CGI($old_query);
4350
4351				To create an empty query, initialize it from an empty string or hash:
4352
4353				$empty_query = new CGI("");
4354
4355				-or-
4356
4357				$empty_query = new CGI({});
4358
4359				=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
4360
4361				@keywords = $query->keywords
4362
4363				If the script was invoked as the result of an <ISINDEX> search, the
4364				parsed keywords can be obtained as an array using the keywords() method.
4365
4366				=head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
4367
4368				@names = $query->param
4369
4370				If the script was invoked with a parameter list
4371				(e.g. "name1=value1&name2=value2&name3=value3"), the param() method
4372				will return the parameter names as a list. If the script was invoked
4373				as an <ISINDEX> script and contains a string without ampersands
4374				(e.g. "value1+value2+value3") , there will be a single parameter named
4375				"keywords" containing the "+"-delimited keywords.
4376
4377				NOTE: As of version 1.5, the array of parameter names returned will
4378				be in the same order as they were submitted by the browser.
4379				Usually this order is the same as the order in which the
4380				parameters are defined in the form (however, this isn't part
4381				of the spec, and so isn't guaranteed).
4382
4383				=head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
4384
4385				@values = $query->param('foo');
4386
4387				-or-
4388
4389				$value = $query->param('foo');
4390
4391				Pass the param() method a single argument to fetch the value of the
4392				named parameter. If the parameter is multivalued (e.g. from multiple
4393				selections in a scrolling list), you can ask to receive an array. Otherwise
4394				the method will return a single value.
4395
4396				If a value is not given in the query string, as in the queries
4397				"name1=&name2=" or "name1&name2", it will be returned as an empty
4398				string. This feature is new in 2.63.
4399
4400
4401				If the parameter does not exist at all, then param() will return undef
4402				in a scalar context, and the empty list in a list context.
4403
4404
4405				=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
4406
4407				$query->param('foo','an','array','of','values');
4408
4409				This sets the value for the named parameter 'foo' to an array of
4410				values. This is one way to change the value of a field AFTER
4411				the script has been invoked once before. (Another way is with
4412				the -override parameter accepted by all methods that generate
4413				form elements.)
4414
4415				param() also recognizes a named parameter style of calling described
4416				in more detail later:
4417
4418				$query->param(-name=>'foo',-values=>['an','array','of','values']);
4419
4420				-or-
4421
4422				$query->param(-name=>'foo',-value=>'the value');
4423
4424				=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
4425
4426				$query->append(-name=>'foo',-values=>['yet','more','values']);
4427
4428				This adds a value or list of values to the named parameter. The
4429				values are appended to the end of the parameter if it already exists.
4430				Otherwise the parameter is created. Note that this method only
4431				recognizes the named argument calling syntax.
4432
4433				=head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
4434
4435				$query->import_names('R');
4436
4437				This creates a series of variables in the 'R' namespace. For example,
4438				$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
4439				If no namespace is given, this method will assume 'Q'.
4440				WARNING: don't import anything into 'main'; this is a major security
4441				risk!!!!
4442
4443				NOTE 1: Variable names are transformed as necessary into legal Perl
4444				variable names. All non-legal characters are transformed into
4445				underscores. If you need to keep the original names, you should use
4446				the param() method instead to access CGI variables by name.
4447
4448				NOTE 2: In older versions, this method was called B<import()>. As of version 2.20,
4449				this name has been removed completely to avoid conflict with the built-in
4450				Perl module B<import> operator.
4451
4452				=head2 DELETING A PARAMETER COMPLETELY:
4453
4454				$query->delete('foo','bar','baz');
4455
4456				This completely clears a list of parameters. It sometimes useful for
4457				resetting parameters that you don't want passed down between script
4458				invocations.
4459
4460				If you are using the function call interface, use "Delete()" instead
4461				to avoid conflicts with Perl's built-in delete operator.
4462
4463				=head2 DELETING ALL PARAMETERS:
4464
4465				$query->delete_all();
4466
4467				This clears the CGI object completely. It might be useful to ensure
4468				that all the defaults are taken when you create a fill-out form.
4469
4470				Use Delete_all() instead if you are using the function call interface.
4471
4472				=head2 HANDLING NON-URLENCODED ARGUMENTS
4473
4474
4475				If POSTed data is not of type application/x-www-form-urlencoded or
4476				multipart/form-data, then the POSTed data will not be processed, but
4477				instead be returned as-is in a parameter named POSTDATA. To retrieve
4478				it, use code like this:
4479
4480				my $data = $query->param('POSTDATA');
4481
4482				(If you don't know what the preceding means, don't worry about it. It
4483				only affects people trying to use CGI for XML processing and other
4484				specialized tasks.)
4485
4486
4487				=head2 DIRECT ACCESS TO THE PARAMETER LIST:
4488
4489				$q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
4490				unshift @{$q->param_fetch(-name=>'address')},'George Munster';
4491
4492				If you need access to the parameter list in a way that isn't covered
4493				by the methods above, you can obtain a direct reference to it by
4494				calling the B<param_fetch()> method with the name of the . This
4495				will return an array reference to the named parameters, which you then
4496				can manipulate in any way you like.
4497
4498				You can also use a named argument style using the B<-name> argument.
4499
4500				=head2 FETCHING THE PARAMETER LIST AS A HASH:
4501
4502				$params = $q->Vars;
4503				print $params->{'address'};
4504				@foo = split("\0",$params->{'foo'});
4505				%params = $q->Vars;
4506
4507				use CGI ':cgi-lib';
4508				$params = Vars;
4509
4510				Many people want to fetch the entire parameter list as a hash in which
4511				the keys are the names of the CGI parameters, and the values are the
4512				parameters' values. The Vars() method does this. Called in a scalar
4513				context, it returns the parameter list as a tied hash reference.
4514				Changing a key changes the value of the parameter in the underlying
4515				CGI parameter list. Called in a list context, it returns the
4516				parameter list as an ordinary hash. This allows you to read the
4517				contents of the parameter list, but not to change it.
4518
4519				When using this, the thing you must watch out for are multivalued CGI
4520				parameters. Because a hash cannot distinguish between scalar and
4521				list context, multivalued parameters will be returned as a packed
4522				string, separated by the "\0" (null) character. You must split this
4523				packed string in order to get at the individual values. This is the
4524				convention introduced long ago by Steve Brenner in his cgi-lib.pl
4525				module for Perl version 4.
4526
4527				If you wish to use Vars() as a function, import the I<:cgi-lib> set of
4528				function calls (also see the section on CGI-LIB compatibility).
4529
4530				=head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
4531
4532				$query->save(\*FILEHANDLE)
4533
4534				This will write the current state of the form to the provided
4535				filehandle. You can read it back in by providing a filehandle
4536				to the new() method. Note that the filehandle can be a file, a pipe,
4537				or whatever!
4538
4539				The format of the saved file is:
4540
4541				NAME1=VALUE1
4542				NAME1=VALUE1'
4543				NAME2=VALUE2
4544				NAME3=VALUE3
4545				=
4546
4547				Both name and value are URL escaped. Multi-valued CGI parameters are
4548				represented as repeated names. A session record is delimited by a
4549				single = symbol. You can write out multiple records and read them
4550				back in with several calls to B<new>. You can do this across several
4551				sessions by opening the file in append mode, allowing you to create
4552				primitive guest books, or to keep a history of users' queries. Here's
4553				a short example of creating multiple session records:
4554
4555				use CGI;
4556
4557				open (OUT,">>test.out") \|\| die;
4558				$records = 5;
4559				foreach (0..$records) {
4560				my $q = new CGI;
4561				$q->param(-name=>'counter',-value=>$_);
4562				$q->save(\*OUT);
4563				}
4564				close OUT;
4565
4566				# reopen for reading
4567				open (IN,"test.out") \|\| die;
4568				while (!eof(IN)) {
4569				my $q = new CGI(\*IN);
4570				print $q->param('counter'),"\n";
4571				}
4572
4573				The file format used for save/restore is identical to that used by the
4574				Whitehead Genome Center's data exchange format "Boulderio", and can be
4575				manipulated and even databased using Boulderio utilities. See
4576
4577				http://stein.cshl.org/boulder/
4578
4579				for further details.
4580
4581				If you wish to use this method from the function-oriented (non-OO)
4582				interface, the exported name for this method is B<save_parameters()>.
4583
4584				=head2 RETRIEVING CGI ERRORS
4585
4586				Errors can occur while processing user input, particularly when
4587				processing uploaded files. When these errors occur, CGI will stop
4588				processing and return an empty parameter list. You can test for
4589				the existence and nature of errors using the I<cgi_error()> function.
4590				The error messages are formatted as HTTP status codes. You can either
4591				incorporate the error text into an HTML page, or use it as the value
4592				of the HTTP status:
4593
4594				my $error = $q->cgi_error;
4595				if ($error) {
4596				print $q->header(-status=>$error),
4597				$q->start_html('Problems'),
4598				$q->h2('Request not processed'),
4599				$q->strong($error);
4600				exit 0;
4601				}
4602
4603				When using the function-oriented interface (see the next section),
4604				errors may only occur the first time you call I<param()>. Be ready
4605				for this!
4606
4607				=head2 USING THE FUNCTION-ORIENTED INTERFACE
4608
4609				To use the function-oriented interface, you must specify which CGI.pm
4610				routines or sets of routines to import into your script's namespace.
4611				There is a small overhead associated with this importation, but it
4612				isn't much.
4613
4614				use CGI <list of methods>;
4615
4616				The listed methods will be imported into the current package; you can
4617				call them directly without creating a CGI object first. This example
4618				shows how to import the B<param()> and B<header()>
4619				methods, and then use them directly:
4620
4621				use CGI 'param','header';
4622				print header('text/plain');
4623				$zipcode = param('zipcode');
4624
4625				More frequently, you'll import common sets of functions by referring
4626				to the groups by name. All function sets are preceded with a ":"
4627				character as in ":html3" (for tags defined in the HTML 3 standard).
4628
4629				Here is a list of the function sets you can import:
4630
4631				=over 4
4632
4633				=item B<:cgi>
4634
4635				Import all CGI-handling methods, such as B<param()>, B<path_info()>
4636				and the like.
4637
4638				=item B<:form>
4639
4640				Import all fill-out form generating methods, such as B<textfield()>.
4641
4642				=item B<:html2>
4643
4644				Import all methods that generate HTML 2.0 standard elements.
4645
4646				=item B<:html3>
4647
4648				Import all methods that generate HTML 3.0 elements (such as
4649				<table>, <super> and <sub>).
4650
4651				=item B<:html4>
4652
4653				Import all methods that generate HTML 4 elements (such as
4654				<abbrev>, <acronym> and <thead>).
4655
4656				=item B<:netscape>
4657
4658				Import all methods that generate Netscape-specific HTML extensions.
4659
4660				=item B<:html>
4661
4662				Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
4663				'netscape')...
4664
4665				=item B<:standard>
4666
4667				Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'.
4668
4669				=item B<:all>
4670
4671				Import all the available methods. For the full list, see the CGI.pm
4672				code, where the variable %EXPORT_TAGS is defined.
4673
4674				=back
4675
4676				If you import a function name that is not part of CGI.pm, the module
4677				will treat it as a new HTML tag and generate the appropriate
4678				subroutine. You can then use it like any other HTML tag. This is to
4679				provide for the rapidly-evolving HTML "standard." For example, say
4680				Microsoft comes out with a new tag called <gradient> (which causes the
4681				user's desktop to be flooded with a rotating gradient fill until his
4682				machine reboots). You don't need to wait for a new version of CGI.pm
4683				to start using it immediately:
4684
4685				use CGI qw/:standard :html3 gradient/;
4686				print gradient({-start=>'red',-end=>'blue'});
4687
4688				Note that in the interests of execution speed CGI.pm does B<not> use
4689				the standard L<Exporter> syntax for specifying load symbols. This may
4690				change in the future.
4691
4692				If you import any of the state-maintaining CGI or form-generating
4693				methods, a default CGI object will be created and initialized
4694				automatically the first time you use any of the methods that require
4695				one to be present. This includes B<param()>, B<textfield()>,
4696				B<submit()> and the like. (If you need direct access to the CGI
4697				object, you can find it in the global variable B<$CGI::Q>). By
4698				importing CGI.pm methods, you can create visually elegant scripts:
4699
4700				use CGI qw/:standard/;
4701				print
4702				header,
4703				start_html('Simple Script'),
4704				h1('Simple Script'),
4705				start_form,
4706				"What's your name? ",textfield('name'),p,
4707				"What's the combination?",
4708				checkbox_group(-name=>'words',
4709				-values=>['eenie','meenie','minie','moe'],
4710				-defaults=>['eenie','moe']),p,
4711				"What's your favorite color?",
4712				popup_menu(-name=>'color',
4713				-values=>['red','green','blue','chartreuse']),p,
4714				submit,
4715				end_form,
4716				hr,"\n";
4717
4718				if (param) {
4719				print
4720				"Your name is ",em(param('name')),p,
4721				"The keywords are: ",em(join(", ",param('words'))),p,
4722				"Your favorite color is ",em(param('color')),".\n";
4723				}
4724				print end_html;
4725
4726				=head2 PRAGMAS
4727
4728				In addition to the function sets, there are a number of pragmas that
4729				you can import. Pragmas, which are always preceded by a hyphen,
4730				change the way that CGI.pm functions in various ways. Pragmas,
4731				function sets, and individual functions can all be imported in the
4732				same use() line. For example, the following use statement imports the
4733				standard set of functions and enables debugging mode (pragma
4734				-debug):
4735
4736				use CGI qw/:standard -debug/;
4737
4738				The current list of pragmas is as follows:
4739
4740				=over 4
4741
4742				=item -any
4743
4744				When you I<use CGI -any>, then any method that the query object
4745				doesn't recognize will be interpreted as a new HTML tag. This allows
4746				you to support the next I<ad hoc> Netscape or Microsoft HTML
4747				extension. This lets you go wild with new and unsupported tags:
4748
4749				use CGI qw(-any);
4750				$q=new CGI;
4751				print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
4752
4753				Since using <cite>any</cite> causes any mistyped method name
4754				to be interpreted as an HTML tag, use it with care or not at
4755				all.
4756
4757				=item -compile
4758
4759				This causes the indicated autoloaded methods to be compiled up front,
4760				rather than deferred to later. This is useful for scripts that run
4761				for an extended period of time under FastCGI or mod_perl, and for
4762				those destined to be crunched by Malcolm Beattie's Perl compiler. Use
4763				it in conjunction with the methods or method families you plan to use.
4764
4765				use CGI qw(-compile :standard :html3);
4766
4767				or even
4768
4769				use CGI qw(-compile :all);
4770
4771				Note that using the -compile pragma in this way will always have
4772				the effect of importing the compiled functions into the current
4773				namespace. If you want to compile without importing use the
4774				compile() method instead:
4775
4776				use CGI();
4777				CGI->compile();
4778
4779				This is particularly useful in a mod_perl environment, in which you
4780				might want to precompile all CGI routines in a startup script, and
4781				then import the functions individually in each mod_perl script.
4782
4783				=item -nosticky
4784
4785				By default the CGI module implements a state-preserving behavior
4786				called "sticky" fields. The way this works is that if you are
4787				regenerating a form, the methods that generate the form field values
4788				will interrogate param() to see if similarly-named parameters are
4789				present in the query string. If they find a like-named parameter, they
4790				will use it to set their default values.
4791
4792				Sometimes this isn't what you want. The B<-nosticky> pragma prevents
4793				this behavior. You can also selectively change the sticky behavior in
4794				each element that you generate.
4795
4796				=item -tabindex
4797
4798				Automatically add tab index attributes to each form field. With this
4799				option turned off, you can still add tab indexes manually by passing a
4800				-tabindex option to each field-generating method.
4801
4802				=item -no_undef_params
4803
4804				This keeps CGI.pm from including undef params in the parameter list.
4805
4806				=item -no_xhtml
4807
4808				By default, CGI.pm versions 2.69 and higher emit XHTML
4809				(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this
4810				feature. Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this
4811				feature.
4812
4813				If start_html()'s -dtd parameter specifies an HTML 2.0 or 3.2 DTD,
4814				XHTML will automatically be disabled without needing to use this
4815				pragma.
4816
4817				=item -nph
4818
4819				This makes CGI.pm produce a header appropriate for an NPH (no
4820				parsed header) script. You may need to do other things as well
4821				to tell the server that the script is NPH. See the discussion
4822				of NPH scripts below.
4823
4824				=item -newstyle_urls
4825
4826				Separate the name=value pairs in CGI parameter query strings with
4827				semicolons rather than ampersands. For example:
4828
4829				?name=fred;age=24;favorite_color=3
4830
4831				Semicolon-delimited query strings are always accepted, but will not be
4832				emitted by self_url() and query_string() unless the -newstyle_urls
4833				pragma is specified.
4834
4835				This became the default in version 2.64.
4836
4837				=item -oldstyle_urls
4838
4839				Separate the name=value pairs in CGI parameter query strings with
4840				ampersands rather than semicolons. This is no longer the default.
4841
4842				=item -autoload
4843
4844				This overrides the autoloader so that any function in your program
4845				that is not recognized is referred to CGI.pm for possible evaluation.
4846				This allows you to use all the CGI.pm functions without adding them to
4847				your symbol table, which is of concern for mod_perl users who are
4848				worried about memory consumption. I<Warning:> when
4849				I<-autoload> is in effect, you cannot use "poetry mode"
4850				(functions without the parenthesis). Use I<hr()> rather
4851				than I<hr>, or add something like I<use subs qw/hr p header/>
4852				to the top of your script.
4853
4854				=item -no_debug
4855
4856				This turns off the command-line processing features. If you want to
4857				run a CGI.pm script from the command line to produce HTML, and you
4858				don't want it to read CGI parameters from the command line or STDIN,
4859				then use this pragma:
4860
4861				use CGI qw(-no_debug :standard);
4862
4863				=item -debug
4864
4865				This turns on full debugging. In addition to reading CGI arguments
4866				from the command-line processing, CGI.pm will pause and try to read
4867				arguments from STDIN, producing the message "(offline mode: enter
4868				name=value pairs on standard input)" features.
4869
4870				See the section on debugging for more details.
4871
4872				=item -private_tempfiles
4873
4874				CGI.pm can process uploaded file. Ordinarily it spools the uploaded
4875				file to a temporary directory, then deletes the file when done.
4876				However, this opens the risk of eavesdropping as described in the file
4877				upload section. Another CGI script author could peek at this data
4878				during the upload, even if it is confidential information. On Unix
4879				systems, the -private_tempfiles pragma will cause the temporary file
4880				to be unlinked as soon as it is opened and before any data is written
4881				into it, reducing, but not eliminating the risk of eavesdropping
4882				(there is still a potential race condition). To make life harder for
4883				the attacker, the program chooses tempfile names by calculating a 32
4884				bit checksum of the incoming HTTP headers.
4885
4886				To ensure that the temporary file cannot be read by other CGI scripts,
4887				use suEXEC or a CGI wrapper program to run your script. The temporary
4888				file is created with mode 0600 (neither world nor group readable).
4889
4890				The temporary directory is selected using the following algorithm:
4891
4892				1. if the current user (e.g. "nobody") has a directory named
4893				"tmp" in its home directory, use that (Unix systems only).
4894
4895				2. if the environment variable TMPDIR exists, use the location
4896				indicated.
4897
4898				3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp,
4899				/tmp, /temp, ::Temporary Items, and \WWW_ROOT.
4900
4901				Each of these locations is checked that it is a directory and is
4902				writable. If not, the algorithm tries the next choice.
4903
4904				=back
4905
4906				=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS
4907
4908				Many of the methods generate HTML tags. As described below, tag
4909				functions automatically generate both the opening and closing tags.
4910				For example:
4911
4912				print h1('Level 1 Header');
4913
4914				produces
4915
4916				<h1>Level 1 Header</h1>
4917
4918				There will be some times when you want to produce the start and end
4919				tags yourself. In this case, you can use the form start_I<tag_name>
4920				and end_I<tag_name>, as in:
4921
4922				print start_h1,'Level 1 Header',end_h1;
4923
4924				With a few exceptions (described below), start_I<tag_name> and
4925				end_I<tag_name> functions are not generated automatically when you
4926				I<use CGI>. However, you can specify the tags you want to generate
4927				I<start/end> functions for by putting an asterisk in front of their
4928				name, or, alternatively, requesting either "start_I<tag_name>" or
4929				"end_I<tag_name>" in the import list.
4930
4931				Example:
4932
4933				use CGI qw/:standard *table start_ul/;
4934
4935				In this example, the following functions are generated in addition to
4936				the standard ones:
4937
4938				=over 4
4939
4940				=item 1. start_table() (generates a <table> tag)
4941
4942				=item 2. end_table() (generates a </table> tag)
4943
4944				=item 3. start_ul() (generates a <ul> tag)
4945
4946				=item 4. end_ul() (generates a </ul> tag)
4947
4948				=back
4949
4950				=head1 GENERATING DYNAMIC DOCUMENTS
4951
4952				Most of CGI.pm's functions deal with creating documents on the fly.
4953				Generally you will produce the HTTP header first, followed by the
4954				document itself. CGI.pm provides functions for generating HTTP
4955				headers of various types as well as for generating HTML. For creating
4956				GIF images, see the GD.pm module.
4957
4958				Each of these functions produces a fragment of HTML or HTTP which you
4959				can print out directly so that it displays in the browser window,
4960				append to a string, or save to a file for later use.
4961
4962				=head2 CREATING A STANDARD HTTP HEADER:
4963
4964				Normally the first thing you will do in any CGI script is print out an
4965				HTTP header. This tells the browser what type of document to expect,
4966				and gives other optional information, such as the language, expiration
4967				date, and whether to cache the document. The header can also be
4968				manipulated for special purposes, such as server push and pay per view
4969				pages.
4970
4971				print header;
4972
4973				-or-
4974
4975				print header('image/gif');
4976
4977				-or-
4978
4979				print header('text/html','204 No response');
4980
4981				-or-
4982
4983				print header(-type=>'image/gif',
4984				-nph=>1,
4985				-status=>'402 Payment required',
4986				-expires=>'+3d',
4987				-cookie=>$cookie,
4988				-charset=>'utf-7',
4989				-attachment=>'foo.gif',
4990				-Cost=>'$2.00');
4991
4992				header() returns the Content-type: header. You can provide your own
4993				MIME type if you choose, otherwise it defaults to text/html. An
4994				optional second parameter specifies the status code and a human-readable
4995				message. For example, you can specify 204, "No response" to create a
4996				script that tells the browser to do nothing at all.
4997
4998				The last example shows the named argument style for passing arguments
4999				to the CGI methods using named parameters. Recognized parameters are
5000				B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named
5001				parameters will be stripped of their initial hyphens and turned into
5002				header fields, allowing you to specify any HTTP header you desire.
5003				Internal underscores will be turned into hyphens:
5004
5005				print header(-Content_length=>3002);
5006
5007				Most browsers will not cache the output from CGI scripts. Every time
5008				the browser reloads the page, the script is invoked anew. You can
5009				change this behavior with the B<-expires> parameter. When you specify
5010				an absolute or relative expiration interval with this parameter, some
5011				browsers and proxy servers will cache the script's output until the
5012				indicated expiration date. The following forms are all valid for the
5013				-expires field:
5014
5015				+30s 30 seconds from now
5016				+10m ten minutes from now
5017				+1h one hour from now
5018				-1d yesterday (i.e. "ASAP!")
5019				now immediately
5020				+3M in three months
5021				+10y in ten years time
5022				Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date
5023
5024				The B<-cookie> parameter generates a header that tells the browser to provide
5025				a "magic cookie" during all subsequent transactions with your script.
5026				Netscape cookies have a special format that includes interesting attributes
5027				such as expiration time. Use the cookie() method to create and retrieve
5028				session cookies.
5029
5030				The B<-nph> parameter, if set to a true value, will issue the correct
5031				headers to work with a NPH (no-parse-header) script. This is important
5032				to use with certain servers that expect all their scripts to be NPH.
5033
5034				The B<-charset> parameter can be used to control the character set
5035				sent to the browser. If not provided, defaults to ISO-8859-1. As a
5036				side effect, this sets the charset() method as well.
5037
5038				The B<-attachment> parameter can be used to turn the page into an
5039				attachment. Instead of displaying the page, some browsers will prompt
5040				the user to save it to disk. The value of the argument is the
5041				suggested name for the saved file. In order for this to work, you may
5042				have to set the B<-type> to "application/octet-stream".
5043
5044				The B<-p3p> parameter will add a P3P tag to the outgoing header. The
5045				parameter can be an arrayref or a space-delimited string of P3P tags.
5046				For example:
5047
5048				print header(-p3p=>[qw(CAO DSP LAW CURa)]);
5049				print header(-p3p=>'CAO DSP LAW CURa');
5050
5051				In either case, the outgoing header will be formatted as:
5052
5053				P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"
5054
5055				=head2 GENERATING A REDIRECTION HEADER
5056
5057				print redirect('http://somewhere.else/in/movie/land');
5058
5059				Sometimes you don't want to produce a document yourself, but simply
5060				redirect the browser elsewhere, perhaps choosing a URL based on the
5061				time of day or the identity of the user.
5062
5063				The redirect() function redirects the browser to a different URL. If
5064				you use redirection like this, you should B<not> print out a header as
5065				well.
5066
5067				You should always use full URLs (including the http: or ftp: part) in
5068				redirection requests. Relative URLs will not work correctly.
5069
5070				You can also use named arguments:
5071
5072				print redirect(-uri=>'http://somewhere.else/in/movie/land',
5073				-nph=>1,
5074				-status=>301);
5075
5076				The B<-nph> parameter, if set to a true value, will issue the correct
5077				headers to work with a NPH (no-parse-header) script. This is important
5078				to use with certain servers, such as Microsoft IIS, which
5079				expect all their scripts to be NPH.
5080
5081				The B<-status> parameter will set the status of the redirect. HTTP
5082				defines three different possible redirection status codes:
5083
5084				301 Moved Permanently
5085				302 Found
5086				303 See Other
5087
5088				The default if not specified is 302, which means "moved temporarily."
5089				You may change the status to another status code if you wish. Be
5090				advised that changing the status to anything other than 301, 302 or
5091				303 will probably break redirection.
5092
5093				=head2 CREATING THE HTML DOCUMENT HEADER
5094
5095				print start_html(-title=>'Secrets of the Pyramids',
5096				-author=>'fred@capricorn.org',
5097				-base=>'true',
5098				-target=>'_blank',
5099				-meta=>{'keywords'=>'pharaoh secret mummy',
5100				'copyright'=>'copyright 1996 King Tut'},
5101				-style=>{'src'=>'/styles/style1.css'},
5102				-BGCOLOR=>'blue');
5103
5104				After creating the HTTP header, most CGI scripts will start writing
5105				out an HTML document. The start_html() routine creates the top of the
5106				page, along with a lot of optional information that controls the
5107				page's appearance and behavior.
5108
5109				This method returns a canned HTML header and the opening <body> tag.
5110				All parameters are optional. In the named parameter form, recognized
5111				parameters are -title, -author, -base, -xbase, -dtd, -lang and -target
5112				(see below for the explanation). Any additional parameters you
5113				provide, such as the Netscape unofficial BGCOLOR attribute, are added
5114				to the <body> tag. Additional parameters must be proceeded by a
5115				hyphen.
5116
5117				The argument B<-xbase> allows you to provide an HREF for the <base> tag
5118				different from the current location, as in
5119
5120				-xbase=>"http://home.mcom.com/"
5121
5122				All relative links will be interpreted relative to this tag.
5123
5124				The argument B<-target> allows you to provide a default target frame
5125				for all the links and fill-out forms on the page. B<This is a
5126				non-standard HTTP feature which only works with Netscape browsers!>
5127				See the Netscape documentation on frames for details of how to
5128				manipulate this.
5129
5130				-target=>"answer_window"
5131
5132				All relative links will be interpreted relative to this tag.
5133				You add arbitrary meta information to the header with the B<-meta>
5134				argument. This argument expects a reference to an associative array
5135				containing name/value pairs of meta information. These will be turned
5136				into a series of header <meta> tags that look something like this:
5137
5138				<meta name="keywords" content="pharaoh secret mummy">
5139				<meta name="description" content="copyright 1996 King Tut">
5140
5141				To create an HTTP-EQUIV type of <meta> tag, use B<-head>, described
5142				below.
5143
5144				The B<-style> argument is used to incorporate cascading stylesheets
5145				into your code. See the section on CASCADING STYLESHEETS for more
5146				information.
5147
5148				The B<-lang> argument is used to incorporate a language attribute into
5149				the <html> tag. For example:
5150
5151				print $q->start_html(-lang=>'fr-CA');
5152
5153				The default if not specified is "en-US" for US English, unless the
5154				-dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the
5155				lang attribute is left off. You can force the lang attribute to left
5156				off in other cases by passing an empty string (-lang=>'').
5157
5158				The B<-encoding> argument can be used to specify the character set for
5159				XHTML. It defaults to iso-8859-1 if not specified.
5160
5161				The B<-declare_xml> argument, when used in conjunction with XHTML,
5162				will put a <?xml> declaration at the top of the HTML header. The sole
5163				purpose of this declaration is to declare the character set
5164				encoding. In the absence of -declare_xml, the output HTML will contain
5165				a <meta> tag that specifies the encoding, allowing the HTML to pass
5166				most validators. The default for -declare_xml is false.
5167
5168				You can place other arbitrary HTML elements to the <head> section with the
5169				B<-head> tag. For example, to place the rarely-used <link> element in the
5170				head section, use this:
5171
5172				print start_html(-head=>Link({-rel=>'next',
5173				-href=>'http://www.capricorn.com/s2.html'}));
5174
5175				To incorporate multiple HTML elements into the <head> section, just pass an
5176				array reference:
5177
5178				print start_html(-head=>[
5179				Link({-rel=>'next',
5180				-href=>'http://www.capricorn.com/s2.html'}),
5181				Link({-rel=>'previous',
5182				-href=>'http://www.capricorn.com/s1.html'})
5183				]
5184				);
5185
5186				And here's how to create an HTTP-EQUIV <meta> tag:
5187
5188				print start_html(-head=>meta({-http_equiv => 'Content-Type',
5189				-content => 'text/html'}))
5190
5191
5192				JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
5193				B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
5194				to add Netscape JavaScript calls to your pages. B<-script> should
5195				point to a block of text containing JavaScript function definitions.
5196				This block will be placed within a <script> block inside the HTML (not
5197				HTTP) header. The block is placed in the header in order to give your
5198				page a fighting chance of having all its JavaScript functions in place
5199				even if the user presses the stop button before the page has loaded
5200				completely. CGI.pm attempts to format the script in such a way that
5201				JavaScript-naive browsers will not choke on the code: unfortunately
5202				there are some browsers, such as Chimera for Unix, that get confused
5203				by it nevertheless.
5204
5205				The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
5206				code to execute when the page is respectively opened and closed by the
5207				browser. Usually these parameters are calls to functions defined in the
5208				B<-script> field:
5209
5210				$query = new CGI;
5211				print header;
5212				$JSCRIPT=<<END;
5213				// Ask a silly question
5214				function riddle_me_this() {
5215				var r = prompt("What walks on four legs in the morning, " +
5216				"two legs in the afternoon, " +
5217				"and three legs in the evening?");
5218				response(r);
5219				}
5220				// Get a silly answer
5221				function response(answer) {
5222				if (answer == "man")
5223				alert("Right you are!");
5224				else
5225				alert("Wrong! Guess again.");
5226				}
5227				END
5228				print start_html(-title=>'The Riddle of the Sphinx',
5229				-script=>$JSCRIPT);
5230
5231				Use the B<-noScript> parameter to pass some HTML text that will be displayed on
5232				browsers that do not have JavaScript (or browsers where JavaScript is turned
5233				off).
5234
5235				The <script> tag, has several attributes including "type" and src.
5236				The latter is particularly interesting, as it allows you to keep the
5237				JavaScript code in a file or CGI script rather than cluttering up each
5238				page with the source. To use these attributes pass a HASH reference
5239				in the B<-script> parameter containing one or more of -type, -src, or
5240				-code:
5241
5242				print $q->start_html(-title=>'The Riddle of the Sphinx',
5243				-script=>{-type=>'JAVASCRIPT',
5244				-src=>'/javascript/sphinx.js'}
5245				);
5246
5247				print $q->(-title=>'The Riddle of the Sphinx',
5248				-script=>{-type=>'PERLSCRIPT',
5249				-code=>'print "hello world!\n;"'}
5250				);
5251
5252
5253				A final feature allows you to incorporate multiple <script> sections into the
5254				header. Just pass the list of script sections as an array reference.
5255				this allows you to specify different source files for different dialects
5256				of JavaScript. Example:
5257
5258				print $q->start_html(-title=>'The Riddle of the Sphinx',
5259				-script=>[
5260				{ -type => 'text/javascript',
5261				-src => '/javascript/utilities10.js'
5262				},
5263				{ -type => 'text/javascript',
5264				-src => '/javascript/utilities11.js'
5265				},
5266				{ -type => 'text/jscript',
5267				-src => '/javascript/utilities12.js'
5268				},
5269				{ -type => 'text/ecmascript',
5270				-src => '/javascript/utilities219.js'
5271				}
5272				]
5273				);
5274
5275				The option "-language" is a synonym for -type, and is supported for
5276				backwad compatibility.
5277
5278				The old-style positional parameters are as follows:
5279
5280				=over 4
5281
5282				=item B<Parameters:>
5283
5284				=item 1.
5285
5286				The title
5287
5288				=item 2.
5289
5290				The author's e-mail address (will create a <link rev="MADE"> tag if present
5291
5292				=item 3.
5293
5294				A 'true' flag if you want to include a <base> tag in the header. This
5295				helps resolve relative addresses to absolute ones when the document is moved,
5296				but makes the document hierarchy non-portable. Use with care!
5297
5298				=item 4, 5, 6...
5299
5300				Any other parameters you want to include in the <body> tag. This is a good
5301				place to put Netscape extensions, such as colors and wallpaper patterns.
5302
5303				=back
5304
5305				=head2 ENDING THE HTML DOCUMENT:
5306
5307				print end_html
5308
5309				This ends an HTML document by printing the </body></html> tags.
5310
5311				=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
5312
5313				$myself = self_url;
5314				print q(<a href="$myself">I'm talking to myself.</a>);
5315
5316				self_url() will return a URL, that, when selected, will reinvoke
5317				this script with all its state information intact. This is most
5318				useful when you want to jump around within the document using
5319				internal anchors but you don't want to disrupt the current contents
5320				of the form(s). Something like this will do the trick.
5321
5322				$myself = self_url;
5323				print "<a href=\"$myself#table1\">See table 1</a>";
5324				print "<a href=\"$myself#table2\">See table 2</a>";
5325				print "<a href=\"$myself#yourself\">See for yourself</a>";
5326
5327				If you want more control over what's returned, using the B<url()>
5328				method instead.
5329
5330				You can also retrieve the unprocessed query string with query_string():
5331
5332				$the_string = query_string;
5333
5334				=head2 OBTAINING THE SCRIPT'S URL
5335
5336				$full_url = url();
5337				$full_url = url(-full=>1); #alternative syntax
5338				$relative_url = url(-relative=>1);
5339				$absolute_url = url(-absolute=>1);
5340				$url_with_path = url(-path_info=>1);
5341				$url_with_path_and_query = url(-path_info=>1,-query=>1);
5342				$netloc = url(-base => 1);
5343
5344				B<url()> returns the script's URL in a variety of formats. Called
5345				without any arguments, it returns the full form of the URL, including
5346				host name and port number
5347
5348				http://your.host.com/path/to/script.cgi
5349
5350				You can modify this format with the following named arguments:
5351
5352				=over 4
5353
5354				=item B<-absolute>
5355
5356				If true, produce an absolute URL, e.g.
5357
5358				/path/to/script.cgi
5359
5360				=item B<-relative>
5361
5362				Produce a relative URL. This is useful if you want to reinvoke your
5363				script with different parameters. For example:
5364
5365				script.cgi
5366
5367				=item B<-full>
5368
5369				Produce the full URL, exactly as if called without any arguments.
5370				This overrides the -relative and -absolute arguments.
5371
5372				=item B<-path> (B<-path_info>)
5373
5374				Append the additional path information to the URL. This can be
5375				combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info>
5376				is provided as a synonym.
5377
5378				=item B<-query> (B<-query_string>)
5379
5380				Append the query string to the URL. This can be combined with
5381				B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
5382				as a synonym.
5383
5384				=item B<-base>
5385
5386				Generate just the protocol and net location, as in http://www.foo.com:8000
5387
5388				=item B<-rewrite>
5389
5390				If Apache's mod_rewrite is turned on, then the script name and path
5391				info probably won't match the request that the user sent. Set
5392				-rewrite=>1 (default) to return URLs that match what the user sent
5393				(the original request URI). Set -rewrite=>0 to return URLs that match
5394				the URL after mod_rewrite's rules have run. Because the additional
5395				path information only makes sense in the context of the rewritten URL,
5396				-rewrite is set to false when you request path info in the URL.
5397
5398				=back
5399
5400				=head2 MIXING POST AND URL PARAMETERS
5401
5402				$color = url_param('color');
5403
5404				It is possible for a script to receive CGI parameters in the URL as
5405				well as in the fill-out form by creating a form that POSTs to a URL
5406				containing a query string (a "?" mark followed by arguments). The
5407				B<param()> method will always return the contents of the POSTed
5408				fill-out form, ignoring the URL's query string. To retrieve URL
5409				parameters, call the B<url_param()> method. Use it in the same way as
5410				B<param()>. The main difference is that it allows you to read the
5411				parameters, but not set them.
5412
5413
5414				Under no circumstances will the contents of the URL query string
5415				interfere with similarly-named CGI parameters in POSTed forms. If you
5416				try to mix a URL query string with a form submitted with the GET
5417				method, the results will not be what you expect.
5418
5419				=head1 CREATING STANDARD HTML ELEMENTS:
5420
5421				CGI.pm defines general HTML shortcut methods for most, if not all of
5422				the HTML 3 and HTML 4 tags. HTML shortcuts are named after a single
5423				HTML element and return a fragment of HTML text that you can then
5424				print or manipulate as you like. Each shortcut returns a fragment of
5425				HTML code that you can append to a string, save to a file, or, most
5426				commonly, print out so that it displays in the browser window.
5427
5428				This example shows how to use the HTML methods:
5429
5430				print $q->blockquote(
5431				"Many years ago on the island of",
5432				$q->a({href=>"http://crete.org/"},"Crete"),
5433				"there lived a Minotaur named",
5434				$q->strong("Fred."),
5435				),
5436				$q->hr;
5437
5438				This results in the following HTML code (extra newlines have been
5439				added for readability):
5440
5441				<blockquote>
5442				Many years ago on the island of
5443				<a href="http://crete.org/">Crete</a> there lived
5444				a minotaur named <strong>Fred.</strong>
5445				</blockquote>
5446				<hr>
5447
5448				If you find the syntax for calling the HTML shortcuts awkward, you can
5449				import them into your namespace and dispense with the object syntax
5450				completely (see the next section for more details):
5451
5452				use CGI ':standard';
5453				print blockquote(
5454				"Many years ago on the island of",
5455				a({href=>"http://crete.org/"},"Crete"),
5456				"there lived a minotaur named",
5457				strong("Fred."),
5458				),
5459				hr;
5460
5461				=head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
5462
5463				The HTML methods will accept zero, one or multiple arguments. If you
5464				provide no arguments, you get a single tag:
5465
5466				print hr; # <hr>
5467
5468				If you provide one or more string arguments, they are concatenated
5469				together with spaces and placed between opening and closing tags:
5470
5471				print h1("Chapter","1"); # <h1>Chapter 1</h1>"
5472
5473				If the first argument is an associative array reference, then the keys
5474				and values of the associative array become the HTML tag's attributes:
5475
5476				print a({-href=>'fred.html',-target=>'_new'},
5477				"Open a new frame");
5478
5479				<a href="fred.html",target="_new">Open a new frame</a>
5480
5481				You may dispense with the dashes in front of the attribute names if
5482				you prefer:
5483
5484				print img {src=>'fred.gif',align=>'LEFT'};
5485
5486				<img align="LEFT" src="fred.gif">
5487
5488				Sometimes an HTML tag attribute has no argument. For example, ordered
5489				lists can be marked as COMPACT. The syntax for this is an argument that
5490				that points to an undef string:
5491
5492				print ol({compact=>undef},li('one'),li('two'),li('three'));
5493
5494				Prior to CGI.pm version 2.41, providing an empty ('') string as an
5495				attribute argument was the same as providing undef. However, this has
5496				changed in order to accommodate those who want to create tags of the form
5497				<img alt="">. The difference is shown in these two pieces of code:
5498
5499				CODE RESULT
5500				img({alt=>undef}) <img alt>
5501				img({alt=>''}) <img alt="">
5502
5503				=head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
5504
5505				One of the cool features of the HTML shortcuts is that they are
5506				distributive. If you give them an argument consisting of a
5507				B<reference> to a list, the tag will be distributed across each
5508				element of the list. For example, here's one way to make an ordered
5509				list:
5510
5511				print ul(
5512				li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy'])
5513				);
5514
5515				This example will result in HTML output that looks like this:
5516
5517				<ul>
5518				<li type="disc">Sneezy</li>
5519				<li type="disc">Doc</li>
5520				<li type="disc">Sleepy</li>
5521				<li type="disc">Happy</li>
5522				</ul>
5523
5524				This is extremely useful for creating tables. For example:
5525
5526				print table({-border=>undef},
5527				caption('When Should You Eat Your Vegetables?'),
5528				Tr({-align=>CENTER,-valign=>TOP},
5529				[
5530				th(['Vegetable', 'Breakfast','Lunch','Dinner']),
5531				td(['Tomatoes' , 'no', 'yes', 'yes']),
5532				td(['Broccoli' , 'no', 'no', 'yes']),
5533				td(['Onions' , 'yes','yes', 'yes'])
5534				]
5535				)
5536				);
5537
5538				=head2 HTML SHORTCUTS AND LIST INTERPOLATION
5539
5540				Consider this bit of code:
5541
5542				print blockquote(em('Hi'),'mom!'));
5543
5544				It will ordinarily return the string that you probably expect, namely:
5545
5546				<blockquote><em>Hi</em> mom!</blockquote>
5547
5548				Note the space between the element "Hi" and the element "mom!".
5549				CGI.pm puts the extra space there using array interpolation, which is
5550				controlled by the magic $" variable. Sometimes this extra space is
5551				not what you want, for example, when you are trying to align a series
5552				of images. In this case, you can simply change the value of $" to an
5553				empty string.
5554
5555				{
5556				local($") = '';
5557				print blockquote(em('Hi'),'mom!'));
5558				}
5559
5560				I suggest you put the code in a block as shown here. Otherwise the
5561				change to $" will affect all subsequent code until you explicitly
5562				reset it.
5563
5564				=head2 NON-STANDARD HTML SHORTCUTS
5565
5566				A few HTML tags don't follow the standard pattern for various
5567				reasons.
5568
5569				B<comment()> generates an HTML comment (<!-- comment -->). Call it
5570				like
5571
5572				print comment('here is my comment');
5573
5574				Because of conflicts with built-in Perl functions, the following functions
5575				begin with initial caps:
5576
5577				Select
5578				Tr
5579				Link
5580				Delete
5581				Accept
5582				Sub
5583
5584				In addition, start_html(), end_html(), start_form(), end_form(),
5585				start_multipart_form() and all the fill-out form tags are special.
5586				See their respective sections.
5587
5588				=head2 AUTOESCAPING HTML
5589
5590				By default, all HTML that is emitted by the form-generating functions
5591				is passed through a function called escapeHTML():
5592
5593				=over 4
5594
5595				=item $escaped_string = escapeHTML("unescaped string");
5596
5597				Escape HTML formatting characters in a string.
5598
5599				=back
5600
5601				Provided that you have specified a character set of ISO-8859-1 (the
5602				default), the standard HTML escaping rules will be used. The "<"
5603				character becomes "<", ">" becomes ">", "&" becomes "&", and
5604				the quote character becomes """. In addition, the hexadecimal
5605				0x8b and 0x9b characters, which some browsers incorrectly interpret
5606				as the left and right angle-bracket characters, are replaced by their
5607				numeric character entities ("&#8249" and "›"). If you manually change
5608				the charset, either by calling the charset() method explicitly or by
5609				passing a -charset argument to header(), then B<all> characters will
5610				be replaced by their numeric entities, since CGI.pm has no lookup
5611				table for all the possible encodings.
5612
5613				The automatic escaping does not apply to other shortcuts, such as
5614				h1(). You should call escapeHTML() yourself on untrusted data in
5615				order to protect your pages against nasty tricks that people may enter
5616				into guestbooks, etc.. To change the character set, use charset().
5617				To turn autoescaping off completely, use autoEscape(0):
5618
5619				=over 4
5620
5621				=item $charset = charset([$charset]);
5622
5623				Get or set the current character set.
5624
5625				=item $flag = autoEscape([$flag]);
5626
5627				Get or set the value of the autoescape flag.
5628
5629				=back
5630
5631				=head2 PRETTY-PRINTING HTML
5632
5633				By default, all the HTML produced by these functions comes out as one
5634				long line without carriage returns or indentation. This is yuck, but
5635				it does reduce the size of the documents by 10-20%. To get
5636				pretty-printed output, please use L<CGI::Pretty>, a subclass
5637				contributed by Brian Paulsen.
5638
5639				=head1 CREATING FILL-OUT FORMS:
5640
5641				I<General note> The various form-creating methods all return strings
5642				to the caller, containing the tag or tags that will create the requested
5643				form element. You are responsible for actually printing out these strings.
5644				It's set up this way so that you can place formatting tags
5645				around the form elements.
5646
5647				I<Another note> The default values that you specify for the forms are only
5648				used the B<first> time the script is invoked (when there is no query
5649				string). On subsequent invocations of the script (when there is a query
5650				string), the former values are used even if they are blank.
5651
5652				If you want to change the value of a field from its previous value, you have two
5653				choices:
5654
5655				(1) call the param() method to set it.
5656
5657				(2) use the -override (alias -force) parameter (a new feature in version 2.15).
5658				This forces the default value to be used, regardless of the previous value:
5659
5660				print textfield(-name=>'field_name',
5661				-default=>'starting value',
5662				-override=>1,
5663				-size=>50,
5664				-maxlength=>80);
5665
5666				I<Yet another note> By default, the text and labels of form elements are
5667				escaped according to HTML rules. This means that you can safely use
5668				"<CLICK ME>" as the label for a button. However, it also interferes with
5669				your ability to incorporate special HTML character sequences, such as Á,
5670				into your fields. If you wish to turn off automatic escaping, call the
5671				autoEscape() method with a false value immediately after creating the CGI object:
5672
5673				$query = new CGI;
5674				autoEscape(undef);
5675
5676				I<A Lurking Trap!> Some of the form-element generating methods return
5677				multiple tags. In a scalar context, the tags will be concatenated
5678				together with spaces, or whatever is the current value of the $"
5679				global. In a list context, the methods will return a list of
5680				elements, allowing you to modify them if you wish. Usually you will
5681				not notice this behavior, but beware of this:
5682
5683				printf("%s\n",end_form())
5684
5685				end_form() produces several tags, and only the first of them will be
5686				printed because the format only expects one value.
5687
5688				<p>
5689
5690
5691				=head2 CREATING AN ISINDEX TAG
5692
5693				print isindex(-action=>$action);
5694
5695				-or-
5696
5697				print isindex($action);
5698
5699				Prints out an <isindex> tag. Not very exciting. The parameter
5700				-action specifies the URL of the script to process the query. The
5701				default is to process the query with the current script.
5702
5703				=head2 STARTING AND ENDING A FORM
5704
5705				print start_form(-method=>$method,
5706				-action=>$action,
5707				-enctype=>$encoding);
5708				<... various form stuff ...>
5709				print endform;
5710
5711				-or-
5712
5713				print start_form($method,$action,$encoding);
5714				<... various form stuff ...>
5715				print endform;
5716
5717				start_form() will return a <form> tag with the optional method,
5718				action and form encoding that you specify. The defaults are:
5719
5720				method: POST
5721				action: this script
5722				enctype: application/x-www-form-urlencoded
5723
5724				endform() returns the closing </form> tag.
5725
5726				Start_form()'s enctype argument tells the browser how to package the various
5727				fields of the form before sending the form to the server. Two
5728				values are possible:
5729
5730				B<Note:> This method was previously named startform(), and startform()
5731				is still recognized as an alias.
5732
5733				=over 4
5734
5735				=item B<application/x-www-form-urlencoded>
5736
5737				This is the older type of encoding used by all browsers prior to
5738				Netscape 2.0. It is compatible with many CGI scripts and is
5739				suitable for short fields containing text data. For your
5740				convenience, CGI.pm stores the name of this encoding
5741				type in B<&CGI::URL_ENCODED>.
5742
5743				=item B<multipart/form-data>
5744
5745				This is the newer type of encoding introduced by Netscape 2.0.
5746				It is suitable for forms that contain very large fields or that
5747				are intended for transferring binary data. Most importantly,
5748				it enables the "file upload" feature of Netscape 2.0 forms. For
5749				your convenience, CGI.pm stores the name of this encoding type
5750				in B<&CGI::MULTIPART>
5751
5752				Forms that use this type of encoding are not easily interpreted
5753				by CGI scripts unless they use CGI.pm or another library designed
5754				to handle them.
5755
5756				If XHTML is activated (the default), then forms will be automatically
5757				created using this type of encoding.
5758
5759				=back
5760
5761				For compatibility, the start_form() method uses the older form of
5762				encoding by default. If you want to use the newer form of encoding
5763				by default, you can call B<start_multipart_form()> instead of
5764				B<start_form()>.
5765
5766				JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
5767				for use with JavaScript. The -name parameter gives the
5768				form a name so that it can be identified and manipulated by
5769				JavaScript functions. -onSubmit should point to a JavaScript
5770				function that will be executed just before the form is submitted to your
5771				server. You can use this opportunity to check the contents of the form
5772				for consistency and completeness. If you find something wrong, you
5773				can put up an alert box or maybe fix things up yourself. You can
5774				abort the submission by returning false from this function.
5775
5776				Usually the bulk of JavaScript functions are defined in a <script>
5777				block in the HTML header and -onSubmit points to one of these function
5778				call. See start_html() for details.
5779
5780				=head2 FORM ELEMENTS
5781
5782				After starting a form, you will typically create one or more
5783				textfields, popup menus, radio groups and other form elements. Each
5784				of these elements takes a standard set of named arguments. Some
5785				elements also have optional arguments. The standard arguments are as
5786				follows:
5787
5788				=over 4
5789
5790				=item B<-name>
5791
5792				The name of the field. After submission this name can be used to
5793				retrieve the field's value using the param() method.
5794
5795				=item B<-value>, B<-values>
5796
5797				The initial value of the field which will be returned to the script
5798				after form submission. Some form elements, such as text fields, take
5799				a single scalar -value argument. Others, such as popup menus, take a
5800				reference to an array of values. The two arguments are synonyms.
5801
5802				=item B<-tabindex>
5803
5804				A numeric value that sets the order in which the form element receives
5805				focus when the user presses the tab key. Elements with lower values
5806				receive focus first.
5807
5808				=item B<-id>
5809
5810				A string identifier that can be used to identify this element to
5811				JavaScript and DHTML.
5812
5813				=item B<-override>
5814
5815				A boolean, which, if true, forces the element to take on the value
5816				specified by B<-value>, overriding the sticky behavior described
5817				earlier for the B<-no_sticky> pragma.
5818
5819				=item B<-onChange>, B<-onFocus>, B<-onBlur>, B<-onMouseOver>, B<-onMouseOut>, B<-onSelect>
5820
5821				These are used to assign JavaScript event handlers. See the
5822				JavaScripting section for more details.
5823
5824				=back
5825
5826				Other common arguments are described in the next section. In addition
5827				to these, all attributes described in the HTML specifications are
5828				supported.
5829
5830				=head2 CREATING A TEXT FIELD
5831
5832				print textfield(-name=>'field_name',
5833				-value=>'starting value',
5834				-size=>50,
5835				-maxlength=>80);
5836				-or-
5837
5838				print textfield('field_name','starting value',50,80);
5839
5840				textfield() will return a text input field.
5841
5842				=over 4
5843
5844				=item B<Parameters>
5845
5846				=item 1.
5847
5848				The first parameter is the required name for the field (-name).
5849
5850				=item 2.
5851
5852				The optional second parameter is the default starting value for the field
5853				contents (-value, formerly known as -default).
5854
5855				=item 3.
5856
5857				The optional third parameter is the size of the field in
5858				characters (-size).
5859
5860				=item 4.
5861
5862				The optional fourth parameter is the maximum number of characters the
5863				field will accept (-maxlength).
5864
5865				=back
5866
5867				As with all these methods, the field will be initialized with its
5868				previous contents from earlier invocations of the script.
5869				When the form is processed, the value of the text field can be
5870				retrieved with:
5871
5872				$value = param('foo');
5873
5874				If you want to reset it from its initial value after the script has been
5875				called once, you can do so like this:
5876
5877				param('foo',"I'm taking over this value!");
5878
5879				=head2 CREATING A BIG TEXT FIELD
5880
5881				print textarea(-name=>'foo',
5882				-default=>'starting value',
5883				-rows=>10,
5884				-columns=>50);
5885
5886				-or
5887
5888				print textarea('foo','starting value',10,50);
5889
5890				textarea() is just like textfield, but it allows you to specify
5891				rows and columns for a multiline text entry box. You can provide
5892				a starting value for the field, which can be long and contain
5893				multiple lines.
5894
5895				=head2 CREATING A PASSWORD FIELD
5896
5897				print password_field(-name=>'secret',
5898				-value=>'starting value',
5899				-size=>50,
5900				-maxlength=>80);
5901				-or-
5902
5903				print password_field('secret','starting value',50,80);
5904
5905				password_field() is identical to textfield(), except that its contents
5906				will be starred out on the web page.
5907
5908				=head2 CREATING A FILE UPLOAD FIELD
5909
5910				print filefield(-name=>'uploaded_file',
5911				-default=>'starting value',
5912				-size=>50,
5913				-maxlength=>80);
5914				-or-
5915
5916				print filefield('uploaded_file','starting value',50,80);
5917
5918				filefield() will return a file upload field for Netscape 2.0 browsers.
5919				In order to take full advantage of this I<you must use the new
5920				multipart encoding scheme> for the form. You can do this either
5921				by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>,
5922				or by calling the new method B<start_multipart_form()> instead of
5923				vanilla B<start_form()>.
5924
5925				=over 4
5926
5927				=item B<Parameters>
5928
5929				=item 1.
5930
5931				The first parameter is the required name for the field (-name).
5932
5933				=item 2.
5934
5935				The optional second parameter is the starting value for the field contents
5936				to be used as the default file name (-default).
5937
5938				For security reasons, browsers don't pay any attention to this field,
5939				and so the starting value will always be blank. Worse, the field
5940				loses its "sticky" behavior and forgets its previous contents. The
5941				starting value field is called for in the HTML specification, however,
5942				and possibly some browser will eventually provide support for it.
5943
5944				=item 3.
5945
5946				The optional third parameter is the size of the field in
5947				characters (-size).
5948
5949				=item 4.
5950
5951				The optional fourth parameter is the maximum number of characters the
5952				field will accept (-maxlength).
5953
5954				=back
5955
5956				When the form is processed, you can retrieve the entered filename
5957				by calling param():
5958
5959				$filename = param('uploaded_file');
5960
5961				Different browsers will return slightly different things for the
5962				name. Some browsers return the filename only. Others return the full
5963				path to the file, using the path conventions of the user's machine.
5964				Regardless, the name returned is always the name of the file on the
5965				I<user's> machine, and is unrelated to the name of the temporary file
5966				that CGI.pm creates during upload spooling (see below).
5967
5968				The filename returned is also a file handle. You can read the contents
5969				of the file using standard Perl file reading calls:
5970
5971				# Read a text file and print it out
5972				while (<$filename>) {
5973				print;
5974				}
5975
5976				# Copy a binary file to somewhere safe
5977				open (OUTFILE,">>/usr/local/web/users/feedback");
5978				while ($bytesread=read($filename,$buffer,1024)) {
5979				print OUTFILE $buffer;
5980				}
5981
5982				However, there are problems with the dual nature of the upload fields.
5983				If you C<use strict>, then Perl will complain when you try to use a
5984				string as a filehandle. You can get around this by placing the file
5985				reading code in a block containing the C<no strict> pragma. More
5986				seriously, it is possible for the remote user to type garbage into the
5987				upload field, in which case what you get from param() is not a
5988				filehandle at all, but a string.
5989
5990				To be safe, use the I<upload()> function (new in version 2.47). When
5991				called with the name of an upload field, I<upload()> returns a
5992				filehandle, or undef if the parameter is not a valid filehandle.
5993
5994				$fh = upload('uploaded_file');
5995				while (<$fh>) {
5996				print;
5997				}
5998
5999				In an list context, upload() will return an array of filehandles.
6000				This makes it possible to create forms that use the same name for
6001				multiple upload fields.
6002
6003				This is the recommended idiom.
6004
6005				For robust code, consider reseting the file handle position to beginning of the
6006				file. Inside of larger frameworks, other code may have already used the query
6007				object and changed the filehandle postion:
6008
6009				seek($fh,0,0); # reset postion to beginning of file.
6010
6011				When a file is uploaded the browser usually sends along some
6012				information along with it in the format of headers. The information
6013				usually includes the MIME content type. Future browsers may send
6014				other information as well (such as modification date and size). To
6015				retrieve this information, call uploadInfo(). It returns a reference to
6016				an associative array containing all the document headers.
6017
6018				$filename = param('uploaded_file');
6019				$type = uploadInfo($filename)->{'Content-Type'};
6020				unless ($type eq 'text/html') {
6021				die "HTML FILES ONLY!";
6022				}
6023
6024				If you are using a machine that recognizes "text" and "binary" data
6025				modes, be sure to understand when and how to use them (see the Camel book).
6026				Otherwise you may find that binary files are corrupted during file
6027				uploads.
6028
6029				There are occasionally problems involving parsing the uploaded file.
6030				This usually happens when the user presses "Stop" before the upload is
6031				finished. In this case, CGI.pm will return undef for the name of the
6032				uploaded file and set I<cgi_error()> to the string "400 Bad request
6033				(malformed multipart POST)". This error message is designed so that
6034				you can incorporate it into a status code to be sent to the browser.
6035				Example:
6036
6037				$file = upload('uploaded_file');
6038				if (!$file && cgi_error) {
6039				print header(-status=>cgi_error);
6040				exit 0;
6041				}
6042
6043				You are free to create a custom HTML page to complain about the error,
6044				if you wish.
6045
6046				You can set up a callback that will be called whenever a file upload
6047				is being read during the form processing. This is much like the
6048				UPLOAD_HOOK facility available in Apache::Request, with the exception
6049				that the first argument to the callback is an Apache::Upload object,
6050				here it's the remote filename.
6051
6052				$q = CGI->new(\&hook [,$data [,$use_tempfile]]);
6053
6054				sub hook
6055				{
6056				my ($filename, $buffer, $bytes_read, $data) = @_;
6057				print "Read $bytes_read bytes of $filename\n";
6058				}
6059
6060				The $data field is optional; it lets you pass configuration
6061				information (e.g. a database handle) to your hook callback.
6062
6063				The $use_tempfile field is a flag that lets you turn on and off
6064				CGI.pm's use of a temporary disk-based file during file upload. If you
6065				set this to a FALSE value (default true) then param('uploaded_file')
6066				will no longer work, and the only way to get at the uploaded data is
6067				via the hook you provide.
6068
6069				If using the function-oriented interface, call the CGI::upload_hook()
6070				method before calling param() or any other CGI functions:
6071
6072				CGI::upload_hook(\&hook [,$data [,$use_tempfile]]);
6073
6074				This method is not exported by default. You will have to import it
6075				explicitly if you wish to use it without the CGI:: prefix.
6076
6077				If you are using CGI.pm on a Windows platform and find that binary
6078				files get slightly larger when uploaded but that text files remain the
6079				same, then you have forgotten to activate binary mode on the output
6080				filehandle. Be sure to call binmode() on any handle that you create
6081				to write the uploaded file to disk.
6082
6083				JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
6084				B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
6085				recognized. See textfield() for details.
6086
6087				=head2 CREATING A POPUP MENU
6088
6089				print popup_menu('menu_name',
6090				['eenie','meenie','minie'],
6091				'meenie');
6092
6093				-or-
6094
6095				%labels = ('eenie'=>'your first choice',
6096				'meenie'=>'your second choice',
6097				'minie'=>'your third choice');
6098				%attributes = ('eenie'=>{'class'=>'class of first choice'});
6099				print popup_menu('menu_name',
6100				['eenie','meenie','minie'],
6101				'meenie',\%labels,\%attributes);
6102
6103				-or (named parameter style)-
6104
6105				print popup_menu(-name=>'menu_name',
6106				-values=>['eenie','meenie','minie'],
6107				-default=>'meenie',
6108				-labels=>\%labels,
6109				-attributes=>\%attributes);
6110
6111				popup_menu() creates a menu.
6112
6113				=over 4
6114
6115				=item 1.
6116
6117				The required first argument is the menu's name (-name).
6118
6119				=item 2.
6120
6121				The required second argument (-values) is an array B<reference>
6122				containing the list of menu items in the menu. You can pass the
6123				method an anonymous array, as shown in the example, or a reference to
6124				a named array, such as "\@foo".
6125
6126				=item 3.
6127
6128				The optional third parameter (-default) is the name of the default
6129				menu choice. If not specified, the first item will be the default.
6130				The values of the previous choice will be maintained across queries.
6131
6132				=item 4.
6133
6134				The optional fourth parameter (-labels) is provided for people who
6135				want to use different values for the user-visible label inside the
6136				popup menu and the value returned to your script. It's a pointer to an
6137				associative array relating menu values to user-visible labels. If you
6138				leave this parameter blank, the menu values will be displayed by
6139				default. (You can also leave a label undefined if you want to).
6140
6141				=item 5.
6142
6143				The optional fifth parameter (-attributes) is provided to assign
6144				any of the common HTML attributes to an individual menu item. It's
6145				a pointer to an associative array relating menu values to another
6146				associative array with the attribute's name as the key and the
6147				attribute's value as the value.
6148
6149				=back
6150
6151				When the form is processed, the selected value of the popup menu can
6152				be retrieved using:
6153
6154				$popup_menu_value = param('menu_name');
6155
6156				=head2 CREATING AN OPTION GROUP
6157
6158				Named parameter style
6159
6160				print popup_menu(-name=>'menu_name',
6161				-values=>[qw/eenie meenie minie/,
6162				optgroup(-name=>'optgroup_name',
6163				-values => ['moe','catch'],
6164				-attributes=>{'catch'=>{'class'=>'red'}})],
6165				-labels=>{'eenie'=>'one',
6166				'meenie'=>'two',
6167				'minie'=>'three'},
6168				-default=>'meenie');
6169
6170				Old style
6171				print popup_menu('menu_name',
6172				['eenie','meenie','minie',
6173				optgroup('optgroup_name', ['moe', 'catch'],
6174				{'catch'=>{'class'=>'red'}})],'meenie',
6175				{'eenie'=>'one','meenie'=>'two','minie'=>'three'});
6176
6177				optgroup() creates an option group within a popup menu.
6178
6179				=over 4
6180
6181				=item 1.
6182
6183				The required first argument (B<-name>) is the label attribute of the
6184				optgroup and is B<not> inserted in the parameter list of the query.
6185
6186				=item 2.
6187
6188				The required second argument (B<-values>) is an array reference
6189				containing the list of menu items in the menu. You can pass the
6190				method an anonymous array, as shown in the example, or a reference
6191				to a named array, such as \@foo. If you pass a HASH reference,
6192				the keys will be used for the menu values, and the values will be
6193				used for the menu labels (see -labels below).
6194
6195				=item 3.
6196
6197				The optional third parameter (B<-labels>) allows you to pass a reference
6198				to an associative array containing user-visible labels for one or more
6199				of the menu items. You can use this when you want the user to see one
6200				menu string, but have the browser return your program a different one.
6201				If you don't specify this, the value string will be used instead
6202				("eenie", "meenie" and "minie" in this example). This is equivalent
6203				to using a hash reference for the -values parameter.
6204
6205				=item 4.
6206
6207				An optional fourth parameter (B<-labeled>) can be set to a true value
6208				and indicates that the values should be used as the label attribute
6209				for each option element within the optgroup.
6210
6211				=item 5.
6212
6213				An optional fifth parameter (-novals) can be set to a true value and
6214				indicates to suppress the val attribute in each option element within
6215				the optgroup.
6216
6217				See the discussion on optgroup at W3C
6218				(http://www.w3.org/TR/REC-html40/interact/forms.html#edef-OPTGROUP)
6219				for details.
6220
6221				=item 6.
6222
6223				An optional sixth parameter (-attributes) is provided to assign
6224				any of the common HTML attributes to an individual menu item. It's
6225				a pointer to an associative array relating menu values to another
6226				associative array with the attribute's name as the key and the
6227				attribute's value as the value.
6228
6229				=back
6230
6231				=head2 CREATING A SCROLLING LIST
6232
6233				print scrolling_list('list_name',
6234				['eenie','meenie','minie','moe'],
6235				['eenie','moe'],5,'true',{'moe'=>{'class'=>'red'}});
6236				-or-
6237
6238				print scrolling_list('list_name',
6239				['eenie','meenie','minie','moe'],
6240				['eenie','moe'],5,'true',
6241				\%labels,%attributes);
6242
6243				-or-
6244
6245				print scrolling_list(-name=>'list_name',
6246				-values=>['eenie','meenie','minie','moe'],
6247				-default=>['eenie','moe'],
6248				-size=>5,
6249				-multiple=>'true',
6250				-labels=>\%labels,
6251				-attributes=>\%attributes);
6252
6253				scrolling_list() creates a scrolling list.
6254
6255				=over 4
6256
6257				=item B<Parameters:>
6258
6259				=item 1.
6260
6261				The first and second arguments are the list name (-name) and values
6262				(-values). As in the popup menu, the second argument should be an
6263				array reference.
6264
6265				=item 2.
6266
6267				The optional third argument (-default) can be either a reference to a
6268				list containing the values to be selected by default, or can be a
6269				single value to select. If this argument is missing or undefined,
6270				then nothing is selected when the list first appears. In the named
6271				parameter version, you can use the synonym "-defaults" for this
6272				parameter.
6273
6274				=item 3.
6275
6276				The optional fourth argument is the size of the list (-size).
6277
6278				=item 4.
6279
6280				The optional fifth argument can be set to true to allow multiple
6281				simultaneous selections (-multiple). Otherwise only one selection
6282				will be allowed at a time.
6283
6284				=item 5.
6285
6286				The optional sixth argument is a pointer to an associative array
6287				containing long user-visible labels for the list items (-labels).
6288				If not provided, the values will be displayed.
6289
6290				=item 6.
6291
6292				The optional sixth parameter (-attributes) is provided to assign
6293				any of the common HTML attributes to an individual menu item. It's
6294				a pointer to an associative array relating menu values to another
6295				associative array with the attribute's name as the key and the
6296				attribute's value as the value.
6297
6298				When this form is processed, all selected list items will be returned as
6299				a list under the parameter name 'list_name'. The values of the
6300				selected items can be retrieved with:
6301
6302				@selected = param('list_name');
6303
6304				=back
6305
6306				=head2 CREATING A GROUP OF RELATED CHECKBOXES
6307
6308				print checkbox_group(-name=>'group_name',
6309				-values=>['eenie','meenie','minie','moe'],
6310				-default=>['eenie','moe'],
6311				-linebreak=>'true',
6312				-disabled => ['moe'],
6313				-labels=>\%labels,
6314				-attributes=>\%attributes);
6315
6316				print checkbox_group('group_name',
6317				['eenie','meenie','minie','moe'],
6318				['eenie','moe'],'true',\%labels,
6319				{'moe'=>{'class'=>'red'}});
6320
6321				HTML3-COMPATIBLE BROWSERS ONLY:
6322
6323				print checkbox_group(-name=>'group_name',
6324				-values=>['eenie','meenie','minie','moe'],
6325				-rows=2,-columns=>2);
6326
6327
6328				checkbox_group() creates a list of checkboxes that are related
6329				by the same name.
6330
6331				=over 4
6332
6333				=item B<Parameters:>
6334
6335				=item 1.
6336
6337				The first and second arguments are the checkbox name and values,
6338				respectively (-name and -values). As in the popup menu, the second
6339				argument should be an array reference. These values are used for the
6340				user-readable labels printed next to the checkboxes as well as for the
6341				values passed to your script in the query string.
6342
6343				=item 2.
6344
6345				The optional third argument (-default) can be either a reference to a
6346				list containing the values to be checked by default, or can be a
6347				single value to checked. If this argument is missing or undefined,
6348				then nothing is selected when the list first appears.
6349
6350				=item 3.
6351
6352				The optional fourth argument (-linebreak) can be set to true to place
6353				line breaks between the checkboxes so that they appear as a vertical
6354				list. Otherwise, they will be strung together on a horizontal line.
6355
6356				=back
6357
6358
6359				The optional b<-labels> argument is a pointer to an associative array
6360				relating the checkbox values to the user-visible labels that will be
6361				printed next to them. If not provided, the values will be used as the
6362				default.
6363
6364
6365				The optional parameters B<-rows>, and B<-columns> cause
6366				checkbox_group() to return an HTML3 compatible table containing the
6367				checkbox group formatted with the specified number of rows and
6368				columns. You can provide just the -columns parameter if you wish;
6369				checkbox_group will calculate the correct number of rows for you.
6370
6371				The option b<-disabled> takes an array of checkbox values and disables
6372				them by greying them out (this may not be supported by all browsers).
6373
6374				The optional B<-attributes> argument is provided to assign any of the
6375				common HTML attributes to an individual menu item. It's a pointer to
6376				an associative array relating menu values to another associative array
6377				with the attribute's name as the key and the attribute's value as the
6378				value.
6379
6380				The optional B<-tabindex> argument can be used to control the order in which
6381				radio buttons receive focus when the user presses the tab button. If
6382				passed a scalar numeric value, the first element in the group will
6383				receive this tab index and subsequent elements will be incremented by
6384				one. If given a reference to an array of radio button values, then
6385				the indexes will be jiggered so that the order specified in the array
6386				will correspond to the tab order. You can also pass a reference to a
6387				hash in which the hash keys are the radio button values and the values
6388				are the tab indexes of each button. Examples:
6389
6390				-tabindex => 100 # this group starts at index 100 and counts up
6391				-tabindex => ['moe','minie','eenie','meenie'] # tab in this order
6392				-tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
6393
6394				When the form is processed, all checked boxes will be returned as
6395				a list under the parameter name 'group_name'. The values of the
6396				"on" checkboxes can be retrieved with:
6397
6398				@turned_on = param('group_name');
6399
6400				The value returned by checkbox_group() is actually an array of button
6401				elements. You can capture them and use them within tables, lists,
6402				or in other creative ways:
6403
6404				@h = checkbox_group(-name=>'group_name',-values=>\@values);
6405				&use_in_creative_way(@h);
6406
6407				=head2 CREATING A STANDALONE CHECKBOX
6408
6409				print checkbox(-name=>'checkbox_name',
6410				-checked=>1,
6411				-value=>'ON',
6412				-label=>'CLICK ME');
6413
6414				-or-
6415
6416				print checkbox('checkbox_name','checked','ON','CLICK ME');
6417
6418				checkbox() is used to create an isolated checkbox that isn't logically
6419				related to any others.
6420
6421				=over 4
6422
6423				=item B<Parameters:>
6424
6425				=item 1.
6426
6427				The first parameter is the required name for the checkbox (-name). It
6428				will also be used for the user-readable label printed next to the
6429				checkbox.
6430
6431				=item 2.
6432
6433				The optional second parameter (-checked) specifies that the checkbox
6434				is turned on by default. Synonyms are -selected and -on.
6435
6436				=item 3.
6437
6438				The optional third parameter (-value) specifies the value of the
6439				checkbox when it is checked. If not provided, the word "on" is
6440				assumed.
6441
6442				=item 4.
6443
6444				The optional fourth parameter (-label) is the user-readable label to
6445				be attached to the checkbox. If not provided, the checkbox name is
6446				used.
6447
6448				=back
6449
6450				The value of the checkbox can be retrieved using:
6451
6452				$turned_on = param('checkbox_name');
6453
6454				=head2 CREATING A RADIO BUTTON GROUP
6455
6456				print radio_group(-name=>'group_name',
6457				-values=>['eenie','meenie','minie'],
6458				-default=>'meenie',
6459				-linebreak=>'true',
6460				-labels=>\%labels,
6461				-attributes=>\%attributes);
6462
6463				-or-
6464
6465				print radio_group('group_name',['eenie','meenie','minie'],
6466				'meenie','true',\%labels,\%attributes);
6467
6468
6469				HTML3-COMPATIBLE BROWSERS ONLY:
6470
6471				print radio_group(-name=>'group_name',
6472				-values=>['eenie','meenie','minie','moe'],
6473				-rows=2,-columns=>2);
6474
6475				radio_group() creates a set of logically-related radio buttons
6476				(turning one member of the group on turns the others off)
6477
6478				=over 4
6479
6480				=item B<Parameters:>
6481
6482				=item 1.
6483
6484				The first argument is the name of the group and is required (-name).
6485
6486				=item 2.
6487
6488				The second argument (-values) is the list of values for the radio
6489				buttons. The values and the labels that appear on the page are
6490				identical. Pass an array I<reference> in the second argument, either
6491				using an anonymous array, as shown, or by referencing a named array as
6492				in "\@foo".
6493
6494				=item 3.
6495
6496				The optional third parameter (-default) is the name of the default
6497				button to turn on. If not specified, the first item will be the
6498				default. You can provide a nonexistent button name, such as "-" to
6499				start up with no buttons selected.
6500
6501				=item 4.
6502
6503				The optional fourth parameter (-linebreak) can be set to 'true' to put
6504				line breaks between the buttons, creating a vertical list.
6505
6506				=item 5.
6507
6508				The optional fifth parameter (-labels) is a pointer to an associative
6509				array relating the radio button values to user-visible labels to be
6510				used in the display. If not provided, the values themselves are
6511				displayed.
6512
6513				=back
6514
6515
6516				All modern browsers can take advantage of the optional parameters
6517				B<-rows>, and B<-columns>. These parameters cause radio_group() to
6518				return an HTML3 compatible table containing the radio group formatted
6519				with the specified number of rows and columns. You can provide just
6520				the -columns parameter if you wish; radio_group will calculate the
6521				correct number of rows for you.
6522
6523				To include row and column headings in the returned table, you
6524				can use the B<-rowheaders> and B<-colheaders> parameters. Both
6525				of these accept a pointer to an array of headings to use.
6526				The headings are just decorative. They don't reorganize the
6527				interpretation of the radio buttons -- they're still a single named
6528				unit.
6529
6530				The optional B<-tabindex> argument can be used to control the order in which
6531				radio buttons receive focus when the user presses the tab button. If
6532				passed a scalar numeric value, the first element in the group will
6533				receive this tab index and subsequent elements will be incremented by
6534				one. If given a reference to an array of radio button values, then
6535				the indexes will be jiggered so that the order specified in the array
6536				will correspond to the tab order. You can also pass a reference to a
6537				hash in which the hash keys are the radio button values and the values
6538				are the tab indexes of each button. Examples:
6539
6540				-tabindex => 100 # this group starts at index 100 and counts up
6541				-tabindex => ['moe','minie','eenie','meenie'] # tab in this order
6542				-tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
6543
6544
6545				The optional B<-attributes> argument is provided to assign any of the
6546				common HTML attributes to an individual menu item. It's a pointer to
6547				an associative array relating menu values to another associative array
6548				with the attribute's name as the key and the attribute's value as the
6549				value.
6550
6551				When the form is processed, the selected radio button can
6552				be retrieved using:
6553
6554				$which_radio_button = param('group_name');
6555
6556				The value returned by radio_group() is actually an array of button
6557				elements. You can capture them and use them within tables, lists,
6558				or in other creative ways:
6559
6560				@h = radio_group(-name=>'group_name',-values=>\@values);
6561				&use_in_creative_way(@h);
6562
6563				=head2 CREATING A SUBMIT BUTTON
6564
6565				print submit(-name=>'button_name',
6566				-value=>'value');
6567
6568				-or-
6569
6570				print submit('button_name','value');
6571
6572				submit() will create the query submission button. Every form
6573				should have one of these.
6574
6575				=over 4
6576
6577				=item B<Parameters:>
6578
6579				=item 1.
6580
6581				The first argument (-name) is optional. You can give the button a
6582				name if you have several submission buttons in your form and you want
6583				to distinguish between them.
6584
6585				=item 2.
6586
6587				The second argument (-value) is also optional. This gives the button
6588				a value that will be passed to your script in the query string. The
6589				name will also be used as the user-visible label.
6590
6591				=item 3.
6592
6593				You can use -label as an alias for -value. I always get confused
6594				about which of -name and -value changes the user-visible label on the
6595				button.
6596
6597				=back
6598
6599				You can figure out which button was pressed by using different
6600				values for each one:
6601
6602				$which_one = param('button_name');
6603
6604				=head2 CREATING A RESET BUTTON
6605
6606				print reset
6607
6608				reset() creates the "reset" button. Note that it restores the
6609				form to its value from the last time the script was called,
6610				NOT necessarily to the defaults.
6611
6612				Note that this conflicts with the Perl reset() built-in. Use
6613				CORE::reset() to get the original reset function.
6614
6615				=head2 CREATING A DEFAULT BUTTON
6616
6617				print defaults('button_label')
6618
6619				defaults() creates a button that, when invoked, will cause the
6620				form to be completely reset to its defaults, wiping out all the
6621				changes the user ever made.
6622
6623				=head2 CREATING A HIDDEN FIELD
6624
6625				print hidden(-name=>'hidden_name',
6626				-default=>['value1','value2'...]);
6627
6628				-or-
6629
6630				print hidden('hidden_name','value1','value2'...);
6631
6632				hidden() produces a text field that can't be seen by the user. It
6633				is useful for passing state variable information from one invocation
6634				of the script to the next.
6635
6636				=over 4
6637
6638				=item B<Parameters:>
6639
6640				=item 1.
6641
6642				The first argument is required and specifies the name of this
6643				field (-name).
6644
6645				=item 2.
6646
6647				The second argument is also required and specifies its value
6648				(-default). In the named parameter style of calling, you can provide
6649				a single value here or a reference to a whole list
6650
6651				=back
6652
6653				Fetch the value of a hidden field this way:
6654
6655				$hidden_value = param('hidden_name');
6656
6657				Note, that just like all the other form elements, the value of a
6658				hidden field is "sticky". If you want to replace a hidden field with
6659				some other values after the script has been called once you'll have to
6660				do it manually:
6661
6662				param('hidden_name','new','values','here');
6663
6664				=head2 CREATING A CLICKABLE IMAGE BUTTON
6665
6666				print image_button(-name=>'button_name',
6667				-src=>'/source/URL',
6668				-align=>'MIDDLE');
6669
6670				-or-
6671
6672				print image_button('button_name','/source/URL','MIDDLE');
6673
6674				image_button() produces a clickable image. When it's clicked on the
6675				position of the click is returned to your script as "button_name.x"
6676				and "button_name.y", where "button_name" is the name you've assigned
6677				to it.
6678
6679				=over 4
6680
6681				=item B<Parameters:>
6682
6683				=item 1.
6684
6685				The first argument (-name) is required and specifies the name of this
6686				field.
6687
6688				=item 2.
6689
6690				The second argument (-src) is also required and specifies the URL
6691
6692				=item 3.
6693				The third option (-align, optional) is an alignment type, and may be
6694				TOP, BOTTOM or MIDDLE
6695
6696				=back
6697
6698				Fetch the value of the button this way:
6699				$x = param('button_name.x');
6700				$y = param('button_name.y');
6701
6702				=head2 CREATING A JAVASCRIPT ACTION BUTTON
6703
6704				print button(-name=>'button_name',
6705				-value=>'user visible label',
6706				-onClick=>"do_something()");
6707
6708				-or-
6709
6710				print button('button_name',"do_something()");
6711
6712				button() produces a button that is compatible with Netscape 2.0's
6713				JavaScript. When it's pressed the fragment of JavaScript code
6714				pointed to by the B<-onClick> parameter will be executed. On
6715				non-Netscape browsers this form element will probably not even
6716				display.
6717
6718				=head1 HTTP COOKIES
6719
6720				Netscape browsers versions 1.1 and higher, and all versions of
6721				Internet Explorer, support a so-called "cookie" designed to help
6722				maintain state within a browser session. CGI.pm has several methods
6723				that support cookies.
6724
6725				A cookie is a name=value pair much like the named parameters in a CGI
6726				query string. CGI scripts create one or more cookies and send
6727				them to the browser in the HTTP header. The browser maintains a list
6728				of cookies that belong to a particular Web server, and returns them
6729				to the CGI script during subsequent interactions.
6730
6731				In addition to the required name=value pair, each cookie has several
6732				optional attributes:
6733
6734				=over 4
6735
6736				=item 1. an expiration time
6737
6738				This is a time/date string (in a special GMT format) that indicates
6739				when a cookie expires. The cookie will be saved and returned to your
6740				script until this expiration date is reached if the user exits
6741				the browser and restarts it. If an expiration date isn't specified, the cookie
6742				will remain active until the user quits the browser.
6743
6744				=item 2. a domain
6745
6746				This is a partial or complete domain name for which the cookie is
6747				valid. The browser will return the cookie to any host that matches
6748				the partial domain name. For example, if you specify a domain name
6749				of ".capricorn.com", then the browser will return the cookie to
6750				Web servers running on any of the machines "www.capricorn.com",
6751				"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
6752				must contain at least two periods to prevent attempts to match
6753				on top level domains like ".edu". If no domain is specified, then
6754				the browser will only return the cookie to servers on the host the
6755				cookie originated from.
6756
6757				=item 3. a path
6758
6759				If you provide a cookie path attribute, the browser will check it
6760				against your script's URL before returning the cookie. For example,
6761				if you specify the path "/cgi-bin", then the cookie will be returned
6762				to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
6763				and "/cgi-bin/customer_service/complain.pl", but not to the script
6764				"/cgi-private/site_admin.pl". By default, path is set to "/", which
6765				causes the cookie to be sent to any CGI script on your site.
6766
6767				=item 4. a "secure" flag
6768
6769				If the "secure" attribute is set, the cookie will only be sent to your
6770				script if the CGI request is occurring on a secure channel, such as SSL.
6771
6772				=back
6773
6774				The interface to HTTP cookies is the B<cookie()> method:
6775
6776				$cookie = cookie(-name=>'sessionID',
6777				-value=>'xyzzy',
6778				-expires=>'+1h',
6779				-path=>'/cgi-bin/database',
6780				-domain=>'.capricorn.org',
6781				-secure=>1);
6782				print header(-cookie=>$cookie);
6783
6784				B<cookie()> creates a new cookie. Its parameters include:
6785
6786				=over 4
6787
6788				=item B<-name>
6789
6790				The name of the cookie (required). This can be any string at all.
6791				Although browsers limit their cookie names to non-whitespace
6792				alphanumeric characters, CGI.pm removes this restriction by escaping
6793				and unescaping cookies behind the scenes.
6794
6795				=item B<-value>
6796
6797				The value of the cookie. This can be any scalar value,
6798				array reference, or even associative array reference. For example,
6799				you can store an entire associative array into a cookie this way:
6800
6801				$cookie=cookie(-name=>'family information',
6802				-value=>\%childrens_ages);
6803
6804				=item B<-path>
6805
6806				The optional partial path for which this cookie will be valid, as described
6807				above.
6808
6809				=item B<-domain>
6810
6811				The optional partial domain for which this cookie will be valid, as described
6812				above.
6813
6814				=item B<-expires>
6815
6816				The optional expiration date for this cookie. The format is as described
6817				in the section on the B<header()> method:
6818
6819				"+1h" one hour from now
6820
6821				=item B<-secure>
6822
6823				If set to true, this cookie will only be used within a secure
6824				SSL session.
6825
6826				=back
6827
6828				The cookie created by cookie() must be incorporated into the HTTP
6829				header within the string returned by the header() method:
6830
6831				use CGI ':standard';
6832				print header(-cookie=>$my_cookie);
6833
6834				To create multiple cookies, give header() an array reference:
6835
6836				$cookie1 = cookie(-name=>'riddle_name',
6837				-value=>"The Sphynx's Question");
6838				$cookie2 = cookie(-name=>'answers',
6839				-value=>\%answers);
6840				print header(-cookie=>[$cookie1,$cookie2]);
6841
6842				To retrieve a cookie, request it by name by calling cookie() method
6843				without the B<-value> parameter. This example uses the object-oriented
6844				form:
6845
6846				use CGI;
6847				$query = new CGI;
6848				$riddle = $query->cookie('riddle_name');
6849				%answers = $query->cookie('answers');
6850
6851				Cookies created with a single scalar value, such as the "riddle_name"
6852				cookie, will be returned in that form. Cookies with array and hash
6853				values can also be retrieved.
6854
6855				The cookie and CGI namespaces are separate. If you have a parameter
6856				named 'answers' and a cookie named 'answers', the values retrieved by
6857				param() and cookie() are independent of each other. However, it's
6858				simple to turn a CGI parameter into a cookie, and vice-versa:
6859
6860				# turn a CGI parameter into a cookie
6861				$c=cookie(-name=>'answers',-value=>[param('answers')]);
6862				# vice-versa
6863				param(-name=>'answers',-value=>[cookie('answers')]);
6864
6865				If you call cookie() without any parameters, it will return a list of
6866				the names of all cookies passed to your script:
6867
6868				@cookies = cookie();
6869
6870				See the B<cookie.cgi> example script for some ideas on how to use
6871				cookies effectively.
6872
6873				=head1 WORKING WITH FRAMES
6874
6875				It's possible for CGI.pm scripts to write into several browser panels
6876				and windows using the HTML 4 frame mechanism. There are three
6877				techniques for defining new frames programmatically:
6878
6879				=over 4
6880
6881				=item 1. Create a <Frameset> document
6882
6883				After writing out the HTTP header, instead of creating a standard
6884				HTML document using the start_html() call, create a <frameset>
6885				document that defines the frames on the page. Specify your script(s)
6886				(with appropriate parameters) as the SRC for each of the frames.
6887
6888				There is no specific support for creating <frameset> sections
6889				in CGI.pm, but the HTML is very simple to write. See the frame
6890				documentation in Netscape's home pages for details
6891
6892				http://wp.netscape.com/assist/net_sites/frames.html
6893
6894				=item 2. Specify the destination for the document in the HTTP header
6895
6896				You may provide a B<-target> parameter to the header() method:
6897
6898				print header(-target=>'ResultsWindow');
6899
6900				This will tell the browser to load the output of your script into the
6901				frame named "ResultsWindow". If a frame of that name doesn't already
6902				exist, the browser will pop up a new window and load your script's
6903				document into that. There are a number of magic names that you can
6904				use for targets. See the frame documents on Netscape's home pages for
6905				details.
6906
6907				=item 3. Specify the destination for the document in the <form> tag
6908
6909				You can specify the frame to load in the FORM tag itself. With
6910				CGI.pm it looks like this:
6911
6912				print start_form(-target=>'ResultsWindow');
6913
6914				When your script is reinvoked by the form, its output will be loaded
6915				into the frame named "ResultsWindow". If one doesn't already exist
6916				a new window will be created.
6917
6918				=back
6919
6920				The script "frameset.cgi" in the examples directory shows one way to
6921				create pages in which the fill-out form and the response live in
6922				side-by-side frames.
6923
6924				=head1 SUPPORT FOR JAVASCRIPT
6925
6926				Netscape versions 2.0 and higher incorporate an interpreted language
6927				called JavaScript. Internet Explorer, 3.0 and higher, supports a
6928				closely-related dialect called JScript. JavaScript isn't the same as
6929				Java, and certainly isn't at all the same as Perl, which is a great
6930				pity. JavaScript allows you to programmatically change the contents of
6931				fill-out forms, create new windows, and pop up dialog box from within
6932				Netscape itself. From the point of view of CGI scripting, JavaScript
6933				is quite useful for validating fill-out forms prior to submitting
6934				them.
6935
6936				You'll need to know JavaScript in order to use it. There are many good
6937				sources in bookstores and on the web.
6938
6939				The usual way to use JavaScript is to define a set of functions in a
6940				<SCRIPT> block inside the HTML header and then to register event
6941				handlers in the various elements of the page. Events include such
6942				things as the mouse passing over a form element, a button being
6943				clicked, the contents of a text field changing, or a form being
6944				submitted. When an event occurs that involves an element that has
6945				registered an event handler, its associated JavaScript code gets
6946				called.
6947
6948				The elements that can register event handlers include the <BODY> of an
6949				HTML document, hypertext links, all the various elements of a fill-out
6950				form, and the form itself. There are a large number of events, and
6951				each applies only to the elements for which it is relevant. Here is a
6952				partial list:
6953
6954				=over 4
6955
6956				=item B<onLoad>
6957
6958				The browser is loading the current document. Valid in:
6959
6960				+ The HTML <BODY> section only.
6961
6962				=item B<onUnload>
6963
6964				The browser is closing the current page or frame. Valid for:
6965
6966				+ The HTML <BODY> section only.
6967
6968				=item B<onSubmit>
6969
6970				The user has pressed the submit button of a form. This event happens
6971				just before the form is submitted, and your function can return a
6972				value of false in order to abort the submission. Valid for:
6973
6974				+ Forms only.
6975
6976				=item B<onClick>
6977
6978				The mouse has clicked on an item in a fill-out form. Valid for:
6979
6980				+ Buttons (including submit, reset, and image buttons)
6981				+ Checkboxes
6982				+ Radio buttons
6983
6984				=item B<onChange>
6985
6986				The user has changed the contents of a field. Valid for:
6987
6988				+ Text fields
6989				+ Text areas
6990				+ Password fields
6991				+ File fields
6992				+ Popup Menus
6993				+ Scrolling lists
6994
6995				=item B<onFocus>
6996
6997				The user has selected a field to work with. Valid for:
6998
6999				+ Text fields
7000				+ Text areas
7001				+ Password fields
7002				+ File fields
7003				+ Popup Menus
7004				+ Scrolling lists
7005
7006				=item B<onBlur>
7007
7008				The user has deselected a field (gone to work somewhere else). Valid
7009				for:
7010
7011				+ Text fields
7012				+ Text areas
7013				+ Password fields
7014				+ File fields
7015				+ Popup Menus
7016				+ Scrolling lists
7017
7018				=item B<onSelect>
7019
7020				The user has changed the part of a text field that is selected. Valid
7021				for:
7022
7023				+ Text fields
7024				+ Text areas
7025				+ Password fields
7026				+ File fields
7027
7028				=item B<onMouseOver>
7029
7030				The mouse has moved over an element.
7031
7032				+ Text fields
7033				+ Text areas
7034				+ Password fields
7035				+ File fields
7036				+ Popup Menus
7037				+ Scrolling lists
7038
7039				=item B<onMouseOut>
7040
7041				The mouse has moved off an element.
7042
7043				+ Text fields
7044				+ Text areas
7045				+ Password fields
7046				+ File fields
7047				+ Popup Menus
7048				+ Scrolling lists
7049
7050				=back
7051
7052				In order to register a JavaScript event handler with an HTML element,
7053				just use the event name as a parameter when you call the corresponding
7054				CGI method. For example, to have your validateAge() JavaScript code
7055				executed every time the textfield named "age" changes, generate the
7056				field like this:
7057
7058				print textfield(-name=>'age',-onChange=>"validateAge(this)");
7059
7060				This example assumes that you've already declared the validateAge()
7061				function by incorporating it into a <SCRIPT> block. The CGI.pm
7062				start_html() method provides a convenient way to create this section.
7063
7064				Similarly, you can create a form that checks itself over for
7065				consistency and alerts the user if some essential value is missing by
7066				creating it this way:
7067				print startform(-onSubmit=>"validateMe(this)");
7068
7069				See the javascript.cgi script for a demonstration of how this all
7070				works.
7071
7072
7073				=head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
7074
7075				CGI.pm has limited support for HTML3's cascading style sheets (css).
7076				To incorporate a stylesheet into your document, pass the
7077				start_html() method a B<-style> parameter. The value of this
7078				parameter may be a scalar, in which case it is treated as the source
7079				URL for the stylesheet, or it may be a hash reference. In the latter
7080				case you should provide the hash with one or more of B<-src> or
7081				B<-code>. B<-src> points to a URL where an externally-defined
7082				stylesheet can be found. B<-code> points to a scalar value to be
7083				incorporated into a <style> section. Style definitions in B<-code>
7084				override similarly-named ones in B<-src>, hence the name "cascading."
7085
7086				You may also specify the type of the stylesheet by adding the optional
7087				B<-type> parameter to the hash pointed to by B<-style>. If not
7088				specified, the style defaults to 'text/css'.
7089
7090				To refer to a style within the body of your document, add the
7091				B<-class> parameter to any HTML element:
7092
7093				print h1({-class=>'Fancy'},'Welcome to the Party');
7094
7095				Or define styles on the fly with the B<-style> parameter:
7096
7097				print h1({-style=>'Color: red;'},'Welcome to Hell');
7098
7099				You may also use the new B<span()> element to apply a style to a
7100				section of text:
7101
7102				print span({-style=>'Color: red;'},
7103				h1('Welcome to Hell'),
7104				"Where did that handbasket get to?"
7105				);
7106
7107				Note that you must import the ":html3" definitions to have the
7108				B<span()> method available. Here's a quick and dirty example of using
7109				CSS's. See the CSS specification at
7110				http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
7111
7112				use CGI qw/:standard :html3/;
7113
7114				#here's a stylesheet incorporated directly into the page
7115				$newStyle=<<END;
7116				<!--
7117				P.Tip {
7118				margin-right: 50pt;
7119				margin-left: 50pt;
7120				color: red;
7121				}
7122				P.Alert {
7123				font-size: 30pt;
7124				font-family: sans-serif;
7125				color: red;
7126				}
7127				-->
7128				END
7129				print header();
7130				print start_html( -title=>'CGI with Style',
7131				-style=>{-src=>'http://www.capricorn.com/style/st1.css',
7132				-code=>$newStyle}
7133				);
7134				print h1('CGI with Style'),
7135				p({-class=>'Tip'},
7136				"Better read the cascading style sheet spec before playing with this!"),
7137				span({-style=>'color: magenta'},
7138				"Look Mom, no hands!",
7139				p(),
7140				"Whooo wee!"
7141				);
7142				print end_html;
7143
7144				Pass an array reference to B<-code> or B<-src> in order to incorporate
7145				multiple stylesheets into your document.
7146
7147				Should you wish to incorporate a verbatim stylesheet that includes
7148				arbitrary formatting in the header, you may pass a -verbatim tag to
7149				the -style hash, as follows:
7150
7151				print start_html (-style => {-verbatim => '@import url("/server-common/css/'.$cssFile.'");',
7152				-src => '/server-common/css/core.css'});
7153
7154
7155				This will generate an HTML header that contains this:
7156
7157				<link rel="stylesheet" type="text/css" href="/server-common/css/core.css">
7158				<style type="text/css">
7159				@import url("/server-common/css/main.css");
7160				</style>
7161
7162				Any additional arguments passed in the -style value will be
7163				incorporated into the <link> tag. For example:
7164
7165				start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'],
7166				-media => 'all'});
7167
7168				This will give:
7169
7170				<link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/>
7171				<link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/>
7172
7173				<p>
7174
7175				To make more complicated <link> tags, use the Link() function
7176				and pass it to start_html() in the -head argument, as in:
7177
7178				@h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}),
7179				Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'}));
7180				print start_html({-head=>\@h})
7181
7182				To create primary and "alternate" stylesheet, use the B<-alternate> option:
7183
7184				start_html(-style=>{-src=>[
7185				{-src=>'/styles/print.css'},
7186				{-src=>'/styles/alt.css',-alternate=>1}
7187				]
7188				});
7189
7190				=head1 DEBUGGING
7191
7192				If you are running the script from the command line or in the perl
7193				debugger, you can pass the script a list of keywords or
7194				parameter=value pairs on the command line or from standard input (you
7195				don't have to worry about tricking your script into reading from
7196				environment variables). You can pass keywords like this:
7197
7198				your_script.pl keyword1 keyword2 keyword3
7199
7200				or this:
7201
7202				your_script.pl keyword1+keyword2+keyword3
7203
7204				or this:
7205
7206				your_script.pl name1=value1 name2=value2
7207
7208				or this:
7209
7210				your_script.pl name1=value1&name2=value2
7211
7212				To turn off this feature, use the -no_debug pragma.
7213
7214				To test the POST method, you may enable full debugging with the -debug
7215				pragma. This will allow you to feed newline-delimited name=value
7216				pairs to the script on standard input.
7217
7218				When debugging, you can use quotes and backslashes to escape
7219				characters in the familiar shell manner, letting you place
7220				spaces and other funny characters in your parameter=value
7221				pairs:
7222
7223				your_script.pl "name1='I am a long value'" "name2=two\ words"
7224
7225				Finally, you can set the path info for the script by prefixing the first
7226				name/value parameter with the path followed by a question mark (?):
7227
7228				your_script.pl /your/path/here?name1=value1&name2=value2
7229
7230				=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
7231
7232				The Dump() method produces a string consisting of all the query's
7233				name/value pairs formatted nicely as a nested list. This is useful
7234				for debugging purposes:
7235
7236				print Dump
7237
7238
7239				Produces something that looks like:
7240
7241				<ul>
7242				<li>name1
7243				<ul>
7244				<li>value1
7245				<li>value2
7246				</ul>
7247				<li>name2
7248				<ul>
7249				<li>value1
7250				</ul>
7251				</ul>
7252
7253				As a shortcut, you can interpolate the entire CGI object into a string
7254				and it will be replaced with the a nice HTML dump shown above:
7255
7256				$query=new CGI;
7257				print "<h2>Current Values</h2> $query\n";
7258
7259				=head1 FETCHING ENVIRONMENT VARIABLES
7260
7261				Some of the more useful environment variables can be fetched
7262				through this interface. The methods are as follows:
7263
7264				=over 4
7265
7266				=item B<Accept()>
7267
7268				Return a list of MIME types that the remote browser accepts. If you
7269				give this method a single argument corresponding to a MIME type, as in
7270				Accept('text/html'), it will return a floating point value
7271				corresponding to the browser's preference for this type from 0.0
7272				(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept
7273				list are handled correctly.
7274
7275				Note that the capitalization changed between version 2.43 and 2.44 in
7276				order to avoid conflict with Perl's accept() function.
7277
7278				=item B<raw_cookie()>
7279
7280				Returns the HTTP_COOKIE variable, an HTTP extension implemented by
7281				Netscape browsers version 1.1 and higher, and all versions of Internet
7282				Explorer. Cookies have a special format, and this method call just
7283				returns the raw form (?cookie dough). See cookie() for ways of
7284				setting and retrieving cooked cookies.
7285
7286				Called with no parameters, raw_cookie() returns the packed cookie
7287				structure. You can separate it into individual cookies by splitting
7288				on the character sequence "; ". Called with the name of a cookie,
7289				retrieves the B<unescaped> form of the cookie. You can use the
7290				regular cookie() method to get the names, or use the raw_fetch()
7291				method from the CGI::Cookie module.
7292
7293				=item B<user_agent()>
7294
7295				Returns the HTTP_USER_AGENT variable. If you give
7296				this method a single argument, it will attempt to
7297				pattern match on it, allowing you to do something
7298				like user_agent(netscape);
7299
7300				=item B<path_info()>
7301
7302				Returns additional path information from the script URL.
7303				E.G. fetching /cgi-bin/your_script/additional/stuff will result in
7304				path_info() returning "/additional/stuff".
7305
7306				NOTE: The Microsoft Internet Information Server
7307				is broken with respect to additional path information. If
7308				you use the Perl DLL library, the IIS server will attempt to
7309				execute the additional path information as a Perl script.
7310				If you use the ordinary file associations mapping, the
7311				path information will be present in the environment,
7312				but incorrect. The best thing to do is to avoid using additional
7313				path information in CGI scripts destined for use with IIS.
7314
7315				=item B<path_translated()>
7316
7317				As per path_info() but returns the additional
7318				path information translated into a physical path, e.g.
7319				"/usr/local/etc/httpd/htdocs/additional/stuff".
7320
7321				The Microsoft IIS is broken with respect to the translated
7322				path as well.
7323
7324				=item B<remote_host()>
7325
7326				Returns either the remote host name or IP address.
7327				if the former is unavailable.
7328
7329				=item B<script_name()>
7330				Return the script name as a partial URL, for self-refering
7331				scripts.
7332
7333				=item B<referer()>
7334
7335				Return the URL of the page the browser was viewing
7336				prior to fetching your script. Not available for all
7337				browsers.
7338
7339				=item B<auth_type ()>
7340
7341				Return the authorization/verification method in use for this
7342				script, if any.
7343
7344				=item B<server_name ()>
7345
7346				Returns the name of the server, usually the machine's host
7347				name.
7348
7349				=item B<virtual_host ()>
7350
7351				When using virtual hosts, returns the name of the host that
7352				the browser attempted to contact
7353
7354				=item B<server_port ()>
7355
7356				Return the port that the server is listening on.
7357
7358				=item B<virtual_port ()>
7359
7360				Like server_port() except that it takes virtual hosts into account.
7361				Use this when running with virtual hosts.
7362
7363				=item B<server_software ()>
7364
7365				Returns the server software and version number.
7366
7367				=item B<remote_user ()>
7368
7369				Return the authorization/verification name used for user
7370				verification, if this script is protected.
7371
7372				=item B<user_name ()>
7373
7374				Attempt to obtain the remote user's name, using a variety of different
7375				techniques. This only works with older browsers such as Mosaic.
7376				Newer browsers do not report the user name for privacy reasons!
7377
7378				=item B<request_method()>
7379
7380				Returns the method used to access your script, usually
7381				one of 'POST', 'GET' or 'HEAD'.
7382
7383				=item B<content_type()>
7384
7385				Returns the content_type of data submitted in a POST, generally
7386				multipart/form-data or application/x-www-form-urlencoded
7387
7388				=item B<http()>
7389
7390				Called with no arguments returns the list of HTTP environment
7391				variables, including such things as HTTP_USER_AGENT,
7392				HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the
7393				like-named HTTP header fields in the request. Called with the name of
7394				an HTTP header field, returns its value. Capitalization and the use
7395				of hyphens versus underscores are not significant.
7396
7397				For example, all three of these examples are equivalent:
7398
7399				$requested_language = http('Accept-language');
7400				$requested_language = http('Accept_language');
7401				$requested_language = http('HTTP_ACCEPT_LANGUAGE');
7402
7403				=item B<https()>
7404
7405				The same as I<http()>, but operates on the HTTPS environment variables
7406				present when the SSL protocol is in effect. Can be used to determine
7407				whether SSL is turned on.
7408
7409				=back
7410
7411				=head1 USING NPH SCRIPTS
7412
7413				NPH, or "no-parsed-header", scripts bypass the server completely by
7414				sending the complete HTTP header directly to the browser. This has
7415				slight performance benefits, but is of most use for taking advantage
7416				of HTTP extensions that are not directly supported by your server,
7417				such as server push and PICS headers.
7418
7419				Servers use a variety of conventions for designating CGI scripts as
7420				NPH. Many Unix servers look at the beginning of the script's name for
7421				the prefix "nph-". The Macintosh WebSTAR server and Microsoft's
7422				Internet Information Server, in contrast, try to decide whether a
7423				program is an NPH script by examining the first line of script output.
7424
7425
7426				CGI.pm supports NPH scripts with a special NPH mode. When in this
7427				mode, CGI.pm will output the necessary extra header information when
7428				the header() and redirect() methods are
7429				called.
7430
7431				The Microsoft Internet Information Server requires NPH mode. As of
7432				version 2.30, CGI.pm will automatically detect when the script is
7433				running under IIS and put itself into this mode. You do not need to
7434				do this manually, although it won't hurt anything if you do. However,
7435				note that if you have applied Service Pack 6, much of the
7436				functionality of NPH scripts, including the ability to redirect while
7437				setting a cookie, b<do not work at all> on IIS without a special patch
7438				from Microsoft. See
7439				http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP:
7440				Non-Parsed Headers Stripped From CGI Applications That Have nph-
7441				Prefix in Name.
7442
7443				=over 4
7444
7445				=item In the B<use> statement
7446
7447				Simply add the "-nph" pragmato the list of symbols to be imported into
7448				your script:
7449
7450				use CGI qw(:standard -nph)
7451
7452				=item By calling the B<nph()> method:
7453
7454				Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
7455
7456				CGI->nph(1)
7457
7458				=item By using B<-nph> parameters
7459
7460				in the B<header()> and B<redirect()> statements:
7461
7462				print header(-nph=>1);
7463
7464				=back
7465
7466				=head1 Server Push
7467
7468				CGI.pm provides four simple functions for producing multipart
7469				documents of the type needed to implement server push. These
7470				functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To
7471				import these into your namespace, you must import the ":push" set.
7472				You are also advised to put the script into NPH mode and to set $\| to
7473				1 to avoid buffering problems.
7474
7475				Here is a simple script that demonstrates server push:
7476
7477				#!/usr/local/bin/perl
7478				use CGI qw/:push -nph/;
7479				$\| = 1;
7480				print multipart_init(-boundary=>'----here we go!');
7481				foreach (0 .. 4) {
7482				print multipart_start(-type=>'text/plain'),
7483				"The current time is ",scalar(localtime),"\n";
7484				if ($_ < 4) {
7485				print multipart_end;
7486				} else {
7487				print multipart_final;
7488				}
7489				sleep 1;
7490				}
7491
7492				This script initializes server push by calling B<multipart_init()>.
7493				It then enters a loop in which it begins a new multipart section by
7494				calling B<multipart_start()>, prints the current local time,
7495				and ends a multipart section with B<multipart_end()>. It then sleeps
7496				a second, and begins again. On the final iteration, it ends the
7497				multipart section with B<multipart_final()> rather than with
7498				B<multipart_end()>.
7499
7500				=over 4
7501
7502				=item multipart_init()
7503
7504				multipart_init(-boundary=>$boundary);
7505
7506				Initialize the multipart system. The -boundary argument specifies
7507				what MIME boundary string to use to separate parts of the document.
7508				If not provided, CGI.pm chooses a reasonable boundary for you.
7509
7510				=item multipart_start()
7511
7512				multipart_start(-type=>$type)
7513
7514				Start a new part of the multipart document using the specified MIME
7515				type. If not specified, text/html is assumed.
7516
7517				=item multipart_end()
7518
7519				multipart_end()
7520
7521				End a part. You must remember to call multipart_end() once for each
7522				multipart_start(), except at the end of the last part of the multipart
7523				document when multipart_final() should be called instead of multipart_end().
7524
7525				=item multipart_final()
7526
7527				multipart_final()
7528
7529				End all parts. You should call multipart_final() rather than
7530				multipart_end() at the end of the last part of the multipart document.
7531
7532				=back
7533
7534				Users interested in server push applications should also have a look
7535				at the CGI::Push module.
7536
7537				Only Netscape Navigator supports server push. Internet Explorer
7538				browsers do not.
7539
7540				=head1 Avoiding Denial of Service Attacks
7541
7542				A potential problem with CGI.pm is that, by default, it attempts to
7543				process form POSTings no matter how large they are. A wily hacker
7544				could attack your site by sending a CGI script a huge POST of many
7545				megabytes. CGI.pm will attempt to read the entire POST into a
7546				variable, growing hugely in size until it runs out of memory. While
7547				the script attempts to allocate the memory the system may slow down
7548				dramatically. This is a form of denial of service attack.
7549
7550				Another possible attack is for the remote user to force CGI.pm to
7551				accept a huge file upload. CGI.pm will accept the upload and store it
7552				in a temporary directory even if your script doesn't expect to receive
7553				an uploaded file. CGI.pm will delete the file automatically when it
7554				terminates, but in the meantime the remote user may have filled up the
7555				server's disk space, causing problems for other programs.
7556
7557				The best way to avoid denial of service attacks is to limit the amount
7558				of memory, CPU time and disk space that CGI scripts can use. Some Web
7559				servers come with built-in facilities to accomplish this. In other
7560				cases, you can use the shell I<limit> or I<ulimit>
7561				commands to put ceilings on CGI resource usage.
7562
7563
7564				CGI.pm also has some simple built-in protections against denial of
7565				service attacks, but you must activate them before you can use them.
7566				These take the form of two global variables in the CGI name space:
7567
7568				=over 4
7569
7570				=item B<$CGI::POST_MAX>
7571
7572				If set to a non-negative integer, this variable puts a ceiling
7573				on the size of POSTings, in bytes. If CGI.pm detects a POST
7574				that is greater than the ceiling, it will immediately exit with an error
7575				message. This value will affect both ordinary POSTs and
7576				multipart POSTs, meaning that it limits the maximum size of file
7577				uploads as well. You should set this to a reasonably high
7578				value, such as 1 megabyte.
7579
7580				=item B<$CGI::DISABLE_UPLOADS>
7581
7582				If set to a non-zero value, this will disable file uploads
7583				completely. Other fill-out form values will work as usual.
7584
7585				=back
7586
7587				You can use these variables in either of two ways.
7588
7589				=over 4
7590
7591				=item B<1. On a script-by-script basis>
7592
7593				Set the variable at the top of the script, right after the "use" statement:
7594
7595				use CGI qw/:standard/;
7596				use CGI::Carp 'fatalsToBrowser';
7597				$CGI::POST_MAX=1024 * 100; # max 100K posts
7598				$CGI::DISABLE_UPLOADS = 1; # no uploads
7599
7600				=item B<2. Globally for all scripts>
7601
7602				Open up CGI.pm, find the definitions for $POST_MAX and
7603				$DISABLE_UPLOADS, and set them to the desired values. You'll
7604				find them towards the top of the file in a subroutine named
7605				initialize_globals().
7606
7607				=back
7608
7609				An attempt to send a POST larger than $POST_MAX bytes will cause
7610				I<param()> to return an empty CGI parameter list. You can test for
7611				this event by checking I<cgi_error()>, either after you create the CGI
7612				object or, if you are using the function-oriented interface, call
7613				<param()> for the first time. If the POST was intercepted, then
7614				cgi_error() will return the message "413 POST too large".
7615
7616				This error message is actually defined by the HTTP protocol, and is
7617				designed to be returned to the browser as the CGI script's status
7618				code. For example:
7619
7620				$uploaded_file = param('upload');
7621				if (!$uploaded_file && cgi_error()) {
7622				print header(-status=>cgi_error());
7623				exit 0;
7624				}
7625
7626				However it isn't clear that any browser currently knows what to do
7627				with this status code. It might be better just to create an
7628				HTML page that warns the user of the problem.
7629
7630				=head1 COMPATIBILITY WITH CGI-LIB.PL
7631
7632				To make it easier to port existing programs that use cgi-lib.pl the
7633				compatibility routine "ReadParse" is provided. Porting is simple:
7634
7635				OLD VERSION
7636				require "cgi-lib.pl";
7637				&ReadParse;
7638				print "The value of the antique is $in{antique}.\n";
7639
7640				NEW VERSION
7641				use CGI;
7642				CGI::ReadParse();
7643				print "The value of the antique is $in{antique}.\n";
7644
7645				CGI.pm's ReadParse() routine creates a tied variable named %in,
7646				which can be accessed to obtain the query variables. Like
7647				ReadParse, you can also provide your own variable. Infrequently
7648				used features of ReadParse, such as the creation of @in and $in
7649				variables, are not supported.
7650
7651				Once you use ReadParse, you can retrieve the query object itself
7652				this way:
7653
7654				$q = $in{CGI};
7655				print textfield(-name=>'wow',
7656				-value=>'does this really work?');
7657
7658				This allows you to start using the more interesting features
7659				of CGI.pm without rewriting your old scripts from scratch.
7660
7661				=head1 AUTHOR INFORMATION
7662
7663				Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
7664
7665				This library is free software; you can redistribute it and/or modify
7666				it under the same terms as Perl itself.
7667
7668				Address bug reports and comments to: lstein@cshl.org. When sending
7669				bug reports, please provide the version of CGI.pm, the version of
7670				Perl, the name and version of your Web server, and the name and
7671				version of the operating system you are using. If the problem is even
7672				remotely browser dependent, please provide information about the
7673				affected browers as well.
7674
7675				=head1 CREDITS
7676
7677				Thanks very much to:
7678
7679				=over 4
7680
7681				=item Matt Heffron (heffron@falstaff.css.beckman.com)
7682
7683				=item James Taylor (james.taylor@srs.gov)
7684
7685				=item Scott Anguish <sanguish@digifix.com>
7686
7687				=item Mike Jewell (mlj3u@virginia.edu)
7688
7689				=item Timothy Shimmin (tes@kbs.citri.edu.au)
7690
7691				=item Joergen Haegg (jh@axis.se)
7692
7693				=item Laurent Delfosse (delfosse@delfosse.com)
7694
7695				=item Richard Resnick (applepi1@aol.com)
7696
7697				=item Craig Bishop (csb@barwonwater.vic.gov.au)
7698
7699				=item Tony Curtis (tc@vcpc.univie.ac.at)
7700
7701				=item Tim Bunce (Tim.Bunce@ig.co.uk)
7702
7703				=item Tom Christiansen (tchrist@convex.com)
7704
7705				=item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
7706
7707				=item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
7708
7709				=item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
7710
7711				=item Stephen Dahmen (joyfire@inxpress.net)
7712
7713				=item Ed Jordan (ed@fidalgo.net)
7714
7715				=item David Alan Pisoni (david@cnation.com)
7716
7717				=item Doug MacEachern (dougm@opengroup.org)
7718
7719				=item Robin Houston (robin@oneworld.org)
7720
7721				=item ...and many many more...
7722
7723				for suggestions and bug fixes.
7724
7725				=back
7726
7727				=head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
7728
7729
7730				#!/usr/local/bin/perl
7731
7732				use CGI ':standard';
7733
7734				print header;
7735				print start_html("Example CGI.pm Form");
7736				print "<h1> Example CGI.pm Form</h1>\n";
7737				print_prompt();
7738				do_work();
7739				print_tail();
7740				print end_html;
7741
7742				sub print_prompt {
7743				print start_form;
7744				print "<em>What's your name?</em><br>";
7745				print textfield('name');
7746				print checkbox('Not my real name');
7747
7748				print "<p><em>Where can you find English Sparrows?</em><br>";
7749				print checkbox_group(
7750				-name=>'Sparrow locations',
7751				-values=>[England,France,Spain,Asia,Hoboken],
7752				-linebreak=>'yes',
7753				-defaults=>[England,Asia]);
7754
7755				print "<p><em>How far can they fly?</em><br>",
7756				radio_group(
7757				-name=>'how far',
7758				-values=>['10 ft','1 mile','10 miles','real far'],
7759				-default=>'1 mile');
7760
7761				print "<p><em>What's your favorite color?</em> ";
7762				print popup_menu(-name=>'Color',
7763				-values=>['black','brown','red','yellow'],
7764				-default=>'red');
7765
7766				print hidden('Reference','Monty Python and the Holy Grail');
7767
7768				print "<p><em>What have you got there?</em><br>";
7769				print scrolling_list(
7770				-name=>'possessions',
7771				-values=>['A Coconut','A Grail','An Icon',
7772				'A Sword','A Ticket'],
7773				-size=>5,
7774				-multiple=>'true');
7775
7776				print "<p><em>Any parting comments?</em><br>";
7777				print textarea(-name=>'Comments',
7778				-rows=>10,
7779				-columns=>50);
7780
7781				print "<p>",reset;
7782				print submit('Action','Shout');
7783				print submit('Action','Scream');
7784				print endform;
7785				print "<hr>\n";
7786				}
7787
7788				sub do_work {
7789				my(@values,$key);
7790
7791				print "<h2>Here are the current settings in this form</h2>";
7792
7793				foreach $key (param) {
7794				print "<strong>$key</strong> -> ";
7795				@values = param($key);
7796				print join(", ",@values),"<br>\n";
7797				}
7798				}
7799
7800				sub print_tail {
7801				print <<END;
7802				<hr>
7803				<address>Lincoln D. Stein</address><br>
7804				<a href="/">Home Page</a>
7805				END
7806				}
7807
7808				=head1 BUGS
7809
7810				Please report them.
7811
7812				=head1 SEE ALSO
7813
7814				L<CGI::Carp>, L<CGI::Fast>, L<CGI::Pretty>
7815
7816				=cut
7817