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