lib/CGI.pm

   1 package CGI;
   2 require 5.004;
   3
   4 # See the bottom of this file for the POD documentation.  Search for the
   5 # string '=head'.
   6
   7 # You can run this file through either pod2man or pod2html to produce pretty
   8 # documentation in manual or html file format (these utilities are part of the
   9 # Perl 5 distribution).
  10
  11 # Copyright 1995-1998 Lincoln D. Stein.  All rights reserved.
  12 # It may be used and modified freely, but I do request that this copyright
  13 # notice remain attached to the file.  You may modify this module as you
  14 # wish, but if you redistribute a modified version, please attach a note
  15 # listing the modifications you have made.
  16
  17 # The most recent version and complete docs are available at:
  18 #   http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
  19 #   ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
  20
  21 $CGI::revision = '$Id: CGI.pm,v 1.32 1998/05/28 21:55:43 lstein Exp lstein $';
  22 $CGI::VERSION='2.42';
  23
  24 # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
  25 # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
  26 # $TempFile::TMPDIRECTORY = '/usr/tmp';
  27
  28 # >>>>> Here are some globals that you might want to adjust <<<<<<
  29 sub initialize_globals {
  30     # Set this to 1 to enable copious autoloader debugging messages
  31     $AUTOLOAD_DEBUG = 0;
  32
  33     # Change this to the preferred DTD to print in start_html()
  34     # or use default_dtd('text of DTD to use');
  35     $DEFAULT_DTD = '-//IETF//DTD HTML//EN';
  36
  37     # Set this to 1 to enable NPH scripts
  38     # or:
  39     #    1) use CGI qw(-nph)
  40     #    2) $CGI::nph(1)
  41     #    3) print header(-nph=>1)
  42     $NPH = 0;
  43
  44     # Set this to 1 to disable debugging from the
  45     # command line
  46     $NO_DEBUG = 0;
  47
  48     # Set this to 1 to make the temporary files created
  49     # during file uploads safe from prying eyes
  50     # or do...
  51     #    1) use CGI qw(:private_tempfiles)
  52     #    2) $CGI::private_tempfiles(1);
  53     $PRIVATE_TEMPFILES = 0;
  54
  55     # Set this to a positive value to limit the size of a POSTing
  56     # to a certain number of bytes:
  57     $POST_MAX = -1;
  58
  59     # Change this to 1 to disable uploads entirely:
  60     $DISABLE_UPLOADS = 0;
  61
  62     # Other globals that you shouldn't worry about.
  63     undef $Q;
  64     $BEEN_THERE = 0;
  65     undef @QUERY_PARAM;
  66     undef %EXPORT;
  67
  68     # prevent complaints by mod_perl
  69     1;
  70 }
  71
  72 # ------------------ START OF THE LIBRARY ------------
  73
  74 # make mod_perlhappy
  75 initialize_globals();
  76
  77 # FIGURE OUT THE OS WE'RE RUNNING UNDER
  78 # Some systems support the $^O variable.  If not
  79 # available then require() the Config library
  80 unless ($OS) {
  81     unless ($OS = $^O) {
  82         require Config;
  83         $OS = $Config::Config{'osname'};
  84     }
  85 }
  86 if ($OS=~/Win/i) {
  87     $OS = 'WINDOWS';
  88 } elsif ($OS=~/vms/i) {
  89     $OS = 'VMS';
  90 } elsif ($OS=~/^MacOS$/i) {
  91     $OS = 'MACINTOSH';
  92 } elsif ($OS=~/os2/i) {
  93     $OS = 'OS2';
  94 } else {
  95     $OS = 'UNIX';
  96 }
  97
  98 # Some OS logic.  Binary mode enabled on DOS, NT and VMS
  99 $needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/;
 100
 101 # This is the default class for the CGI object to use when all else fails.
 102 $DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
 103
 104 # This is where to look for autoloaded routines.
 105 $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
 106
 107 # The path separator is a slash, backslash or semicolon, depending
 108 # on the paltform.
 109 $SL = {
 110     UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', MACINTOSH=>':', VMS=>'/'
 111     }->{$OS};
 112
 113 # This no longer seems to be necessary
 114 # Turn on NPH scripts by default when running under IIS server!
 115 # $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
 116 $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
 117
 118 # Turn on special checking for Doug MacEachern's modperl
 119 if (defined($ENV{'GATEWAY_INTERFACE'}) &&
 120     ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
 121 {
 122     $| = 1;
 123     require Apache;
 124 }
 125 # Turn on special checking for ActiveState's PerlEx
 126 $PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
 127
 128 # Define the CRLF sequence.  I can't use a simple "\r\n" because the meaning
 129 # of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
 130 # and sometimes CR).  The most popular VMS web server
 131 # doesn't accept CRLF -- instead it wants a LR.  EBCDIC machines don't
 132 # use ASCII, so \015\012 means something different.  I find this all
 133 # really annoying.
 134 $EBCDIC = "\t" ne "\011";
 135 if ($OS eq 'VMS') {
 136     $CRLF = "\n";
 137 } elsif ($EBCDIC) {
 138     $CRLF= "\r\n";
 139 } else {
 140     $CRLF = "\015\012";
 141 }
 142
 143 if ($needs_binmode) {
 144     $CGI::DefaultClass->binmode(main::STDOUT);
 145     $CGI::DefaultClass->binmode(main::STDIN);
 146     $CGI::DefaultClass->binmode(main::STDERR);
 147 }
 148
 149 %EXPORT_TAGS = (
 150                 ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
 151                            tt u i b blockquote pre img a address cite samp dfn html head
 152                            base body Link nextid title meta kbd start_html end_html
 153                            input Select option comment/],
 154                 ':html3'=>[qw/div table caption th td TR Tr sup sub strike applet Param
 155                            embed basefont style span layer ilayer font frameset frame script small big/],
 156                 ':netscape'=>[qw/blink fontsize center/],
 157                 ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
 158                           submit reset defaults radio_group popup_menu button autoEscape
 159                           scrolling_list image_button start_form end_form startform endform
 160                           start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
 161                 ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump
 162                          raw_cookie request_method query_string accept user_agent remote_host
 163                          remote_addr referer server_name server_software server_port server_protocol
 164                          virtual_host remote_ident auth_type http use_named_parameters
 165                          save_parameters restore_parameters param_fetch
 166                          remote_user user_name header redirect import_names put Delete Delete_all url_param/],
 167                 ':ssl' => [qw/https/],
 168                 ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
 169                 ':html' => [qw/:html2 :html3 :netscape/],
 170                 ':standard' => [qw/:html2 :html3 :form :cgi/],
 171                 ':push' => [qw/multipart_init multipart_start multipart_end/],
 172                 ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/]
 173                 );
 174
 175 # to import symbols into caller
 176 sub import {
 177     my $self = shift;
 178
 179 # This causes modules to clash.
 180 #    undef %EXPORT_OK;
 181 #    undef %EXPORT;
 182
 183     $self->_setup_symbols(@_);
 184     my ($callpack, $callfile, $callline) = caller;
 185
 186     # To allow overriding, search through the packages
 187     # Till we find one in which the correct subroutine is defined.
 188     my @packages = ($self,@{"$self\:\:ISA"});
 189     foreach $sym (keys %EXPORT) {
 190         my $pck;
 191         my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
 192         foreach $pck (@packages) {
 193             if (defined(&{"$pck\:\:$sym"})) {
 194                 $def = $pck;
 195                 last;
 196             }
 197         }
 198         *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
 199     }
 200 }
 201
 202 sub compile {
 203     my $pack = shift;
 204     $pack->_setup_symbols('-compile',@_);
 205 }
 206
 207 sub expand_tags {
 208     my($tag) = @_;
 209     my(@r);
 210     return ($tag) unless $EXPORT_TAGS{$tag};
 211     foreach (@{$EXPORT_TAGS{$tag}}) {
 212         push(@r,&expand_tags($_));
 213     }
 214     return @r;
 215 }
 216
 217 #### Method: new
 218 # The new routine.  This will check the current environment
 219 # for an existing query string, and initialize itself, if so.
 220 ####
 221 sub new {
 222     my($class,$initializer) = @_;
 223     my $self = {};
 224     bless $self,ref $class || $class || $DefaultClass;
 225     if ($MOD_PERL) {
 226         Apache->request->register_cleanup(\&CGI::_reset_globals);
 227         undef $NPH;
 228     }
 229     $self->_reset_globals if $PERLEX;
 230     $self->init($initializer);
 231     return $self;
 232 }
 233
 234 # We provide a DESTROY method so that the autoloader
 235 # doesn't bother trying to find it.
 236 sub DESTROY { }
 237
 238 #### Method: param
 239 # Returns the value(s)of a named parameter.
 240 # If invoked in a list context, returns the
 241 # entire list.  Otherwise returns the first
 242 # member of the list.
 243 # If name is not provided, return a list of all
 244 # the known parameters names available.
 245 # If more than one argument is provided, the
 246 # second and subsequent arguments are used to
 247 # set the value of the parameter.
 248 ####
 249 sub param {
 250     my($self,@p) = self_or_default(@_);
 251     return $self->all_parameters unless @p;
 252     my($name,$value,@other);
 253
 254     # For compatibility between old calling style and use_named_parameters() style,
 255     # we have to special case for a single parameter present.
 256     if (@p > 1) {
 257         ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
 258         my(@values);
 259
 260         if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
 261             @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
 262         } else {
 263             foreach ($value,@other) {
 264                 push(@values,$_) if defined($_);
 265             }
 266         }
 267         # If values is provided, then we set it.
 268         if (@values) {
 269             $self->add_parameter($name);
 270             $self->{$name}=[@values];
 271         }
 272     } else {
 273         $name = $p[0];
 274     }
 275
 276     return () unless defined($name) && $self->{$name};
 277     return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
 278 }
 279
 280 sub self_or_default {
 281     return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
 282     unless (defined($_[0]) &&
 283             (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
 284             ) {
 285         $Q = $CGI::DefaultClass->new unless defined($Q);
 286         unshift(@_,$Q);
 287     }
 288     return @_;
 289 }
 290
 291 sub self_or_CGI {
 292     local $^W=0;                # prevent a warning
 293     if (defined($_[0]) &&
 294         (substr(ref($_[0]),0,3) eq 'CGI'
 295          || UNIVERSAL::isa($_[0],'CGI'))) {
 296         return @_;
 297     } else {
 298         return ($DefaultClass,@_);
 299     }
 300 }
 301
 302 ########################################
 303 # THESE METHODS ARE MORE OR LESS PRIVATE
 304 # GO TO THE __DATA__ SECTION TO SEE MORE
 305 # PUBLIC METHODS
 306 ########################################
 307
 308 # Initialize the query object from the environment.
 309 # If a parameter list is found, this object will be set
 310 # to an associative array in which parameter names are keys
 311 # and the values are stored as lists
 312 # If a keyword list is found, this method creates a bogus
 313 # parameter list with the single parameter 'keywords'.
 314
 315 sub init {
 316     my($self,$initializer) = @_;
 317     my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
 318
 319     # if we get called more than once, we want to initialize
 320     # ourselves from the original query (which may be gone
 321     # if it was read from STDIN originally.)
 322     if (defined(@QUERY_PARAM) && !defined($initializer)) {
 323         foreach (@QUERY_PARAM) {
 324             $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
 325         }
 326         return;
 327     }
 328
 329     $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
 330     $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
 331     die "Client attempted to POST $content_length bytes, but POSTs are limited to $POST_MAX"
 332         if ($POST_MAX > 0) && ($content_length > $POST_MAX);
 333     $fh = to_filehandle($initializer) if $initializer;
 334
 335   METHOD: {
 336
 337       # Process multipart postings, but only if the initializer is
 338       # not defined.
 339       if ($meth eq 'POST'
 340           && defined($ENV{'CONTENT_TYPE'})
 341           && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
 342           && !defined($initializer)
 343           ) {
 344           my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";]+)\"?/;
 345           $self->read_multipart($boundary,$content_length);
 346           last METHOD;
 347       }
 348
 349       # If initializer is defined, then read parameters
 350       # from it.
 351       if (defined($initializer)) {
 352           if (UNIVERSAL::isa($initializer,'CGI')) {
 353               $query_string = $initializer->query_string;
 354               last METHOD;
 355           }
 356           if (ref($initializer) && ref($initializer) eq 'HASH') {
 357               foreach (keys %$initializer) {
 358                   $self->param('-name'=>$_,'-value'=>$initializer->{$_});
 359               }
 360               last METHOD;
 361           }
 362
 363           if (defined($fh) && ($fh ne '')) {
 364               while (<$fh>) {
 365                   chomp;
 366                   last if /^=/;
 367                   push(@lines,$_);
 368               }
 369               # massage back into standard format
 370               if ("@lines" =~ /=/) {
 371                   $query_string=join("&",@lines);
 372               } else {
 373                   $query_string=join("+",@lines);
 374               }
 375               last METHOD;
 376           }
 377
 378           # last chance -- treat it as a string
 379           $initializer = $$initializer if ref($initializer) eq 'SCALAR';
 380           $query_string = $initializer;
 381
 382           last METHOD;
 383       }
 384
 385       # If method is GET or HEAD, fetch the query from
 386       # the environment.
 387       if ($meth=~/^(GET|HEAD)$/) {
 388           $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
 389           last METHOD;
 390       }
 391
 392       if ($meth eq 'POST') {
 393           $self->read_from_client(\*STDIN,\$query_string,$content_length,0)
 394               if $content_length > 0;
 395           # Some people want to have their cake and eat it too!
 396           # Uncomment this line to have the contents of the query string
 397           # APPENDED to the POST data.
 398           # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
 399           last METHOD;
 400       }
 401
 402       # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
 403       # Check the command line and then the standard input for data.
 404       # We use the shellwords package in order to behave the way that
 405       # UN*X programmers expect.
 406       $query_string = read_from_cmdline() unless $NO_DEBUG;
 407   }
 408
 409     # We now have the query string in hand.  We do slightly
 410     # different things for keyword lists and parameter lists.
 411     if ($query_string ne '') {
 412         if ($query_string =~ /=/) {
 413             $self->parse_params($query_string);
 414         } else {
 415             $self->add_parameter('keywords');
 416             $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
 417         }
 418     }
 419
 420     # Special case.  Erase everything if there is a field named
 421     # .defaults.
 422     if ($self->param('.defaults')) {
 423         undef %{$self};
 424     }
 425
 426     # Associative array containing our defined fieldnames
 427     $self->{'.fieldnames'} = {};
 428     foreach ($self->param('.cgifields')) {
 429         $self->{'.fieldnames'}->{$_}++;
 430     }
 431
 432     # Clear out our default submission button flag if present
 433     $self->delete('.submit');
 434     $self->delete('.cgifields');
 435     $self->save_request unless $initializer;
 436 }
 437
 438 # FUNCTIONS TO OVERRIDE:
 439 # Turn a string into a filehandle
 440 sub to_filehandle {
 441     my $thingy = shift;
 442     return undef unless $thingy;
 443     return $thingy if UNIVERSAL::isa($thingy,'GLOB');
 444     return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
 445     if (!ref($thingy)) {
 446         my $caller = 1;
 447         while (my $package = caller($caller++)) {
 448             my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
 449             return $tmp if defined(fileno($tmp));
 450         }
 451     }
 452     return undef;
 453 }
 454
 455 # send output to the browser
 456 sub put {
 457     my($self,@p) = self_or_default(@_);
 458     $self->print(@p);
 459 }
 460
 461 # print to standard output (for overriding in mod_perl)
 462 sub print {
 463     shift;
 464     CORE::print(@_);
 465 }
 466
 467 # unescape URL-encoded data
 468 sub unescape {
 469     shift() if ref($_[0]);
 470     my $todecode = shift;
 471     return undef unless defined($todecode);
 472     $todecode =~ tr/+/ /;       # pluses become spaces
 473     $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
 474     return $todecode;
 475 }
 476
 477 # URL-encode data
 478 sub escape {
 479     shift() if ref($_[0]) || $_[0] eq $DefaultClass;
 480     my $toencode = shift;
 481     return undef unless defined($toencode);
 482     $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
 483     return $toencode;
 484 }
 485
 486 sub save_request {
 487     my($self) = @_;
 488     # We're going to play with the package globals now so that if we get called
 489     # again, we initialize ourselves in exactly the same way.  This allows
 490     # us to have several of these objects.
 491     @QUERY_PARAM = $self->param; # save list of parameters
 492     foreach (@QUERY_PARAM) {
 493         $QUERY_PARAM{$_}=$self->{$_};
 494     }
 495 }
 496
 497 sub parse_params {
 498     my($self,$tosplit) = @_;
 499     my(@pairs) = split('&',$tosplit);
 500     my($param,$value);
 501     foreach (@pairs) {
 502         ($param,$value) = split('=',$_,2);
 503         $param = unescape($param);
 504         $value = unescape($value);
 505         $self->add_parameter($param);
 506         push (@{$self->{$param}},$value);
 507     }
 508 }
 509
 510 sub add_parameter {
 511     my($self,$param)=@_;
 512     push (@{$self->{'.parameters'}},$param)
 513         unless defined($self->{$param});
 514 }
 515
 516 sub all_parameters {
 517     my $self = shift;
 518     return () unless defined($self) && $self->{'.parameters'};
 519     return () unless @{$self->{'.parameters'}};
 520     return @{$self->{'.parameters'}};
 521 }
 522
 523 # put a filehandle into binary mode (DOS)
 524 sub binmode {
 525     CORE::binmode($_[1]);
 526 }
 527
 528 sub _make_tag_func {
 529     my $tagname = shift;
 530     return qq{
 531         sub $tagname {
 532             # handle various cases in which we're called
 533             # most of this bizarre stuff is to avoid -w errors
 534             shift if \$_[0] &&
 535                 (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) ||
 536                     (ref(\$_[0]) &&
 537                      (substr(ref(\$_[0]),0,3) eq 'CGI' ||
 538                     UNIVERSAL::isa(\$_[0],'CGI')));
 539
 540             my(\$attr) = '';
 541             if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') {
 542                 my(\@attr) = make_attributes( '',shift() );
 543                 \$attr = " \@attr" if \@attr;
 544             }
 545             my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U</$tagname>\E");
 546             return \$tag unless \@_;
 547             my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
 548             return "\@result";
 549          }
 550 }
 551 }
 552
 553 sub AUTOLOAD {
 554     print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
 555     my $func = &_compile;
 556     goto &$func;
 557 }
 558
 559 # PRIVATE SUBROUTINE
 560 # Smart rearrangement of parameters to allow named parameter
 561 # calling.  We do the rearangement if:
 562 # 1. The first parameter begins with a -
 563 # 2. The use_named_parameters() method returns true
 564 sub rearrange {
 565     my($self,$order,@param) = @_;
 566     return () unless @param;
 567
 568     if (ref($param[0]) eq 'HASH') {
 569         @param = %{$param[0]};
 570     } else {
 571         return @param
 572             unless (defined($param[0]) && substr($param[0],0,1) eq '-')
 573                 || $self->use_named_parameters;
 574     }
 575
 576     # map parameters into positional indices
 577     my ($i,%pos);
 578     $i = 0;
 579     foreach (@$order) {
 580         foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; }
 581         $i++;
 582     }
 583
 584     my (@result,%leftover);
 585     $#result = $#$order;  # preextend
 586     while (@param) {
 587         my $key = uc(shift(@param));
 588         $key =~ s/^\-//;
 589         if (exists $pos{$key}) {
 590             $result[$pos{$key}] = shift(@param);
 591         } else {
 592             $leftover{$key} = shift(@param);
 593         }
 594     }
 595
 596     push (@result,$self->make_attributes(\%leftover)) if %leftover;
 597     @result;
 598 }
 599
 600 sub _compile {
 601     my($func) = $AUTOLOAD;
 602     my($pack,$func_name);
 603     {
 604         local($1,$2); # this fixes an obscure variable suicide problem.
 605         $func=~/(.+)::([^:]+)$/;
 606         ($pack,$func_name) = ($1,$2);
 607         $pack=~s/::SUPER$//;    # fix another obscure problem
 608         $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
 609             unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
 610
 611         my($sub) = \%{"$pack\:\:SUBS"};
 612         unless (%$sub) {
 613            my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
 614            eval "package $pack; $$auto";
 615            die $@ if $@;
 616            $$auto = '';  # Free the unneeded storage (but don't undef it!!!)
 617        }
 618        my($code) = $sub->{$func_name};
 619
 620        $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
 621        if (!$code) {
 622            if ($EXPORT{':any'} ||
 623                $EXPORT{'-any'} ||
 624                $EXPORT{$func_name} ||
 625                (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
 626                    && $EXPORT_OK{$func_name}) {
 627                $code = _make_tag_func($func_name);
 628            }
 629        }
 630        die "Undefined subroutine $AUTOLOAD\n" unless $code;
 631        eval "package $pack; $code";
 632        if ($@) {
 633            $@ =~ s/ at .*\n//;
 634            die $@;
 635        }
 636     }
 637     delete($sub->{$func_name});  #free storage
 638     return "$pack\:\:$func_name";
 639 }
 640
 641 sub _reset_globals { initialize_globals(); }
 642
 643 sub _setup_symbols {
 644     my $self = shift;
 645     my $compile = 0;
 646     foreach (@_) {
 647         $NPH++, next if /^[:-]nph$/;
 648         $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/;
 649         $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
 650         $EXPORT{$_}++, next if /^[:-]any$/;
 651         $compile++, next if /^[:-]compile$/;
 652
 653         # This is probably extremely evil code -- to be deleted
 654         # some day.
 655         if (/^[-]autoload$/) {
 656             my($pkg) = caller(1);
 657             *{"${pkg}::AUTOLOAD"} = sub {
 658                 my($routine) = $AUTOLOAD;
 659                 $routine =~ s/^.*::/CGI::/;
 660                 &$routine;
 661             };
 662             next;
 663         }
 664
 665         foreach (&expand_tags($_)) {
 666             tr/a-zA-Z0-9_//cd;  # don't allow weird function names
 667             $EXPORT{$_}++;
 668         }
 669     }
 670     _compile_all(keys %EXPORT) if $compile;
 671 }
 672
 673 ###############################################################################
 674 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
 675 ###############################################################################
 676 $AUTOLOADED_ROUTINES = '';      # get rid of -w warning
 677 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
 678
 679 %SUBS = (
 680
 681 'URL_ENCODED'=> <<'END_OF_FUNC',
 682 sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
 683 END_OF_FUNC
 684
 685 'MULTIPART' => <<'END_OF_FUNC',
 686 sub MULTIPART {  'multipart/form-data'; }
 687 END_OF_FUNC
 688
 689 'SERVER_PUSH' => <<'END_OF_FUNC',
 690 sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; }
 691 END_OF_FUNC
 692
 693 'use_named_parameters' => <<'END_OF_FUNC',
 694 #### Method: use_named_parameters
 695 # Force CGI.pm to use named parameter-style method calls
 696 # rather than positional parameters.  The same effect
 697 # will happen automatically if the first parameter
 698 # begins with a -.
 699 sub use_named_parameters {
 700     my($self,$use_named) = self_or_default(@_);
 701     return $self->{'.named'} unless defined ($use_named);
 702
 703     # stupidity to avoid annoying warnings
 704     return $self->{'.named'}=$use_named;
 705 }
 706 END_OF_FUNC
 707
 708 'new_MultipartBuffer' => <<'END_OF_FUNC',
 709 # Create a new multipart buffer
 710 sub new_MultipartBuffer {
 711     my($self,$boundary,$length,$filehandle) = @_;
 712     return MultipartBuffer->new($self,$boundary,$length,$filehandle);
 713 }
 714 END_OF_FUNC
 715
 716 'read_from_client' => <<'END_OF_FUNC',
 717 # Read data from a file handle
 718 sub read_from_client {
 719     my($self, $fh, $buff, $len, $offset) = @_;
 720     local $^W=0;                # prevent a warning
 721     return undef unless defined($fh);
 722     return read($fh, $$buff, $len, $offset);
 723 }
 724 END_OF_FUNC
 725
 726 'delete' => <<'END_OF_FUNC',
 727 #### Method: delete
 728 # Deletes the named parameter entirely.
 729 ####
 730 sub delete {
 731     my($self,$name) = self_or_default(@_);
 732     delete $self->{$name};
 733     delete $self->{'.fieldnames'}->{$name};
 734     @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
 735     return wantarray ? () : undef;
 736 }
 737 END_OF_FUNC
 738
 739 #### Method: import_names
 740 # Import all parameters into the given namespace.
 741 # Assumes namespace 'Q' if not specified
 742 ####
 743 'import_names' => <<'END_OF_FUNC',
 744 sub import_names {
 745     my($self,$namespace,$delete) = self_or_default(@_);
 746     $namespace = 'Q' unless defined($namespace);
 747     die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
 748     if ($delete || $MOD_PERL) {
 749         # can anyone find an easier way to do this?
 750         foreach (keys %{"${namespace}::"}) {
 751             local *symbol = "${namespace}::${_}";
 752             undef $symbol;
 753             undef @symbol;
 754             undef %symbol;
 755         }
 756     }
 757     my($param,@value,$var);
 758     foreach $param ($self->param) {
 759         # protect against silly names
 760         ($var = $param)=~tr/a-zA-Z0-9_/_/c;
 761         $var =~ s/^(?=\d)/_/;
 762         local *symbol = "${namespace}::$var";
 763         @value = $self->param($param);
 764         @symbol = @value;
 765         $symbol = $value[0];
 766     }
 767 }
 768 END_OF_FUNC
 769
 770 #### Method: keywords
 771 # Keywords acts a bit differently.  Calling it in a list context
 772 # returns the list of keywords.
 773 # Calling it in a scalar context gives you the size of the list.
 774 ####
 775 'keywords' => <<'END_OF_FUNC',
 776 sub keywords {
 777     my($self,@values) = self_or_default(@_);
 778     # If values is provided, then we set it.
 779     $self->{'keywords'}=[@values] if defined(@values);
 780     my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
 781     @result;
 782 }
 783 END_OF_FUNC
 784
 785 # These are some tie() interfaces for compatibility
 786 # with Steve Brenner's cgi-lib.pl routines
 787 'ReadParse' => <<'END_OF_FUNC',
 788 sub ReadParse {
 789     local(*in);
 790     if (@_) {
 791         *in = $_[0];
 792     } else {
 793         my $pkg = caller();
 794         *in=*{"${pkg}::in"};
 795     }
 796     tie(%in,CGI);
 797     return scalar(keys %in);
 798 }
 799 END_OF_FUNC
 800
 801 'PrintHeader' => <<'END_OF_FUNC',
 802 sub PrintHeader {
 803     my($self) = self_or_default(@_);
 804     return $self->header();
 805 }
 806 END_OF_FUNC
 807
 808 'HtmlTop' => <<'END_OF_FUNC',
 809 sub HtmlTop {
 810     my($self,@p) = self_or_default(@_);
 811     return $self->start_html(@p);
 812 }
 813 END_OF_FUNC
 814
 815 'HtmlBot' => <<'END_OF_FUNC',
 816 sub HtmlBot {
 817     my($self,@p) = self_or_default(@_);
 818     return $self->end_html(@p);
 819 }
 820 END_OF_FUNC
 821
 822 'SplitParam' => <<'END_OF_FUNC',
 823 sub SplitParam {
 824     my ($param) = @_;
 825     my (@params) = split ("\0", $param);
 826     return (wantarray ? @params : $params[0]);
 827 }
 828 END_OF_FUNC
 829
 830 'MethGet' => <<'END_OF_FUNC',
 831 sub MethGet {
 832     return request_method() eq 'GET';
 833 }
 834 END_OF_FUNC
 835
 836 'MethPost' => <<'END_OF_FUNC',
 837 sub MethPost {
 838     return request_method() eq 'POST';
 839 }
 840 END_OF_FUNC
 841
 842 'TIEHASH' => <<'END_OF_FUNC',
 843 sub TIEHASH {
 844     return $Q || new CGI;
 845 }
 846 END_OF_FUNC
 847
 848 'STORE' => <<'END_OF_FUNC',
 849 sub STORE {
 850     $_[0]->param($_[1],split("\0",$_[2]));
 851 }
 852 END_OF_FUNC
 853
 854 'FETCH' => <<'END_OF_FUNC',
 855 sub FETCH {
 856     return $_[0] if $_[1] eq 'CGI';
 857     return undef unless defined $_[0]->param($_[1]);
 858     return join("\0",$_[0]->param($_[1]));
 859 }
 860 END_OF_FUNC
 861
 862 'FIRSTKEY' => <<'END_OF_FUNC',
 863 sub FIRSTKEY {
 864     $_[0]->{'.iterator'}=0;
 865     $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
 866 }
 867 END_OF_FUNC
 868
 869 'NEXTKEY' => <<'END_OF_FUNC',
 870 sub NEXTKEY {
 871     $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
 872 }
 873 END_OF_FUNC
 874
 875 'EXISTS' => <<'END_OF_FUNC',
 876 sub EXISTS {
 877     exists $_[0]->{$_[1]};
 878 }
 879 END_OF_FUNC
 880
 881 'DELETE' => <<'END_OF_FUNC',
 882 sub DELETE {
 883     $_[0]->delete($_[1]);
 884 }
 885 END_OF_FUNC
 886
 887 'CLEAR' => <<'END_OF_FUNC',
 888 sub CLEAR {
 889     %{$_[0]}=();
 890 }
 891 ####
 892 END_OF_FUNC
 893
 894 ####
 895 # Append a new value to an existing query
 896 ####
 897 'append' => <<'EOF',
 898 sub append {
 899     my($self,@p) = @_;
 900     my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
 901     my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
 902     if (@values) {
 903         $self->add_parameter($name);
 904         push(@{$self->{$name}},@values);
 905     }
 906     return $self->param($name);
 907 }
 908 EOF
 909
 910 #### Method: delete_all
 911 # Delete all parameters
 912 ####
 913 'delete_all' => <<'EOF',
 914 sub delete_all {
 915     my($self) = self_or_default(@_);
 916     undef %{$self};
 917 }
 918 EOF
 919
 920 'Delete' => <<'EOF',
 921 sub Delete {
 922     my($self,@p) = self_or_default(@_);
 923     $self->delete(@p);
 924 }
 925 EOF
 926
 927 'Delete_all' => <<'EOF',
 928 sub Delete_all {
 929     my($self,@p) = self_or_default(@_);
 930     $self->delete_all(@p);
 931 }
 932 EOF
 933
 934 #### Method: autoescape
 935 # If you want to turn off the autoescaping features,
 936 # call this method with undef as the argument
 937 'autoEscape' => <<'END_OF_FUNC',
 938 sub autoEscape {
 939     my($self,$escape) = self_or_default(@_);
 940     $self->{'dontescape'}=!$escape;
 941 }
 942 END_OF_FUNC
 943
 944
 945 #### Method: version
 946 # Return the current version
 947 ####
 948 'version' => <<'END_OF_FUNC',
 949 sub version {
 950     return $VERSION;
 951 }
 952 END_OF_FUNC
 953
 954 'make_attributes' => <<'END_OF_FUNC',
 955 sub make_attributes {
 956     my($self,$attr) = @_;
 957     return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
 958     my(@att);
 959     foreach (keys %{$attr}) {
 960         my($key) = $_;
 961         $key=~s/^\-//;     # get rid of initial - if present
 962         $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
 963         push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/);
 964     }
 965     return @att;
 966 }
 967 END_OF_FUNC
 968
 969 #### Method: url_param
 970 # Return a parameter in the QUERY_STRING, regardless of
 971 # whether this was a POST or a GET
 972 ####
 973 'url_param' => <<'END_OF_FUNC',
 974 sub url_param {
 975     my ($self,@p) = self_or_default(@_);
 976     my $name = shift(@p);
 977     return undef unless exists($ENV{QUERY_STRING});
 978     unless (exists($self->{'.url_param'})) {
 979         $self->{'.url_param'}={}; # empty hash
 980         if ($ENV{QUERY_STRING} =~ /=/) {
 981             my(@pairs) = split('&',$ENV{QUERY_STRING});
 982             my($param,$value);
 983             foreach (@pairs) {
 984                 ($param,$value) = split('=',$_,2);
 985                 $param = unescape($param);
 986                 $value = unescape($value);
 987                 push(@{$self->{'.url_param'}->{$param}},$value);
 988             }
 989         } else {
 990             $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
 991         }
 992     }
 993     return keys %{$self->{'.url_param'}} unless defined($name);
 994     return () unless $self->{'.url_param'}->{$name};
 995     return wantarray ? @{$self->{'.url_param'}->{$name}}
 996                      : $self->{'.url_param'}->{$name}->[0];
 997 }
 998 END_OF_FUNC
 999
1000 #### Method: dump
1001 # Returns a string in which all the known parameter/value
1002 # pairs are represented as nested lists, mainly for the purposes
1003 # of debugging.
1004 ####
1005 'dump' => <<'END_OF_FUNC',
1006 sub dump {
1007     my($self) = self_or_default(@_);
1008     my($param,$value,@result);
1009     return '<UL></UL>' unless $self->param;
1010     push(@result,"<UL>");
1011     foreach $param ($self->param) {
1012         my($name)=$self->escapeHTML($param);
1013         push(@result,"<LI><STRONG>$param</STRONG>");
1014         push(@result,"<UL>");
1015         foreach $value ($self->param($param)) {
1016             $value = $self->escapeHTML($value);
1017             push(@result,"<LI>$value");
1018         }
1019         push(@result,"</UL>");
1020     }
1021     push(@result,"</UL>\n");
1022     return join("\n",@result);
1023 }
1024 END_OF_FUNC
1025
1026 #### Method as_string
1027 #
1028 # synonym for "dump"
1029 ####
1030 'as_string' => <<'END_OF_FUNC',
1031 sub as_string {
1032     &dump(@_);
1033 }
1034 END_OF_FUNC
1035
1036 #### Method: save
1037 # Write values out to a filehandle in such a way that they can
1038 # be reinitialized by the filehandle form of the new() method
1039 ####
1040 'save' => <<'END_OF_FUNC',
1041 sub save {
1042     my($self,$filehandle) = self_or_default(@_);
1043     $filehandle = to_filehandle($filehandle);
1044     my($param);
1045     local($,) = '';  # set print field separator back to a sane value
1046     foreach $param ($self->param) {
1047         my($escaped_param) = escape($param);
1048         my($value);
1049         foreach $value ($self->param($param)) {
1050             print $filehandle "$escaped_param=",escape($value),"\n";
1051         }
1052     }
1053     print $filehandle "=\n";    # end of record
1054 }
1055 END_OF_FUNC
1056
1057
1058 #### Method: save_parameters
1059 # An alias for save() that is a better name for exportation.
1060 # Only intended to be used with the function (non-OO) interface.
1061 ####
1062 'save_parameters' => <<'END_OF_FUNC',
1063 sub save_parameters {
1064     my $fh = shift;
1065     return save(to_filehandle($fh));
1066 }
1067 END_OF_FUNC
1068
1069 #### Method: restore_parameters
1070 # A way to restore CGI parameters from an initializer.
1071 # Only intended to be used with the function (non-OO) interface.
1072 ####
1073 'restore_parameters' => <<'END_OF_FUNC',
1074 sub restore_parameters {
1075     $Q = $CGI::DefaultClass->new(@_);
1076 }
1077 END_OF_FUNC
1078
1079 #### Method: multipart_init
1080 # Return a Content-Type: style header for server-push
1081 # This has to be NPH, and it is advisable to set $| = 1
1082 #
1083 # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1084 # contribution
1085 ####
1086 'multipart_init' => <<'END_OF_FUNC',
1087 sub multipart_init {
1088     my($self,@p) = self_or_default(@_);
1089     my($boundary,@other) = $self->rearrange([BOUNDARY],@p);
1090     $boundary = $boundary || '------- =_aaaaaaaaaa0';
1091     $self->{'separator'} = "\n--$boundary\n";
1092     $type = SERVER_PUSH($boundary);
1093     return $self->header(
1094         -nph => 1,
1095         -type => $type,
1096         (map { split "=", $_, 2 } @other),
1097     ) . $self->multipart_end;
1098 }
1099 END_OF_FUNC
1100
1101
1102 #### Method: multipart_start
1103 # Return a Content-Type: style header for server-push, start of section
1104 #
1105 # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1106 # contribution
1107 ####
1108 'multipart_start' => <<'END_OF_FUNC',
1109 sub multipart_start {
1110     my($self,@p) = self_or_default(@_);
1111     my($type,@other) = $self->rearrange([TYPE],@p);
1112     $type = $type || 'text/html';
1113     return $self->header(
1114         -type => $type,
1115         (map { split "=", $_, 2 } @other),
1116     );
1117 }
1118 END_OF_FUNC
1119
1120
1121 #### Method: multipart_end
1122 # Return a Content-Type: style header for server-push, end of section
1123 #
1124 # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1125 # contribution
1126 ####
1127 'multipart_end' => <<'END_OF_FUNC',
1128 sub multipart_end {
1129     my($self,@p) = self_or_default(@_);
1130     return $self->{'separator'};
1131 }
1132 END_OF_FUNC
1133
1134
1135 #### Method: header
1136 # Return a Content-Type: style header
1137 #
1138 ####
1139 'header' => <<'END_OF_FUNC',
1140 sub header {
1141     my($self,@p) = self_or_default(@_);
1142     my(@header);
1143
1144     my($type,$status,$cookie,$target,$expires,$nph,@other) =
1145         $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
1146
1147     $nph ||= $NPH;
1148     # rearrange() was designed for the HTML portion, so we
1149     # need to fix it up a little.
1150     foreach (@other) {
1151         next unless my($header,$value) = /([^\s=]+)=\"?([^\"]+)\"?/;
1152         ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e;
1153     }
1154
1155     $type = $type || 'text/html';
1156
1157     # Maybe future compatibility.  Maybe not.
1158     my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
1159     push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
1160
1161     push(@header,"Status: $status") if $status;
1162     push(@header,"Window-Target: $target") if $target;
1163     # push all the cookies -- there may be several
1164     if ($cookie) {
1165         my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
1166         foreach (@cookie) {
1167             push(@header,"Set-Cookie: " . (UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_));
1168         }
1169     }
1170     # if the user indicates an expiration time, then we need
1171     # both an Expires and a Date header (so that the browser is
1172     # uses OUR clock)
1173     push(@header,"Expires: " . expires($expires,'http'))
1174         if $expires;
1175     push(@header,"Date: " . expires(0,'http')) if $expires || $cookie;
1176     push(@header,"Pragma: no-cache") if $self->cache();
1177     push(@header,@other);
1178     push(@header,"Content-Type: $type");
1179
1180     my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1181     if ($MOD_PERL and not $nph) {
1182         my $r = Apache->request;
1183         $r->send_cgi_header($header);
1184         return '';
1185     }
1186     return $header;
1187 }
1188 END_OF_FUNC
1189
1190
1191 #### Method: cache
1192 # Control whether header() will produce the no-cache
1193 # Pragma directive.
1194 ####
1195 'cache' => <<'END_OF_FUNC',
1196 sub cache {
1197     my($self,$new_value) = self_or_default(@_);
1198     $new_value = '' unless $new_value;
1199     if ($new_value ne '') {
1200         $self->{'cache'} = $new_value;
1201     }
1202     return $self->{'cache'};
1203 }
1204 END_OF_FUNC
1205
1206
1207 #### Method: redirect
1208 # Return a Location: style header
1209 #
1210 ####
1211 'redirect' => <<'END_OF_FUNC',
1212 sub redirect {
1213     my($self,@p) = self_or_default(@_);
1214     my($url,$target,$cookie,$nph,@other) = $self->rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p);
1215     $url = $url || $self->self_url;
1216     my(@o);
1217     foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
1218     unshift(@o,
1219          '-Status'=>'302 Moved',
1220          '-Location'=>$url,
1221          '-nph'=>$nph);
1222     unshift(@o,'-Target'=>$target) if $target;
1223     unshift(@o,'-Cookie'=>$cookie) if $cookie;
1224     return $self->header(@o);
1225 }
1226 END_OF_FUNC
1227
1228
1229 #### Method: start_html
1230 # Canned HTML header
1231 #
1232 # Parameters:
1233 # $title -> (optional) The title for this HTML document (-title)
1234 # $author -> (optional) e-mail address of the author (-author)
1235 # $base -> (optional) if set to true, will enter the BASE address of this document
1236 #          for resolving relative references (-base)
1237 # $xbase -> (optional) alternative base at some remote location (-xbase)
1238 # $target -> (optional) target window to load all links into (-target)
1239 # $script -> (option) Javascript code (-script)
1240 # $no_script -> (option) Javascript <noscript> tag (-noscript)
1241 # $meta -> (optional) Meta information tags
1242 # $head -> (optional) any other elements you'd like to incorporate into the <HEAD> tag
1243 #           (a scalar or array ref)
1244 # $style -> (optional) reference to an external style sheet
1245 # @other -> (optional) any other named parameters you'd like to incorporate into
1246 #           the <BODY> tag.
1247 ####
1248 'start_html' => <<'END_OF_FUNC',
1249 sub start_html {
1250     my($self,@p) = &self_or_default(@_);
1251     my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,@other) =
1252         $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD],@p);
1253
1254     # strangely enough, the title needs to be escaped as HTML
1255     # while the author needs to be escaped as a URL
1256     $title = $self->escapeHTML($title || 'Untitled Document');
1257     $author = $self->escape($author);
1258     my(@result);
1259     $dtd = $DEFAULT_DTD unless $dtd && $dtd =~ m|^-//|;
1260     push(@result,qq(<!DOCTYPE HTML PUBLIC "$dtd">)) if $dtd;
1261     push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
1262     push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if defined $author;
1263
1264     if ($base || $xbase || $target) {
1265         my $href = $xbase || $self->url('-path'=>1);
1266         my $t = $target ? qq/ TARGET="$target"/ : '';
1267         push(@result,qq/<BASE HREF="$href"$t>/);
1268     }
1269
1270     if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
1271         foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
1272     }
1273
1274     push(@result,ref($head) ? @$head : $head) if $head;
1275
1276     # handle the infrequently-used -style and -script parameters
1277     push(@result,$self->_style($style)) if defined $style;
1278     push(@result,$self->_script($script)) if defined $script;
1279
1280     # handle -noscript parameter
1281     push(@result,<<END) if $noscript;
1282 <NOSCRIPT>
1283 $noscript
1284 </NOSCRIPT>
1285 END
1286     ;
1287     my($other) = @other ? " @other" : '';
1288     push(@result,"</HEAD><BODY$other>");
1289     return join("\n",@result);
1290 }
1291 END_OF_FUNC
1292
1293 ### Method: _style
1294 # internal method for generating a CSS style section
1295 ####
1296 '_style' => <<'END_OF_FUNC',
1297 sub _style {
1298     my ($self,$style) = @_;
1299     my (@result);
1300     my $type = 'text/css';
1301     if (ref($style)) {
1302         my($src,$code,$stype,@other) =
1303             $self->rearrange([SRC,CODE,TYPE],
1304                              '-foo'=>'bar',     # a trick to allow the '-' to be omitted
1305                              ref($style) eq 'ARRAY' ? @$style : %$style);
1306         $type = $stype if $stype;
1307         push(@result,qq/<LINK REL="stylesheet" HREF="$src">/) if $src;
1308         push(@result,style({'type'=>$type},"<!--\n$code\n-->")) if $code;
1309     } else {
1310         push(@result,style({'type'=>$type},"<!--\n$style\n-->"));
1311     }
1312     @result;
1313 }
1314 END_OF_FUNC
1315
1316
1317 '_script' => <<'END_OF_FUNC',
1318 sub _script {
1319     my ($self,$script) = @_;
1320     my (@result);
1321     my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
1322     foreach $script (@scripts) {
1323         my($src,$code,$language);
1324         if (ref($script)) { # script is a hash
1325             ($src,$code,$language) =
1326                 $self->rearrange([SRC,CODE,LANGUAGE],
1327                                  '-foo'=>'bar', # a trick to allow the '-' to be omitted
1328                                  ref($style) eq 'ARRAY' ? @$script : %$script);
1329
1330         } else {
1331             ($src,$code,$language) = ('',$script,'JavaScript');
1332         }
1333         my(@satts);
1334         push(@satts,'src'=>$src) if $src;
1335         push(@satts,'language'=>$language || 'JavaScript');
1336         $code = "<!-- Hide script\n$code\n// End script hiding -->"
1337             if $code && $language=~/javascript/i;
1338         $code = "<!-- Hide script\n$code\n\# End script hiding -->"
1339             if $code && $language=~/perl/i;
1340         push(@result,script({@satts},$code));
1341     }
1342     @result;
1343 }
1344 END_OF_FUNC
1345
1346 #### Method: end_html
1347 # End an HTML document.
1348 # Trivial method for completeness.  Just returns "</BODY>"
1349 ####
1350 'end_html' => <<'END_OF_FUNC',
1351 sub end_html {
1352     return "</BODY></HTML>";
1353 }
1354 END_OF_FUNC
1355
1356
1357 ################################
1358 # METHODS USED IN BUILDING FORMS
1359 ################################
1360
1361 #### Method: isindex
1362 # Just prints out the isindex tag.
1363 # Parameters:
1364 #  $action -> optional URL of script to run
1365 # Returns:
1366 #   A string containing a <ISINDEX> tag
1367 'isindex' => <<'END_OF_FUNC',
1368 sub isindex {
1369     my($self,@p) = self_or_default(@_);
1370     my($action,@other) = $self->rearrange([ACTION],@p);
1371     $action = qq/ACTION="$action"/ if $action;
1372     my($other) = @other ? " @other" : '';
1373     return "<ISINDEX $action$other>";
1374 }
1375 END_OF_FUNC
1376
1377
1378 #### Method: startform
1379 # Start a form
1380 # Parameters:
1381 #   $method -> optional submission method to use (GET or POST)
1382 #   $action -> optional URL of script to run
1383 #   $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1384 'startform' => <<'END_OF_FUNC',
1385 sub startform {
1386     my($self,@p) = self_or_default(@_);
1387
1388     my($method,$action,$enctype,@other) =
1389         $self->rearrange([METHOD,ACTION,ENCTYPE],@p);
1390
1391     $method = $method || 'POST';
1392     $enctype = $enctype || &URL_ENCODED;
1393     $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
1394         'ACTION="'.$self->script_name.'"' : '';
1395     my($other) = @other ? " @other" : '';
1396     $self->{'.parametersToAdd'}={};
1397     return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
1398 }
1399 END_OF_FUNC
1400
1401
1402 #### Method: start_form
1403 # synonym for startform
1404 'start_form' => <<'END_OF_FUNC',
1405 sub start_form {
1406     &startform;
1407 }
1408 END_OF_FUNC
1409
1410
1411 #### Method: start_multipart_form
1412 # synonym for startform
1413 'start_multipart_form' => <<'END_OF_FUNC',
1414 sub start_multipart_form {
1415     my($self,@p) = self_or_default(@_);
1416     if ($self->use_named_parameters ||
1417         (defined($param[0]) && substr($param[0],0,1) eq '-')) {
1418         my(%p) = @p;
1419         $p{'-enctype'}=&MULTIPART;
1420         return $self->startform(%p);
1421     } else {
1422         my($method,$action,@other) =
1423             $self->rearrange([METHOD,ACTION],@p);
1424         return $self->startform($method,$action,&MULTIPART,@other);
1425     }
1426 }
1427 END_OF_FUNC
1428
1429
1430 #### Method: endform
1431 # End a form
1432 'endform' => <<'END_OF_FUNC',
1433 sub endform {
1434     my($self,@p) = self_or_default(@_);
1435     return ($self->get_fields,"</FORM>");
1436 }
1437 END_OF_FUNC
1438
1439
1440 #### Method: end_form
1441 # synonym for endform
1442 'end_form' => <<'END_OF_FUNC',
1443 sub end_form {
1444     &endform;
1445 }
1446 END_OF_FUNC
1447
1448
1449 '_textfield' => <<'END_OF_FUNC',
1450 sub _textfield {
1451     my($self,$tag,@p) = self_or_default(@_);
1452     my($name,$default,$size,$maxlength,$override,@other) =
1453         $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1454
1455     my $current = $override ? $default :
1456         (defined($self->param($name)) ? $self->param($name) : $default);
1457
1458     $current = defined($current) ? $self->escapeHTML($current) : '';
1459     $name = defined($name) ? $self->escapeHTML($name) : '';
1460     my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1461     my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
1462     my($other) = @other ? " @other" : '';
1463     return qq/<INPUT TYPE="$tag" NAME="$name" VALUE="$current"$s$m$other>/;
1464 }
1465 END_OF_FUNC
1466
1467 #### Method: textfield
1468 # Parameters:
1469 #   $name -> Name of the text field
1470 #   $default -> Optional default value of the field if not
1471 #                already defined.
1472 #   $size ->  Optional width of field in characaters.
1473 #   $maxlength -> Optional maximum number of characters.
1474 # Returns:
1475 #   A string containing a <INPUT TYPE="text"> field
1476 #
1477 'textfield' => <<'END_OF_FUNC',
1478 sub textfield {
1479     my($self,@p) = self_or_default(@_);
1480     $self->_textfield('text',@p);
1481 }
1482 END_OF_FUNC
1483
1484
1485 #### Method: filefield
1486 # Parameters:
1487 #   $name -> Name of the file upload field
1488 #   $size ->  Optional width of field in characaters.
1489 #   $maxlength -> Optional maximum number of characters.
1490 # Returns:
1491 #   A string containing a <INPUT TYPE="text"> field
1492 #
1493 'filefield' => <<'END_OF_FUNC',
1494 sub filefield {
1495     my($self,@p) = self_or_default(@_);
1496     $self->_textfield('file',@p);
1497 }
1498 END_OF_FUNC
1499
1500
1501 #### Method: password
1502 # Create a "secret password" entry field
1503 # Parameters:
1504 #   $name -> Name of the field
1505 #   $default -> Optional default value of the field if not
1506 #                already defined.
1507 #   $size ->  Optional width of field in characters.
1508 #   $maxlength -> Optional maximum characters that can be entered.
1509 # Returns:
1510 #   A string containing a <INPUT TYPE="password"> field
1511 #
1512 'password_field' => <<'END_OF_FUNC',
1513 sub password_field {
1514     my ($self,@p) = self_or_default(@_);
1515     $self->_textfield('password',@p);
1516 }
1517 END_OF_FUNC
1518
1519 #### Method: textarea
1520 # Parameters:
1521 #   $name -> Name of the text field
1522 #   $default -> Optional default value of the field if not
1523 #                already defined.
1524 #   $rows ->  Optional number of rows in text area
1525 #   $columns -> Optional number of columns in text area
1526 # Returns:
1527 #   A string containing a <TEXTAREA></TEXTAREA> tag
1528 #
1529 'textarea' => <<'END_OF_FUNC',
1530 sub textarea {
1531     my($self,@p) = self_or_default(@_);
1532
1533     my($name,$default,$rows,$cols,$override,@other) =
1534         $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
1535
1536     my($current)= $override ? $default :
1537         (defined($self->param($name)) ? $self->param($name) : $default);
1538
1539     $name = defined($name) ? $self->escapeHTML($name) : '';
1540     $current = defined($current) ? $self->escapeHTML($current) : '';
1541     my($r) = $rows ? " ROWS=$rows" : '';
1542     my($c) = $cols ? " COLS=$cols" : '';
1543     my($other) = @other ? " @other" : '';
1544     return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
1545 }
1546 END_OF_FUNC
1547
1548
1549 #### Method: button
1550 # Create a javascript button.
1551 # Parameters:
1552 #   $name ->  (optional) Name for the button. (-name)
1553 #   $value -> (optional) Value of the button when selected (and visible name) (-value)
1554 #   $onclick -> (optional) Text of the JavaScript to run when the button is
1555 #                clicked.
1556 # Returns:
1557 #   A string containing a <INPUT TYPE="button"> tag
1558 ####
1559 'button' => <<'END_OF_FUNC',
1560 sub button {
1561     my($self,@p) = self_or_default(@_);
1562
1563     my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
1564                                                          [ONCLICK,SCRIPT]],@p);
1565
1566     $label=$self->escapeHTML($label);
1567     $value=$self->escapeHTML($value);
1568     $script=$self->escapeHTML($script);
1569
1570     my($name) = '';
1571     $name = qq/ NAME="$label"/ if $label;
1572     $value = $value || $label;
1573     my($val) = '';
1574     $val = qq/ VALUE="$value"/ if $value;
1575     $script = qq/ ONCLICK="$script"/ if $script;
1576     my($other) = @other ? " @other" : '';
1577     return qq/<INPUT TYPE="button"$name$val$script$other>/;
1578 }
1579 END_OF_FUNC
1580
1581
1582 #### Method: submit
1583 # Create a "submit query" button.
1584 # Parameters:
1585 #   $name ->  (optional) Name for the button.
1586 #   $value -> (optional) Value of the button when selected (also doubles as label).
1587 #   $label -> (optional) Label printed on the button(also doubles as the value).
1588 # Returns:
1589 #   A string containing a <INPUT TYPE="submit"> tag
1590 ####
1591 'submit' => <<'END_OF_FUNC',
1592 sub submit {
1593     my($self,@p) = self_or_default(@_);
1594
1595     my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p);
1596
1597     $label=$self->escapeHTML($label);
1598     $value=$self->escapeHTML($value);
1599
1600     my($name) = ' NAME=".submit"';
1601     $name = qq/ NAME="$label"/ if defined($label);
1602     $value = defined($value) ? $value : $label;
1603     my($val) = '';
1604     $val = qq/ VALUE="$value"/ if defined($value);
1605     my($other) = @other ? " @other" : '';
1606     return qq/<INPUT TYPE="submit"$name$val$other>/;
1607 }
1608 END_OF_FUNC
1609
1610
1611 #### Method: reset
1612 # Create a "reset" button.
1613 # Parameters:
1614 #   $name -> (optional) Name for the button.
1615 # Returns:
1616 #   A string containing a <INPUT TYPE="reset"> tag
1617 ####
1618 'reset' => <<'END_OF_FUNC',
1619 sub reset {
1620     my($self,@p) = self_or_default(@_);
1621     my($label,@other) = $self->rearrange([NAME],@p);
1622     $label=$self->escapeHTML($label);
1623     my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
1624     my($other) = @other ? " @other" : '';
1625     return qq/<INPUT TYPE="reset"$value$other>/;
1626 }
1627 END_OF_FUNC
1628
1629
1630 #### Method: defaults
1631 # Create a "defaults" button.
1632 # Parameters:
1633 #   $name -> (optional) Name for the button.
1634 # Returns:
1635 #   A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
1636 #
1637 # Note: this button has a special meaning to the initialization script,
1638 # and tells it to ERASE the current query string so that your defaults
1639 # are used again!
1640 ####
1641 'defaults' => <<'END_OF_FUNC',
1642 sub defaults {
1643     my($self,@p) = self_or_default(@_);
1644
1645     my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
1646
1647     $label=$self->escapeHTML($label);
1648     $label = $label || "Defaults";
1649     my($value) = qq/ VALUE="$label"/;
1650     my($other) = @other ? " @other" : '';
1651     return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
1652 }
1653 END_OF_FUNC
1654
1655
1656 #### Method: comment
1657 # Create an HTML <!-- comment -->
1658 # Parameters: a string
1659 'comment' => <<'END_OF_FUNC',
1660 sub comment {
1661     my($self,@p) = self_or_CGI(@_);
1662     return "<!-- @p -->";
1663 }
1664 END_OF_FUNC
1665
1666 #### Method: checkbox
1667 # Create a checkbox that is not logically linked to any others.
1668 # The field value is "on" when the button is checked.
1669 # Parameters:
1670 #   $name -> Name of the checkbox
1671 #   $checked -> (optional) turned on by default if true
1672 #   $value -> (optional) value of the checkbox, 'on' by default
1673 #   $label -> (optional) a user-readable label printed next to the box.
1674 #             Otherwise the checkbox name is used.
1675 # Returns:
1676 #   A string containing a <INPUT TYPE="checkbox"> field
1677 ####
1678 'checkbox' => <<'END_OF_FUNC',
1679 sub checkbox {
1680     my($self,@p) = self_or_default(@_);
1681
1682     my($name,$checked,$value,$label,$override,@other) =
1683         $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
1684
1685     $value = defined $value ? $value : 'on';
1686
1687     if (!$override && ($self->{'.fieldnames'}->{$name} ||
1688                        defined $self->param($name))) {
1689         $checked = grep($_ eq $value,$self->param($name)) ? ' CHECKED' : '';
1690     } else {
1691         $checked = $checked ? ' CHECKED' : '';
1692     }
1693     my($the_label) = defined $label ? $label : $name;
1694     $name = $self->escapeHTML($name);
1695     $value = $self->escapeHTML($value);
1696     $the_label = $self->escapeHTML($the_label);
1697     my($other) = @other ? " @other" : '';
1698     $self->register_parameter($name);
1699     return <<END;
1700 <INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label
1701 END
1702 }
1703 END_OF_FUNC
1704
1705
1706 #### Method: checkbox_group
1707 # Create a list of logically-linked checkboxes.
1708 # Parameters:
1709 #   $name -> Common name for all the check boxes
1710 #   $values -> A pointer to a regular array containing the
1711 #             values for each checkbox in the group.
1712 #   $defaults -> (optional)
1713 #             1. If a pointer to a regular array of checkbox values,
1714 #             then this will be used to decide which
1715 #             checkboxes to turn on by default.
1716 #             2. If a scalar, will be assumed to hold the
1717 #             value of a single checkbox in the group to turn on.
1718 #   $linebreak -> (optional) Set to true to place linebreaks
1719 #             between the buttons.
1720 #   $labels -> (optional)
1721 #             A pointer to an associative array of labels to print next to each checkbox
1722 #             in the form $label{'value'}="Long explanatory label".
1723 #             Otherwise the provided values are used as the labels.
1724 # Returns:
1725 #   An ARRAY containing a series of <INPUT TYPE="checkbox"> fields
1726 ####
1727 'checkbox_group' => <<'END_OF_FUNC',
1728 sub checkbox_group {
1729     my($self,@p) = self_or_default(@_);
1730
1731     my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
1732        $rowheaders,$colheaders,$override,$nolabels,@other) =
1733         $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1734                           LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
1735                           ROWHEADERS,COLHEADERS,
1736                           [OVERRIDE,FORCE],NOLABELS],@p);
1737
1738     my($checked,$break,$result,$label);
1739
1740     my(%checked) = $self->previous_or_default($name,$defaults,$override);
1741
1742     $break = $linebreak ? "<BR>" : '';
1743     $name=$self->escapeHTML($name);
1744
1745     # Create the elements
1746     my(@elements,@values);
1747
1748     @values = $self->_set_values_and_labels($values,\$labels,$name);
1749
1750     my($other) = @other ? " @other" : '';
1751     foreach (@values) {
1752         $checked = $checked{$_} ? ' CHECKED' : '';
1753         $label = '';
1754         unless (defined($nolabels) && $nolabels) {
1755             $label = $_;
1756             $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1757             $label = $self->escapeHTML($label);
1758         }
1759         $_ = $self->escapeHTML($_);
1760         push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label}${break}/);
1761     }
1762     $self->register_parameter($name);
1763     return wantarray ? @elements : join(' ',@elements)
1764         unless defined($columns) || defined($rows);
1765     return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1766 }
1767 END_OF_FUNC
1768
1769 # Escape HTML -- used internally
1770 'escapeHTML' => <<'END_OF_FUNC',
1771 sub escapeHTML {
1772     my($self,$toencode) = @_;
1773     $toencode = $self unless ref($self);
1774     return undef unless defined($toencode);
1775     return $toencode if ref($self) && $self->{'dontescape'};
1776
1777     $toencode=~s/&/&amp;/g;
1778     $toencode=~s/\"/&quot;/g;
1779     $toencode=~s/>/&gt;/g;
1780     $toencode=~s/</&lt;/g;
1781     return $toencode;
1782 }
1783 END_OF_FUNC
1784
1785 # unescape HTML -- used internally
1786 'unescapeHTML' => <<'END_OF_FUNC',
1787 sub unescapeHTML {
1788     my $string = ref($_[0]) ? $_[1] : $_[0];
1789     return undef unless defined($string);
1790     $string=~s/&amp;/&/ig;
1791     $string=~s/&quot;/\"/ig;
1792     $string=~s/&gt;/>/ig;
1793     $string=~s/&lt;/</ig;
1794     $string=~s/&#(\d+);/chr($1)/eg;
1795     $string=~s/&#[xX]([0-9a-fA-F]);/chr(hex($1))/eg;
1796     return $string;
1797 }
1798 END_OF_FUNC
1799
1800 # Internal procedure - don't use
1801 '_tableize' => <<'END_OF_FUNC',
1802 sub _tableize {
1803     my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
1804     my($result);
1805
1806     if (defined($columns)) {
1807         $rows = int(0.99 + @elements/$columns) unless defined($rows);
1808     }
1809     if (defined($rows)) {
1810         $columns = int(0.99 + @elements/$rows) unless defined($columns);
1811     }
1812
1813     # rearrange into a pretty table
1814     $result = "<TABLE>";
1815     my($row,$column);
1816     unshift(@$colheaders,'') if defined(@$colheaders) && defined(@$rowheaders);
1817     $result .= "<TR>" if defined(@{$colheaders});
1818     foreach (@{$colheaders}) {
1819         $result .= "<TH>$_</TH>";
1820     }
1821     for ($row=0;$row<$rows;$row++) {
1822         $result .= "<TR>";
1823         $result .= "<TH>$rowheaders->[$row]</TH>" if defined(@$rowheaders);
1824         for ($column=0;$column<$columns;$column++) {
1825             $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>"
1826                 if defined($elements[$column*$rows + $row]);
1827         }
1828         $result .= "</TR>";
1829     }
1830     $result .= "</TABLE>";
1831     return $result;
1832 }
1833 END_OF_FUNC
1834
1835
1836 #### Method: radio_group
1837 # Create a list of logically-linked radio buttons.
1838 # Parameters:
1839 #   $name -> Common name for all the buttons.
1840 #   $values -> A pointer to a regular array containing the
1841 #             values for each button in the group.
1842 #   $default -> (optional) Value of the button to turn on by default.  Pass '-'
1843 #               to turn _nothing_ on.
1844 #   $linebreak -> (optional) Set to true to place linebreaks
1845 #             between the buttons.
1846 #   $labels -> (optional)
1847 #             A pointer to an associative array of labels to print next to each checkbox
1848 #             in the form $label{'value'}="Long explanatory label".
1849 #             Otherwise the provided values are used as the labels.
1850 # Returns:
1851 #   An ARRAY containing a series of <INPUT TYPE="radio"> fields
1852 ####
1853 'radio_group' => <<'END_OF_FUNC',
1854 sub radio_group {
1855     my($self,@p) = self_or_default(@_);
1856
1857     my($name,$values,$default,$linebreak,$labels,
1858        $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
1859         $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
1860                           ROWS,[COLUMNS,COLS],
1861                           ROWHEADERS,COLHEADERS,
1862                           [OVERRIDE,FORCE],NOLABELS],@p);
1863     my($result,$checked);
1864
1865     if (!$override && defined($self->param($name))) {
1866         $checked = $self->param($name);
1867     } else {
1868         $checked = $default;
1869     }
1870     # If no check array is specified, check the first by default
1871     $checked = $values->[0] unless defined($checked) && $checked ne '';
1872     $name=$self->escapeHTML($name);
1873
1874     my(@elements,@values);
1875
1876     @values = $self->_set_values_and_labels($values,\$labels,$name);
1877
1878     my($other) = @other ? " @other" : '';
1879     foreach (@values) {
1880         my($checkit) = $checked eq $_ ? ' CHECKED' : '';
1881         my($break) = $linebreak ? '<BR>' : '';
1882         my($label)='';
1883         unless (defined($nolabels) && $nolabels) {
1884             $label = $_;
1885             $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1886             $label = $self->escapeHTML($label);
1887         }
1888         $_=$self->escapeHTML($_);
1889         push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label}${break}/);
1890     }
1891     $self->register_parameter($name);
1892     return wantarray ? @elements : join(' ',@elements)
1893            unless defined($columns) || defined($rows);
1894     return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1895 }
1896 END_OF_FUNC
1897
1898
1899 #### Method: popup_menu
1900 # Create a popup menu.
1901 # Parameters:
1902 #   $name -> Name for all the menu
1903 #   $values -> A pointer to a regular array containing the
1904 #             text of each menu item.
1905 #   $default -> (optional) Default item to display
1906 #   $labels -> (optional)
1907 #             A pointer to an associative array of labels to print next to each checkbox
1908 #             in the form $label{'value'}="Long explanatory label".
1909 #             Otherwise the provided values are used as the labels.
1910 # Returns:
1911 #   A string containing the definition of a popup menu.
1912 ####
1913 'popup_menu' => <<'END_OF_FUNC',
1914 sub popup_menu {
1915     my($self,@p) = self_or_default(@_);
1916
1917     my($name,$values,$default,$labels,$override,@other) =
1918         $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
1919     my($result,$selected);
1920
1921     if (!$override && defined($self->param($name))) {
1922         $selected = $self->param($name);
1923     } else {
1924         $selected = $default;
1925     }
1926     $name=$self->escapeHTML($name);
1927     my($other) = @other ? " @other" : '';
1928
1929     my(@values);
1930     @values = $self->_set_values_and_labels($values,\$labels,$name);
1931
1932     $result = qq/<SELECT NAME="$name"$other>\n/;
1933     foreach (@values) {
1934         my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
1935         my($label) = $_;
1936         $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1937         my($value) = $self->escapeHTML($_);
1938         $label=$self->escapeHTML($label);
1939         $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
1940     }
1941
1942     $result .= "</SELECT>\n";
1943     return $result;
1944 }
1945 END_OF_FUNC
1946
1947
1948 #### Method: scrolling_list
1949 # Create a scrolling list.
1950 # Parameters:
1951 #   $name -> name for the list
1952 #   $values -> A pointer to a regular array containing the
1953 #             values for each option line in the list.
1954 #   $defaults -> (optional)
1955 #             1. If a pointer to a regular array of options,
1956 #             then this will be used to decide which
1957 #             lines to turn on by default.
1958 #             2. Otherwise holds the value of the single line to turn on.
1959 #   $size -> (optional) Size of the list.
1960 #   $multiple -> (optional) If set, allow multiple selections.
1961 #   $labels -> (optional)
1962 #             A pointer to an associative array of labels to print next to each checkbox
1963 #             in the form $label{'value'}="Long explanatory label".
1964 #             Otherwise the provided values are used as the labels.
1965 # Returns:
1966 #   A string containing the definition of a scrolling list.
1967 ####
1968 'scrolling_list' => <<'END_OF_FUNC',
1969 sub scrolling_list {
1970     my($self,@p) = self_or_default(@_);
1971     my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
1972         = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1973                             SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
1974
1975     my($result,@values);
1976     @values = $self->_set_values_and_labels($values,\$labels,$name);
1977
1978     $size = $size || scalar(@values);
1979
1980     my(%selected) = $self->previous_or_default($name,$defaults,$override);
1981     my($is_multiple) = $multiple ? ' MULTIPLE' : '';
1982     my($has_size) = $size ? " SIZE=$size" : '';
1983     my($other) = @other ? " @other" : '';
1984
1985     $name=$self->escapeHTML($name);
1986     $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
1987     foreach (@values) {
1988         my($selectit) = $selected{$_} ? 'SELECTED' : '';
1989         my($label) = $_;
1990         $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1991         $label=$self->escapeHTML($label);
1992         my($value)=$self->escapeHTML($_);
1993         $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
1994     }
1995     $result .= "</SELECT>\n";
1996     $self->register_parameter($name);
1997     return $result;
1998 }
1999 END_OF_FUNC
2000
2001
2002 #### Method: hidden
2003 # Parameters:
2004 #   $name -> Name of the hidden field
2005 #   @default -> (optional) Initial values of field (may be an array)
2006 #      or
2007 #   $default->[initial values of field]
2008 # Returns:
2009 #   A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
2010 ####
2011 'hidden' => <<'END_OF_FUNC',
2012 sub hidden {
2013     my($self,@p) = self_or_default(@_);
2014
2015     # this is the one place where we departed from our standard
2016     # calling scheme, so we have to special-case (darn)
2017     my(@result,@value);
2018     my($name,$default,$override,@other) =
2019         $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
2020
2021     my $do_override = 0;
2022     if ( ref($p[0]) || substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
2023         @value = ref($default) ? @{$default} : $default;
2024         $do_override = $override;
2025     } else {
2026         foreach ($default,$override,@other) {
2027             push(@value,$_) if defined($_);
2028         }
2029     }
2030
2031     # use previous values if override is not set
2032     my @prev = $self->param($name);
2033     @value = @prev if !$do_override && @prev;
2034
2035     $name=$self->escapeHTML($name);
2036     foreach (@value) {
2037         $_=$self->escapeHTML($_);
2038         push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
2039     }
2040     return wantarray ? @result : join('',@result);
2041 }
2042 END_OF_FUNC
2043
2044
2045 #### Method: image_button
2046 # Parameters:
2047 #   $name -> Name of the button
2048 #   $src ->  URL of the image source
2049 #   $align -> Alignment style (TOP, BOTTOM or MIDDLE)
2050 # Returns:
2051 #   A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment">
2052 ####
2053 'image_button' => <<'END_OF_FUNC',
2054 sub image_button {
2055     my($self,@p) = self_or_default(@_);
2056
2057     my($name,$src,$alignment,@other) =
2058         $self->rearrange([NAME,SRC,ALIGN],@p);
2059
2060     my($align) = $alignment ? " ALIGN=\U$alignment" : '';
2061     my($other) = @other ? " @other" : '';
2062     $name=$self->escapeHTML($name);
2063     return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/;
2064 }
2065 END_OF_FUNC
2066
2067
2068 #### Method: self_url
2069 # Returns a URL containing the current script and all its
2070 # param/value pairs arranged as a query.  You can use this
2071 # to create a link that, when selected, will reinvoke the
2072 # script with all its state information preserved.
2073 ####
2074 'self_url' => <<'END_OF_FUNC',
2075 sub self_url {
2076     my($self,@p) = self_or_default(@_);
2077     return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
2078 }
2079 END_OF_FUNC
2080
2081
2082 # This is provided as a synonym to self_url() for people unfortunate
2083 # enough to have incorporated it into their programs already!
2084 'state' => <<'END_OF_FUNC',
2085 sub state {
2086     &self_url;
2087 }
2088 END_OF_FUNC
2089
2090
2091 #### Method: url
2092 # Like self_url, but doesn't return the query string part of
2093 # the URL.
2094 ####
2095 'url' => <<'END_OF_FUNC',
2096 sub url {
2097     my($self,@p) = self_or_default(@_);
2098     my ($relative,$absolute,$full,$path_info,$query) =
2099         $self->rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING']],@p);
2100     my $url;
2101     $full++ if !($relative || $absolute);
2102
2103     if ($full) {
2104         my $protocol = $self->protocol();
2105         $url = "$protocol://";
2106         my $vh = http('host');
2107         if ($vh) {
2108             $url .= $vh;
2109         } else {
2110             $url .= server_name();
2111             my $port = $self->server_port;
2112             $url .= ":" . $port
2113                 unless (lc($protocol) eq 'http' && $port == 80)
2114                     || (lc($protocol) eq 'https' && $port == 443);
2115         }
2116         $url .= $self->script_name;
2117     } elsif ($relative) {
2118         ($url) = $self->script_name =~ m!([^/]+)$!;
2119     } elsif ($absolute) {
2120         $url = $self->script_name;
2121     }
2122     $url .= $self->path_info if $path_info and $self->path_info;
2123     $url .= "?" . $self->query_string if $query and $self->query_string;
2124     return $url;
2125 }
2126
2127 END_OF_FUNC
2128
2129 #### Method: cookie
2130 # Set or read a cookie from the specified name.
2131 # Cookie can then be passed to header().
2132 # Usual rules apply to the stickiness of -value.
2133 #  Parameters:
2134 #   -name -> name for this cookie (optional)
2135 #   -value -> value of this cookie (scalar, array or hash)
2136 #   -path -> paths for which this cookie is valid (optional)
2137 #   -domain -> internet domain in which this cookie is valid (optional)
2138 #   -secure -> if true, cookie only passed through secure channel (optional)
2139 #   -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
2140 ####
2141 'cookie' => <<'END_OF_FUNC',
2142 sub cookie {
2143     my($self,@p) = self_or_default(@_);
2144     my($name,$value,$path,$domain,$secure,$expires) =
2145         $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
2146
2147     require CGI::Cookie;
2148
2149     # if no value is supplied, then we retrieve the
2150     # value of the cookie, if any.  For efficiency, we cache the parsed
2151     # cookies in our state variables.
2152     unless ( defined($value) ) {
2153         $self->{'.cookies'} = CGI::Cookie->fetch
2154             unless $self->{'.cookies'};
2155
2156         # If no name is supplied, then retrieve the names of all our cookies.
2157         return () unless $self->{'.cookies'};
2158         return keys %{$self->{'.cookies'}} unless $name;
2159         return () unless $self->{'.cookies'}->{$name};
2160         return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
2161     }
2162
2163     # If we get here, we're creating a new cookie
2164     return undef unless $name;  # this is an error
2165
2166     my @param;
2167     push(@param,'-name'=>$name);
2168     push(@param,'-value'=>$value);
2169     push(@param,'-domain'=>$domain) if $domain;
2170     push(@param,'-path'=>$path) if $path;
2171     push(@param,'-expires'=>$expires) if $expires;
2172     push(@param,'-secure'=>$secure) if $secure;
2173
2174     return new CGI::Cookie(@param);
2175 }
2176 END_OF_FUNC
2177
2178 # This internal routine creates an expires time exactly some number of
2179 # hours from the current time.  It incorporates modifications from
2180 # Mark Fisher.
2181 'expire_calc' => <<'END_OF_FUNC',
2182 sub expire_calc {
2183     my($time) = @_;
2184     my(%mult) = ('s'=>1,
2185                  'm'=>60,
2186                  'h'=>60*60,
2187                  'd'=>60*60*24,
2188                  'M'=>60*60*24*30,
2189                  'y'=>60*60*24*365);
2190     # format for time can be in any of the forms...
2191     # "now" -- expire immediately
2192     # "+180s" -- in 180 seconds
2193     # "+2m" -- in 2 minutes
2194     # "+12h" -- in 12 hours
2195     # "+1d"  -- in 1 day
2196     # "+3M"  -- in 3 months
2197     # "+2y"  -- in 2 years
2198     # "-3m"  -- 3 minutes ago(!)
2199     # If you don't supply one of these forms, we assume you are
2200     # specifying the date yourself
2201     my($offset);
2202     if (!$time || (lc($time) eq 'now')) {
2203         $offset = 0;
2204     } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
2205         $offset = ($mult{$2} || 1)*$1;
2206     } else {
2207         return $time;
2208     }
2209     return (time+$offset);
2210 }
2211 END_OF_FUNC
2212
2213 # This internal routine creates date strings suitable for use in
2214 # cookies and HTTP headers.  (They differ, unfortunately.)
2215 # Thanks to Fisher Mark for this.
2216 'expires' => <<'END_OF_FUNC',
2217 sub expires {
2218     my($time,$format) = @_;
2219     $format ||= 'http';
2220
2221     my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
2222     my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
2223
2224     # pass through preformatted dates for the sake of expire_calc()
2225     $time = expire_calc($time);
2226     return $time unless $time =~ /^\d+$/;
2227
2228     # make HTTP/cookie date string from GMT'ed time
2229     # (cookies use '-' as date separator, HTTP uses ' ')
2230     my($sc) = ' ';
2231     $sc = '-' if $format eq "cookie";
2232     my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
2233     $year += 1900;
2234     return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
2235                    $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
2236 }
2237 END_OF_FUNC
2238
2239 'parse_keywordlist' => <<'END_OF_FUNC',
2240 sub parse_keywordlist {
2241     my($self,$tosplit) = @_;
2242     $tosplit = unescape($tosplit); # unescape the keywords
2243     $tosplit=~tr/+/ /;          # pluses to spaces
2244     my(@keywords) = split(/\s+/,$tosplit);
2245     return @keywords;
2246 }
2247 END_OF_FUNC
2248
2249 'param_fetch' => <<'END_OF_FUNC',
2250 sub param_fetch {
2251     my($self,@p) = self_or_default(@_);
2252     my($name) = $self->rearrange([NAME],@p);
2253     unless (exists($self->{$name})) {
2254         $self->add_parameter($name);
2255         $self->{$name} = [];
2256     }
2257
2258     return $self->{$name};
2259 }
2260 END_OF_FUNC
2261
2262 ###############################################
2263 # OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
2264 ###############################################
2265
2266 #### Method: path_info
2267 # Return the extra virtual path information provided
2268 # after the URL (if any)
2269 ####
2270 'path_info' => <<'END_OF_FUNC',
2271 sub path_info {
2272     my ($self,$info) = self_or_default(@_);
2273     if (defined($info)) {
2274         $info = "/$info" if $info ne '' &&  substr($info,0,1) ne '/';
2275         $self->{'.path_info'} = $info;
2276     } elsif (! defined($self->{'.path_info'}) ) {
2277         $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ?
2278             $ENV{'PATH_INFO'} : '';
2279
2280         # hack to fix broken path info in IIS
2281         $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
2282
2283     }
2284     return $self->{'.path_info'};
2285 }
2286 END_OF_FUNC
2287
2288
2289 #### Method: request_method
2290 # Returns 'POST', 'GET', 'PUT' or 'HEAD'
2291 ####
2292 'request_method' => <<'END_OF_FUNC',
2293 sub request_method {
2294     return $ENV{'REQUEST_METHOD'};
2295 }
2296 END_OF_FUNC
2297
2298 #### Method: path_translated
2299 # Return the physical path information provided
2300 # by the URL (if any)
2301 ####
2302 'path_translated' => <<'END_OF_FUNC',
2303 sub path_translated {
2304     return $ENV{'PATH_TRANSLATED'};
2305 }
2306 END_OF_FUNC
2307
2308
2309 #### Method: query_string
2310 # Synthesize a query string from our current
2311 # parameters
2312 ####
2313 'query_string' => <<'END_OF_FUNC',
2314 sub query_string {
2315     my($self) = self_or_default(@_);
2316     my($param,$value,@pairs);
2317     foreach $param ($self->param) {
2318         my($eparam) = escape($param);
2319         foreach $value ($self->param($param)) {
2320             $value = escape($value);
2321             push(@pairs,"$eparam=$value");
2322         }
2323     }
2324     return join("&",@pairs);
2325 }
2326 END_OF_FUNC
2327
2328
2329 #### Method: accept
2330 # Without parameters, returns an array of the
2331 # MIME types the browser accepts.
2332 # With a single parameter equal to a MIME
2333 # type, will return undef if the browser won't
2334 # accept it, 1 if the browser accepts it but
2335 # doesn't give a preference, or a floating point
2336 # value between 0.0 and 1.0 if the browser
2337 # declares a quantitative score for it.
2338 # This handles MIME type globs correctly.
2339 ####
2340 'accept' => <<'END_OF_FUNC',
2341 sub accept {
2342     my($self,$search) = self_or_CGI(@_);
2343     my(%prefs,$type,$pref,$pat);
2344
2345     my(@accept) = split(',',$self->http('accept'));
2346
2347     foreach (@accept) {
2348         ($pref) = /q=(\d\.\d+|\d+)/;
2349         ($type) = m#(\S+/[^;]+)#;
2350         next unless $type;
2351         $prefs{$type}=$pref || 1;
2352     }
2353
2354     return keys %prefs unless $search;
2355
2356     # if a search type is provided, we may need to
2357     # perform a pattern matching operation.
2358     # The MIME types use a glob mechanism, which
2359     # is easily translated into a perl pattern match
2360
2361     # First return the preference for directly supported
2362     # types:
2363     return $prefs{$search} if $prefs{$search};
2364
2365     # Didn't get it, so try pattern matching.
2366     foreach (keys %prefs) {
2367         next unless /\*/;       # not a pattern match
2368         ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2369         $pat =~ s/\*/.*/g; # turn it into a pattern
2370         return $prefs{$_} if $search=~/$pat/;
2371     }
2372 }
2373 END_OF_FUNC
2374
2375
2376 #### Method: user_agent
2377 # If called with no parameters, returns the user agent.
2378 # If called with one parameter, does a pattern match (case
2379 # insensitive) on the user agent.
2380 ####
2381 'user_agent' => <<'END_OF_FUNC',
2382 sub user_agent {
2383     my($self,$match)=self_or_CGI(@_);
2384     return $self->http('user_agent') unless $match;
2385     return $self->http('user_agent') =~ /$match/i;
2386 }
2387 END_OF_FUNC
2388
2389
2390 #### Method: raw_cookie
2391 # Returns the magic cookies for the session.
2392 # The cookies are not parsed or altered in any way, i.e.
2393 # cookies are returned exactly as given in the HTTP
2394 # headers.  If a cookie name is given, only that cookie's
2395 # value is returned, otherwise the entire raw cookie
2396 # is returned.
2397 ####
2398 'raw_cookie' => <<'END_OF_FUNC',
2399 sub raw_cookie {
2400     my($self,$key) = self_or_CGI(@_);
2401
2402     require CGI::Cookie;
2403
2404     if (defined($key)) {
2405         $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
2406             unless $self->{'.raw_cookies'};
2407
2408         return () unless $self->{'.raw_cookies'};
2409         return () unless $self->{'.raw_cookies'}->{$key};
2410         return $self->{'.raw_cookies'}->{$key};
2411     }
2412     return $self->http('cookie') || $ENV{'COOKIE'} || '';
2413 }
2414 END_OF_FUNC
2415
2416 #### Method: virtual_host
2417 # Return the name of the virtual_host, which
2418 # is not always the same as the server
2419 ######
2420 'virtual_host' => <<'END_OF_FUNC',
2421 sub virtual_host {
2422     my $vh = http('host') || server_name();
2423     $vh =~ s/:\d+$//;           # get rid of port number
2424     return $vh;
2425 }
2426 END_OF_FUNC
2427
2428 #### Method: remote_host
2429 # Return the name of the remote host, or its IP
2430 # address if unavailable.  If this variable isn't
2431 # defined, it returns "localhost" for debugging
2432 # purposes.
2433 ####
2434 'remote_host' => <<'END_OF_FUNC',
2435 sub remote_host {
2436     return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
2437     || 'localhost';
2438 }
2439 END_OF_FUNC
2440
2441
2442 #### Method: remote_addr
2443 # Return the IP addr of the remote host.
2444 ####
2445 'remote_addr' => <<'END_OF_FUNC',
2446 sub remote_addr {
2447     return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
2448 }
2449 END_OF_FUNC
2450
2451
2452 #### Method: script_name
2453 # Return the partial URL to this script for
2454 # self-referencing scripts.  Also see
2455 # self_url(), which returns a URL with all state information
2456 # preserved.
2457 ####
2458 'script_name' => <<'END_OF_FUNC',
2459 sub script_name {
2460     return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'});
2461     # These are for debugging
2462     return "/$0" unless $0=~/^\//;
2463     return $0;
2464 }
2465 END_OF_FUNC
2466
2467
2468 #### Method: referer
2469 # Return the HTTP_REFERER: useful for generating
2470 # a GO BACK button.
2471 ####
2472 'referer' => <<'END_OF_FUNC',
2473 sub referer {
2474     my($self) = self_or_CGI(@_);
2475     return $self->http('referer');
2476 }
2477 END_OF_FUNC
2478
2479
2480 #### Method: server_name
2481 # Return the name of the server
2482 ####
2483 'server_name' => <<'END_OF_FUNC',
2484 sub server_name {
2485     return $ENV{'SERVER_NAME'} || 'localhost';
2486 }
2487 END_OF_FUNC
2488
2489 #### Method: server_software
2490 # Return the name of the server software
2491 ####
2492 'server_software' => <<'END_OF_FUNC',
2493 sub server_software {
2494     return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
2495 }
2496 END_OF_FUNC
2497
2498 #### Method: server_port
2499 # Return the tcp/ip port the server is running on
2500 ####
2501 'server_port' => <<'END_OF_FUNC',
2502 sub server_port {
2503     return $ENV{'SERVER_PORT'} || 80; # for debugging
2504 }
2505 END_OF_FUNC
2506
2507 #### Method: server_protocol
2508 # Return the protocol (usually HTTP/1.0)
2509 ####
2510 'server_protocol' => <<'END_OF_FUNC',
2511 sub server_protocol {
2512     return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
2513 }
2514 END_OF_FUNC
2515
2516 #### Method: http
2517 # Return the value of an HTTP variable, or
2518 # the list of variables if none provided
2519 ####
2520 'http' => <<'END_OF_FUNC',
2521 sub http {
2522     my ($self,$parameter) = self_or_CGI(@_);
2523     return $ENV{$parameter} if $parameter=~/^HTTP/;
2524     return $ENV{"HTTP_\U$parameter\E"} if $parameter;
2525     my(@p);
2526     foreach (keys %ENV) {
2527         push(@p,$_) if /^HTTP/;
2528     }
2529     return @p;
2530 }
2531 END_OF_FUNC
2532
2533 #### Method: https
2534 # Return the value of HTTPS
2535 ####
2536 'https' => <<'END_OF_FUNC',
2537 sub https {
2538     local($^W)=0;
2539     my ($self,$parameter) = self_or_CGI(@_);
2540     return $ENV{HTTPS} unless $parameter;
2541     return $ENV{$parameter} if $parameter=~/^HTTPS/;
2542     return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
2543     my(@p);
2544     foreach (keys %ENV) {
2545         push(@p,$_) if /^HTTPS/;
2546     }
2547     return @p;
2548 }
2549 END_OF_FUNC
2550
2551 #### Method: protocol
2552 # Return the protocol (http or https currently)
2553 ####
2554 'protocol' => <<'END_OF_FUNC',
2555 sub protocol {
2556     local($^W)=0;
2557     my $self = shift;
2558     return 'https' if uc($self->https()) eq 'ON';
2559     return 'https' if $self->server_port == 443;
2560     my $prot = $self->server_protocol;
2561     my($protocol,$version) = split('/',$prot);
2562     return "\L$protocol\E";
2563 }
2564 END_OF_FUNC
2565
2566 #### Method: remote_ident
2567 # Return the identity of the remote user
2568 # (but only if his host is running identd)
2569 ####
2570 'remote_ident' => <<'END_OF_FUNC',
2571 sub remote_ident {
2572     return $ENV{'REMOTE_IDENT'};
2573 }
2574 END_OF_FUNC
2575
2576
2577 #### Method: auth_type
2578 # Return the type of use verification/authorization in use, if any.
2579 ####
2580 'auth_type' => <<'END_OF_FUNC',
2581 sub auth_type {
2582     return $ENV{'AUTH_TYPE'};
2583 }
2584 END_OF_FUNC
2585
2586
2587 #### Method: remote_user
2588 # Return the authorization name used for user
2589 # verification.
2590 ####
2591 'remote_user' => <<'END_OF_FUNC',
2592 sub remote_user {
2593     return $ENV{'REMOTE_USER'};
2594 }
2595 END_OF_FUNC
2596
2597
2598 #### Method: user_name
2599 # Try to return the remote user's name by hook or by
2600 # crook
2601 ####
2602 'user_name' => <<'END_OF_FUNC',
2603 sub user_name {
2604     my ($self) = self_or_CGI(@_);
2605     return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
2606 }
2607 END_OF_FUNC
2608
2609 #### Method: nph
2610 # Set or return the NPH global flag
2611 ####
2612 'nph' => <<'END_OF_FUNC',
2613 sub nph {
2614     my ($self,$param) = self_or_CGI(@_);
2615     $CGI::NPH = $param if defined($param);
2616     return $CGI::NPH;
2617 }
2618 END_OF_FUNC
2619
2620 #### Method: private_tempfiles
2621 # Set or return the private_tempfiles global flag
2622 ####
2623 'private_tempfiles' => <<'END_OF_FUNC',
2624 sub private_tempfiles {
2625     my ($self,$param) = self_or_CGI(@_);
2626     $CGI::PRIVATE_TEMPFILES = $param if defined($param);
2627     return $CGI::PRIVATE_TEMPFILES;
2628 }
2629 END_OF_FUNC
2630
2631 #### Method: default_dtd
2632 # Set or return the default_dtd global
2633 ####
2634 'default_dtd' => <<'END_OF_FUNC',
2635 sub default_dtd {
2636     my ($self,$param) = self_or_CGI(@_);
2637     $CGI::DEFAULT_DTD = $param if defined($param);
2638     return $CGI::DEFAULT_DTD;
2639 }
2640 END_OF_FUNC
2641
2642 # -------------- really private subroutines -----------------
2643 'previous_or_default' => <<'END_OF_FUNC',
2644 sub previous_or_default {
2645     my($self,$name,$defaults,$override) = @_;
2646     my(%selected);
2647
2648     if (!$override && ($self->{'.fieldnames'}->{$name} ||
2649                        defined($self->param($name)) ) ) {
2650         grep($selected{$_}++,$self->param($name));
2651     } elsif (defined($defaults) && ref($defaults) &&
2652              (ref($defaults) eq 'ARRAY')) {
2653         grep($selected{$_}++,@{$defaults});
2654     } else {
2655         $selected{$defaults}++ if defined($defaults);
2656     }
2657
2658     return %selected;
2659 }
2660 END_OF_FUNC
2661
2662 'register_parameter' => <<'END_OF_FUNC',
2663 sub register_parameter {
2664     my($self,$param) = @_;
2665     $self->{'.parametersToAdd'}->{$param}++;
2666 }
2667 END_OF_FUNC
2668
2669 'get_fields' => <<'END_OF_FUNC',
2670 sub get_fields {
2671     my($self) = @_;
2672     return $self->CGI::hidden('-name'=>'.cgifields',
2673                               '-values'=>[keys %{$self->{'.parametersToAdd'}}],
2674                               '-override'=>1);
2675 }
2676 END_OF_FUNC
2677
2678 'read_from_cmdline' => <<'END_OF_FUNC',
2679 sub read_from_cmdline {
2680     my($input,@words);
2681     my($query_string);
2682     if (@ARGV) {
2683         @words = @ARGV;
2684     } else {
2685         require "shellwords.pl";
2686         print STDERR "(offline mode: enter name=value pairs on standard input)\n";
2687         chomp(@lines = <STDIN>); # remove newlines
2688         $input = join(" ",@lines);
2689         @words = &shellwords($input);
2690     }
2691     foreach (@words) {
2692         s/\\=/%3D/g;
2693         s/\\&/%26/g;
2694     }
2695
2696     if ("@words"=~/=/) {
2697         $query_string = join('&',@words);
2698     } else {
2699         $query_string = join('+',@words);
2700     }
2701     return $query_string;
2702 }
2703 END_OF_FUNC
2704
2705 #####
2706 # subroutine: read_multipart
2707 #
2708 # Read multipart data and store it into our parameters.
2709 # An interesting feature is that if any of the parts is a file, we
2710 # create a temporary file and open up a filehandle on it so that the
2711 # caller can read from it if necessary.
2712 #####
2713 'read_multipart' => <<'END_OF_FUNC',
2714 sub read_multipart {
2715     my($self,$boundary,$length,$filehandle) = @_;
2716     my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle);
2717     return unless $buffer;
2718     my(%header,$body);
2719     my $filenumber = 0;
2720     while (!$buffer->eof) {
2721         %header = $buffer->readHeader;
2722         die "Malformed multipart POST\n" unless %header;
2723
2724         my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
2725
2726         # Bug:  Netscape doesn't escape quotation marks in file names!!!
2727         my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/;
2728
2729         # add this parameter to our list
2730         $self->add_parameter($param);
2731
2732         # If no filename specified, then just read the data and assign it
2733         # to our parameter list.
2734         unless ($filename) {
2735             my($value) = $buffer->readBody;
2736             push(@{$self->{$param}},$value);
2737             next;
2738         }
2739
2740         my ($tmpfile,$tmp,$filehandle);
2741       UPLOADS: {
2742           # If we get here, then we are dealing with a potentially large
2743           # uploaded form.  Save the data to a temporary file, then open
2744           # the file for reading.
2745
2746           # skip the file if uploads disabled
2747           if ($DISABLE_UPLOADS) {
2748               while (defined($data = $buffer->read)) { }
2749               last UPLOADS;
2750           }
2751
2752           $tmpfile = new TempFile;
2753           $tmp = $tmpfile->as_string;
2754
2755           $filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES);
2756
2757           $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2758           chmod 0600,$tmp;    # only the owner can tamper with it
2759
2760           my ($data);
2761           while (defined($data = $buffer->read)) {
2762               print $filehandle $data;
2763           }
2764
2765           # back up to beginning of file
2766           seek($filehandle,0,0);
2767           $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2768
2769           # Save some information about the uploaded file where we can get
2770           # at it later.
2771           $self->{'.tmpfiles'}->{$filename}= {
2772               name => $tmpfile,
2773               info => {%header},
2774           };
2775           push(@{$self->{$param}},$filehandle);
2776       }
2777     }
2778 }
2779 END_OF_FUNC
2780
2781 'tmpFileName' => <<'END_OF_FUNC',
2782 sub tmpFileName {
2783     my($self,$filename) = self_or_default(@_);
2784     return $self->{'.tmpfiles'}->{$filename}->{name} ?
2785         $self->{'.tmpfiles'}->{$filename}->{name}->as_string
2786             : '';
2787 }
2788 END_OF_FUNC
2789
2790 'uploadInfo' => <<'END_OF_FUNC',
2791 sub uploadInfo {
2792     my($self,$filename) = self_or_default(@_);
2793     return $self->{'.tmpfiles'}->{$filename}->{info};
2794 }
2795 END_OF_FUNC
2796
2797 # internal routine, don't use
2798 '_set_values_and_labels' => <<'END_OF_FUNC',
2799 sub _set_values_and_labels {
2800     my $self = shift;
2801     my ($v,$l,$n) = @_;
2802     $$l = $v if ref($v) eq 'HASH' && !ref($$l);
2803     return $self->param($n) if !defined($v);
2804     return $v if !ref($v);
2805     return ref($v) eq 'HASH' ? keys %$v : @$v;
2806 }
2807 END_OF_FUNC
2808
2809 '_compile_all' => <<'END_OF_FUNC',
2810 sub _compile_all {
2811     foreach (@_) {
2812         next if defined(&$_);
2813         $AUTOLOAD = "CGI::$_";
2814         _compile();
2815     }
2816 }
2817 END_OF_FUNC
2818
2819 );
2820 END_OF_AUTOLOAD
2821 ;
2822
2823 #########################################################
2824 # Globals and stubs for other packages that we use.
2825 #########################################################
2826
2827 ################### Fh -- lightweight filehandle ###############
2828 package Fh;
2829 use overload
2830     '""'  => \&asString,
2831     'cmp' => \&compare,
2832     'fallback'=>1;
2833
2834 $FH='fh00000';
2835
2836 *Fh::AUTOLOAD = \&CGI::AUTOLOAD;
2837
2838 $AUTOLOADED_ROUTINES = '';      # prevent -w error
2839 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
2840 %SUBS =  (
2841 'asString' => <<'END_OF_FUNC',
2842 sub asString {
2843     my $self = shift;
2844     my $i = $$self;
2845     $i=~ s/^\*(\w+::)+//; # get rid of package name
2846     $i =~ s/\\(.)/$1/g;
2847     return $i;
2848 }
2849 END_OF_FUNC
2850
2851 'compare' => <<'END_OF_FUNC',
2852 sub compare {
2853     my $self = shift;
2854     my $value = shift;
2855     return "$self" cmp $value;
2856 }
2857 END_OF_FUNC
2858
2859 'new'  => <<'END_OF_FUNC',
2860 sub new {
2861     my($pack,$name,$file,$delete) = @_;
2862     require Fcntl unless defined &Fcntl::O_RDWR;
2863     ++$FH;
2864     *{$FH} = quotemeta($name);
2865     sysopen($FH,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL())
2866         || die "CGI open of $file: $!\n";
2867     unlink($file) if $delete;
2868     return bless \*{$FH},$pack;
2869 }
2870 END_OF_FUNC
2871
2872 'DESTROY'  => <<'END_OF_FUNC',
2873 sub DESTROY {
2874     my $self = shift;
2875     close $self;
2876 }
2877 END_OF_FUNC
2878
2879 );
2880 END_OF_AUTOLOAD
2881
2882 ######################## MultipartBuffer ####################
2883 package MultipartBuffer;
2884
2885 # how many bytes to read at a time.  We use
2886 # a 5K buffer by default.
2887 $INITIAL_FILLUNIT = 1024 * 5;
2888 $TIMEOUT = 10*60;       # 10 minute timeout
2889 $SPIN_LOOP_MAX = 1000;  # bug fix for some Netscape servers
2890 $CRLF=$CGI::CRLF;
2891
2892 #reuse the autoload function
2893 *MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
2894
2895 # avoid autoloader warnings
2896 sub DESTROY {}
2897
2898 ###############################################################################
2899 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
2900 ###############################################################################
2901 $AUTOLOADED_ROUTINES = '';      # prevent -w error
2902 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
2903 %SUBS =  (
2904
2905 'new' => <<'END_OF_FUNC',
2906 sub new {
2907     my($package,$interface,$boundary,$length,$filehandle) = @_;
2908     $FILLUNIT = $INITIAL_FILLUNIT;
2909     my $IN;
2910     if ($filehandle) {
2911         my($package) = caller;
2912         # force into caller's package if necessary
2913         $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
2914     }
2915     $IN = "main::STDIN" unless $IN;
2916
2917     $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
2918
2919     # If the user types garbage into the file upload field,
2920     # then Netscape passes NOTHING to the server (not good).
2921     # We may hang on this read in that case. So we implement
2922     # a read timeout.  If nothing is ready to read
2923     # by then, we return.
2924
2925     # Netscape seems to be a little bit unreliable
2926     # about providing boundary strings.
2927     if ($boundary) {
2928
2929         # Under the MIME spec, the boundary consists of the
2930         # characters "--" PLUS the Boundary string
2931
2932         # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
2933         # the two extra spaces.  We do a special case here on the user-agent!!!!
2934         $boundary = "--$boundary" unless CGI::user_agent('MSIE 3\.0[12];  Mac');
2935
2936     } else { # otherwise we find it ourselves
2937         my($old);
2938         ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
2939         $boundary = <$IN>;      # BUG: This won't work correctly under mod_perl
2940         $length -= length($boundary);
2941         chomp($boundary);               # remove the CRLF
2942         $/ = $old;                      # restore old line separator
2943     }
2944
2945     my $self = {LENGTH=>$length,
2946                 BOUNDARY=>$boundary,
2947                 IN=>$IN,
2948                 INTERFACE=>$interface,
2949                 BUFFER=>'',
2950             };
2951
2952     $FILLUNIT = length($boundary)
2953         if length($boundary) > $FILLUNIT;
2954
2955     my $retval = bless $self,ref $package || $package;
2956
2957     # Read the preamble and the topmost (boundary) line plus the CRLF.
2958     while ($self->read(0)) { }
2959     die "Malformed multipart POST\n" if $self->eof;
2960
2961     return $retval;
2962 }
2963 END_OF_FUNC
2964
2965 'readHeader' => <<'END_OF_FUNC',
2966 sub readHeader {
2967     my($self) = @_;
2968     my($end);
2969     my($ok) = 0;
2970     my($bad) = 0;
2971
2972     if ($CGI::OS eq 'VMS') {  # tssk, tssk: inconsistency alert!
2973         local($CRLF) = "\015\012";
2974     }
2975
2976     do {
2977         $self->fillBuffer($FILLUNIT);
2978         $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
2979         $ok++ if $self->{BUFFER} eq '';
2980         $bad++ if !$ok && $self->{LENGTH} <= 0;
2981         # this was a bad idea
2982         # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
2983     } until $ok || $bad;
2984     return () if $bad;
2985
2986     my($header) = substr($self->{BUFFER},0,$end+2);
2987     substr($self->{BUFFER},0,$end+4) = '';
2988     my %return;
2989
2990
2991     # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
2992     #   (Folding Long Header Fields), 3.4.3 (Comments)
2993     #   and 3.4.5 (Quoted-Strings).
2994
2995     my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
2996     $header=~s/$CRLF\s+/ /og;           # merge continuation lines
2997     while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
2998         my ($field_name,$field_value) = ($1,$2); # avoid taintedness
2999         $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
3000         $return{$field_name}=$field_value;
3001     }
3002     return %return;
3003 }
3004 END_OF_FUNC
3005
3006 # This reads and returns the body as a single scalar value.
3007 'readBody' => <<'END_OF_FUNC',
3008 sub readBody {
3009     my($self) = @_;
3010     my($data);
3011     my($returnval)='';
3012     while (defined($data = $self->read)) {
3013         $returnval .= $data;
3014     }
3015     return $returnval;
3016 }
3017 END_OF_FUNC
3018
3019 # This will read $bytes or until the boundary is hit, whichever happens
3020 # first.  After the boundary is hit, we return undef.  The next read will
3021 # skip over the boundary and begin reading again;
3022 'read' => <<'END_OF_FUNC',
3023 sub read {
3024     my($self,$bytes) = @_;
3025
3026     # default number of bytes to read
3027     $bytes = $bytes || $FILLUNIT;
3028
3029     # Fill up our internal buffer in such a way that the boundary
3030     # is never split between reads.
3031     $self->fillBuffer($bytes);
3032
3033     # Find the boundary in the buffer (it may not be there).
3034     my $start = index($self->{BUFFER},$self->{BOUNDARY});
3035     # protect against malformed multipart POST operations
3036     die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
3037
3038     # If the boundary begins the data, then skip past it
3039     # and return undef.  The +2 here is a fiendish plot to
3040     # remove the CR/LF pair at the end of the boundary.
3041     if ($start == 0) {
3042
3043         # clear us out completely if we've hit the last boundary.
3044         if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
3045             $self->{BUFFER}='';
3046             $self->{LENGTH}=0;
3047             return undef;
3048         }
3049
3050         # just remove the boundary.
3051         substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
3052         return undef;
3053     }
3054
3055     my $bytesToReturn;
3056     if ($start > 0) {           # read up to the boundary
3057         $bytesToReturn = $start > $bytes ? $bytes : $start;
3058     } else {    # read the requested number of bytes
3059         # leave enough bytes in the buffer to allow us to read
3060         # the boundary.  Thanks to Kevin Hendrick for finding
3061         # this one.
3062         $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
3063     }
3064
3065     my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
3066     substr($self->{BUFFER},0,$bytesToReturn)='';
3067
3068     # If we hit the boundary, remove the CRLF from the end.
3069     return ($start > 0) ? substr($returnval,0,-2) : $returnval;
3070 }
3071 END_OF_FUNC
3072
3073
3074 # This fills up our internal buffer in such a way that the
3075 # boundary is never split between reads
3076 'fillBuffer' => <<'END_OF_FUNC',
3077 sub fillBuffer {
3078     my($self,$bytes) = @_;
3079     return unless $self->{LENGTH};
3080
3081     my($boundaryLength) = length($self->{BOUNDARY});
3082     my($bufferLength) = length($self->{BUFFER});
3083     my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
3084     $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
3085
3086     # Try to read some data.  We may hang here if the browser is screwed up.
3087     my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN},
3088                                                          \$self->{BUFFER},
3089                                                          $bytesToRead,
3090                                                          $bufferLength);
3091
3092     # An apparent bug in the Apache server causes the read()
3093     # to return zero bytes repeatedly without blocking if the
3094     # remote user aborts during a file transfer.  I don't know how
3095     # they manage this, but the workaround is to abort if we get
3096     # more than SPIN_LOOP_MAX consecutive zero reads.
3097     if ($bytesRead == 0) {
3098         die  "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
3099             if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
3100     } else {
3101         $self->{ZERO_LOOP_COUNTER}=0;
3102     }
3103
3104     $self->{LENGTH} -= $bytesRead;
3105 }
3106 END_OF_FUNC
3107
3108
3109 # Return true when we've finished reading
3110 'eof' => <<'END_OF_FUNC'
3111 sub eof {
3112     my($self) = @_;
3113     return 1 if (length($self->{BUFFER}) == 0)
3114                  && ($self->{LENGTH} <= 0);
3115     undef;
3116 }
3117 END_OF_FUNC
3118
3119 );
3120 END_OF_AUTOLOAD
3121
3122 ####################################################################################
3123 ################################## TEMPORARY FILES #################################
3124 ####################################################################################
3125 package TempFile;
3126
3127 $SL = $CGI::SL;
3128 $MAC = $CGI::OS eq 'MACINTOSH';
3129 my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
3130 unless ($TMPDIRECTORY) {
3131     @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
3132            "${SL}tmp","${SL}temp","${vol}${SL}Temporary Items",
3133            "${SL}WWW_ROOT");
3134     foreach (@TEMP) {
3135         do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
3136     }
3137 }
3138
3139 $TMPDIRECTORY  = $MAC ? "" : "." unless $TMPDIRECTORY;
3140 $SEQUENCE=0;
3141 $MAXTRIES = 5000;
3142
3143 # cute feature, but overload implementation broke it
3144 # %OVERLOAD = ('""'=>'as_string');
3145 *TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
3146
3147 ###############################################################################
3148 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3149 ###############################################################################
3150 $AUTOLOADED_ROUTINES = '';      # prevent -w error
3151 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3152 %SUBS = (
3153
3154 'new' => <<'END_OF_FUNC',
3155 sub new {
3156     my($package) = @_;
3157     my $directory;
3158     my $i;
3159     for ($i = 0; $i < $MAXTRIES; $i++) {
3160         $directory = sprintf("${TMPDIRECTORY}${SL}CGItemp%d%04d",${$},++$SEQUENCE);
3161         last if ! -f $directory;
3162     }
3163     return bless \$directory;
3164 }
3165 END_OF_FUNC
3166
3167 'DESTROY' => <<'END_OF_FUNC',
3168 sub DESTROY {
3169     my($self) = @_;
3170     unlink $$self;              # get rid of the file
3171 }
3172 END_OF_FUNC
3173
3174 'as_string' => <<'END_OF_FUNC'
3175 sub as_string {
3176     my($self) = @_;
3177     return $$self;
3178 }
3179 END_OF_FUNC
3180
3181 );
3182 END_OF_AUTOLOAD
3183
3184 package CGI;
3185
3186 # We get a whole bunch of warnings about "possibly uninitialized variables"
3187 # when running with the -w switch.  Touch them all once to get rid of the
3188 # warnings.  This is ugly and I hate it.
3189 if ($^W) {
3190     $CGI::CGI = '';
3191     $CGI::CGI=<<EOF;
3192     $CGI::VERSION;
3193     $MultipartBuffer::SPIN_LOOP_MAX;
3194     $MultipartBuffer::CRLF;
3195     $MultipartBuffer::TIMEOUT;
3196     $MultipartBuffer::INITIAL_FILLUNIT;
3197     $TempFile::SEQUENCE;
3198 EOF
3199     ;
3200 }
3201
3202 1;
3203
3204 __END__
3205
3206 =head1 NAME
3207
3208 CGI - Simple Common Gateway Interface Class
3209
3210 =head1 SYNOPSIS
3211
3212   # CGI script that creates a fill-out form
3213   # and echoes back its values.
3214
3215   use CGI qw/:standard/;
3216   print header,
3217         start_html('A Simple Example'),
3218         h1('A Simple Example'),
3219         start_form,
3220         "What's your name? ",textfield('name'),p,
3221         "What's the combination?", p,
3222         checkbox_group(-name=>'words',
3223                        -values=>['eenie','meenie','minie','moe'],
3224                        -defaults=>['eenie','minie']), p,
3225         "What's your favorite color? ",
3226         popup_menu(-name=>'color',
3227                    -values=>['red','green','blue','chartreuse']),p,
3228         submit,
3229         end_form,
3230         hr;
3231
3232    if (param()) {
3233        print "Your name is",em(param('name')),p,
3234              "The keywords are: ",em(join(", ",param('words'))),p,
3235              "Your favorite color is ",em(param('color')),
3236              hr;
3237    }
3238
3239 =head1 ABSTRACT
3240
3241 This perl library uses perl5 objects to make it easy to create Web
3242 fill-out forms and parse their contents.  This package defines CGI
3243 objects, entities that contain the values of the current query string
3244 and other state variables.  Using a CGI object's methods, you can
3245 examine keywords and parameters passed to your script, and create
3246 forms whose initial values are taken from the current query (thereby
3247 preserving state information).  The module provides shortcut functions
3248 that produce boilerplate HTML, reducing typing and coding errors. It
3249 also provides functionality for some of the more advanced features of
3250 CGI scripting, including support for file uploads, cookies, cascading
3251 style sheets, server push, and frames.
3252
3253 CGI.pm also provides a simple function-oriented programming style for
3254 those who don't need its object-oriented features.
3255
3256 The current version of CGI.pm is available at
3257
3258   http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
3259   ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
3260
3261 =head1 DESCRIPTION
3262
3263 =head2 PROGRAMMING STYLE
3264
3265 There are two styles of programming with CGI.pm, an object-oriented
3266 style and a function-oriented style.  In the object-oriented style you
3267 create one or more CGI objects and then use object methods to create
3268 the various elements of the page.  Each CGI object starts out with the
3269 list of named parameters that were passed to your CGI script by the
3270 server.  You can modify the objects, save them to a file or database
3271 and recreate them.  Because each object corresponds to the "state" of
3272 the CGI script, and because each object's parameter list is
3273 independent of the others, this allows you to save the state of the
3274 script and restore it later.
3275
3276 For example, using the object oriented style, here is now you create
3277 a simple "Hello World" HTML page:
3278
3279    #!/usr/local/bin/pelr
3280    use CGI;                             # load CGI routines
3281    $q = new CGI;                        # create new CGI object
3282    print $q->header,                    # create the HTTP header
3283          $q->start_html('hello world'), # start the HTML
3284          $q->h1('hello world'),         # level 1 header
3285          $q->end_html;                  # end the HTML
3286
3287 In the function-oriented style, there is one default CGI object that
3288 you rarely deal with directly.  Instead you just call functions to
3289 retrieve CGI parameters, create HTML tags, manage cookies, and so
3290 on.  This provides you with a cleaner programming interface, but
3291 limits you to using one CGI object at a time.  The following example
3292 prints the same page, but uses the function-oriented interface.
3293 The main differences are that we now need to import a set of functions
3294 into our name space (usually the "standard" functions), and we don't
3295 need to create the CGI object.
3296
3297    #!/usr/local/bin/pelr
3298    use CGI qw/:standard/;           # load standard CGI routines
3299    print header,                    # create the HTTP header
3300          start_html('hello world'), # start the HTML
3301          h1('hello world'),         # level 1 header
3302          end_html;                  # end the HTML
3303
3304 The examples in this document mainly use the object-oriented style.
3305 See HOW TO IMPORT FUNCTIONS for important information on
3306 function-oriented programming in CGI.pm
3307
3308 =head2 CALLING CGI.PM ROUTINES
3309
3310 Most CGI.pm routines accept several arguments, sometimes as many as 20
3311 optional ones!  To simplify this interface, all routines use a named
3312 argument calling style that looks like this:
3313
3314    print $q->header(-type=>'image/gif',-expires=>'+3d');
3315
3316 Each argument name is preceded by a dash.  Neither case nor order
3317 matters in the argument list.  -type, -Type, and -TYPE are all
3318 acceptable.  In fact, only the first argument needs to begin with a
3319 dash.  If a dash is present in the first argument, CGI.pm assumes
3320 dashes for the subsequent ones.
3321
3322 You don't have to use the hyphen at allif you don't want to.  After
3323 creating a CGI object, call the B<use_named_parameters()> method with
3324 a nonzero value.  This will tell CGI.pm that you intend to use named
3325 parameters exclusively:
3326
3327    $query = new CGI;
3328    $query->use_named_parameters(1);
3329    $field = $query->radio_group('name'=>'OS',
3330                                 'values'=>['Unix','Windows','Macintosh'],
3331                                 'default'=>'Unix');
3332
3333 Several routines are commonly called with just one argument.  In the
3334 case of these routines you can provide the single argument without an
3335 argument name.  header() happens to be one of these routines.  In this
3336 case, the single argument is the document type.
3337
3338    print $q->header('text/html');
3339
3340 Other such routines are documented below.
3341
3342 Sometimes named arguments expect a scalar, sometimes a reference to an
3343 array, and sometimes a reference to a hash.  Often, you can pass any
3344 type of argument and the routine will do whatever is most appropriate.
3345 For example, the param() routine is used to set a CGI parameter to a
3346 single or a multi-valued value.  The two cases are shown below:
3347
3348    $q->param(-name=>'veggie',-value=>'tomato');
3349    $q->param(-name=>'veggie',-value=>'[tomato','tomahto','potato','potahto']);
3350
3351 A large number of routines in CGI.pm actually aren't specifically
3352 defined in the module, but are generated automatically as needed.
3353 These are the "HTML shortcuts," routines that generate HTML tags for
3354 use in dynamically-generated pages.  HTML tags have both attributes
3355 (the attribute="value" pairs within the tag itself) and contents (the
3356 part between the opening and closing pairs.)  To distinguish between
3357 attributes and contents, CGI.pm uses the convention of passing HTML
3358 attributes as a hash reference as the first argument, and the
3359 contents, if any, as any subsequent arguments.  It works out like
3360 this:
3361
3362    Code                           Generated HTML
3363    ----                           --------------
3364    h1()                           <H1>
3365    h1('some','contents');         <H1>some contents</H1>
3366    h1({-align=>left});            <H1 ALIGN="LEFT">
3367    h1({-align=>left},'contents'); <H1 ALIGN="LEFT">contents</H1>
3368
3369 HTML tags are described in more detail later.
3370
3371 Many newcomers to CGI.pm are puzzled by the difference between the
3372 calling conventions for the HTML shortcuts, which require curly braces
3373 around the HTML tag attributes, and the calling conventions for other
3374 routines, which manage to generate attributes without the curly
3375 brackets.  Don't be confused.  As a convenience the curly braces are
3376 optional in all but the HTML shortcuts.  If you like, you can use
3377 curly braces when calling any routine that takes named arguments.  For
3378 example:
3379
3380    print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
3381
3382 If you use the B<-w> switch, you will be warned that some CGI.pm argument
3383 names conflict with built-in Perl functions.  The most frequent of
3384 these is the -values argument, used to create multi-valued menus,
3385 radio button clusters and the like.  To get around this warning, you
3386 have several choices:
3387
3388 =over 4
3389
3390 =item 1. Use another name for the argument, if one is available.  For
3391 example, -value is an alias for -values.
3392
3393 =item 2. Change the capitalization, e.g. -Values
3394
3395 =item 3. Put quotes around the argument name, e.g. '-values'
3396
3397 =back
3398
3399 Many routines will do something useful with a named argument that it
3400 doesn't recognize.  For example, you can produce non-standard HTTP
3401 header fields by providing them as named arguments:
3402
3403   print $q->header(-type  =>  'text/html',
3404                    -cost  =>  'Three smackers',
3405                    -annoyance_level => 'high',
3406                    -complaints_to   => 'bit bucket');
3407
3408 This will produce the following nonstandard HTTP header:
3409
3410    HTTP/1.0 200 OK
3411    Cost: Three smackers
3412    Annoyance-level: high
3413    Complaints-to: bit bucket
3414    Content-type: text/html
3415
3416 Notice the way that underscores are translated automatically into
3417 hyphens.  HTML-generating routines perform a different type of
3418 translation.
3419
3420 This feature allows you to keep up with the rapidly changing HTTP and
3421 HTML "standards".
3422
3423 =head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
3424
3425      $query = new CGI;
3426
3427 This will parse the input (from both POST and GET methods) and store
3428 it into a perl5 object called $query.
3429
3430 =head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
3431
3432      $query = new CGI(INPUTFILE);
3433
3434 If you provide a file handle to the new() method, it will read
3435 parameters from the file (or STDIN, or whatever).  The file can be in
3436 any of the forms describing below under debugging (i.e. a series of
3437 newline delimited TAG=VALUE pairs will work).  Conveniently, this type
3438 of file is created by the save() method (see below).  Multiple records
3439 can be saved and restored.
3440
3441 Perl purists will be pleased to know that this syntax accepts
3442 references to file handles, or even references to filehandle globs,
3443 which is the "official" way to pass a filehandle:
3444
3445     $query = new CGI(\*STDIN);
3446
3447 You can also initialize the CGI object with a FileHandle or IO::File
3448 object.
3449
3450 If you are using the function-oriented interface and want to
3451 initialize CGI state from a file handle, the way to do this is with
3452 B<restore_parameters()>.  This will (re)initialize the
3453 default CGI object from the indicated file handle.
3454
3455     open (IN,"test.in") || die;
3456     restore_parameters(IN);
3457     close IN;
3458
3459 You can also initialize the query object from an associative array
3460 reference:
3461
3462     $query = new CGI( {'dinosaur'=>'barney',
3463                        'song'=>'I love you',
3464                        'friends'=>[qw/Jessica George Nancy/]}
3465                     );
3466
3467 or from a properly formatted, URL-escaped query string:
3468
3469     $query = new CGI('dinosaur=barney&color=purple');
3470
3471 or from a previously existing CGI object (currently this clones the
3472 parameter list, but none of the other object-specific fields, such as
3473 autoescaping):
3474
3475     $old_query = new CGI;
3476     $new_query = new CGI($old_query);
3477
3478 To create an empty query, initialize it from an empty string or hash:
3479
3480    $empty_query = new CGI("");
3481
3482        -or-
3483
3484    $empty_query = new CGI({});
3485
3486 =head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
3487
3488      @keywords = $query->keywords
3489
3490 If the script was invoked as the result of an <ISINDEX> search, the
3491 parsed keywords can be obtained as an array using the keywords() method.
3492
3493 =head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
3494
3495      @names = $query->param
3496
3497 If the script was invoked with a parameter list
3498 (e.g. "name1=value1&name2=value2&name3=value3"), the param()
3499 method will return the parameter names as a list.  If the
3500 script was invoked as an <ISINDEX> script, there will be a
3501 single parameter named 'keywords'.
3502
3503 NOTE: As of version 1.5, the array of parameter names returned will
3504 be in the same order as they were submitted by the browser.
3505 Usually this order is the same as the order in which the
3506 parameters are defined in the form (however, this isn't part
3507 of the spec, and so isn't guaranteed).
3508
3509 =head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
3510
3511     @values = $query->param('foo');
3512
3513               -or-
3514
3515     $value = $query->param('foo');
3516
3517 Pass the param() method a single argument to fetch the value of the
3518 named parameter. If the parameter is multivalued (e.g. from multiple
3519 selections in a scrolling list), you can ask to receive an array.  Otherwise
3520 the method will return a single value.
3521
3522 =head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
3523
3524     $query->param('foo','an','array','of','values');
3525
3526 This sets the value for the named parameter 'foo' to an array of
3527 values.  This is one way to change the value of a field AFTER
3528 the script has been invoked once before.  (Another way is with
3529 the -override parameter accepted by all methods that generate
3530 form elements.)
3531
3532 param() also recognizes a named parameter style of calling described
3533 in more detail later:
3534
3535     $query->param(-name=>'foo',-values=>['an','array','of','values']);
3536
3537                               -or-
3538
3539     $query->param(-name=>'foo',-value=>'the value');
3540
3541 =head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
3542
3543    $query->append(-name=>'foo',-values=>['yet','more','values']);
3544
3545 This adds a value or list of values to the named parameter.  The
3546 values are appended to the end of the parameter if it already exists.
3547 Otherwise the parameter is created.  Note that this method only
3548 recognizes the named argument calling syntax.
3549
3550 =head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
3551
3552    $query->import_names('R');
3553
3554 This creates a series of variables in the 'R' namespace.  For example,
3555 $R::foo, @R:foo.  For keyword lists, a variable @R::keywords will appear.
3556 If no namespace is given, this method will assume 'Q'.
3557 WARNING:  don't import anything into 'main'; this is a major security
3558 risk!!!!
3559
3560 In older versions, this method was called B<import()>.  As of version 2.20,
3561 this name has been removed completely to avoid conflict with the built-in
3562 Perl module B<import> operator.
3563
3564 =head2 DELETING A PARAMETER COMPLETELY:
3565
3566     $query->delete('foo');
3567
3568 This completely clears a parameter.  It sometimes useful for
3569 resetting parameters that you don't want passed down between
3570 script invocations.
3571
3572 If you are using the function call interface, use "Delete()" instead
3573 to avoid conflicts with Perl's built-in delete operator.
3574
3575 =head2 DELETING ALL PARAMETERS:
3576
3577    $query->delete_all();
3578
3579 This clears the CGI object completely.  It might be useful to ensure
3580 that all the defaults are taken when you create a fill-out form.
3581
3582 Use Delete_all() instead if you are using the function call interface.
3583
3584 =head2 DIRECT ACCESS TO THE PARAMETER LIST:
3585
3586    $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
3587    unshift @{$q->param_fetch(-name=>'address')},'George Munster';
3588
3589 If you need access to the parameter list in a way that isn't covered
3590 by the methods above, you can obtain a direct reference to it by
3591 calling the B<param_fetch()> method with the name of the .  This
3592 will return an array reference to the named parameters, which you then
3593 can manipulate in any way you like.
3594
3595 You can also use a named argument style using the B<-name> argument.
3596
3597 =head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
3598
3599     $query->save(FILEHANDLE)
3600
3601 This will write the current state of the form to the provided
3602 filehandle.  You can read it back in by providing a filehandle
3603 to the new() method.  Note that the filehandle can be a file, a pipe,
3604 or whatever!
3605
3606 The format of the saved file is:
3607
3608         NAME1=VALUE1
3609         NAME1=VALUE1'
3610         NAME2=VALUE2
3611         NAME3=VALUE3
3612         =
3613
3614 Both name and value are URL escaped.  Multi-valued CGI parameters are
3615 represented as repeated names.  A session record is delimited by a
3616 single = symbol.  You can write out multiple records and read them
3617 back in with several calls to B<new>.  You can do this across several
3618 sessions by opening the file in append mode, allowing you to create
3619 primitive guest books, or to keep a history of users' queries.  Here's
3620 a short example of creating multiple session records:
3621
3622    use CGI;
3623
3624    open (OUT,">>test.out") || die;
3625    $records = 5;
3626    foreach (0..$records) {
3627        my $q = new CGI;
3628        $q->param(-name=>'counter',-value=>$_);
3629        $q->save(OUT);
3630    }
3631    close OUT;
3632
3633    # reopen for reading
3634    open (IN,"test.out") || die;
3635    while (!eof(IN)) {
3636        my $q = new CGI(IN);
3637        print $q->param('counter'),"\n";
3638    }
3639
3640 The file format used for save/restore is identical to that used by the
3641 Whitehead Genome Center's data exchange format "Boulderio", and can be
3642 manipulated and even databased using Boulderio utilities.  See
3643
3644   http://www.genome.wi.mit.edu/genome_software/other/boulder.html
3645
3646 for further details.
3647
3648 If you wish to use this method from the function-oriented (non-OO)
3649 interface, the exported name for this method is B<save_parameters()>.
3650
3651 =head2 USING THE FUNCTION-ORIENTED INTERFACE
3652
3653 To use the function-oriented interface, you must specify which CGI.pm
3654 routines or sets of routines to import into your script's namespace.
3655 There is a small overhead associated with this importation, but it
3656 isn't much.
3657
3658    use CGI <list of methods>;
3659
3660 The listed methods will be imported into the current package; you can
3661 call them directly without creating a CGI object first.  This example
3662 shows how to import the B<param()> and B<header()>
3663 methods, and then use them directly:
3664
3665    use CGI 'param','header';
3666    print header('text/plain');
3667    $zipcode = param('zipcode');
3668
3669 More frequently, you'll import common sets of functions by referring
3670 to the gropus by name.  All function sets are preceded with a ":"
3671 character as in ":html3" (for tags defined in the HTML 3 standard).
3672
3673 Here is a list of the function sets you can import:
3674
3675 =over 4
3676
3677 =item B<:cgi>
3678
3679 Import all CGI-handling methods, such as B<param()>, B<path_info()>
3680 and the like.
3681
3682 =item B<:form>
3683
3684 Import all fill-out form generating methods, such as B<textfield()>.
3685
3686 =item B<:html2>
3687
3688 Import all methods that generate HTML 2.0 standard elements.
3689
3690 =item B<:html3>
3691
3692 Import all methods that generate HTML 3.0 proposed elements (such as
3693 <table>, <super> and <sub>).
3694
3695 =item B<:netscape>
3696
3697 Import all methods that generate Netscape-specific HTML extensions.
3698
3699 =item B<:html>
3700
3701 Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
3702 'netscape')...
3703
3704 =item B<:standard>
3705
3706 Import "standard" features, 'html2', 'html3', 'form' and 'cgi'.
3707
3708 =item B<:all>
3709
3710 Import all the available methods.  For the full list, see the CGI.pm
3711 code, where the variable %TAGS is defined.
3712
3713 =back
3714
3715 If you import a function name that is not part of CGI.pm, the module
3716 will treat it as a new HTML tag and generate the appropriate
3717 subroutine.  You can then use it like any other HTML tag.  This is to
3718 provide for the rapidly-evolving HTML "standard."  For example, say
3719 Microsoft comes out with a new tag called <GRADIENT> (which causes the
3720 user's desktop to be flooded with a rotating gradient fill until his
3721 machine reboots).  You don't need to wait for a new version of CGI.pm
3722 to start using it immeidately:
3723
3724    use CGI qw/:standard :html3 gradient/;
3725    print gradient({-start=>'red',-end=>'blue'});
3726
3727 Note that in the interests of execution speed CGI.pm does B<not> use
3728 the standard L<Exporter> syntax for specifying load symbols.  This may
3729 change in the future.
3730
3731 If you import any of the state-maintaining CGI or form-generating
3732 methods, a default CGI object will be created and initialized
3733 automatically the first time you use any of the methods that require
3734 one to be present.  This includes B<param()>, B<textfield()>,
3735 B<submit()> and the like.  (If you need direct access to the CGI
3736 object, you can find it in the global variable B<$CGI::Q>).  By
3737 importing CGI.pm methods, you can create visually elegant scripts:
3738
3739    use CGI qw/:standard/;
3740    print
3741        header,
3742        start_html('Simple Script'),
3743        h1('Simple Script'),
3744        start_form,
3745        "What's your name? ",textfield('name'),p,
3746        "What's the combination?",
3747        checkbox_group(-name=>'words',
3748                       -values=>['eenie','meenie','minie','moe'],
3749                       -defaults=>['eenie','moe']),p,
3750        "What's your favorite color?",
3751        popup_menu(-name=>'color',
3752                   -values=>['red','green','blue','chartreuse']),p,
3753        submit,
3754        end_form,
3755        hr,"\n";
3756
3757     if (param) {
3758        print
3759            "Your name is ",em(param('name')),p,
3760            "The keywords are: ",em(join(", ",param('words'))),p,
3761            "Your favorite color is ",em(param('color')),".\n";
3762     }
3763     print end_html;
3764
3765 =head2 PRAGMAS
3766
3767 In addition to the function sets, there are a number of pragmas that
3768 you can import.  Pragmas, which are always preceded by a hyphen,
3769 change the way that CGI.pm functions in various ways.  Pragmas,
3770 function sets, and individual functions can all be imported in the
3771 same use() line.  For example, the following use statement imports the
3772 standard set of functions and disables debugging mode (pragma
3773 -no_debug):
3774
3775    use CGI qw/:standard -no_debug/;
3776
3777 The current list of pragmas is as follows:
3778
3779 =over 4
3780
3781 =item -any
3782
3783 When you I<use CGI -any>, then any method that the query object
3784 doesn't recognize will be interpreted as a new HTML tag.  This allows
3785 you to support the next I<ad hoc> Netscape or Microsoft HTML
3786 extension.  This lets you go wild with new and unsupported tags:
3787
3788    use CGI qw(-any);
3789    $q=new CGI;
3790    print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
3791
3792 Since using <cite>any</cite> causes any mistyped method name
3793 to be interpreted as an HTML tag, use it with care or not at
3794 all.
3795
3796 =item -compile
3797
3798 This causes the indicated autoloaded methods to be compiled up front,
3799 rather than deferred to later.  This is useful for scripts that run
3800 for an extended period of time under FastCGI or mod_perl, and for
3801 those destined to be crunched by Malcom Beattie's Perl compiler.  Use
3802 it in conjunction with the methods or method familes you plan to use.
3803
3804    use CGI qw(-compile :standard :html3);
3805
3806 or even
3807
3808    use CGI qw(-compile :all);
3809
3810 Note that using the -compile pragma in this way will always have
3811 the effect of importing the compiled functions into the current
3812 namespace.  If you want to compile without importing use the
3813 compile() method instead (see below).
3814
3815 =item -nph
3816
3817 This makes CGI.pm produce a header appropriate for an NPH (no
3818 parsed header) script.  You may need to do other things as well
3819 to tell the server that the script is NPH.  See the discussion
3820 of NPH scripts below.
3821
3822 =item -autoload
3823
3824 This overrides the autoloader so that any function in your program
3825 that is not recognized is referred to CGI.pm for possible evaluation.
3826 This allows you to use all the CGI.pm functions without adding them to
3827 your symbol table, which is of concern for mod_perl users who are
3828 worried about memory consumption.  I<Warning:> when
3829 I<-autoload> is in effect, you cannot use "poetry mode"
3830 (functions without the parenthesis).  Use I<hr()> rather
3831 than I<hr>, or add something like I<use subs qw/hr p header/>
3832 to the top of your script.
3833
3834 =item -no_debug
3835
3836 This turns off the command-line processing features.  If you want to
3837 run a CGI.pm script from the command line to produce HTML, and you
3838 don't want it pausing to request CGI parameters from standard input or
3839 the command line, then use this pragma:
3840
3841    use CGI qw(-no_debug :standard);
3842
3843 If you'd like to process the command-line parameters but not standard
3844 input, this should work:
3845
3846    use CGI qw(-no_debug :standard);
3847    restore_parameters(join('&',@ARGV));
3848
3849 See the section on debugging for more details.
3850
3851 =item -private_tempfiles
3852
3853 CGI.pm can process uploaded file. Ordinarily it spools the
3854 uploaded file to a temporary directory, then deletes the file
3855 when done.  However, this opens the risk of eavesdropping as
3856 described in the file upload section.
3857 Another CGI script author could peek at this data during the
3858 upload, even if it is confidential information. On Unix systems,
3859 the -private_tempfiles pragma will cause the temporary file to be unlinked as soon
3860 as it is opened and before any data is written into it,
3861 eliminating the risk of eavesdropping.
3862 n
3863 =back
3864
3865 =head1 GENERATING DYNAMIC DOCUMENTS
3866
3867 Most of CGI.pm's functions deal with creating documents on the fly.
3868 Generally you will produce the HTTP header first, followed by the
3869 document itself.  CGI.pm provides functions for generating HTTP
3870 headers of various types as well as for generating HTML.  For creating
3871 GIF images, see the GD.pm module.
3872
3873 Each of these functions produces a fragment of HTML or HTTP which you
3874 can print out directly so that it displays in the browser window,
3875 append to a string, or save to a file for later use.
3876
3877 =head2 CREATING A STANDARD HTTP HEADER:
3878
3879 Normally the first thing you will do in any CGI script is print out an
3880 HTTP header.  This tells the browser what type of document to expect,
3881 and gives other optional information, such as the language, expiration
3882 date, and whether to cache the document.  The header can also be
3883 manipulated for special purposes, such as server push and pay per view
3884 pages.
3885
3886         print $query->header;
3887
3888              -or-
3889
3890         print $query->header('image/gif');
3891
3892              -or-
3893
3894         print $query->header('text/html','204 No response');
3895
3896              -or-
3897
3898         print $query->header(-type=>'image/gif',
3899                              -nph=>1,
3900                              -status=>'402 Payment required',
3901                              -expires=>'+3d',
3902                              -cookie=>$cookie,
3903                              -Cost=>'$2.00');
3904
3905 header() returns the Content-type: header.  You can provide your own
3906 MIME type if you choose, otherwise it defaults to text/html.  An
3907 optional second parameter specifies the status code and a human-readable
3908 message.  For example, you can specify 204, "No response" to create a
3909 script that tells the browser to do nothing at all.
3910
3911 The last example shows the named argument style for passing arguments
3912 to the CGI methods using named parameters.  Recognized parameters are
3913 B<-type>, B<-status>, B<-expires>, and B<-cookie>.  Any other named
3914 parameters will be stripped of their initial hyphens and turned into
3915 header fields, allowing you to specify any HTTP header you desire.
3916 Internal underscores will be turned into hyphens:
3917
3918     print $query->header(-Content_length=>3002);
3919
3920 Most browsers will not cache the output from CGI scripts.  Every time
3921 the browser reloads the page, the script is invoked anew.  You can
3922 change this behavior with the B<-expires> parameter.  When you specify
3923 an absolute or relative expiration interval with this parameter, some
3924 browsers and proxy servers will cache the script's output until the
3925 indicated expiration date.  The following forms are all valid for the
3926 -expires field:
3927
3928         +30s                              30 seconds from now
3929         +10m                              ten minutes from now
3930         +1h                               one hour from now
3931         -1d                               yesterday (i.e. "ASAP!")
3932         now                               immediately
3933         +3M                               in three months
3934         +10y                              in ten years time
3935         Thursday, 25-Apr-1999 00:40:33 GMT  at the indicated time & date
3936
3937 The B<-cookie> parameter generates a header that tells the browser to provide
3938 a "magic cookie" during all subsequent transactions with your script.
3939 Netscape cookies have a special format that includes interesting attributes
3940 such as expiration time.  Use the cookie() method to create and retrieve
3941 session cookies.
3942
3943 The B<-nph> parameter, if set to a true value, will issue the correct
3944 headers to work with a NPH (no-parse-header) script.  This is important
3945 to use with certain servers, such as Microsoft Internet Explorer, which
3946 expect all their scripts to be NPH.
3947
3948 =head2 GENERATING A REDIRECTION HEADER
3949
3950    print $query->redirect('http://somewhere.else/in/movie/land');
3951
3952 Sometimes you don't want to produce a document yourself, but simply
3953 redirect the browser elsewhere, perhaps choosing a URL based on the
3954 time of day or the identity of the user.
3955
3956 The redirect() function redirects the browser to a different URL.  If
3957 you use redirection like this, you should B<not> print out a header as
3958 well.  As of version 2.0, we produce both the unofficial Location:
3959 header and the official URI: header.  This should satisfy most servers
3960 and browsers.
3961
3962 One hint I can offer is that relative links may not work correctly
3963 when you generate a redirection to another document on your site.
3964 This is due to a well-intentioned optimization that some servers use.
3965 The solution to this is to use the full URL (including the http: part)
3966 of the document you are redirecting to.
3967
3968 You can also use named arguments:
3969
3970     print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
3971                            -nph=>1);
3972
3973 The B<-nph> parameter, if set to a true value, will issue the correct
3974 headers to work with a NPH (no-parse-header) script.  This is important
3975 to use with certain servers, such as Microsoft Internet Explorer, which
3976 expect all their scripts to be NPH.
3977
3978 =head2 CREATING THE HTML DOCUMENT HEADER
3979
3980    print $query->start_html(-title=>'Secrets of the Pyramids',
3981                             -author=>'fred@capricorn.org',
3982                             -base=>'true',
3983                             -target=>'_blank',
3984                             -meta=>{'keywords'=>'pharaoh secret mummy',
3985                                     'copyright'=>'copyright 1996 King Tut'},
3986                             -style=>{'src'=>'/styles/style1.css'},
3987                             -BGCOLOR=>'blue');
3988
3989 After creating the HTTP header, most CGI scripts will start writing
3990 out an HTML document.  The start_html() routine creates the top of the
3991 page, along with a lot of optional information that controls the
3992 page's appearance and behavior.
3993
3994 This method returns a canned HTML header and the opening <BODY> tag.
3995 All parameters are optional.  In the named parameter form, recognized
3996 parameters are -title, -author, -base, -xbase and -target (see below
3997 for the explanation).  Any additional parameters you provide, such as
3998 the Netscape unofficial BGCOLOR attribute, are added to the <BODY>
3999 tag.  Additional parameters must be proceeded by a hyphen.
4000
4001 The argument B<-xbase> allows you to provide an HREF for the <BASE> tag
4002 different from the current location, as in
4003
4004     -xbase=>"http://home.mcom.com/"
4005
4006 All relative links will be interpreted relative to this tag.
4007
4008 The argument B<-target> allows you to provide a default target frame
4009 for all the links and fill-out forms on the page.  See the Netscape
4010 documentation on frames for details of how to manipulate this.
4011
4012     -target=>"answer_window"
4013
4014 All relative links will be interpreted relative to this tag.
4015 You add arbitrary meta information to the header with the B<-meta>
4016 argument.  This argument expects a reference to an associative array
4017 containing name/value pairs of meta information.  These will be turned
4018 into a series of header <META> tags that look something like this:
4019
4020     <META NAME="keywords" CONTENT="pharaoh secret mummy">
4021     <META NAME="description" CONTENT="copyright 1996 King Tut">
4022
4023 There is no support for the HTTP-EQUIV type of <META> tag.  This is
4024 because you can modify the HTTP header directly with the B<header()>
4025 method.  For example, if you want to send the Refresh: header, do it
4026 in the header() method:
4027
4028     print $q->header(-Refresh=>'10; URL=http://www.capricorn.com');
4029
4030 The B<-style> tag is used to incorporate cascading stylesheets into
4031 your code.  See the section on CASCADING STYLESHEETS for more information.
4032
4033 You can place other arbitrary HTML elements to the <HEAD> section with the
4034 B<-head> tag.  For example, to place the rarely-used <LINK> element in the
4035 head section, use this:
4036
4037     print $q->start_html(-head=>Link({-rel=>'next',
4038                                   -href=>'http://www.capricorn.com/s2.html'}));
4039
4040 To incorporate multiple HTML elements into the <HEAD> section, just pass an
4041 array reference:
4042
4043     print $q->start_html(-head=>[
4044                               Link({-rel=>'next',
4045                                     -href=>'http://www.capricorn.com/s2.html'}),
4046                               Link({-rel=>'previous',
4047                                     -href=>'http://www.capricorn.com/s1.html'})
4048                              ]
4049                      );
4050
4051 JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
4052 B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
4053 to add Netscape JavaScript calls to your pages.  B<-script> should
4054 point to a block of text containing JavaScript function definitions.
4055 This block will be placed within a <SCRIPT> block inside the HTML (not
4056 HTTP) header.  The block is placed in the header in order to give your
4057 page a fighting chance of having all its JavaScript functions in place
4058 even if the user presses the stop button before the page has loaded
4059 completely.  CGI.pm attempts to format the script in such a way that
4060 JavaScript-naive browsers will not choke on the code: unfortunately
4061 there are some browsers, such as Chimera for Unix, that get confused
4062 by it nevertheless.
4063
4064 The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
4065 code to execute when the page is respectively opened and closed by the
4066 browser.  Usually these parameters are calls to functions defined in the
4067 B<-script> field:
4068
4069       $query = new CGI;
4070       print $query->header;
4071       $JSCRIPT=<<END;
4072       // Ask a silly question
4073       function riddle_me_this() {
4074          var r = prompt("What walks on four legs in the morning, " +
4075                        "two legs in the afternoon, " +
4076                        "and three legs in the evening?");
4077          response(r);
4078       }
4079       // Get a silly answer
4080       function response(answer) {
4081          if (answer == "man")
4082             alert("Right you are!");
4083          else
4084             alert("Wrong!  Guess again.");
4085       }
4086       END
4087       print $query->start_html(-title=>'The Riddle of the Sphinx',
4088                                -script=>$JSCRIPT);
4089
4090 Use the B<-noScript> parameter to pass some HTML text that will be displayed on
4091 browsers that do not have JavaScript (or browsers where JavaScript is turned
4092 off).
4093
4094 Netscape 3.0 recognizes several attributes of the <SCRIPT> tag,
4095 including LANGUAGE and SRC.  The latter is particularly interesting,
4096 as it allows you to keep the JavaScript code in a file or CGI script
4097 rather than cluttering up each page with the source.  To use these
4098 attributes pass a HASH reference in the B<-script> parameter containing
4099 one or more of -language, -src, or -code:
4100
4101     print $q->start_html(-title=>'The Riddle of the Sphinx',
4102                          -script=>{-language=>'JAVASCRIPT',
4103                                    -src=>'/javascript/sphinx.js'}
4104                          );
4105
4106     print $q->(-title=>'The Riddle of the Sphinx',
4107                -script=>{-language=>'PERLSCRIPT'},
4108                          -code=>'print "hello world!\n;"'
4109                );
4110
4111
4112 A final feature allows you to incorporate multiple <SCRIPT> sections into the
4113 header.  Just pass the list of script sections as an array reference.
4114 this allows you to specify different source files for different dialects
4115 of JavaScript.  Example:
4116
4117      print $q-&gt;start_html(-title=&gt;'The Riddle of the Sphinx',
4118                           -script=&gt;[
4119                                     { -language =&gt; 'JavaScript1.0',
4120                                       -src      =&gt; '/javascript/utilities10.js'
4121                                     },
4122                                     { -language =&gt; 'JavaScript1.1',
4123                                       -src      =&gt; '/javascript/utilities11.js'
4124                                     },
4125                                     { -language =&gt; 'JavaScript1.2',
4126                                       -src      =&gt; '/javascript/utilities12.js'
4127                                     },
4128                                     { -language =&gt; 'JavaScript28.2',
4129                                       -src      =&gt; '/javascript/utilities219.js'
4130                                     }
4131                                  ]
4132                              );
4133      </pre>
4134
4135 If this looks a bit extreme, take my advice and stick with straight CGI scripting.
4136
4137 See
4138
4139    http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
4140
4141 for more information about JavaScript.
4142
4143 The old-style positional parameters are as follows:
4144
4145 =over 4
4146
4147 =item B<Parameters:>
4148
4149 =item 1.
4150
4151 The title
4152
4153 =item 2.
4154
4155 The author's e-mail address (will create a <LINK REV="MADE"> tag if present
4156
4157 =item 3.
4158
4159 A 'true' flag if you want to include a <BASE> tag in the header.  This
4160 helps resolve relative addresses to absolute ones when the document is moved,
4161 but makes the document hierarchy non-portable.  Use with care!
4162
4163 =item 4, 5, 6...
4164
4165 Any other parameters you want to include in the <BODY> tag.  This is a good
4166 place to put Netscape extensions, such as colors and wallpaper patterns.
4167
4168 =back
4169
4170 =head2 ENDING THE HTML DOCUMENT:
4171
4172         print $query->end_html
4173
4174 This ends an HTML document by printing the </BODY></HTML> tags.
4175
4176 =head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
4177
4178     $myself = $query->self_url;
4179     print "<A HREF=$myself>I'm talking to myself.</A>";
4180
4181 self_url() will return a URL, that, when selected, will reinvoke
4182 this script with all its state information intact.  This is most
4183 useful when you want to jump around within the document using
4184 internal anchors but you don't want to disrupt the current contents
4185 of the form(s).  Something like this will do the trick.
4186
4187      $myself = $query->self_url;
4188      print "<A HREF=$myself#table1>See table 1</A>";
4189      print "<A HREF=$myself#table2>See table 2</A>";
4190      print "<A HREF=$myself#yourself>See for yourself</A>";
4191
4192 If you want more control over what's returned, using the B<url()>
4193 method instead.
4194
4195 You can also retrieve the unprocessed query string with query_string():
4196
4197     $the_string = $query->query_string;
4198
4199 =head2 OBTAINING THE SCRIPT'S URL
4200
4201     $full_url      = $query->url();
4202     $full_url      = $query->url(-full=>1);  #alternative syntax
4203     $relative_url  = $query->url(-relative=>1);
4204     $absolute_url  = $query->url(-absolute=>1);
4205     $url_with_path = $query->url(-path_info=>1);
4206     $url_with_path_and_query = $query->url(-path_info=>1,-query=>1);
4207
4208 B<url()> returns the script's URL in a variety of formats.  Called
4209 without any arguments, it returns the full form of the URL, including
4210 host name and port number
4211
4212     http://your.host.com/path/to/script.cgi
4213
4214 You can modify this format with the following named arguments:
4215
4216 =over 4
4217
4218 =item B<-absolute>
4219
4220 If true, produce an absolute URL, e.g.
4221
4222     /path/to/script.cgi
4223
4224 =item B<-relative>
4225
4226 Produce a relative URL.  This is useful if you want to reinvoke your
4227 script with different parameters. For example:
4228
4229     script.cgi
4230
4231 =item B<-full>
4232
4233 Produce the full URL, exactly as if called without any arguments.
4234 This overrides the -relative and -absolute arguments.
4235
4236 =item B<-path> (B<-path_info>)
4237
4238 Append the additional path information to the URL.  This can be
4239 combined with B<-full>, B<-absolute> or B<-relative>.  B<-path_info>
4240 is provided as a synonym.
4241
4242 =item B<-query> (B<-query_string>)
4243
4244 Append the query string to the URL.  This can be combined with
4245 B<-full>, B<-absolute> or B<-relative>.  B<-query_string> is provided
4246 as a synonym.
4247
4248 =back
4249
4250 =head1 CREATING STANDARD HTML ELEMENTS:
4251
4252 CGI.pm defines general HTML shortcut methods for most, if not all of
4253 the HTML 3 and HTML 4 tags.  HTML shortcuts are named after a single
4254 HTML element and return a fragment of HTML text that you can then
4255 print or manipulate as you like.  Each shortcut returns a fragment of
4256 HTML code that you can append to a string, save to a file, or, most
4257 commonly, print out so that it displays in the browser window.
4258
4259 This example shows how to use the HTML methods:
4260
4261    $q = new CGI;
4262    print $q->blockquote(
4263                      "Many years ago on the island of",
4264                      $q->a({href=>"http://crete.org/"},"Crete"),
4265                      "there lived a minotaur named",
4266                      $q->strong("Fred."),
4267                     ),
4268        $q->hr;
4269
4270 This results in the following HTML code (extra newlines have been
4271 added for readability):
4272
4273    <blockquote>
4274    Many years ago on the island of
4275    <a HREF="http://crete.org/">Crete</a> there lived
4276    a minotaur named <strong>Fred.</strong>
4277    </blockquote>
4278    <hr>
4279
4280 If you find the syntax for calling the HTML shortcuts awkward, you can
4281 import them into your namespace and dispense with the object syntax
4282 completely (see the next section for more details):
4283
4284    use CGI ':standard';
4285    print blockquote(
4286       "Many years ago on the island of",
4287       a({href=>"http://crete.org/"},"Crete"),
4288       "there lived a minotaur named",
4289       strong("Fred."),
4290       ),
4291       hr;
4292
4293 =head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
4294
4295 The HTML methods will accept zero, one or multiple arguments.  If you
4296 provide no arguments, you get a single tag:
4297
4298    print hr;    #  <HR>
4299
4300 If you provide one or more string arguments, they are concatenated
4301 together with spaces and placed between opening and closing tags:
4302
4303    print h1("Chapter","1"); # <H1>Chapter 1</H1>"
4304
4305 If the first argument is an associative array reference, then the keys
4306 and values of the associative array become the HTML tag's attributes:
4307
4308    print a({-href=>'fred.html',-target=>'_new'},
4309       "Open a new frame");
4310
4311             <A HREF="fred.html",TARGET="_new">Open a new frame</A>
4312
4313 You may dispense with the dashes in front of the attribute names if
4314 you prefer:
4315
4316    print img {src=>'fred.gif',align=>'LEFT'};
4317
4318            <IMG ALIGN="LEFT" SRC="fred.gif">
4319
4320 Sometimes an HTML tag attribute has no argument.  For example, ordered
4321 lists can be marked as COMPACT.  The syntax for this is an argument that
4322 that points to an undef string:
4323
4324    print ol({compact=>undef},li('one'),li('two'),li('three'));
4325
4326 Prior to CGI.pm version 2.41, providing an empty ('') string as an
4327 attribute argument was the same as providing undef.  However, this has
4328 changed in order to accomodate those who want to create tags of the form
4329 <IMG ALT="">.  The difference is shown in these two pieces of code:
4330
4331    CODE                   RESULT
4332    img({alt=>undef})      <IMG ALT>
4333    img({alt=>''})         <IMT ALT="">
4334
4335 =head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
4336
4337 One of the cool features of the HTML shortcuts is that they are
4338 distributive.  If you give them an argument consisting of a
4339 B<reference> to a list, the tag will be distributed across each
4340 element of the list.  For example, here's one way to make an ordered
4341 list:
4342
4343    print ul(
4344              li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']);
4345            );
4346
4347 This example will result in HTML output that looks like this:
4348
4349    <UL>
4350      <LI TYPE="disc">Sneezy</LI>
4351      <LI TYPE="disc">Doc</LI>
4352      <LI TYPE="disc">Sleepy</LI>
4353      <LI TYPE="disc">Happy</LI>
4354    </UL>
4355
4356 This is extremely useful for creating tables.  For example:
4357
4358    print table({-border=>undef},
4359            caption('When Should You Eat Your Vegetables?'),
4360            Tr({-align=>CENTER,-valign=>TOP},
4361            [
4362               th(['Vegetable', 'Breakfast','Lunch','Dinner']),
4363               td(['Tomatoes' , 'no', 'yes', 'yes']),
4364               td(['Broccoli' , 'no', 'no',  'yes']),
4365               td(['Onions'   , 'yes','yes', 'yes'])
4366            ]
4367            )
4368         );
4369
4370 =head2 HTML SHORTCUTS AND LIST INTERPOLATION
4371
4372 Consider this bit of code:
4373
4374    print blockquote(em('Hi'),'mom!'));
4375
4376 It will ordinarily return the string that you probably expect, namely:
4377
4378    <BLOCKQUOTE><EM>Hi</EM> mom!</BLOCKQUOTE>
4379
4380 Note the space between the element "Hi" and the element "mom!".
4381 CGI.pm puts the extra space there using array interpolation, which is
4382 controlled by the magic $" variable.  Sometimes this extra space is
4383 not what you want, for example, when you are trying to align a series
4384 of images.  In this case, you can simply change the value of $" to an
4385 empty string.
4386
4387    {
4388       local($") = '';
4389       print blockquote(em('Hi'),'mom!'));
4390     }
4391
4392 I suggest you put the code in a block as shown here.  Otherwise the
4393 change to $" will affect all subsequent code until you explicitly
4394 reset it.
4395
4396 =head2 NON-STANDARD HTML SHORTCUTS
4397
4398 A few HTML tags don't follow the standard pattern for various
4399 reasons.
4400
4401 B<comment()> generates an HTML comment (<!-- comment -->).  Call it
4402 like
4403
4404     print comment('here is my comment');
4405
4406 Because of conflicts with built-in Perl functions, the following functions
4407 begin with initial caps:
4408
4409     Select
4410     Tr
4411     Link
4412     Delete
4413
4414 In addition, start_html(), end_html(), start_form(), end_form(),
4415 start_multipart_form() and all the fill-out form tags are special.
4416 See their respective sections.
4417
4418 =head1 CREATING FILL-OUT FORMS:
4419
4420 I<General note>  The various form-creating methods all return strings
4421 to the caller, containing the tag or tags that will create the requested
4422 form element.  You are responsible for actually printing out these strings.
4423 It's set up this way so that you can place formatting tags
4424 around the form elements.
4425
4426 I<Another note> The default values that you specify for the forms are only
4427 used the B<first> time the script is invoked (when there is no query
4428 string).  On subsequent invocations of the script (when there is a query
4429 string), the former values are used even if they are blank.
4430
4431 If you want to change the value of a field from its previous value, you have two
4432 choices:
4433
4434 (1) call the param() method to set it.
4435
4436 (2) use the -override (alias -force) parameter (a new feature in version 2.15).
4437 This forces the default value to be used, regardless of the previous value:
4438
4439    print $query->textfield(-name=>'field_name',
4440                            -default=>'starting value',
4441                            -override=>1,
4442                            -size=>50,
4443                            -maxlength=>80);
4444
4445 I<Yet another note> By default, the text and labels of form elements are
4446 escaped according to HTML rules.  This means that you can safely use
4447 "<CLICK ME>" as the label for a button.  However, it also interferes with
4448 your ability to incorporate special HTML character sequences, such as &Aacute;,
4449 into your fields.  If you wish to turn off automatic escaping, call the
4450 autoEscape() method with a false value immediately after creating the CGI object:
4451
4452    $query = new CGI;
4453    $query->autoEscape(undef);
4454
4455
4456 =head2 CREATING AN ISINDEX TAG
4457
4458    print $query->isindex(-action=>$action);
4459
4460          -or-
4461
4462    print $query->isindex($action);
4463
4464 Prints out an <ISINDEX> tag.  Not very exciting.  The parameter
4465 -action specifies the URL of the script to process the query.  The
4466 default is to process the query with the current script.
4467
4468 =head2 STARTING AND ENDING A FORM
4469
4470     print $query->startform(-method=>$method,
4471                             -action=>$action,
4472                             -encoding=>$encoding);
4473       <... various form stuff ...>
4474     print $query->endform;
4475
4476         -or-
4477
4478     print $query->startform($method,$action,$encoding);
4479       <... various form stuff ...>
4480     print $query->endform;
4481
4482 startform() will return a <FORM> tag with the optional method,
4483 action and form encoding that you specify.  The defaults are:
4484
4485     method: POST
4486     action: this script
4487     encoding: application/x-www-form-urlencoded
4488
4489 endform() returns the closing </FORM> tag.
4490
4491 Startform()'s encoding method tells the browser how to package the various
4492 fields of the form before sending the form to the server.  Two
4493 values are possible:
4494
4495 =over 4
4496
4497 =item B<application/x-www-form-urlencoded>
4498
4499 This is the older type of encoding used by all browsers prior to
4500 Netscape 2.0.  It is compatible with many CGI scripts and is
4501 suitable for short fields containing text data.  For your
4502 convenience, CGI.pm stores the name of this encoding
4503 type in B<$CGI::URL_ENCODED>.
4504
4505 =item B<multipart/form-data>
4506
4507 This is the newer type of encoding introduced by Netscape 2.0.
4508 It is suitable for forms that contain very large fields or that
4509 are intended for transferring binary data.  Most importantly,
4510 it enables the "file upload" feature of Netscape 2.0 forms.  For
4511 your convenience, CGI.pm stores the name of this encoding type
4512 in B<&CGI::MULTIPART>
4513
4514 Forms that use this type of encoding are not easily interpreted
4515 by CGI scripts unless they use CGI.pm or another library designed
4516 to handle them.
4517
4518 =back
4519
4520 For compatibility, the startform() method uses the older form of
4521 encoding by default.  If you want to use the newer form of encoding
4522 by default, you can call B<start_multipart_form()> instead of
4523 B<startform()>.
4524
4525 JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
4526 for use with JavaScript.  The -name parameter gives the
4527 form a name so that it can be identified and manipulated by
4528 JavaScript functions.  -onSubmit should point to a JavaScript
4529 function that will be executed just before the form is submitted to your
4530 server.  You can use this opportunity to check the contents of the form
4531 for consistency and completeness.  If you find something wrong, you
4532 can put up an alert box or maybe fix things up yourself.  You can
4533 abort the submission by returning false from this function.
4534
4535 Usually the bulk of JavaScript functions are defined in a <SCRIPT>
4536 block in the HTML header and -onSubmit points to one of these function
4537 call.  See start_html() for details.
4538
4539 =head2 CREATING A TEXT FIELD
4540
4541     print $query->textfield(-name=>'field_name',
4542                             -default=>'starting value',
4543                             -size=>50,
4544                             -maxlength=>80);
4545         -or-
4546
4547     print $query->textfield('field_name','starting value',50,80);
4548
4549 textfield() will return a text input field.
4550
4551 =over 4
4552
4553 =item B<Parameters>
4554
4555 =item 1.
4556
4557 The first parameter is the required name for the field (-name).
4558
4559 =item 2.
4560
4561 The optional second parameter is the default starting value for the field
4562 contents (-default).
4563
4564 =item 3.
4565
4566 The optional third parameter is the size of the field in
4567       characters (-size).
4568
4569 =item 4.
4570
4571 The optional fourth parameter is the maximum number of characters the
4572       field will accept (-maxlength).
4573
4574 =back
4575
4576 As with all these methods, the field will be initialized with its
4577 previous contents from earlier invocations of the script.
4578 When the form is processed, the value of the text field can be
4579 retrieved with:
4580
4581        $value = $query->param('foo');
4582
4583 If you want to reset it from its initial value after the script has been
4584 called once, you can do so like this:
4585
4586        $query->param('foo',"I'm taking over this value!");
4587
4588 NEW AS OF VERSION 2.15: If you don't want the field to take on its previous
4589 value, you can force its current value by using the -override (alias -force)
4590 parameter:
4591
4592     print $query->textfield(-name=>'field_name',
4593                             -default=>'starting value',
4594                             -override=>1,
4595                             -size=>50,
4596                             -maxlength=>80);
4597
4598 JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>,
4599 B<-onBlur>, B<-onMouseOver>, B<-onMouseOut> and B<-onSelect>
4600 parameters to register JavaScript event handlers.  The onChange
4601 handler will be called whenever the user changes the contents of the
4602 text field.  You can do text validation if you like.  onFocus and
4603 onBlur are called respectively when the insertion point moves into and
4604 out of the text field.  onSelect is called when the user changes the
4605 portion of the text that is selected.
4606
4607 =head2 CREATING A BIG TEXT FIELD
4608
4609    print $query->textarea(-name=>'foo',
4610                           -default=>'starting value',
4611                           -rows=>10,
4612                           -columns=>50);
4613
4614         -or
4615
4616    print $query->textarea('foo','starting value',10,50);
4617
4618 textarea() is just like textfield, but it allows you to specify
4619 rows and columns for a multiline text entry box.  You can provide
4620 a starting value for the field, which can be long and contain
4621 multiple lines.
4622
4623 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> ,
4624 B<-onMouseOver>, B<-onMouseOut>, and B<-onSelect> parameters are
4625 recognized.  See textfield().
4626
4627 =head2 CREATING A PASSWORD FIELD
4628
4629    print $query->password_field(-name=>'secret',
4630                                 -value=>'starting value',
4631                                 -size=>50,
4632                                 -maxlength=>80);
4633         -or-
4634
4635    print $query->password_field('secret','starting value',50,80);
4636
4637 password_field() is identical to textfield(), except that its contents
4638 will be starred out on the web page.
4639
4640 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
4641 B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
4642 recognized.  See textfield().
4643
4644 =head2 CREATING A FILE UPLOAD FIELD
4645
4646     print $query->filefield(-name=>'uploaded_file',
4647                             -default=>'starting value',
4648                             -size=>50,
4649                             -maxlength=>80);
4650         -or-
4651
4652     print $query->filefield('uploaded_file','starting value',50,80);
4653
4654 filefield() will return a file upload field for Netscape 2.0 browsers.
4655 In order to take full advantage of this I<you must use the new
4656 multipart encoding scheme> for the form.  You can do this either
4657 by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>,
4658 or by calling the new method B<start_multipart_form()> instead of
4659 vanilla B<startform()>.
4660
4661 =over 4
4662
4663 =item B<Parameters>
4664
4665 =item 1.
4666
4667 The first parameter is the required name for the field (-name).
4668
4669 =item 2.
4670
4671 The optional second parameter is the starting value for the field contents
4672 to be used as the default file name (-default).
4673
4674 The beta2 version of Netscape 2.0 currently doesn't pay any attention
4675 to this field, and so the starting value will always be blank.  Worse,
4676 the field loses its "sticky" behavior and forgets its previous
4677 contents.  The starting value field is called for in the HTML
4678 specification, however, and possibly later versions of Netscape will
4679 honor it.
4680
4681 =item 3.
4682
4683 The optional third parameter is the size of the field in
4684 characters (-size).
4685
4686 =item 4.
4687
4688 The optional fourth parameter is the maximum number of characters the
4689 field will accept (-maxlength).
4690
4691 =back
4692
4693 When the form is processed, you can retrieve the entered filename
4694 by calling param().
4695
4696        $filename = $query->param('uploaded_file');
4697
4698 In Netscape Navigator 2.0, the filename that gets returned is the full
4699 local filename on the B<remote user's> machine.  If the remote user is
4700 on a Unix machine, the filename will follow Unix conventions:
4701
4702         /path/to/the/file
4703
4704 On an MS-DOS/Windows and OS/2 machines, the filename will follow DOS conventions:
4705
4706         C:\PATH\TO\THE\FILE.MSW
4707
4708 On a Macintosh machine, the filename will follow Mac conventions:
4709
4710         HD 40:Desktop Folder:Sort Through:Reminders
4711
4712 The filename returned is also a file handle.  You can read the contents
4713 of the file using standard Perl file reading calls:
4714
4715         # Read a text file and print it out
4716         while (<$filename>) {
4717            print;
4718         }
4719
4720         # Copy a binary file to somewhere safe
4721         open (OUTFILE,">>/usr/local/web/users/feedback");
4722         while ($bytesread=read($filename,$buffer,1024)) {
4723            print OUTFILE $buffer;
4724         }
4725
4726 When a file is uploaded the browser usually sends along some
4727 information along with it in the format of headers.  The information
4728 usually includes the MIME content type.  Future browsers may send
4729 other information as well (such as modification date and size). To
4730 retrieve this information, call uploadInfo().  It returns a reference to
4731 an associative array containing all the document headers.
4732
4733        $filename = $query->param('uploaded_file');
4734        $type = $query->uploadInfo($filename)->{'Content-Type'};
4735        unless ($type eq 'text/html') {
4736           die "HTML FILES ONLY!";
4737        }
4738
4739 If you are using a machine that recognizes "text" and "binary" data
4740 modes, be sure to understand when and how to use them (see the Camel book).
4741 Otherwise you may find that binary files are corrupted during file uploads.
4742
4743 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
4744 B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
4745 recognized.  See textfield() for details.
4746
4747 =head2 CREATING A POPUP MENU
4748
4749    print $query->popup_menu('menu_name',
4750                             ['eenie','meenie','minie'],
4751                             'meenie');
4752
4753       -or-
4754
4755    %labels = ('eenie'=>'your first choice',
4756               'meenie'=>'your second choice',
4757               'minie'=>'your third choice');
4758    print $query->popup_menu('menu_name',
4759                             ['eenie','meenie','minie'],
4760                             'meenie',\%labels);
4761
4762         -or (named parameter style)-
4763
4764    print $query->popup_menu(-name=>'menu_name',
4765                             -values=>['eenie','meenie','minie'],
4766                             -default=>'meenie',
4767                             -labels=>\%labels);
4768
4769 popup_menu() creates a menu.
4770
4771 =over 4
4772
4773 =item 1.
4774
4775 The required first argument is the menu's name (-name).
4776
4777 =item 2.
4778
4779 The required second argument (-values) is an array B<reference>
4780 containing the list of menu items in the menu.  You can pass the
4781 method an anonymous array, as shown in the example, or a reference to
4782 a named array, such as "\@foo".
4783
4784 =item 3.
4785
4786 The optional third parameter (-default) is the name of the default
4787 menu choice.  If not specified, the first item will be the default.
4788 The values of the previous choice will be maintained across queries.
4789
4790 =item 4.
4791
4792 The optional fourth parameter (-labels) is provided for people who
4793 want to use different values for the user-visible label inside the
4794 popup menu nd the value returned to your script.  It's a pointer to an
4795 associative array relating menu values to user-visible labels.  If you
4796 leave this parameter blank, the menu values will be displayed by
4797 default.  (You can also leave a label undefined if you want to).
4798
4799 =back
4800
4801 When the form is processed, the selected value of the popup menu can
4802 be retrieved using:
4803
4804       $popup_menu_value = $query->param('menu_name');
4805
4806 JAVASCRIPTING: popup_menu() recognizes the following event handlers:
4807 B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>, and
4808 B<-onBlur>.  See the textfield() section for details on when these
4809 handlers are called.
4810
4811 =head2 CREATING A SCROLLING LIST
4812
4813    print $query->scrolling_list('list_name',
4814                                 ['eenie','meenie','minie','moe'],
4815                                 ['eenie','moe'],5,'true');
4816       -or-
4817
4818    print $query->scrolling_list('list_name',
4819                                 ['eenie','meenie','minie','moe'],
4820                                 ['eenie','moe'],5,'true',
4821                                 \%labels);
4822
4823         -or-
4824
4825    print $query->scrolling_list(-name=>'list_name',
4826                                 -values=>['eenie','meenie','minie','moe'],
4827                                 -default=>['eenie','moe'],
4828                                 -size=>5,
4829                                 -multiple=>'true',
4830                                 -labels=>\%labels);
4831
4832 scrolling_list() creates a scrolling list.
4833
4834 =over 4
4835
4836 =item B<Parameters:>
4837
4838 =item 1.
4839
4840 The first and second arguments are the list name (-name) and values
4841 (-values).  As in the popup menu, the second argument should be an
4842 array reference.
4843
4844 =item 2.
4845
4846 The optional third argument (-default) can be either a reference to a
4847 list containing the values to be selected by default, or can be a
4848 single value to select.  If this argument is missing or undefined,
4849 then nothing is selected when the list first appears.  In the named
4850 parameter version, you can use the synonym "-defaults" for this
4851 parameter.
4852
4853 =item 3.
4854
4855 The optional fourth argument is the size of the list (-size).
4856
4857 =item 4.
4858
4859 The optional fifth argument can be set to true to allow multiple
4860 simultaneous selections (-multiple).  Otherwise only one selection
4861 will be allowed at a time.
4862
4863 =item 5.
4864
4865 The optional sixth argument is a pointer to an associative array
4866 containing long user-visible labels for the list items (-labels).
4867 If not provided, the values will be displayed.
4868
4869 When this form is processed, all selected list items will be returned as
4870 a list under the parameter name 'list_name'.  The values of the
4871 selected items can be retrieved with:
4872
4873       @selected = $query->param('list_name');
4874
4875 =back
4876
4877 JAVASCRIPTING: scrolling_list() recognizes the following event
4878 handlers: B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>
4879 and B<-onBlur>.  See textfield() for the description of when these
4880 handlers are called.
4881
4882 =head2 CREATING A GROUP OF RELATED CHECKBOXES
4883
4884    print $query->checkbox_group(-name=>'group_name',
4885                                 -values=>['eenie','meenie','minie','moe'],
4886                                 -default=>['eenie','moe'],
4887                                 -linebreak=>'true',
4888                                 -labels=>\%labels);
4889
4890    print $query->checkbox_group('group_name',
4891                                 ['eenie','meenie','minie','moe'],
4892                                 ['eenie','moe'],'true',\%labels);
4893
4894    HTML3-COMPATIBLE BROWSERS ONLY:
4895
4896    print $query->checkbox_group(-name=>'group_name',
4897                                 -values=>['eenie','meenie','minie','moe'],
4898                                 -rows=2,-columns=>2);
4899
4900
4901 checkbox_group() creates a list of checkboxes that are related
4902 by the same name.
4903
4904 =over 4
4905
4906 =item B<Parameters:>
4907
4908 =item 1.
4909
4910 The first and second arguments are the checkbox name and values,
4911 respectively (-name and -values).  As in the popup menu, the second
4912 argument should be an array reference.  These values are used for the
4913 user-readable labels printed next to the checkboxes as well as for the
4914 values passed to your script in the query string.
4915
4916 =item 2.
4917
4918 The optional third argument (-default) can be either a reference to a
4919 list containing the values to be checked by default, or can be a
4920 single value to checked.  If this argument is missing or undefined,
4921 then nothing is selected when the list first appears.
4922
4923 =item 3.
4924
4925 The optional fourth argument (-linebreak) can be set to true to place
4926 line breaks between the checkboxes so that they appear as a vertical
4927 list.  Otherwise, they will be strung together on a horizontal line.
4928
4929 =item 4.
4930
4931 The optional fifth argument is a pointer to an associative array
4932 relating the checkbox values to the user-visible labels that will
4933 be printed next to them (-labels).  If not provided, the values will
4934 be used as the default.
4935
4936 =item 5.
4937
4938 B<HTML3-compatible browsers> (such as Netscape) can take advantage of
4939 the optional parameters B<-rows>, and B<-columns>.  These parameters
4940 cause checkbox_group() to return an HTML3 compatible table containing
4941 the checkbox group formatted with the specified number of rows and
4942 columns.  You can provide just the -columns parameter if you wish;
4943 checkbox_group will calculate the correct number of rows for you.
4944
4945 To include row and column headings in the returned table, you
4946 can use the B<-rowheaders> and B<-colheaders> parameters.  Both
4947 of these accept a pointer to an array of headings to use.
4948 The headings are just decorative.  They don't reorganize the
4949 interpretation of the checkboxes -- they're still a single named
4950 unit.
4951
4952 =back
4953
4954 When the form is processed, all checked boxes will be returned as
4955 a list under the parameter name 'group_name'.  The values of the
4956 "on" checkboxes can be retrieved with:
4957
4958       @turned_on = $query->param('group_name');
4959
4960 The value returned by checkbox_group() is actually an array of button
4961 elements.  You can capture them and use them within tables, lists,
4962 or in other creative ways:
4963
4964     @h = $query->checkbox_group(-name=>'group_name',-values=>\@values);
4965     &use_in_creative_way(@h);
4966
4967 JAVASCRIPTING: checkbox_group() recognizes the B<-onClick>
4968 parameter.  This specifies a JavaScript code fragment or
4969 function call to be executed every time the user clicks on
4970 any of the buttons in the group.  You can retrieve the identity
4971 of the particular button clicked on using the "this" variable.
4972
4973 =head2 CREATING A STANDALONE CHECKBOX
4974
4975     print $query->checkbox(-name=>'checkbox_name',
4976                            -checked=>'checked',
4977                            -value=>'ON',
4978                            -label=>'CLICK ME');
4979
4980         -or-
4981
4982     print $query->checkbox('checkbox_name','checked','ON','CLICK ME');
4983
4984 checkbox() is used to create an isolated checkbox that isn't logically
4985 related to any others.
4986
4987 =over 4
4988
4989 =item B<Parameters:>
4990
4991 =item 1.
4992
4993 The first parameter is the required name for the checkbox (-name).  It
4994 will also be used for the user-readable label printed next to the
4995 checkbox.
4996
4997 =item 2.
4998
4999 The optional second parameter (-checked) specifies that the checkbox
5000 is turned on by default.  Synonyms are -selected and -on.
5001
5002 =item 3.
5003
5004 The optional third parameter (-value) specifies the value of the
5005 checkbox when it is checked.  If not provided, the word "on" is
5006 assumed.
5007
5008 =item 4.
5009
5010 The optional fourth parameter (-label) is the user-readable label to
5011 be attached to the checkbox.  If not provided, the checkbox name is
5012 used.
5013
5014 =back
5015
5016 The value of the checkbox can be retrieved using:
5017
5018     $turned_on = $query->param('checkbox_name');
5019
5020 JAVASCRIPTING: checkbox() recognizes the B<-onClick>
5021 parameter.  See checkbox_group() for further details.
5022
5023 =head2 CREATING A RADIO BUTTON GROUP
5024
5025    print $query->radio_group(-name=>'group_name',
5026                              -values=>['eenie','meenie','minie'],
5027                              -default=>'meenie',
5028                              -linebreak=>'true',
5029                              -labels=>\%labels);
5030
5031         -or-
5032
5033    print $query->radio_group('group_name',['eenie','meenie','minie'],
5034                                           'meenie','true',\%labels);
5035
5036
5037    HTML3-COMPATIBLE BROWSERS ONLY:
5038
5039    print $query->radio_group(-name=>'group_name',
5040                              -values=>['eenie','meenie','minie','moe'],
5041                              -rows=2,-columns=>2);
5042
5043 radio_group() creates a set of logically-related radio buttons
5044 (turning one member of the group on turns the others off)
5045
5046 =over 4
5047
5048 =item B<Parameters:>
5049
5050 =item 1.
5051
5052 The first argument is the name of the group and is required (-name).
5053
5054 =item 2.
5055
5056 The second argument (-values) is the list of values for the radio
5057 buttons.  The values and the labels that appear on the page are
5058 identical.  Pass an array I<reference> in the second argument, either
5059 using an anonymous array, as shown, or by referencing a named array as
5060 in "\@foo".
5061
5062 =item 3.
5063
5064 The optional third parameter (-default) is the name of the default
5065 button to turn on. If not specified, the first item will be the
5066 default.  You can provide a nonexistent button name, such as "-" to
5067 start up with no buttons selected.
5068
5069 =item 4.
5070
5071 The optional fourth parameter (-linebreak) can be set to 'true' to put
5072 line breaks between the buttons, creating a vertical list.
5073
5074 =item 5.
5075
5076 The optional fifth parameter (-labels) is a pointer to an associative
5077 array relating the radio button values to user-visible labels to be
5078 used in the display.  If not provided, the values themselves are
5079 displayed.
5080
5081 =item 6.
5082
5083 B<HTML3-compatible browsers> (such as Netscape) can take advantage
5084 of the optional
5085 parameters B<-rows>, and B<-columns>.  These parameters cause
5086 radio_group() to return an HTML3 compatible table containing
5087 the radio group formatted with the specified number of rows
5088 and columns.  You can provide just the -columns parameter if you
5089 wish; radio_group will calculate the correct number of rows
5090 for you.
5091
5092 To include row and column headings in the returned table, you
5093 can use the B<-rowheader> and B<-colheader> parameters.  Both
5094 of these accept a pointer to an array of headings to use.
5095 The headings are just decorative.  They don't reorganize the
5096 interpetation of the radio buttons -- they're still a single named
5097 unit.
5098
5099 =back
5100
5101 When the form is processed, the selected radio button can
5102 be retrieved using:
5103
5104       $which_radio_button = $query->param('group_name');
5105
5106 The value returned by radio_group() is actually an array of button
5107 elements.  You can capture them and use them within tables, lists,
5108 or in other creative ways:
5109
5110     @h = $query->radio_group(-name=>'group_name',-values=>\@values);
5111     &use_in_creative_way(@h);
5112
5113 =head2 CREATING A SUBMIT BUTTON
5114
5115    print $query->submit(-name=>'button_name',
5116                         -value=>'value');
5117
5118         -or-
5119
5120    print $query->submit('button_name','value');
5121
5122 submit() will create the query submission button.  Every form
5123 should have one of these.
5124
5125 =over 4
5126
5127 =item B<Parameters:>
5128
5129 =item 1.
5130
5131 The first argument (-name) is optional.  You can give the button a
5132 name if you have several submission buttons in your form and you want
5133 to distinguish between them.  The name will also be used as the
5134 user-visible label.  Be aware that a few older browsers don't deal with this correctly and
5135 B<never> send back a value from a button.
5136
5137 =item 2.
5138
5139 The second argument (-value) is also optional.  This gives the button
5140 a value that will be passed to your script in the query string.
5141
5142 =back
5143
5144 You can figure out which button was pressed by using different
5145 values for each one:
5146
5147      $which_one = $query->param('button_name');
5148
5149 JAVASCRIPTING: radio_group() recognizes the B<-onClick>
5150 parameter.  See checkbox_group() for further details.
5151
5152 =head2 CREATING A RESET BUTTON
5153
5154    print $query->reset
5155
5156 reset() creates the "reset" button.  Note that it restores the
5157 form to its value from the last time the script was called,
5158 NOT necessarily to the defaults.
5159
5160 =head2 CREATING A DEFAULT BUTTON
5161
5162    print $query->defaults('button_label')
5163
5164 defaults() creates a button that, when invoked, will cause the
5165 form to be completely reset to its defaults, wiping out all the
5166 changes the user ever made.
5167
5168 =head2 CREATING A HIDDEN FIELD
5169
5170         print $query->hidden(-name=>'hidden_name',
5171                              -default=>['value1','value2'...]);
5172
5173                 -or-
5174
5175         print $query->hidden('hidden_name','value1','value2'...);
5176
5177 hidden() produces a text field that can't be seen by the user.  It
5178 is useful for passing state variable information from one invocation
5179 of the script to the next.
5180
5181 =over 4
5182
5183 =item B<Parameters:>
5184
5185 =item 1.
5186
5187 The first argument is required and specifies the name of this
5188 field (-name).
5189
5190 =item 2.
5191
5192 The second argument is also required and specifies its value
5193 (-default).  In the named parameter style of calling, you can provide
5194 a single value here or a reference to a whole list
5195
5196 =back
5197
5198 Fetch the value of a hidden field this way:
5199
5200      $hidden_value = $query->param('hidden_name');
5201
5202 Note, that just like all the other form elements, the value of a
5203 hidden field is "sticky".  If you want to replace a hidden field with
5204 some other values after the script has been called once you'll have to
5205 do it manually:
5206
5207      $query->param('hidden_name','new','values','here');
5208
5209 =head2 CREATING A CLICKABLE IMAGE BUTTON
5210
5211      print $query->image_button(-name=>'button_name',
5212                                 -src=>'/source/URL',
5213                                 -align=>'MIDDLE');
5214
5215         -or-
5216
5217      print $query->image_button('button_name','/source/URL','MIDDLE');
5218
5219 image_button() produces a clickable image.  When it's clicked on the
5220 position of the click is returned to your script as "button_name.x"
5221 and "button_name.y", where "button_name" is the name you've assigned
5222 to it.
5223
5224 JAVASCRIPTING: image_button() recognizes the B<-onClick>
5225 parameter.  See checkbox_group() for further details.
5226
5227 =over 4
5228
5229 =item B<Parameters:>
5230
5231 =item 1.
5232
5233 The first argument (-name) is required and specifies the name of this
5234 field.
5235
5236 =item 2.
5237
5238 The second argument (-src) is also required and specifies the URL
5239
5240 =item 3.
5241 The third option (-align, optional) is an alignment type, and may be
5242 TOP, BOTTOM or MIDDLE
5243
5244 =back
5245
5246 Fetch the value of the button this way:
5247      $x = $query->param('button_name.x');
5248      $y = $query->param('button_name.y');
5249
5250 =head2 CREATING A JAVASCRIPT ACTION BUTTON
5251
5252      print $query->button(-name=>'button_name',
5253                           -value=>'user visible label',
5254                           -onClick=>"do_something()");
5255
5256         -or-
5257
5258      print $query->button('button_name',"do_something()");
5259
5260 button() produces a button that is compatible with Netscape 2.0's
5261 JavaScript.  When it's pressed the fragment of JavaScript code
5262 pointed to by the B<-onClick> parameter will be executed.  On
5263 non-Netscape browsers this form element will probably not even
5264 display.
5265
5266 =head1 NETSCAPE COOKIES
5267
5268 Netscape browsers versions 1.1 and higher support a so-called
5269 "cookie" designed to help maintain state within a browser session.
5270 CGI.pm has several methods that support cookies.
5271
5272 A cookie is a name=value pair much like the named parameters in a CGI
5273 query string.  CGI scripts create one or more cookies and send
5274 them to the browser in the HTTP header.  The browser maintains a list
5275 of cookies that belong to a particular Web server, and returns them
5276 to the CGI script during subsequent interactions.
5277
5278 In addition to the required name=value pair, each cookie has several
5279 optional attributes:
5280
5281 =over 4
5282
5283 =item 1. an expiration time
5284
5285 This is a time/date string (in a special GMT format) that indicates
5286 when a cookie expires.  The cookie will be saved and returned to your
5287 script until this expiration date is reached if the user exits
5288 Netscape and restarts it.  If an expiration date isn't specified, the cookie
5289 will remain active until the user quits Netscape.
5290
5291 =item 2. a domain
5292
5293 This is a partial or complete domain name for which the cookie is
5294 valid.  The browser will return the cookie to any host that matches
5295 the partial domain name.  For example, if you specify a domain name
5296 of ".capricorn.com", then Netscape will return the cookie to
5297 Web servers running on any of the machines "www.capricorn.com",
5298 "www2.capricorn.com", "feckless.capricorn.com", etc.  Domain names
5299 must contain at least two periods to prevent attempts to match
5300 on top level domains like ".edu".  If no domain is specified, then
5301 the browser will only return the cookie to servers on the host the
5302 cookie originated from.
5303
5304 =item 3. a path
5305
5306 If you provide a cookie path attribute, the browser will check it
5307 against your script's URL before returning the cookie.  For example,
5308 if you specify the path "/cgi-bin", then the cookie will be returned
5309 to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
5310 and "/cgi-bin/customer_service/complain.pl", but not to the script
5311 "/cgi-private/site_admin.pl".  By default, path is set to "/", which
5312 causes the cookie to be sent to any CGI script on your site.
5313
5314 =item 4. a "secure" flag
5315
5316 If the "secure" attribute is set, the cookie will only be sent to your
5317 script if the CGI request is occurring on a secure channel, such as SSL.
5318
5319 =back
5320
5321 The interface to Netscape cookies is the B<cookie()> method:
5322
5323     $cookie = $query->cookie(-name=>'sessionID',
5324                              -value=>'xyzzy',
5325                              -expires=>'+1h',
5326                              -path=>'/cgi-bin/database',
5327                              -domain=>'.capricorn.org',
5328                              -secure=>1);
5329     print $query->header(-cookie=>$cookie);
5330
5331 B<cookie()> creates a new cookie.  Its parameters include:
5332
5333 =over 4
5334
5335 =item B<-name>
5336
5337 The name of the cookie (required).  This can be any string at all.
5338 Although Netscape limits its cookie names to non-whitespace
5339 alphanumeric characters, CGI.pm removes this restriction by escaping
5340 and unescaping cookies behind the scenes.
5341
5342 =item B<-value>
5343
5344 The value of the cookie.  This can be any scalar value,
5345 array reference, or even associative array reference.  For example,
5346 you can store an entire associative array into a cookie this way:
5347
5348         $cookie=$query->cookie(-name=>'family information',
5349                                -value=>\%childrens_ages);
5350
5351 =item B<-path>
5352
5353 The optional partial path for which this cookie will be valid, as described
5354 above.
5355
5356 =item B<-domain>
5357
5358 The optional partial domain for which this cookie will be valid, as described
5359 above.
5360
5361 =item B<-expires>
5362
5363 The optional expiration date for this cookie.  The format is as described
5364 in the section on the B<header()> method:
5365
5366         "+1h"  one hour from now
5367
5368 =item B<-secure>
5369
5370 If set to true, this cookie will only be used within a secure
5371 SSL session.
5372
5373 =back
5374
5375 The cookie created by cookie() must be incorporated into the HTTP
5376 header within the string returned by the header() method:
5377
5378         print $query->header(-cookie=>$my_cookie);
5379
5380 To create multiple cookies, give header() an array reference:
5381
5382         $cookie1 = $query->cookie(-name=>'riddle_name',
5383                                   -value=>"The Sphynx's Question");
5384         $cookie2 = $query->cookie(-name=>'answers',
5385                                   -value=>\%answers);
5386         print $query->header(-cookie=>[$cookie1,$cookie2]);
5387
5388 To retrieve a cookie, request it by name by calling cookie()
5389 method without the B<-value> parameter:
5390
5391         use CGI;
5392         $query = new CGI;
5393         %answers = $query->cookie(-name=>'answers');
5394         # $query->cookie('answers') will work too!
5395
5396 The cookie and CGI namespaces are separate.  If you have a parameter
5397 named 'answers' and a cookie named 'answers', the values retrieved by
5398 param() and cookie() are independent of each other.  However, it's
5399 simple to turn a CGI parameter into a cookie, and vice-versa:
5400
5401    # turn a CGI parameter into a cookie
5402    $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]);
5403    # vice-versa
5404    $q->param(-name=>'answers',-value=>[$q->cookie('answers')]);
5405
5406 See the B<cookie.cgi> example script for some ideas on how to use
5407 cookies effectively.
5408
5409 B<NOTE:> There appear to be some (undocumented) restrictions on
5410 Netscape cookies.  In Netscape 2.01, at least, I haven't been able to
5411 set more than three cookies at a time.  There may also be limits on
5412 the length of cookies.  If you need to store a lot of information,
5413 it's probably better to create a unique session ID, store it in a
5414 cookie, and use the session ID to locate an external file/database
5415 saved on the server's side of the connection.
5416
5417 =head1 WORKING WITH NETSCAPE FRAMES
5418
5419 It's possible for CGI.pm scripts to write into several browser
5420 panels and windows using Netscape's frame mechanism.
5421 There are three techniques for defining new frames programmatically:
5422
5423 =over 4
5424
5425 =item 1. Create a <Frameset> document
5426
5427 After writing out the HTTP header, instead of creating a standard
5428 HTML document using the start_html() call, create a <FRAMESET>
5429 document that defines the frames on the page.  Specify your script(s)
5430 (with appropriate parameters) as the SRC for each of the frames.
5431
5432 There is no specific support for creating <FRAMESET> sections
5433 in CGI.pm, but the HTML is very simple to write.  See the frame
5434 documentation in Netscape's home pages for details
5435
5436   http://home.netscape.com/assist/net_sites/frames.html
5437
5438 =item 2. Specify the destination for the document in the HTTP header
5439
5440 You may provide a B<-target> parameter to the header() method:
5441
5442     print $q->header(-target=>'ResultsWindow');
5443
5444 This will tell Netscape to load the output of your script into the
5445 frame named "ResultsWindow".  If a frame of that name doesn't
5446 already exist, Netscape will pop up a new window and load your
5447 script's document into that.  There are a number of magic names
5448 that you can use for targets.  See the frame documents on Netscape's
5449 home pages for details.
5450
5451 =item 3. Specify the destination for the document in the <FORM> tag
5452
5453 You can specify the frame to load in the FORM tag itself.  With
5454 CGI.pm it looks like this:
5455
5456     print $q->startform(-target=>'ResultsWindow');
5457
5458 When your script is reinvoked by the form, its output will be loaded
5459 into the frame named "ResultsWindow".  If one doesn't already exist
5460 a new window will be created.
5461
5462 =back
5463
5464 The script "frameset.cgi" in the examples directory shows one way to
5465 create pages in which the fill-out form and the response live in
5466 side-by-side frames.
5467
5468 =head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
5469
5470 CGI.pm has limited support for HTML3's cascading style sheets (css).
5471 To incorporate a stylesheet into your document, pass the
5472 start_html() method a B<-style> parameter.  The value of this
5473 parameter may be a scalar, in which case it is incorporated directly
5474 into a <STYLE> section, or it may be a hash reference.  In the latter
5475 case you should provide the hash with one or more of B<-src> or
5476 B<-code>.  B<-src> points to a URL where an externally-defined
5477 stylesheet can be found.  B<-code> points to a scalar value to be
5478 incorporated into a <STYLE> section.  Style definitions in B<-code>
5479 override similarly-named ones in B<-src>, hence the name "cascading."
5480
5481 You may also specify the type of the stylesheet by adding the optional
5482 B<-type> parameter to the hash pointed to by B<-style>.  If not
5483 specified, the style defaults to 'text/css'.
5484
5485 To refer to a style within the body of your document, add the
5486 B<-class> parameter to any HTML element:
5487
5488     print h1({-class=>'Fancy'},'Welcome to the Party');
5489
5490 Or define styles on the fly with the B<-style> parameter:
5491
5492     print h1({-style=>'Color: red;'},'Welcome to Hell');
5493
5494 You may also use the new B<span()> element to apply a style to a
5495 section of text:
5496
5497     print span({-style=>'Color: red;'},
5498                h1('Welcome to Hell'),
5499                "Where did that handbasket get to?"
5500                );
5501
5502 Note that you must import the ":html3" definitions to have the
5503 B<span()> method available.  Here's a quick and dirty example of using
5504 CSS's.  See the CSS specification at
5505 http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
5506
5507     use CGI qw/:standard :html3/;
5508
5509     #here's a stylesheet incorporated directly into the page
5510     $newStyle=<<END;
5511     <!--
5512     P.Tip {
5513         margin-right: 50pt;
5514         margin-left: 50pt;
5515         color: red;
5516     }
5517     P.Alert {
5518         font-size: 30pt;
5519         font-family: sans-serif;
5520       color: red;
5521     }
5522     -->
5523     END
5524     print header();
5525     print start_html( -title=>'CGI with Style',
5526                       -style=>{-src=>'http://www.capricorn.com/style/st1.css',
5527                                -code=>$newStyle}
5528                      );
5529     print h1('CGI with Style'),
5530           p({-class=>'Tip'},
5531             "Better read the cascading style sheet spec before playing with this!"),
5532           span({-style=>'color: magenta'},
5533                "Look Mom, no hands!",
5534                p(),
5535                "Whooo wee!"
5536                );
5537     print end_html;
5538
5539 =head1 DEBUGGING
5540
5541 If you are running the script
5542 from the command line or in the perl debugger, you can pass the script
5543 a list of keywords or parameter=value pairs on the command line or
5544 from standard input (you don't have to worry about tricking your
5545 script into reading from environment variables).
5546 You can pass keywords like this:
5547
5548     your_script.pl keyword1 keyword2 keyword3
5549
5550 or this:
5551
5552    your_script.pl keyword1+keyword2+keyword3
5553
5554 or this:
5555
5556     your_script.pl name1=value1 name2=value2
5557
5558 or this:
5559
5560     your_script.pl name1=value1&name2=value2
5561
5562 or even as newline-delimited parameters on standard input.
5563
5564 When debugging, you can use quotes and backslashes to escape
5565 characters in the familiar shell manner, letting you place
5566 spaces and other funny characters in your parameter=value
5567 pairs:
5568
5569    your_script.pl "name1='I am a long value'" "name2=two\ words"
5570
5571 =head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
5572
5573 The dump() method produces a string consisting of all the query's
5574 name/value pairs formatted nicely as a nested list.  This is useful
5575 for debugging purposes:
5576
5577     print $query->dump
5578
5579
5580 Produces something that looks like:
5581
5582     <UL>
5583     <LI>name1
5584         <UL>
5585         <LI>value1
5586         <LI>value2
5587         </UL>
5588     <LI>name2
5589         <UL>
5590         <LI>value1
5591         </UL>
5592     </UL>
5593
5594 You can pass a value of 'true' to dump() in order to get it to
5595 print the results out as plain text, suitable for incorporating
5596 into a <PRE> section.
5597
5598 As a shortcut, as of version 1.56 you can interpolate the entire CGI
5599 object into a string and it will be replaced with the a nice HTML dump
5600 shown above:
5601
5602     $query=new CGI;
5603     print "<H2>Current Values</H2> $query\n";
5604
5605 =head1 FETCHING ENVIRONMENT VARIABLES
5606
5607 Some of the more useful environment variables can be fetched
5608 through this interface.  The methods are as follows:
5609
5610 =over 4
5611
5612 =item B<accept()>
5613
5614 Return a list of MIME types that the remote browser
5615 accepts. If you give this method a single argument
5616 corresponding to a MIME type, as in
5617 $query->accept('text/html'), it will return a
5618 floating point value corresponding to the browser's
5619 preference for this type from 0.0 (don't want) to 1.0.
5620 Glob types (e.g. text/*) in the browser's accept list
5621 are handled correctly.
5622
5623 =item B<raw_cookie()>
5624
5625 Returns the HTTP_COOKIE variable, an HTTP extension implemented by
5626 Netscape browsers version 1.1 and higher.  Cookies have a special
5627 format, and this method call just returns the raw form (?cookie
5628 dough).  See cookie() for ways of setting and retrieving cooked
5629 cookies.
5630
5631 Called with no parameters, raw_cookie() returns the packed cookie
5632 structure.  You can separate it into individual cookies by splitting
5633 on the character sequence "; ".  Called with the name of a cookie,
5634 retrieves the B<unescaped> form of the cookie.  You can use the
5635 regular cookie() method to get the names, or use the raw_fetch()
5636 method from the CGI::Cookie module.
5637
5638 =item B<user_agent()>
5639
5640 Returns the HTTP_USER_AGENT variable.  If you give
5641 this method a single argument, it will attempt to
5642 pattern match on it, allowing you to do something
5643 like $query->user_agent(netscape);
5644
5645 =item B<path_info()>
5646
5647 Returns additional path information from the script URL.
5648 E.G. fetching /cgi-bin/your_script/additional/stuff will
5649 result in $query->path_info() returning
5650 "additional/stuff".
5651
5652 NOTE: The Microsoft Internet Information Server
5653 is broken with respect to additional path information.  If
5654 you use the Perl DLL library, the IIS server will attempt to
5655 execute the additional path information as a Perl script.
5656 If you use the ordinary file associations mapping, the
5657 path information will be present in the environment,
5658 but incorrect.  The best thing to do is to avoid using additional
5659 path information in CGI scripts destined for use with IIS.
5660
5661 =item B<path_translated()>
5662
5663 As per path_info() but returns the additional
5664 path information translated into a physical path, e.g.
5665 "/usr/local/etc/httpd/htdocs/additional/stuff".
5666
5667 The Microsoft IIS is broken with respect to the translated
5668 path as well.
5669
5670 =item B<remote_host()>
5671
5672 Returns either the remote host name or IP address.
5673 if the former is unavailable.
5674
5675 =item B<script_name()>
5676 Return the script name as a partial URL, for self-refering
5677 scripts.
5678
5679 =item B<referer()>
5680
5681 Return the URL of the page the browser was viewing
5682 prior to fetching your script.  Not available for all
5683 browsers.
5684
5685 =item B<auth_type ()>
5686
5687 Return the authorization/verification method in use for this
5688 script, if any.
5689
5690 =item B<server_name ()>
5691
5692 Returns the name of the server, usually the machine's host
5693 name.
5694
5695 =item B<virtual_host ()>
5696
5697 When using virtual hosts, returns the name of the host that
5698 the browser attempted to contact
5699
5700 =item B<server_software ()>
5701
5702 Returns the server software and version number.
5703
5704 =item B<remote_user ()>
5705
5706 Return the authorization/verification name used for user
5707 verification, if this script is protected.
5708
5709 =item B<user_name ()>
5710
5711 Attempt to obtain the remote user's name, using a variety
5712 of different techniques.  This only works with older browsers
5713 such as Mosaic.  Netscape does not reliably report the user
5714 name!
5715
5716 =item B<request_method()>
5717
5718 Returns the method used to access your script, usually
5719 one of 'POST', 'GET' or 'HEAD'.
5720
5721 =back
5722
5723 =head1 USING NPH SCRIPTS
5724
5725 NPH, or "no-parsed-header", scripts bypass the server completely by
5726 sending the complete HTTP header directly to the browser.  This has
5727 slight performance benefits, but is of most use for taking advantage
5728 of HTTP extensions that are not directly supported by your server,
5729 such as server push and PICS headers.
5730
5731 Servers use a variety of conventions for designating CGI scripts as
5732 NPH.  Many Unix servers look at the beginning of the script's name for
5733 the prefix "nph-".  The Macintosh WebSTAR server and Microsoft's
5734 Internet Information Server, in contrast, try to decide whether a
5735 program is an NPH script by examining the first line of script output.
5736
5737
5738 CGI.pm supports NPH scripts with a special NPH mode.  When in this
5739 mode, CGI.pm will output the necessary extra header information when
5740 the header() and redirect() methods are
5741 called.
5742
5743 The Microsoft Internet Information Server requires NPH mode.  As of version
5744 2.30, CGI.pm will automatically detect when the script is running under IIS
5745 and put itself into this mode.  You do not need to do this manually, although
5746 it won't hurt anything if you do.
5747
5748 There are a number of ways to put CGI.pm into NPH mode:
5749
5750 =over 4
5751
5752 =item In the B<use> statement
5753
5754 Simply add the "-nph" pragmato the list of symbols to be imported into
5755 your script:
5756
5757       use CGI qw(:standard -nph)
5758
5759 =item By calling the B<nph()> method:
5760
5761 Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
5762
5763       CGI->nph(1)
5764
5765 =item By using B<-nph> parameters in the B<header()> and B<redirect()>  statements:
5766
5767       print $q->header(-nph=>1);
5768
5769 =back
5770
5771 =head1 Server Push
5772
5773 CGI.pm provides three simple functions for producing multipart
5774 documents of the type needed to implement server push.  These
5775 functions were graciously provided by Ed Jordan <ed@fidalgo.net>.  To
5776 import these into your namespace, you must import the ":push" set.
5777 You are also advised to put the script into NPH mode and to set $| to
5778 1 to avoid buffering problems.
5779
5780 Here is a simple script that demonstrates server push:
5781
5782   #!/usr/local/bin/perl
5783   use CGI qw/:push -nph/;
5784   $| = 1;
5785   print multipart_init(-boundary=>'----------------here we go!');
5786   while (1) {
5787       print multipart_start(-type=>'text/plain'),
5788             "The current time is ",scalar(localtime),"\n",
5789             multipart_end;
5790       sleep 1;
5791   }
5792
5793 This script initializes server push by calling B<multipart_init()>.
5794 It then enters an infinite loop in which it begins a new multipart
5795 section by calling B<multipart_start()>, prints the current local time,
5796 and ends a multipart section with B<multipart_end()>.  It then sleeps
5797 a second, and begins again.
5798
5799 =over 4
5800
5801 =item multipart_init()
5802
5803   multipart_init(-boundary=>$boundary);
5804
5805 Initialize the multipart system.  The -boundary argument specifies
5806 what MIME boundary string to use to separate parts of the document.
5807 If not provided, CGI.pm chooses a reasonable boundary for you.
5808
5809 =item multipart_start()
5810
5811   multipart_start(-type=>$type)
5812
5813 Start a new part of the multipart document using the specified MIME
5814 type.  If not specified, text/html is assumed.
5815
5816 =item multipart_end()
5817
5818   multipart_end()
5819
5820 End a part.  You must remember to call multipart_end() once for each
5821 multipart_start().
5822
5823 =back
5824
5825 Users interested in server push applications should also have a look
5826 at the CGI::Push module.
5827
5828 =head1 Avoiding Denial of Service Attacks
5829
5830 A potential problem with CGI.pm is that, by default, it attempts to
5831 process form POSTings no matter how large they are.  A wily hacker
5832 could attack your site by sending a CGI script a huge POST of many
5833 megabytes.  CGI.pm will attempt to read the entire POST into a
5834 variable, growing hugely in size until it runs out of memory.  While
5835 the script attempts to allocate the memory the system may slow down
5836 dramatically.  This is a form of denial of service attack.
5837
5838 Another possible attack is for the remote user to force CGI.pm to
5839 accept a huge file upload.  CGI.pm will accept the upload and store it
5840 in a temporary directory even if your script doesn't expect to receive
5841 an uploaded file.  CGI.pm will delete the file automatically when it
5842 terminates, but in the meantime the remote user may have filled up the
5843 server's disk space, causing problems for other programs.
5844
5845 The best way to avoid denial of service attacks is to limit the amount
5846 of memory, CPU time and disk space that CGI scripts can use.  Some Web
5847 servers come with built-in facilities to accomplish this. In other
5848 cases, you can use the shell I<limit> or I<ulimit>
5849 commands to put ceilings on CGI resource usage.
5850
5851
5852 CGI.pm also has some simple built-in protections against denial of
5853 service attacks, but you must activate them before you can use them.
5854 These take the form of two global variables in the CGI name space:
5855
5856 =over 4
5857
5858 =item B<$CGI::POST_MAX>
5859
5860 If set to a non-negative integer, this variable puts a ceiling
5861 on the size of POSTings, in bytes.  If CGI.pm detects a POST
5862 that is greater than the ceiling, it will immediately exit with an error
5863 message.  This value will affect both ordinary POSTs and
5864 multipart POSTs, meaning that it limits the maximum size of file
5865 uploads as well.  You should set this to a reasonably high
5866 value, such as 1 megabyte.
5867
5868 =item B<$CGI::DISABLE_UPLOADS>
5869
5870 If set to a non-zero value, this will disable file uploads
5871 completely.  Other fill-out form values will work as usual.
5872
5873 =back
5874
5875 You can use these variables in either of two ways.
5876
5877 =over 4
5878
5879 =item B<1. On a script-by-script basis>
5880
5881 Set the variable at the top of the script, right after the "use" statement:
5882
5883     use CGI qw/:standard/;
5884     use CGI::Carp 'fatalsToBrowser';
5885     $CGI::POST_MAX=1024 * 100;  # max 100K posts
5886     $CGI::DISABLE_UPLOADS = 1;  # no uploads
5887
5888 =item B<2. Globally for all scripts>
5889
5890 Open up CGI.pm, find the definitions for $POST_MAX and
5891 $DISABLE_UPLOADS, and set them to the desired values.  You'll
5892 find them towards the top of the file in a subroutine named
5893 initialize_globals().
5894
5895 =back
5896
5897 Since an attempt to send a POST larger than $POST_MAX bytes
5898 will cause a fatal error, you might want to use CGI::Carp to echo the
5899 fatal error message to the browser window as shown in the example
5900 above.  Otherwise the remote user will see only a generic "Internal
5901 Server" error message.  See the L<CGI::Carp> manual page for more
5902 details.
5903
5904 =head1 COMPATIBILITY WITH CGI-LIB.PL
5905
5906 To make it easier to port existing programs that use cgi-lib.pl
5907 the compatibility routine "ReadParse" is provided.  Porting is
5908 simple:
5909
5910 OLD VERSION
5911     require "cgi-lib.pl";
5912     &ReadParse;
5913     print "The value of the antique is $in{antique}.\n";
5914
5915 NEW VERSION
5916     use CGI;
5917     CGI::ReadParse
5918     print "The value of the antique is $in{antique}.\n";
5919
5920 CGI.pm's ReadParse() routine creates a tied variable named %in,
5921 which can be accessed to obtain the query variables.  Like
5922 ReadParse, you can also provide your own variable.  Infrequently
5923 used features of ReadParse, such as the creation of @in and $in
5924 variables, are not supported.
5925
5926 Once you use ReadParse, you can retrieve the query object itself
5927 this way:
5928
5929     $q = $in{CGI};
5930     print $q->textfield(-name=>'wow',
5931                         -value=>'does this really work?');
5932
5933 This allows you to start using the more interesting features
5934 of CGI.pm without rewriting your old scripts from scratch.
5935
5936 =head1 AUTHOR INFORMATION
5937
5938 Copyright 1995-1997, Lincoln D. Stein.  All rights reserved.  It may
5939 be used and modified freely, but I do request that this copyright
5940 notice remain attached to the file.  You may modify this module as you
5941 wish, but if you redistribute a modified version, please attach a note
5942 listing the modifications you have made.
5943
5944 Address bug reports and comments to:
5945 lstein@genome.wi.mit.edu
5946
5947 =head1 CREDITS
5948
5949 Thanks very much to:
5950
5951 =over 4
5952
5953 =item Matt Heffron (heffron@falstaff.css.beckman.com)
5954
5955 =item James Taylor (james.taylor@srs.gov)
5956
5957 =item Scott Anguish <sanguish@digifix.com>
5958
5959 =item Mike Jewell (mlj3u@virginia.edu)
5960
5961 =item Timothy Shimmin (tes@kbs.citri.edu.au)
5962
5963 =item Joergen Haegg (jh@axis.se)
5964
5965 =item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu)
5966
5967 =item Richard Resnick (applepi1@aol.com)
5968
5969 =item Craig Bishop (csb@barwonwater.vic.gov.au)
5970
5971 =item Tony Curtis (tc@vcpc.univie.ac.at)
5972
5973 =item Tim Bunce (Tim.Bunce@ig.co.uk)
5974
5975 =item Tom Christiansen (tchrist@convex.com)
5976
5977 =item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
5978
5979 =item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
5980
5981 =item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
5982
5983 =item Stephen Dahmen (joyfire@inxpress.net)
5984
5985 =item Ed Jordan (ed@fidalgo.net)
5986
5987 =item David Alan Pisoni (david@cnation.com)
5988
5989 =item Doug MacEachern (dougm@opengroup.org)
5990
5991 =item Robin Houston (robin@oneworld.org)
5992
5993 =item ...and many many more...
5994
5995 for suggestions and bug fixes.
5996
5997 =back
5998
5999 =head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
6000
6001
6002         #!/usr/local/bin/perl
6003
6004         use CGI;
6005
6006         $query = new CGI;
6007
6008         print $query->header;
6009         print $query->start_html("Example CGI.pm Form");
6010         print "<H1> Example CGI.pm Form</H1>\n";
6011         &print_prompt($query);
6012         &do_work($query);
6013         &print_tail;
6014         print $query->end_html;
6015
6016         sub print_prompt {
6017            my($query) = @_;
6018
6019            print $query->startform;
6020            print "<EM>What's your name?</EM><BR>";
6021            print $query->textfield('name');
6022            print $query->checkbox('Not my real name');
6023
6024            print "<P><EM>Where can you find English Sparrows?</EM><BR>";
6025            print $query->checkbox_group(
6026                                  -name=>'Sparrow locations',
6027                                  -values=>[England,France,Spain,Asia,Hoboken],
6028                                  -linebreak=>'yes',
6029                                  -defaults=>[England,Asia]);
6030
6031            print "<P><EM>How far can they fly?</EM><BR>",
6032                 $query->radio_group(
6033                         -name=>'how far',
6034                         -values=>['10 ft','1 mile','10 miles','real far'],
6035                         -default=>'1 mile');
6036
6037            print "<P><EM>What's your favorite color?</EM>  ";
6038            print $query->popup_menu(-name=>'Color',
6039                                     -values=>['black','brown','red','yellow'],
6040                                     -default=>'red');
6041
6042            print $query->hidden('Reference','Monty Python and the Holy Grail');
6043
6044            print "<P><EM>What have you got there?</EM><BR>";
6045            print $query->scrolling_list(
6046                          -name=>'possessions',
6047                          -values=>['A Coconut','A Grail','An Icon',
6048                                    'A Sword','A Ticket'],
6049                          -size=>5,
6050                          -multiple=>'true');
6051
6052            print "<P><EM>Any parting comments?</EM><BR>";
6053            print $query->textarea(-name=>'Comments',
6054                                   -rows=>10,
6055                                   -columns=>50);
6056
6057            print "<P>",$query->reset;
6058            print $query->submit('Action','Shout');
6059            print $query->submit('Action','Scream');
6060            print $query->endform;
6061            print "<HR>\n";
6062         }
6063
6064         sub do_work {
6065            my($query) = @_;
6066            my(@values,$key);
6067
6068            print "<H2>Here are the current settings in this form</H2>";
6069
6070            foreach $key ($query->param) {
6071               print "<STRONG>$key</STRONG> -> ";
6072               @values = $query->param($key);
6073               print join(", ",@values),"<BR>\n";
6074           }
6075         }
6076
6077         sub print_tail {
6078            print <<END;
6079         <HR>
6080         <ADDRESS>Lincoln D. Stein</ADDRESS><BR>
6081         <A HREF="/">Home Page</A>
6082         END
6083         }
6084
6085 =head1 BUGS
6086
6087 This module has grown large and monolithic.  Furthermore it's doing many
6088 things, such as handling URLs, parsing CGI input, writing HTML, etc., that
6089 are also done in the LWP modules. It should be discarded in favor of
6090 the CGI::* modules, but somehow I continue to work on it.
6091
6092 Note that the code is truly contorted in order to avoid spurious
6093 warnings when programs are run with the B<-w> switch.
6094
6095 =head1 SEE ALSO
6096
6097 L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>,
6098 L<CGI::Base>, L<CGI::Form>, L<CGI::Apache>, L<CGI::Switch>,
6099 L<CGI::Push>, L<CGI::Fast>
6100
6101 =cut
6102