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