lib/CGI.pm

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