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