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