lib/CGI.pm

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