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