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