lib/CGI.pm

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