lib/CGI.pm

   1 package CGI;
   2 require 5.001;
   3
   4 # See the bottom of this file for the POD documentation.  Search for the
   5 # string '=head'.
   6
   7 # You can run this file through either pod2man or pod2html to produce pretty
   8 # documentation in manual or html file format (these utilities are part of the
   9 # Perl 5 distribution).
  10
  11 # Copyright 1995-1997 Lincoln D. Stein.  All rights reserved.
  12 # It may be used and modified freely, but I do request that this copyright
  13 # notice remain attached to the file.  You may modify this module as you
  14 # wish, but if you redistribute a modified version, please attach a note
  15 # listing the modifications you have made.
  16
  17 # The most recent version and complete docs are available at:
  18 #   http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
  19 #   ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
  20
  21 # Set this to 1 to enable copious autoloader debugging messages
  22 $AUTOLOAD_DEBUG=0;
  23
  24 # Set this to 1 to enable NPH scripts
  25 # or:
  26 #    1) use CGI qw(:nph)
  27 #    2) $CGI::nph(1)
  28 #    3) print header(-nph=>1)
  29 $NPH=0;
  30
  31 $CGI::revision = '$Id: CGI.pm,v 2.32 1997/3/19 10:10 lstein Exp $';
  32 $CGI::VERSION='2.3201';
  33
  34 # OVERRIDE THE OS HERE IF CGI.pm GUESSES WRONG
  35 # $OS = 'UNIX';
  36 # $OS = 'MACINTOSH';
  37 # $OS = 'WINDOWS';
  38 # $OS = 'VMS';
  39 # $OS = 'OS2';
  40
  41 # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
  42 # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
  43 # $TempFile::TMPDIRECTORY = '/usr/tmp';
  44
  45 # ------------------ START OF THE LIBRARY ------------
  46
  47 # FIGURE OUT THE OS WE'RE RUNNING UNDER
  48 # Some systems support the $^O variable.  If not
  49 # available then require() the Config library
  50 unless ($OS) {
  51     unless ($OS = $^O) {
  52         require Config;
  53         $OS = $Config::Config{'osname'};
  54     }
  55 }
  56 if ($OS=~/Win/i) {
  57     $OS = 'WINDOWS';
  58 } elsif ($OS=~/vms/i) {
  59     $OS = 'VMS';
  60 } elsif ($OS=~/Mac/i) {
  61     $OS = 'MACINTOSH';
  62 } elsif ($OS=~/os2/i) {
  63     $OS = 'OS2';
  64 } else {
  65     $OS = 'UNIX';
  66 }
  67
  68 # Some OS logic.  Binary mode enabled on DOS, NT and VMS
  69 $needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/;
  70
  71 # This is the default class for the CGI object to use when all else fails.
  72 $DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
  73 # This is where to look for autoloaded routines.
  74 $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
  75
  76 # The path separator is a slash, backslash or semicolon, depending
  77 # on the paltform.
  78 $SL = {
  79     UNIX=>'/',
  80     OS2=>'\\',
  81     WINDOWS=>'\\',
  82     MACINTOSH=>':',
  83     VMS=>'\\'
  84     }->{$OS};
  85
  86 # Turn on NPH scripts by default when running under IIS server!
  87 $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
  88
  89 # Turn on special checking for Doug MacEachern's modperl
  90 if (defined($MOD_PERL = $ENV{'GATEWAY_INTERFACE'}) &&
  91     $MOD_PERL =~ /^CGI-Perl/)
  92 {
  93     $NPH++;
  94     $| = 1;
  95     $SEQNO = 1;
  96 }
  97
  98 # This is really "\r\n", but the meaning of \n is different
  99 # in MacPerl, so we resort to octal here.
 100 $CRLF = "\015\012";
 101
 102 if ($needs_binmode) {
 103     $CGI::DefaultClass->binmode(main::STDOUT);
 104     $CGI::DefaultClass->binmode(main::STDIN);
 105     $CGI::DefaultClass->binmode(main::STDERR);
 106 }
 107
 108 # Cute feature, but it broke when the overload mechanism changed...
 109 # %OVERLOAD = ('""'=>'as_string');
 110
 111 %EXPORT_TAGS = (
 112               ':html2'=>[h1..h6,qw/p br hr ol ul li dl dt dd menu code var strong em
 113                          tt i b blockquote pre img a address cite samp dfn html head
 114                          base body link nextid title meta kbd start_html end_html
 115                          input Select option/],
 116               ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont/],
 117               ':netscape'=>[qw/blink frameset frame script font fontsize center/],
 118               ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
 119                        submit reset defaults radio_group popup_menu button autoEscape
 120                        scrolling_list image_button start_form end_form startform endform
 121                        start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
 122               ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump
 123                        raw_cookie request_method query_string accept user_agent remote_host
 124                        remote_addr referer server_name server_software server_port server_protocol
 125                        virtual_host remote_ident auth_type http
 126                        remote_user user_name header redirect import_names put/],
 127               ':ssl' => [qw/https/],
 128               ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
 129               ':html' => [qw/:html2 :html3 :netscape/],
 130               ':standard' => [qw/:html2 :form :cgi/],
 131               ':all' => [qw/:html2 :html3 :netscape :form :cgi/]
 132          );
 133
 134 # to import symbols into caller
 135 sub import {
 136     my $self = shift;
 137     my ($callpack, $callfile, $callline) = caller;
 138     foreach (@_) {
 139         $NPH++, next if $_ eq ':nph';
 140         foreach (&expand_tags($_)) {
 141             tr/a-zA-Z0-9_//cd;  # don't allow weird function names
 142             $EXPORT{$_}++;
 143         }
 144     }
 145     # To allow overriding, search through the packages
 146     # Till we find one in which the correct subroutine is defined.
 147     my @packages = ($self,@{"$self\:\:ISA"});
 148     foreach $sym (keys %EXPORT) {
 149         my $pck;
 150         my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
 151         foreach $pck (@packages) {
 152             if (defined(&{"$pck\:\:$sym"})) {
 153                 $def = $pck;
 154                 last;
 155             }
 156         }
 157         *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
 158     }
 159 }
 160
 161 sub expand_tags {
 162     my($tag) = @_;
 163     my(@r);
 164     return ($tag) unless $EXPORT_TAGS{$tag};
 165     foreach (@{$EXPORT_TAGS{$tag}}) {
 166         push(@r,&expand_tags($_));
 167     }
 168     return @r;
 169 }
 170
 171 #### Method: new
 172 # The new routine.  This will check the current environment
 173 # for an existing query string, and initialize itself, if so.
 174 ####
 175 sub new {
 176     my($class,$initializer) = @_;
 177     my $self = {};
 178     bless $self,ref $class || $class || $DefaultClass;
 179     $CGI::DefaultClass->_reset_globals() if $MOD_PERL;
 180     $initializer = to_filehandle($initializer) if $initializer;
 181     $self->init($initializer);
 182     return $self;
 183 }
 184
 185 # We provide a DESTROY method so that the autoloader
 186 # doesn't bother trying to find it.
 187 sub DESTROY { }
 188
 189 #### Method: param
 190 # Returns the value(s)of a named parameter.
 191 # If invoked in a list context, returns the
 192 # entire list.  Otherwise returns the first
 193 # member of the list.
 194 # If name is not provided, return a list of all
 195 # the known parameters names available.
 196 # If more than one argument is provided, the
 197 # second and subsequent arguments are used to
 198 # set the value of the parameter.
 199 ####
 200 sub param {
 201     my($self,@p) = self_or_default(@_);
 202     return $self->all_parameters unless @p;
 203     my($name,$value,@other);
 204
 205     # For compatibility between old calling style and use_named_parameters() style,
 206     # we have to special case for a single parameter present.
 207     if (@p > 1) {
 208         ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
 209         my(@values);
 210
 211         if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
 212             @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
 213         } else {
 214             foreach ($value,@other) {
 215                 push(@values,$_) if defined($_);
 216             }
 217         }
 218         # If values is provided, then we set it.
 219         if (@values) {
 220             $self->add_parameter($name);
 221             $self->{$name}=[@values];
 222         }
 223     } else {
 224         $name = $p[0];
 225     }
 226
 227     return () unless defined($name) && $self->{$name};
 228     return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
 229 }
 230
 231 #### Method: delete
 232 # Deletes the named parameter entirely.
 233 ####
 234 sub delete {
 235     my($self,$name) = self_or_default(@_);
 236     delete $self->{$name};
 237     delete $self->{'.fieldnames'}->{$name};
 238     @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
 239     return wantarray ? () : undef;
 240 }
 241
 242 sub self_or_default {
 243     return @_ if defined($_[0]) && !ref($_[0]) && ($_[0] eq 'CGI');
 244     unless (defined($_[0]) &&
 245             ref($_[0]) &&
 246             (ref($_[0]) eq 'CGI' ||
 247              eval "\$_[0]->isaCGI()")) { # optimize for the common case
 248         $CGI::DefaultClass->_reset_globals()
 249             if defined($Q) && $MOD_PERL && $CGI::DefaultClass->_new_request();
 250         $Q = $CGI::DefaultClass->new unless defined($Q);
 251         unshift(@_,$Q);
 252     }
 253     return @_;
 254 }
 255
 256 sub _new_request {
 257     return undef unless (defined(Apache->seqno()) or eval { require Apache });
 258     if (Apache->seqno() != $SEQNO) {
 259         $SEQNO = Apache->seqno();
 260         return 1;
 261     } else {
 262         return undef;
 263     }
 264 }
 265
 266 sub _reset_globals {
 267     undef $Q;
 268     undef @QUERY_PARAM;
 269 }
 270
 271 sub self_or_CGI {
 272     local $^W=0;                # prevent a warning
 273     if (defined($_[0]) &&
 274         (substr(ref($_[0]),0,3) eq 'CGI'
 275          || eval "\$_[0]->isaCGI()")) {
 276         return @_;
 277     } else {
 278         return ($DefaultClass,@_);
 279     }
 280 }
 281
 282 sub isaCGI {
 283     return 1;
 284 }
 285
 286 #### Method: import_names
 287 # Import all parameters into the given namespace.
 288 # Assumes namespace 'Q' if not specified
 289 ####
 290 sub import_names {
 291     my($self,$namespace) = self_or_default(@_);
 292     $namespace = 'Q' unless defined($namespace);
 293     die "Can't import names into 'main'\n"
 294         if $namespace eq 'main';
 295     my($param,@value,$var);
 296     foreach $param ($self->param) {
 297         # protect against silly names
 298         ($var = $param)=~tr/a-zA-Z0-9_/_/c;
 299         $var = "${namespace}::$var";
 300         @value = $self->param($param);
 301         @{$var} = @value;
 302         ${$var} = $value[0];
 303     }
 304 }
 305
 306 #### Method: use_named_parameters
 307 # Force CGI.pm to use named parameter-style method calls
 308 # rather than positional parameters.  The same effect
 309 # will happen automatically if the first parameter
 310 # begins with a -.
 311 sub use_named_parameters {
 312     my($self,$use_named) = self_or_default(@_);
 313     return $self->{'.named'} unless defined ($use_named);
 314
 315     # stupidity to avoid annoying warnings
 316     return $self->{'.named'}=$use_named;
 317 }
 318
 319 ########################################
 320 # THESE METHODS ARE MORE OR LESS PRIVATE
 321 # GO TO THE __DATA__ SECTION TO SEE MORE
 322 # PUBLIC METHODS
 323 ########################################
 324
 325 # Initialize the query object from the environment.
 326 # If a parameter list is found, this object will be set
 327 # to an associative array in which parameter names are keys
 328 # and the values are stored as lists
 329 # If a keyword list is found, this method creates a bogus
 330 # parameter list with the single parameter 'keywords'.
 331
 332 sub init {
 333     my($self,$initializer) = @_;
 334     my($query_string,@lines);
 335     my($meth) = '';
 336
 337     # if we get called more than once, we want to initialize
 338     # ourselves from the original query (which may be gone
 339     # if it was read from STDIN originally.)
 340     if (defined(@QUERY_PARAM) && !defined($initializer)) {
 341
 342         foreach (@QUERY_PARAM) {
 343             $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
 344         }
 345         return;
 346     }
 347
 348     $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
 349
 350     # If initializer is defined, then read parameters
 351     # from it.
 352   METHOD: {
 353       if (defined($initializer)) {
 354
 355           if (ref($initializer) && ref($initializer) eq 'HASH') {
 356               foreach (keys %$initializer) {
 357                   $self->param('-name'=>$_,'-value'=>$initializer->{$_});
 358               }
 359               last METHOD;
 360           }
 361
 362           $initializer = $$initializer if ref($initializer);
 363           if (defined(fileno($initializer))) {
 364               while (<$initializer>) {
 365                   chomp;
 366                   last if /^=/;
 367                   push(@lines,$_);
 368               }
 369               # massage back into standard format
 370               if ("@lines" =~ /=/) {
 371                   $query_string=join("&",@lines);
 372               } else {
 373                   $query_string=join("+",@lines);
 374               }
 375               last METHOD;
 376           }
 377           $query_string = $initializer;
 378           last METHOD;
 379       }
 380           # If method is GET or HEAD, fetch the query from
 381           # the environment.
 382       if ($meth=~/^(GET|HEAD)$/) {
 383         $query_string = $ENV{'QUERY_STRING'};
 384         last METHOD;
 385     }
 386
 387       # If the method is POST, fetch the query from standard
 388       # input.
 389       if ($meth eq 'POST') {
 390
 391           if (defined($ENV{'CONTENT_TYPE'})
 392               &&
 393               $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|) {
 394               my($boundary) = $ENV{'CONTENT_TYPE'}=~/boundary=(\S+)/;
 395               $self->read_multipart($boundary,$ENV{'CONTENT_LENGTH'});
 396
 397           } else {
 398
 399               $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0)
 400                   if $ENV{'CONTENT_LENGTH'} > 0;
 401
 402           }
 403           # Some people want to have their cake and eat it too!
 404           # Uncomment this line to have the contents of the query string
 405           # APPENDED to the POST data.
 406           # $query_string .= ($query_string ? '&' : '') . $ENV{'QUERY_STRING'} if $ENV{'QUERY_STRING'};
 407           last METHOD;
 408       }
 409
 410       # If neither is set, assume we're being debugged offline.
 411       # Check the command line and then the standard input for data.
 412       # We use the shellwords package in order to behave the way that
 413       # UN*X programmers expect.
 414       $query_string = &read_from_cmdline;
 415   }
 416
 417     # We now have the query string in hand.  We do slightly
 418     # different things for keyword lists and parameter lists.
 419     if ($query_string) {
 420         if ($query_string =~ /=/) {
 421             $self->parse_params($query_string);
 422         } else {
 423             $self->add_parameter('keywords');
 424             $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
 425         }
 426     }
 427
 428     # Special case.  Erase everything if there is a field named
 429     # .defaults.
 430     if ($self->param('.defaults')) {
 431         undef %{$self};
 432     }
 433
 434     # Associative array containing our defined fieldnames
 435     $self->{'.fieldnames'} = {};
 436     foreach ($self->param('.cgifields')) {
 437         $self->{'.fieldnames'}->{$_}++;
 438     }
 439
 440     # Clear out our default submission button flag if present
 441     $self->delete('.submit');
 442     $self->delete('.cgifields');
 443     $self->save_request unless $initializer;
 444
 445 }
 446
 447
 448 # FUNCTIONS TO OVERRIDE:
 449
 450 # Turn a string into a filehandle
 451 sub to_filehandle {
 452     my $string = shift;
 453     if ($string && !ref($string)) {
 454         my($package) = caller(1);
 455         my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string";
 456         return $tmp if defined(fileno($tmp));
 457     }
 458     return $string;
 459 }
 460
 461 # Create a new multipart buffer
 462 sub new_MultipartBuffer {
 463     my($self,$boundary,$length,$filehandle) = @_;
 464     return MultipartBuffer->new($self,$boundary,$length,$filehandle);
 465 }
 466
 467 # Read data from a file handle
 468 sub read_from_client {
 469     my($self, $fh, $buff, $len, $offset) = @_;
 470     local $^W=0;                # prevent a warning
 471     return read($fh, $$buff, $len, $offset);
 472 }
 473
 474 # put a filehandle into binary mode (DOS)
 475 sub binmode {
 476     binmode($_[1]);
 477 }
 478
 479 # send output to the browser
 480 sub put {
 481     my($self,@p) = self_or_default(@_);
 482     $self->print(@p);
 483 }
 484
 485 # print to standard output (for overriding in mod_perl)
 486 sub print {
 487     shift;
 488     CORE::print(@_);
 489 }
 490
 491 # unescape URL-encoded data
 492 sub unescape {
 493     my($todecode) = @_;
 494     $todecode =~ tr/+/ /;       # pluses become spaces
 495     $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
 496     return $todecode;
 497 }
 498
 499 # URL-encode data
 500 sub escape {
 501     my($toencode) = @_;
 502     $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
 503     return $toencode;
 504 }
 505
 506 sub save_request {
 507     my($self) = @_;
 508     # We're going to play with the package globals now so that if we get called
 509     # again, we initialize ourselves in exactly the same way.  This allows
 510     # us to have several of these objects.
 511     @QUERY_PARAM = $self->param; # save list of parameters
 512     foreach (@QUERY_PARAM) {
 513         $QUERY_PARAM{$_}=$self->{$_};
 514     }
 515 }
 516
 517 sub parse_keywordlist {
 518     my($self,$tosplit) = @_;
 519     $tosplit = &unescape($tosplit); # unescape the keywords
 520     $tosplit=~tr/+/ /;          # pluses to spaces
 521     my(@keywords) = split(/\s+/,$tosplit);
 522     return @keywords;
 523 }
 524
 525 sub parse_params {
 526     my($self,$tosplit) = @_;
 527     my(@pairs) = split('&',$tosplit);
 528     my($param,$value);
 529     foreach (@pairs) {
 530         ($param,$value) = split('=');
 531         $param = &unescape($param);
 532         $value = &unescape($value);
 533         $self->add_parameter($param);
 534         push (@{$self->{$param}},$value);
 535     }
 536 }
 537
 538 sub add_parameter {
 539     my($self,$param)=@_;
 540     push (@{$self->{'.parameters'}},$param)
 541         unless defined($self->{$param});
 542 }
 543
 544 sub all_parameters {
 545     my $self = shift;
 546     return () unless defined($self) && $self->{'.parameters'};
 547     return () unless @{$self->{'.parameters'}};
 548     return @{$self->{'.parameters'}};
 549 }
 550
 551
 552
 553 #### Method as_string
 554 #
 555 # synonym for "dump"
 556 ####
 557 sub as_string {
 558     &dump(@_);
 559 }
 560
 561 sub AUTOLOAD {
 562     print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
 563     my($func) = $AUTOLOAD;
 564     my($pack,$func_name) = $func=~/(.+)::([^:]+)$/;
 565     $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
 566                 unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
 567
 568     my($sub) = \%{"$pack\:\:SUBS"};
 569     unless (%$sub) {
 570         my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
 571         eval "package $pack; $$auto";
 572         die $@ if $@;
 573     }
 574     my($code) = $sub->{$func_name};
 575
 576     $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
 577     if (!$code) {
 578         if ($EXPORT{':any'} ||
 579             $EXPORT{$func_name} ||
 580             (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
 581             && $EXPORT_OK{$func_name}) {
 582             $code = $sub->{'HTML_FUNC'};
 583             $code=~s/func_name/$func_name/mg;
 584         }
 585     }
 586     die "Undefined subroutine $AUTOLOAD\n" unless $code;
 587     eval "package $pack; $code";
 588     if ($@) {
 589         $@ =~ s/ at .*\n//;
 590         die $@;
 591     }
 592     goto &{"$pack\:\:$func_name"};
 593 }
 594
 595 # PRIVATE SUBROUTINE
 596 # Smart rearrangement of parameters to allow named parameter
 597 # calling.  We do the rearangement if:
 598 # 1. The first parameter begins with a -
 599 # 2. The use_named_parameters() method returns true
 600 sub rearrange {
 601     my($self,$order,@param) = @_;
 602     return () unless @param;
 603
 604     return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-')
 605         || $self->use_named_parameters;
 606
 607     my $i;
 608     for ($i=0;$i<@param;$i+=2) {
 609         $param[$i]=~s/^\-//;     # get rid of initial - if present
 610         $param[$i]=~tr/a-z/A-Z/; # parameters are upper case
 611     }
 612
 613     my(%param) = @param;                # convert into associative array
 614     my(@return_array);
 615
 616     my($key)='';
 617     foreach $key (@$order) {
 618         my($value);
 619         # this is an awful hack to fix spurious warnings when the
 620         # -w switch is set.
 621         if (ref($key) && ref($key) eq 'ARRAY') {
 622             foreach (@$key) {
 623                 last if defined($value);
 624                 $value = $param{$_};
 625                 delete $param{$_};
 626             }
 627         } else {
 628             $value = $param{$key};
 629             delete $param{$key};
 630         }
 631         push(@return_array,$value);
 632     }
 633     push (@return_array,$self->make_attributes(\%param)) if %param;
 634     return (@return_array);
 635 }
 636
 637 ###############################################################################
 638 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
 639 ###############################################################################
 640 $AUTOLOADED_ROUTINES = '';      # get rid of -w warning
 641 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
 642
 643 %SUBS = (
 644
 645 'URL_ENCODED'=> <<'END_OF_FUNC',
 646 sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
 647 END_OF_FUNC
 648
 649 'MULTIPART' => <<'END_OF_FUNC',
 650 sub MULTIPART {  'multipart/form-data'; }
 651 END_OF_FUNC
 652
 653 'HTML_FUNC' => <<'END_OF_FUNC',
 654 sub func_name {
 655
 656     # handle various cases in which we're called
 657     # most of this bizarre stuff is to avoid -w errors
 658     shift if $_[0] &&
 659         (!ref($_[0]) && $_[0] eq $CGI::DefaultClass) ||
 660             (ref($_[0]) &&
 661              (substr(ref($_[0]),0,3) eq 'CGI' ||
 662               eval "\$_[0]->isaCGI()"));
 663
 664     my($attr) = '';
 665     if (ref($_[0]) && ref($_[0]) eq 'HASH') {
 666         my(@attr) = CGI::make_attributes('',shift);
 667         $attr = " @attr" if @attr;
 668     }
 669     my($tag,$untag) = ("\U<func_name\E$attr>","\U</func_name>\E");
 670     return $tag unless @_;
 671     if (ref($_[0]) eq 'ARRAY') {
 672         my(@r);
 673         foreach (@{$_[0]}) {
 674             push(@r,"$tag$_$untag");
 675         }
 676         return "@r";
 677     } else {
 678         return "$tag@_$untag";
 679     }
 680 }
 681 END_OF_FUNC
 682
 683 #### Method: keywords
 684 # Keywords acts a bit differently.  Calling it in a list context
 685 # returns the list of keywords.
 686 # Calling it in a scalar context gives you the size of the list.
 687 ####
 688 'keywords' => <<'END_OF_FUNC',
 689 sub keywords {
 690     my($self,@values) = self_or_default(@_);
 691     # If values is provided, then we set it.
 692     $self->{'keywords'}=[@values] if @values;
 693     my(@result) = @{$self->{'keywords'}};
 694     @result;
 695 }
 696 END_OF_FUNC
 697
 698 # These are some tie() interfaces for compatibility
 699 # with Steve Brenner's cgi-lib.pl routines
 700 'ReadParse' => <<'END_OF_FUNC',
 701 sub ReadParse {
 702     local(*in);
 703     if (@_) {
 704         *in = $_[0];
 705     } else {
 706         my $pkg = caller();
 707         *in=*{"${pkg}::in"};
 708     }
 709     tie(%in,CGI);
 710 }
 711 END_OF_FUNC
 712
 713 'PrintHeader' => <<'END_OF_FUNC',
 714 sub PrintHeader {
 715     my($self) = self_or_default(@_);
 716     return $self->header();
 717 }
 718 END_OF_FUNC
 719
 720 'HtmlTop' => <<'END_OF_FUNC',
 721 sub HtmlTop {
 722     my($self,@p) = self_or_default(@_);
 723     return $self->start_html(@p);
 724 }
 725 END_OF_FUNC
 726
 727 'HtmlBot' => <<'END_OF_FUNC',
 728 sub HtmlBot {
 729     my($self,@p) = self_or_default(@_);
 730     return $self->end_html(@p);
 731 }
 732 END_OF_FUNC
 733
 734 'SplitParam' => <<'END_OF_FUNC',
 735 sub SplitParam {
 736     my ($param) = @_;
 737     my (@params) = split ("\0", $param);
 738     return (wantarray ? @params : $params[0]);
 739 }
 740 END_OF_FUNC
 741
 742 'MethGet' => <<'END_OF_FUNC',
 743 sub MethGet {
 744     return request_method() eq 'GET';
 745 }
 746 END_OF_FUNC
 747
 748 'MethPost' => <<'END_OF_FUNC',
 749 sub MethPost {
 750     return request_method() eq 'POST';
 751 }
 752 END_OF_FUNC
 753
 754 'TIEHASH' => <<'END_OF_FUNC',
 755 sub TIEHASH {
 756     return new CGI;
 757 }
 758 END_OF_FUNC
 759
 760 'STORE' => <<'END_OF_FUNC',
 761 sub STORE {
 762     $_[0]->param($_[1],split("\0",$_[2]));
 763 }
 764 END_OF_FUNC
 765
 766 'FETCH' => <<'END_OF_FUNC',
 767 sub FETCH {
 768     return $_[0] if $_[1] eq 'CGI';
 769     return undef unless defined $_[0]->param($_[1]);
 770     return join("\0",$_[0]->param($_[1]));
 771 }
 772 END_OF_FUNC
 773
 774 'FIRSTKEY' => <<'END_OF_FUNC',
 775 sub FIRSTKEY {
 776     $_[0]->{'.iterator'}=0;
 777     $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
 778 }
 779 END_OF_FUNC
 780
 781 'NEXTKEY' => <<'END_OF_FUNC',
 782 sub NEXTKEY {
 783     $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
 784 }
 785 END_OF_FUNC
 786
 787 'EXISTS' => <<'END_OF_FUNC',
 788 sub EXISTS {
 789     exists $_[0]->{$_[1]};
 790 }
 791 END_OF_FUNC
 792
 793 'DELETE' => <<'END_OF_FUNC',
 794 sub DELETE {
 795     $_[0]->delete($_[1]);
 796 }
 797 END_OF_FUNC
 798
 799 'CLEAR' => <<'END_OF_FUNC',
 800 sub CLEAR {
 801     %{$_[0]}=();
 802 }
 803 ####
 804 END_OF_FUNC
 805
 806 ####
 807 # Append a new value to an existing query
 808 ####
 809 'append' => <<'EOF',
 810 sub append {
 811     my($self,@p) = @_;
 812     my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
 813     my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
 814     if (@values) {
 815         $self->add_parameter($name);
 816         push(@{$self->{$name}},@values);
 817     }
 818     return $self->param($name);
 819 }
 820 EOF
 821
 822 #### Method: delete_all
 823 # Delete all parameters
 824 ####
 825 'delete_all' => <<'EOF',
 826 sub delete_all {
 827     my($self) = self_or_default(@_);
 828     undef %{$self};
 829 }
 830 EOF
 831
 832 #### Method: autoescape
 833 # If you want to turn off the autoescaping features,
 834 # call this method with undef as the argument
 835 'autoEscape' => <<'END_OF_FUNC',
 836 sub autoEscape {
 837     my($self,$escape) = self_or_default(@_);
 838     $self->{'dontescape'}=!$escape;
 839 }
 840 END_OF_FUNC
 841
 842
 843 #### Method: version
 844 # Return the current version
 845 ####
 846 'version' => <<'END_OF_FUNC',
 847 sub version {
 848     return $VERSION;
 849 }
 850 END_OF_FUNC
 851
 852 'make_attributes' => <<'END_OF_FUNC',
 853 sub make_attributes {
 854     my($self,$attr) = @_;
 855     return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
 856     my(@att);
 857     foreach (keys %{$attr}) {
 858         my($key) = $_;
 859         $key=~s/^\-//;     # get rid of initial - if present
 860         $key=~tr/a-z/A-Z/; # parameters are upper case
 861         push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/);
 862     }
 863     return @att;
 864 }
 865 END_OF_FUNC
 866
 867 #### Method: dump
 868 # Returns a string in which all the known parameter/value
 869 # pairs are represented as nested lists, mainly for the purposes
 870 # of debugging.
 871 ####
 872 'dump' => <<'END_OF_FUNC',
 873 sub dump {
 874     my($self) = self_or_default(@_);
 875     my($param,$value,@result);
 876     return '<UL></UL>' unless $self->param;
 877     push(@result,"<UL>");
 878     foreach $param ($self->param) {
 879         my($name)=$self->escapeHTML($param);
 880         push(@result,"<LI><STRONG>$param</STRONG>");
 881         push(@result,"<UL>");
 882         foreach $value ($self->param($param)) {
 883             $value = $self->escapeHTML($value);
 884             push(@result,"<LI>$value");
 885         }
 886         push(@result,"</UL>");
 887     }
 888     push(@result,"</UL>\n");
 889     return join("\n",@result);
 890 }
 891 END_OF_FUNC
 892
 893
 894 #### Method: save
 895 # Write values out to a filehandle in such a way that they can
 896 # be reinitialized by the filehandle form of the new() method
 897 ####
 898 'save' => <<'END_OF_FUNC',
 899 sub save {
 900     my($self,$filehandle) = self_or_default(@_);
 901     my($param);
 902     my($package) = caller;
 903 # Check that this still works!
 904 #    $filehandle = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
 905     $filehandle = to_filehandle($filehandle);
 906     foreach $param ($self->param) {
 907         my($escaped_param) = &escape($param);
 908         my($value);
 909         foreach $value ($self->param($param)) {
 910             print $filehandle "$escaped_param=",escape($value),"\n";
 911         }
 912     }
 913     print $filehandle "=\n";    # end of record
 914 }
 915 END_OF_FUNC
 916
 917
 918 #### Method: header
 919 # Return a Content-Type: style header
 920 #
 921 ####
 922 'header' => <<'END_OF_FUNC',
 923 sub header {
 924     my($self,@p) = self_or_default(@_);
 925     my(@header);
 926
 927     my($type,$status,$cookie,$target,$expires,$nph,@other) =
 928         $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
 929
 930     # rearrange() was designed for the HTML portion, so we
 931     # need to fix it up a little.
 932     foreach (@other) {
 933         next unless my($header,$value) = /([^\s=]+)=(.+)/;
 934         substr($header,1,1000)=~tr/A-Z/a-z/;
 935         ($value)=$value=~/^"(.*)"$/;
 936         $_ = "$header: $value";
 937     }
 938
 939     $type = $type || 'text/html';
 940
 941     push(@header,'HTTP/1.0 ' . ($status || '200 OK')) if $nph || $NPH;
 942     push(@header,"Status: $status") if $status;
 943     push(@header,"Window-target: $target") if $target;
 944     # push all the cookies -- there may be several
 945     if ($cookie) {
 946         my(@cookie) = ref($cookie) ? @{$cookie} : $cookie;
 947         foreach (@cookie) {
 948             push(@header,"Set-cookie: $_");
 949         }
 950     }
 951     # if the user indicates an expiration time, then we need
 952     # both an Expires and a Date header (so that the browser is
 953     # uses OUR clock)
 954     push(@header,"Expires: " . &expires($expires)) if $expires;
 955     push(@header,"Date: " . &expires(0)) if $expires;
 956     push(@header,"Pragma: no-cache") if $self->cache();
 957     push(@header,@other);
 958     push(@header,"Content-type: $type");
 959
 960     my $header = join($CRLF,@header);
 961     return $header . "${CRLF}${CRLF}";
 962 }
 963 END_OF_FUNC
 964
 965
 966 #### Method: cache
 967 # Control whether header() will produce the no-cache
 968 # Pragma directive.
 969 ####
 970 'cache' => <<'END_OF_FUNC',
 971 sub cache {
 972     my($self,$new_value) = self_or_default(@_);
 973     $new_value = '' unless $new_value;
 974     if ($new_value ne '') {
 975         $self->{'cache'} = $new_value;
 976     }
 977     return $self->{'cache'};
 978 }
 979 END_OF_FUNC
 980
 981
 982 #### Method: redirect
 983 # Return a Location: style header
 984 #
 985 ####
 986 'redirect' => <<'END_OF_FUNC',
 987 sub redirect {
 988     my($self,@p) = self_or_default(@_);
 989     my($url,$target,$cookie,$nph,@other) = $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p);
 990     $url = $url || $self->self_url;
 991     my(@o);
 992     foreach (@other) { push(@o,split("=")); }
 993     push(@o,
 994          '-Status'=>'302 Found',
 995          '-Location'=>$url,
 996          '-URI'=>$url,
 997          '-nph'=>($nph||$NPH));
 998     push(@o,'-Target'=>$target) if $target;
 999     push(@o,'-Cookie'=>$cookie) if $cookie;
1000     return $self->header(@o);
1001 }
1002 END_OF_FUNC
1003
1004
1005 #### Method: start_html
1006 # Canned HTML header
1007 #
1008 # Parameters:
1009 # $title -> (optional) The title for this HTML document (-title)
1010 # $author -> (optional) e-mail address of the author (-author)
1011 # $base -> (optional) if set to true, will enter the BASE address of this document
1012 #          for resolving relative references (-base)
1013 # $xbase -> (optional) alternative base at some remote location (-xbase)
1014 # $target -> (optional) target window to load all links into (-target)
1015 # $script -> (option) Javascript code (-script)
1016 # $meta -> (optional) Meta information tags
1017 # @other -> (optional) any other named parameters you'd like to incorporate into
1018 #           the <BODY> tag.
1019 ####
1020 'start_html' => <<'END_OF_FUNC',
1021 sub start_html {
1022     my($self,@p) = &self_or_default(@_);
1023     my($title,$author,$base,$xbase,$script,$target,$meta,@other) =
1024         $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,TARGET,META],@p);
1025
1026     # strangely enough, the title needs to be escaped as HTML
1027     # while the author needs to be escaped as a URL
1028     $title = $self->escapeHTML($title || 'Untitled Document');
1029     $author = $self->escapeHTML($author);
1030     my(@result);
1031     push(@result,'<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">');
1032     push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
1033     push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if $author;
1034
1035     if ($base || $xbase || $target) {
1036         my $href = $xbase || $self->url();
1037         my $t = $target ? qq/ TARGET="$target"/ : '';
1038         push(@result,qq/<BASE HREF="$href"$t>/);
1039     }
1040
1041     if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
1042         foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
1043     }
1044     push(@result,<<END) if $script;
1045 <SCRIPT>
1046 <!-- Hide script from HTML-compliant browsers
1047 $script
1048 // End script hiding. -->
1049 </SCRIPT>
1050 END
1051     ;
1052     my($other) = @other ? " @other" : '';
1053     push(@result,"</HEAD><BODY$other>");
1054     return join("\n",@result);
1055 }
1056 END_OF_FUNC
1057
1058
1059 #### Method: end_html
1060 # End an HTML document.
1061 # Trivial method for completeness.  Just returns "</BODY>"
1062 ####
1063 'end_html' => <<'END_OF_FUNC',
1064 sub end_html {
1065     return "</BODY></HTML>";
1066 }
1067 END_OF_FUNC
1068
1069
1070 ################################
1071 # METHODS USED IN BUILDING FORMS
1072 ################################
1073
1074 #### Method: isindex
1075 # Just prints out the isindex tag.
1076 # Parameters:
1077 #  $action -> optional URL of script to run
1078 # Returns:
1079 #   A string containing a <ISINDEX> tag
1080 'isindex' => <<'END_OF_FUNC',
1081 sub isindex {
1082     my($self,@p) = self_or_default(@_);
1083     my($action,@other) = $self->rearrange([ACTION],@p);
1084     $action = qq/ACTION="$action"/ if $action;
1085     my($other) = @other ? " @other" : '';
1086     return "<ISINDEX $action$other>";
1087 }
1088 END_OF_FUNC
1089
1090
1091 #### Method: startform
1092 # Start a form
1093 # Parameters:
1094 #   $method -> optional submission method to use (GET or POST)
1095 #   $action -> optional URL of script to run
1096 #   $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1097 'startform' => <<'END_OF_FUNC',
1098 sub startform {
1099     my($self,@p) = self_or_default(@_);
1100
1101     my($method,$action,$enctype,@other) =
1102         $self->rearrange([METHOD,ACTION,ENCTYPE],@p);
1103
1104     $method = $method || 'POST';
1105     $enctype = $enctype || &URL_ENCODED;
1106     $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
1107         'ACTION="'.$self->script_name.'"' : '';
1108     my($other) = @other ? " @other" : '';
1109     $self->{'.parametersToAdd'}={};
1110     return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
1111 }
1112 END_OF_FUNC
1113
1114
1115 #### Method: start_form
1116 # synonym for startform
1117 'start_form' => <<'END_OF_FUNC',
1118 sub start_form {
1119     &startform;
1120 }
1121 END_OF_FUNC
1122
1123
1124 #### Method: start_multipart_form
1125 # synonym for startform
1126 'start_multipart_form' => <<'END_OF_FUNC',
1127 sub start_multipart_form {
1128     my($self,@p) = self_or_default(@_);
1129     if ($self->use_named_parameters ||
1130         (defined($param[0]) && substr($param[0],0,1) eq '-')) {
1131         my(%p) = @p;
1132         $p{'-enctype'}=&MULTIPART;
1133         return $self->startform(%p);
1134     } else {
1135         my($method,$action,@other) =
1136             $self->rearrange([METHOD,ACTION],@p);
1137         return $self->startform($method,$action,&MULTIPART,@other);
1138     }
1139 }
1140 END_OF_FUNC
1141
1142
1143 #### Method: endform
1144 # End a form
1145 'endform' => <<'END_OF_FUNC',
1146 sub endform {
1147     my($self,@p) = self_or_default(@_);
1148     return ($self->get_fields,"</FORM>");
1149 }
1150 END_OF_FUNC
1151
1152
1153 #### Method: end_form
1154 # synonym for endform
1155 'end_form' => <<'END_OF_FUNC',
1156 sub end_form {
1157     &endform;
1158 }
1159 END_OF_FUNC
1160
1161
1162 #### Method: textfield
1163 # Parameters:
1164 #   $name -> Name of the text field
1165 #   $default -> Optional default value of the field if not
1166 #                already defined.
1167 #   $size ->  Optional width of field in characaters.
1168 #   $maxlength -> Optional maximum number of characters.
1169 # Returns:
1170 #   A string containing a <INPUT TYPE="text"> field
1171 #
1172 'textfield' => <<'END_OF_FUNC',
1173 sub textfield {
1174     my($self,@p) = self_or_default(@_);
1175     my($name,$default,$size,$maxlength,$override,@other) =
1176         $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1177
1178     my $current = $override ? $default :
1179         (defined($self->param($name)) ? $self->param($name) : $default);
1180
1181     $current = defined($current) ? $self->escapeHTML($current) : '';
1182     $name = defined($name) ? $self->escapeHTML($name) : '';
1183     my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1184     my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
1185     my($other) = @other ? " @other" : '';
1186     return qq/<INPUT TYPE="text" NAME="$name" VALUE="$current"$s$m$other>/;
1187 }
1188 END_OF_FUNC
1189
1190
1191 #### Method: filefield
1192 # Parameters:
1193 #   $name -> Name of the file upload field
1194 #   $size ->  Optional width of field in characaters.
1195 #   $maxlength -> Optional maximum number of characters.
1196 # Returns:
1197 #   A string containing a <INPUT TYPE="text"> field
1198 #
1199 'filefield' => <<'END_OF_FUNC',
1200 sub filefield {
1201     my($self,@p) = self_or_default(@_);
1202
1203     my($name,$default,$size,$maxlength,$override,@other) =
1204         $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1205
1206     $current = $override ? $default :
1207         (defined($self->param($name)) ? $self->param($name) : $default);
1208
1209     $name = defined($name) ? $self->escapeHTML($name) : '';
1210     my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1211     my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
1212     $current = defined($current) ? $self->escapeHTML($current) : '';
1213     $other = ' ' . join(" ",@other);
1214     return qq/<INPUT TYPE="file" NAME="$name" VALUE="$current"$s$m$other>/;
1215 }
1216 END_OF_FUNC
1217
1218
1219 #### Method: password
1220 # Create a "secret password" entry field
1221 # Parameters:
1222 #   $name -> Name of the field
1223 #   $default -> Optional default value of the field if not
1224 #                already defined.
1225 #   $size ->  Optional width of field in characters.
1226 #   $maxlength -> Optional maximum characters that can be entered.
1227 # Returns:
1228 #   A string containing a <INPUT TYPE="password"> field
1229 #
1230 'password_field' => <<'END_OF_FUNC',
1231 sub password_field {
1232     my ($self,@p) = self_or_default(@_);
1233
1234     my($name,$default,$size,$maxlength,$override,@other) =
1235         $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1236
1237     my($current) =  $override ? $default :
1238         (defined($self->param($name)) ? $self->param($name) : $default);
1239
1240     $name = defined($name) ? $self->escapeHTML($name) : '';
1241     $current = defined($current) ? $self->escapeHTML($current) : '';
1242     my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1243     my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
1244     my($other) = @other ? " @other" : '';
1245     return qq/<INPUT TYPE="password" NAME="$name" VALUE="$current"$s$m$other>/;
1246 }
1247 END_OF_FUNC
1248
1249
1250 #### Method: textarea
1251 # Parameters:
1252 #   $name -> Name of the text field
1253 #   $default -> Optional default value of the field if not
1254 #                already defined.
1255 #   $rows ->  Optional number of rows in text area
1256 #   $columns -> Optional number of columns in text area
1257 # Returns:
1258 #   A string containing a <TEXTAREA></TEXTAREA> tag
1259 #
1260 'textarea' => <<'END_OF_FUNC',
1261 sub textarea {
1262     my($self,@p) = self_or_default(@_);
1263
1264     my($name,$default,$rows,$cols,$override,@other) =
1265         $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
1266
1267     my($current)= $override ? $default :
1268         (defined($self->param($name)) ? $self->param($name) : $default);
1269
1270     $name = defined($name) ? $self->escapeHTML($name) : '';
1271     $current = defined($current) ? $self->escapeHTML($current) : '';
1272     my($r) = $rows ? " ROWS=$rows" : '';
1273     my($c) = $cols ? " COLS=$cols" : '';
1274     my($other) = @other ? " @other" : '';
1275     return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
1276 }
1277 END_OF_FUNC
1278
1279
1280 #### Method: button
1281 # Create a javascript button.
1282 # Parameters:
1283 #   $name ->  (optional) Name for the button. (-name)
1284 #   $value -> (optional) Value of the button when selected (and visible name) (-value)
1285 #   $onclick -> (optional) Text of the JavaScript to run when the button is
1286 #                clicked.
1287 # Returns:
1288 #   A string containing a <INPUT TYPE="button"> tag
1289 ####
1290 'button' => <<'END_OF_FUNC',
1291 sub button {
1292     my($self,@p) = self_or_default(@_);
1293
1294     my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
1295                                                          [ONCLICK,SCRIPT]],@p);
1296
1297     $label=$self->escapeHTML($label);
1298     $value=$self->escapeHTML($value);
1299     $script=$self->escapeHTML($script);
1300
1301     my($name) = '';
1302     $name = qq/ NAME="$label"/ if $label;
1303     $value = $value || $label;
1304     my($val) = '';
1305     $val = qq/ VALUE="$value"/ if $value;
1306     $script = qq/ ONCLICK="$script"/ if $script;
1307     my($other) = @other ? " @other" : '';
1308     return qq/<INPUT TYPE="button"$name$val$script$other>/;
1309 }
1310 END_OF_FUNC
1311
1312
1313 #### Method: submit
1314 # Create a "submit query" button.
1315 # Parameters:
1316 #   $name ->  (optional) Name for the button.
1317 #   $value -> (optional) Value of the button when selected (also doubles as label).
1318 #   $label -> (optional) Label printed on the button(also doubles as the value).
1319 # Returns:
1320 #   A string containing a <INPUT TYPE="submit"> tag
1321 ####
1322 'submit' => <<'END_OF_FUNC',
1323 sub submit {
1324     my($self,@p) = self_or_default(@_);
1325
1326     my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p);
1327
1328     $label=$self->escapeHTML($label);
1329     $value=$self->escapeHTML($value);
1330
1331     my($name) = ' NAME=".submit"';
1332     $name = qq/ NAME="$label"/ if $label;
1333     $value = $value || $label;
1334     my($val) = '';
1335     $val = qq/ VALUE="$value"/ if defined($value);
1336     my($other) = @other ? " @other" : '';
1337     return qq/<INPUT TYPE="submit"$name$val$other>/;
1338 }
1339 END_OF_FUNC
1340
1341
1342 #### Method: reset
1343 # Create a "reset" button.
1344 # Parameters:
1345 #   $name -> (optional) Name for the button.
1346 # Returns:
1347 #   A string containing a <INPUT TYPE="reset"> tag
1348 ####
1349 'reset' => <<'END_OF_FUNC',
1350 sub reset {
1351     my($self,@p) = self_or_default(@_);
1352     my($label,@other) = $self->rearrange([NAME],@p);
1353     $label=$self->escapeHTML($label);
1354     my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
1355     my($other) = @other ? " @other" : '';
1356     return qq/<INPUT TYPE="reset"$value$other>/;
1357 }
1358 END_OF_FUNC
1359
1360
1361 #### Method: defaults
1362 # Create a "defaults" button.
1363 # Parameters:
1364 #   $name -> (optional) Name for the button.
1365 # Returns:
1366 #   A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
1367 #
1368 # Note: this button has a special meaning to the initialization script,
1369 # and tells it to ERASE the current query string so that your defaults
1370 # are used again!
1371 ####
1372 'defaults' => <<'END_OF_FUNC',
1373 sub defaults {
1374     my($self,@p) = self_or_default(@_);
1375
1376     my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
1377
1378     $label=$self->escapeHTML($label);
1379     $label = $label || "Defaults";
1380     my($value) = qq/ VALUE="$label"/;
1381     my($other) = @other ? " @other" : '';
1382     return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
1383 }
1384 END_OF_FUNC
1385
1386
1387 #### Method: checkbox
1388 # Create a checkbox that is not logically linked to any others.
1389 # The field value is "on" when the button is checked.
1390 # Parameters:
1391 #   $name -> Name of the checkbox
1392 #   $checked -> (optional) turned on by default if true
1393 #   $value -> (optional) value of the checkbox, 'on' by default
1394 #   $label -> (optional) a user-readable label printed next to the box.
1395 #             Otherwise the checkbox name is used.
1396 # Returns:
1397 #   A string containing a <INPUT TYPE="checkbox"> field
1398 ####
1399 'checkbox' => <<'END_OF_FUNC',
1400 sub checkbox {
1401     my($self,@p) = self_or_default(@_);
1402
1403     my($name,$checked,$value,$label,$override,@other) =
1404         $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
1405
1406     if (!$override && defined($self->param($name))) {
1407         $value = $self->param($name) unless defined $value;
1408         $checked = $self->param($name) eq $value ? ' CHECKED' : '';
1409     } else {
1410         $checked = $checked ? ' CHECKED' : '';
1411         $value = defined $value ? $value : 'on';
1412     }
1413     my($the_label) = defined $label ? $label : $name;
1414     $name = $self->escapeHTML($name);
1415     $value = $self->escapeHTML($value);
1416     $the_label = $self->escapeHTML($the_label);
1417     my($other) = @other ? " @other" : '';
1418     $self->register_parameter($name);
1419     return <<END;
1420 <INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label
1421 END
1422 }
1423 END_OF_FUNC
1424
1425
1426 #### Method: checkbox_group
1427 # Create a list of logically-linked checkboxes.
1428 # Parameters:
1429 #   $name -> Common name for all the check boxes
1430 #   $values -> A pointer to a regular array containing the
1431 #             values for each checkbox in the group.
1432 #   $defaults -> (optional)
1433 #             1. If a pointer to a regular array of checkbox values,
1434 #             then this will be used to decide which
1435 #             checkboxes to turn on by default.
1436 #             2. If a scalar, will be assumed to hold the
1437 #             value of a single checkbox in the group to turn on.
1438 #   $linebreak -> (optional) Set to true to place linebreaks
1439 #             between the buttons.
1440 #   $labels -> (optional)
1441 #             A pointer to an associative array of labels to print next to each checkbox
1442 #             in the form $label{'value'}="Long explanatory label".
1443 #             Otherwise the provided values are used as the labels.
1444 # Returns:
1445 #   An ARRAY containing a series of <INPUT TYPE="checkbox"> fields
1446 ####
1447 'checkbox_group' => <<'END_OF_FUNC',
1448 sub checkbox_group {
1449     my($self,@p) = self_or_default(@_);
1450
1451     my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
1452        $rowheaders,$colheaders,$override,$nolabels,@other) =
1453         $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1454                           LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
1455                           ROWHEADERS,COLHEADERS,
1456                           [OVERRIDE,FORCE],NOLABELS],@p);
1457
1458     my($checked,$break,$result,$label);
1459
1460     my(%checked) = $self->previous_or_default($name,$defaults,$override);
1461
1462     $break = $linebreak ? "<BR>" : '';
1463     $name=$self->escapeHTML($name);
1464
1465     # Create the elements
1466     my(@elements);
1467     my(@values) = $values ? @$values : $self->param($name);
1468     my($other) = @other ? " @other" : '';
1469     foreach (@values) {
1470         $checked = $checked{$_} ? ' CHECKED' : '';
1471         $label = '';
1472         unless (defined($nolabels) && $nolabels) {
1473             $label = $_;
1474             $label = $labels->{$_} if defined($labels) && $labels->{$_};
1475             $label = $self->escapeHTML($label);
1476         }
1477         $_ = $self->escapeHTML($_);
1478         push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label} ${break}/);
1479     }
1480     $self->register_parameter($name);
1481     return wantarray ? @elements : join('',@elements) unless $columns;
1482     return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1483 }
1484 END_OF_FUNC
1485
1486
1487 # Escape HTML -- used internally
1488 'escapeHTML' => <<'END_OF_FUNC',
1489 sub escapeHTML {
1490     my($self,$toencode) = @_;
1491     return undef unless defined($toencode);
1492     return $toencode if $self->{'dontescape'};
1493     $toencode=~s/&/&amp;/g;
1494     $toencode=~s/\"/&quot;/g;
1495     $toencode=~s/>/&gt;/g;
1496     $toencode=~s/</&lt;/g;
1497     return $toencode;
1498 }
1499 END_OF_FUNC
1500
1501
1502 # Internal procedure - don't use
1503 '_tableize' => <<'END_OF_FUNC',
1504 sub _tableize {
1505     my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
1506     my($result);
1507
1508     $rows = int(0.99 + @elements/$columns) unless $rows;
1509     # rearrange into a pretty table
1510     $result = "<TABLE>";
1511     my($row,$column);
1512     unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
1513     $result .= "<TR>" if @{$colheaders};
1514     foreach (@{$colheaders}) {
1515         $result .= "<TH>$_</TH>";
1516     }
1517     for ($row=0;$row<$rows;$row++) {
1518         $result .= "<TR>";
1519         $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
1520         for ($column=0;$column<$columns;$column++) {
1521             $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>";
1522         }
1523         $result .= "</TR>";
1524     }
1525     $result .= "</TABLE>";
1526     return $result;
1527 }
1528 END_OF_FUNC
1529
1530
1531 #### Method: radio_group
1532 # Create a list of logically-linked radio buttons.
1533 # Parameters:
1534 #   $name -> Common name for all the buttons.
1535 #   $values -> A pointer to a regular array containing the
1536 #             values for each button in the group.
1537 #   $default -> (optional) Value of the button to turn on by default.  Pass '-'
1538 #               to turn _nothing_ on.
1539 #   $linebreak -> (optional) Set to true to place linebreaks
1540 #             between the buttons.
1541 #   $labels -> (optional)
1542 #             A pointer to an associative array of labels to print next to each checkbox
1543 #             in the form $label{'value'}="Long explanatory label".
1544 #             Otherwise the provided values are used as the labels.
1545 # Returns:
1546 #   An ARRAY containing a series of <INPUT TYPE="radio"> fields
1547 ####
1548 'radio_group' => <<'END_OF_FUNC',
1549 sub radio_group {
1550     my($self,@p) = self_or_default(@_);
1551
1552     my($name,$values,$default,$linebreak,$labels,
1553        $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
1554         $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
1555                           ROWS,[COLUMNS,COLS],
1556                           ROWHEADERS,COLHEADERS,
1557                           [OVERRIDE,FORCE],NOLABELS],@p);
1558     my($result,$checked);
1559
1560     if (!$override && defined($self->param($name))) {
1561         $checked = $self->param($name);
1562     } else {
1563         $checked = $default;
1564     }
1565     # If no check array is specified, check the first by default
1566     $checked = $values->[0] unless $checked;
1567     $name=$self->escapeHTML($name);
1568
1569     my(@elements);
1570     my(@values) = $values ? @$values : $self->param($name);
1571     my($other) = @other ? " @other" : '';
1572     foreach (@values) {
1573         my($checkit) = $checked eq $_ ? ' CHECKED' : '';
1574         my($break) = $linebreak ? '<BR>' : '';
1575         my($label)='';
1576         unless (defined($nolabels) && $nolabels) {
1577             $label = $_;
1578             $label = $labels->{$_} if defined($labels) && $labels->{$_};
1579             $label = $self->escapeHTML($label);
1580         }
1581         $_=$self->escapeHTML($_);
1582         push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label} ${break}/);
1583     }
1584     $self->register_parameter($name);
1585     return wantarray ? @elements : join('',@elements) unless $columns;
1586     return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1587 }
1588 END_OF_FUNC
1589
1590
1591 #### Method: popup_menu
1592 # Create a popup menu.
1593 # Parameters:
1594 #   $name -> Name for all the menu
1595 #   $values -> A pointer to a regular array containing the
1596 #             text of each menu item.
1597 #   $default -> (optional) Default item to display
1598 #   $labels -> (optional)
1599 #             A pointer to an associative array of labels to print next to each checkbox
1600 #             in the form $label{'value'}="Long explanatory label".
1601 #             Otherwise the provided values are used as the labels.
1602 # Returns:
1603 #   A string containing the definition of a popup menu.
1604 ####
1605 'popup_menu' => <<'END_OF_FUNC',
1606 sub popup_menu {
1607     my($self,@p) = self_or_default(@_);
1608
1609     my($name,$values,$default,$labels,$override,@other) =
1610         $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
1611     my($result,$selected);
1612
1613     if (!$override && defined($self->param($name))) {
1614         $selected = $self->param($name);
1615     } else {
1616         $selected = $default;
1617     }
1618     $name=$self->escapeHTML($name);
1619     my($other) = @other ? " @other" : '';
1620
1621     my(@values) = $values ? @$values : $self->param($name);
1622     $result = qq/<SELECT NAME="$name"$other>\n/;
1623     foreach (@values) {
1624         my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
1625         my($label) = $_;
1626         $label = $labels->{$_} if defined($labels) && $labels->{$_};
1627         my($value) = $self->escapeHTML($_);
1628         $label=$self->escapeHTML($label);
1629         $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
1630     }
1631
1632     $result .= "</SELECT>\n";
1633     return $result;
1634 }
1635 END_OF_FUNC
1636
1637
1638 #### Method: scrolling_list
1639 # Create a scrolling list.
1640 # Parameters:
1641 #   $name -> name for the list
1642 #   $values -> A pointer to a regular array containing the
1643 #             values for each option line in the list.
1644 #   $defaults -> (optional)
1645 #             1. If a pointer to a regular array of options,
1646 #             then this will be used to decide which
1647 #             lines to turn on by default.
1648 #             2. Otherwise holds the value of the single line to turn on.
1649 #   $size -> (optional) Size of the list.
1650 #   $multiple -> (optional) If set, allow multiple selections.
1651 #   $labels -> (optional)
1652 #             A pointer to an associative array of labels to print next to each checkbox
1653 #             in the form $label{'value'}="Long explanatory label".
1654 #             Otherwise the provided values are used as the labels.
1655 # Returns:
1656 #   A string containing the definition of a scrolling list.
1657 ####
1658 'scrolling_list' => <<'END_OF_FUNC',
1659 sub scrolling_list {
1660     my($self,@p) = self_or_default(@_);
1661     my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
1662         = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1663                             SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
1664
1665     my($result);
1666     my(@values) = $values ? @$values : $self->param($name);
1667     $size = $size || scalar(@values);
1668
1669     my(%selected) = $self->previous_or_default($name,$defaults,$override);
1670     my($is_multiple) = $multiple ? ' MULTIPLE' : '';
1671     my($has_size) = $size ? " SIZE=$size" : '';
1672     my($other) = @other ? " @other" : '';
1673
1674     $name=$self->escapeHTML($name);
1675     $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
1676     foreach (@values) {
1677         my($selectit) = $selected{$_} ? 'SELECTED' : '';
1678         my($label) = $_;
1679         $label = $labels->{$_} if defined($labels) && $labels->{$_};
1680         $label=$self->escapeHTML($label);
1681         my($value)=$self->escapeHTML($_);
1682         $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
1683     }
1684     $result .= "</SELECT>\n";
1685     $self->register_parameter($name);
1686     return $result;
1687 }
1688 END_OF_FUNC
1689
1690
1691 #### Method: hidden
1692 # Parameters:
1693 #   $name -> Name of the hidden field
1694 #   @default -> (optional) Initial values of field (may be an array)
1695 #      or
1696 #   $default->[initial values of field]
1697 # Returns:
1698 #   A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
1699 ####
1700 'hidden' => <<'END_OF_FUNC',
1701 sub hidden {
1702     my($self,@p) = self_or_default(@_);
1703
1704     # this is the one place where we departed from our standard
1705     # calling scheme, so we have to special-case (darn)
1706     my(@result,@value);
1707     my($name,$default,$override,@other) =
1708         $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
1709
1710     my $do_override = 0;
1711     if ( substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
1712         @value = ref($default) ? @{$default} : $default;
1713         $do_override = $override;
1714     } else {
1715         foreach ($default,$override,@other) {
1716             push(@value,$_) if defined($_);
1717         }
1718     }
1719
1720     # use previous values if override is not set
1721     my @prev = $self->param($name);
1722     @value = @prev if !$do_override && @prev;
1723
1724     $name=$self->escapeHTML($name);
1725     foreach (@value) {
1726         $_=$self->escapeHTML($_);
1727         push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
1728     }
1729     return wantarray ? @result : join('',@result);
1730 }
1731 END_OF_FUNC
1732
1733
1734 #### Method: image_button
1735 # Parameters:
1736 #   $name -> Name of the button
1737 #   $src ->  URL of the image source
1738 #   $align -> Alignment style (TOP, BOTTOM or MIDDLE)
1739 # Returns:
1740 #   A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment">
1741 ####
1742 'image_button' => <<'END_OF_FUNC',
1743 sub image_button {
1744     my($self,@p) = self_or_default(@_);
1745
1746     my($name,$src,$alignment,@other) =
1747         $self->rearrange([NAME,SRC,ALIGN],@p);
1748
1749     my($align) = $alignment ? " ALIGN=\U$alignment" : '';
1750     my($other) = @other ? " @other" : '';
1751     $name=$self->escapeHTML($name);
1752     return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/;
1753 }
1754 END_OF_FUNC
1755
1756
1757 #### Method: self_url
1758 # Returns a URL containing the current script and all its
1759 # param/value pairs arranged as a query.  You can use this
1760 # to create a link that, when selected, will reinvoke the
1761 # script with all its state information preserved.
1762 ####
1763 'self_url' => <<'END_OF_FUNC',
1764 sub self_url {
1765     my($self) = self_or_default(@_);
1766     my($query_string) = $self->query_string;
1767     my $protocol = $self->protocol();
1768     my $name = "$protocol://" . $self->server_name;
1769     $name .= ":" . $self->server_port
1770         unless $self->server_port == 80;
1771     $name .= $self->script_name;
1772     $name .= $self->path_info if $self->path_info;
1773     return $name unless $query_string;
1774     return "$name?$query_string";
1775 }
1776 END_OF_FUNC
1777
1778
1779 # This is provided as a synonym to self_url() for people unfortunate
1780 # enough to have incorporated it into their programs already!
1781 'state' => <<'END_OF_FUNC',
1782 sub state {
1783     &self_url;
1784 }
1785 END_OF_FUNC
1786
1787
1788 #### Method: url
1789 # Like self_url, but doesn't return the query string part of
1790 # the URL.
1791 ####
1792 'url' => <<'END_OF_FUNC',
1793 sub url {
1794     my($self) = self_or_default(@_);
1795     my $protocol = $self->protocol();
1796     my $name = "$protocol://" . $self->server_name;
1797     $name .= ":" . $self->server_port
1798         unless $self->server_port == 80;
1799     $name .= $self->script_name;
1800     return $name;
1801 }
1802
1803 END_OF_FUNC
1804
1805 #### Method: cookie
1806 # Set or read a cookie from the specified name.
1807 # Cookie can then be passed to header().
1808 # Usual rules apply to the stickiness of -value.
1809 #  Parameters:
1810 #   -name -> name for this cookie (optional)
1811 #   -value -> value of this cookie (scalar, array or hash)
1812 #   -path -> paths for which this cookie is valid (optional)
1813 #   -domain -> internet domain in which this cookie is valid (optional)
1814 #   -secure -> if true, cookie only passed through secure channel (optional)
1815 #   -expires -> expiry date in format Wdy, DD-Mon-YY HH:MM:SS GMT (optional)
1816 ####
1817 'cookie' => <<'END_OF_FUNC',
1818 # temporary, for debugging.
1819 sub cookie {
1820     my($self,@p) = self_or_default(@_);
1821     my($name,$value,$path,$domain,$secure,$expires) =
1822         $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
1823
1824
1825     # if no value is supplied, then we retrieve the
1826     # value of the cookie, if any.  For efficiency, we cache the parsed
1827     # cookie in our state variables.
1828     unless (defined($value)) {
1829         unless ($self->{'.cookies'}) {
1830             my(@pairs) = split("; ",$self->raw_cookie);
1831             foreach (@pairs) {
1832                 my($key,$value) = split("=");
1833                 my(@values) = map unescape($_),split('&',$value);
1834                 $self->{'.cookies'}->{unescape($key)} = [@values];
1835             }
1836         }
1837
1838         # If no name is supplied, then retrieve the names of all our cookies.
1839         return () unless $self->{'.cookies'};
1840         return wantarray ? @{$self->{'.cookies'}->{$name}} : $self->{'.cookies'}->{$name}->[0]
1841             if defined($name) && $name ne '';
1842         return keys %{$self->{'.cookies'}};
1843     }
1844     my(@values);
1845
1846     # Pull out our parameters.
1847     if (ref($value)) {
1848         if (ref($value) eq 'ARRAY') {
1849             @values = @$value;
1850         } elsif (ref($value) eq 'HASH') {
1851             @values = %$value;
1852         }
1853     } else {
1854         @values = ($value);
1855     }
1856     @values = map escape($_),@values;
1857
1858     # I.E. requires the path to be present.
1859     ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $path;
1860
1861     my(@constant_values);
1862     push(@constant_values,"domain=$domain") if $domain;
1863     push(@constant_values,"path=$path") if $path;
1864     push(@constant_values,"expires=".&expires($expires)) if $expires;
1865     push(@constant_values,'secure') if $secure;
1866
1867     my($key) = &escape($name);
1868     my($cookie) = join("=",$key,join("&",@values));
1869     return join("; ",$cookie,@constant_values);
1870 }
1871 END_OF_FUNC
1872
1873
1874 # This internal routine creates an expires string exactly some number of
1875 # hours from the current time in GMT.  This is the format
1876 # required by Netscape cookies, and I think it works for the HTTP
1877 # Expires: header as well.
1878 'expires' => <<'END_OF_FUNC',
1879 sub expires {
1880     my($time) = @_;
1881     my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
1882     my(@WDAY) = qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/;
1883     my(%mult) = ('s'=>1,
1884                  'm'=>60,
1885                  'h'=>60*60,
1886                  'd'=>60*60*24,
1887                  'M'=>60*60*24*30,
1888                  'y'=>60*60*24*365);
1889     # format for time can be in any of the forms...
1890     # "now" -- expire immediately
1891     # "+180s" -- in 180 seconds
1892     # "+2m" -- in 2 minutes
1893     # "+12h" -- in 12 hours
1894     # "+1d"  -- in 1 day
1895     # "+3M"  -- in 3 months
1896     # "+2y"  -- in 2 years
1897     # "-3m"  -- 3 minutes ago(!)
1898     # If you don't supply one of these forms, we assume you are
1899     # specifying the date yourself
1900     my($offset);
1901     if (!$time || ($time eq 'now')) {
1902         $offset = 0;
1903     } elsif ($time=~/^([+-]?\d+)([mhdMy]?)/) {
1904         $offset = ($mult{$2} || 1)*$1;
1905     } else {
1906         return $time;
1907     }
1908     my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime(time+$offset);
1909     $year += 1900 unless $year < 100;
1910     return sprintf("%s, %02d-%s-%02d %02d:%02d:%02d GMT",
1911                    $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
1912 }
1913 END_OF_FUNC
1914
1915
1916 ###############################################
1917 # OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
1918 ###############################################
1919
1920 #### Method: path_info
1921 # Return the extra virtual path information provided
1922 # after the URL (if any)
1923 ####
1924 'path_info' => <<'END_OF_FUNC',
1925 sub path_info {
1926     return $ENV{'PATH_INFO'};
1927 }
1928 END_OF_FUNC
1929
1930
1931 #### Method: request_method
1932 # Returns 'POST', 'GET', 'PUT' or 'HEAD'
1933 ####
1934 'request_method' => <<'END_OF_FUNC',
1935 sub request_method {
1936     return $ENV{'REQUEST_METHOD'};
1937 }
1938 END_OF_FUNC
1939
1940 #### Method: path_translated
1941 # Return the physical path information provided
1942 # by the URL (if any)
1943 ####
1944 'path_translated' => <<'END_OF_FUNC',
1945 sub path_translated {
1946     return $ENV{'PATH_TRANSLATED'};
1947 }
1948 END_OF_FUNC
1949
1950
1951 #### Method: query_string
1952 # Synthesize a query string from our current
1953 # parameters
1954 ####
1955 'query_string' => <<'END_OF_FUNC',
1956 sub query_string {
1957     my($self) = self_or_default(@_);
1958     my($param,$value,@pairs);
1959     foreach $param ($self->param) {
1960         my($eparam) = &escape($param);
1961         foreach $value ($self->param($param)) {
1962             $value = &escape($value);
1963             push(@pairs,"$eparam=$value");
1964         }
1965     }
1966     return join("&",@pairs);
1967 }
1968 END_OF_FUNC
1969
1970
1971 #### Method: accept
1972 # Without parameters, returns an array of the
1973 # MIME types the browser accepts.
1974 # With a single parameter equal to a MIME
1975 # type, will return undef if the browser won't
1976 # accept it, 1 if the browser accepts it but
1977 # doesn't give a preference, or a floating point
1978 # value between 0.0 and 1.0 if the browser
1979 # declares a quantitative score for it.
1980 # This handles MIME type globs correctly.
1981 ####
1982 'accept' => <<'END_OF_FUNC',
1983 sub accept {
1984     my($self,$search) = self_or_CGI(@_);
1985     my(%prefs,$type,$pref,$pat);
1986
1987     my(@accept) = split(',',$self->http('accept'));
1988
1989     foreach (@accept) {
1990         ($pref) = /q=(\d\.\d+|\d+)/;
1991         ($type) = m#(\S+/[^;]+)#;
1992         next unless $type;
1993         $prefs{$type}=$pref || 1;
1994     }
1995
1996     return keys %prefs unless $search;
1997
1998     # if a search type is provided, we may need to
1999     # perform a pattern matching operation.
2000     # The MIME types use a glob mechanism, which
2001     # is easily translated into a perl pattern match
2002
2003     # First return the preference for directly supported
2004     # types:
2005     return $prefs{$search} if $prefs{$search};
2006
2007     # Didn't get it, so try pattern matching.
2008     foreach (keys %prefs) {
2009         next unless /\*/;       # not a pattern match
2010         ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2011         $pat =~ s/\*/.*/g; # turn it into a pattern
2012         return $prefs{$_} if $search=~/$pat/;
2013     }
2014 }
2015 END_OF_FUNC
2016
2017
2018 #### Method: user_agent
2019 # If called with no parameters, returns the user agent.
2020 # If called with one parameter, does a pattern match (case
2021 # insensitive) on the user agent.
2022 ####
2023 'user_agent' => <<'END_OF_FUNC',
2024 sub user_agent {
2025     my($self,$match)=self_or_CGI(@_);
2026     return $self->http('user_agent') unless $match;
2027     return $self->http('user_agent') =~ /$match/i;
2028 }
2029 END_OF_FUNC
2030
2031
2032 #### Method: cookie
2033 # Returns the magic cookie for the session.
2034 # To set the magic cookie for new transations,
2035 # try print $q->header('-Set-cookie'=>'my cookie')
2036 ####
2037 'raw_cookie' => <<'END_OF_FUNC',
2038 sub raw_cookie {
2039     my($self) = self_or_CGI(@_);
2040     return $self->http('cookie') || $ENV{'COOKIE'} || '';
2041 }
2042 END_OF_FUNC
2043
2044 #### Method: virtual_host
2045 # Return the name of the virtual_host, which
2046 # is not always the same as the server
2047 ######
2048 'virtual_host' => <<'END_OF_FUNC',
2049 sub virtual_host {
2050     return http('host') || server_name();
2051 }
2052 END_OF_FUNC
2053
2054 #### Method: remote_host
2055 # Return the name of the remote host, or its IP
2056 # address if unavailable.  If this variable isn't
2057 # defined, it returns "localhost" for debugging
2058 # purposes.
2059 ####
2060 'remote_host' => <<'END_OF_FUNC',
2061 sub remote_host {
2062     return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
2063     || 'localhost';
2064 }
2065 END_OF_FUNC
2066
2067
2068 #### Method: remote_addr
2069 # Return the IP addr of the remote host.
2070 ####
2071 'remote_addr' => <<'END_OF_FUNC',
2072 sub remote_addr {
2073     return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
2074 }
2075 END_OF_FUNC
2076
2077
2078 #### Method: script_name
2079 # Return the partial URL to this script for
2080 # self-referencing scripts.  Also see
2081 # self_url(), which returns a URL with all state information
2082 # preserved.
2083 ####
2084 'script_name' => <<'END_OF_FUNC',
2085 sub script_name {
2086     return $ENV{'SCRIPT_NAME'} if $ENV{'SCRIPT_NAME'};
2087     # These are for debugging
2088     return "/$0" unless $0=~/^\//;
2089     return $0;
2090 }
2091 END_OF_FUNC
2092
2093
2094 #### Method: referer
2095 # Return the HTTP_REFERER: useful for generating
2096 # a GO BACK button.
2097 ####
2098 'referer' => <<'END_OF_FUNC',
2099 sub referer {
2100     my($self) = self_or_CGI(@_);
2101     return $self->http('referer');
2102 }
2103 END_OF_FUNC
2104
2105
2106 #### Method: server_name
2107 # Return the name of the server
2108 ####
2109 'server_name' => <<'END_OF_FUNC',
2110 sub server_name {
2111     return $ENV{'SERVER_NAME'} || 'localhost';
2112 }
2113 END_OF_FUNC
2114
2115 #### Method: server_software
2116 # Return the name of the server software
2117 ####
2118 'server_software' => <<'END_OF_FUNC',
2119 sub server_software {
2120     return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
2121 }
2122 END_OF_FUNC
2123
2124 #### Method: server_port
2125 # Return the tcp/ip port the server is running on
2126 ####
2127 'server_port' => <<'END_OF_FUNC',
2128 sub server_port {
2129     return $ENV{'SERVER_PORT'} || 80; # for debugging
2130 }
2131 END_OF_FUNC
2132
2133 #### Method: server_protocol
2134 # Return the protocol (usually HTTP/1.0)
2135 ####
2136 'server_protocol' => <<'END_OF_FUNC',
2137 sub server_protocol {
2138     return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
2139 }
2140 END_OF_FUNC
2141
2142 #### Method: http
2143 # Return the value of an HTTP variable, or
2144 # the list of variables if none provided
2145 ####
2146 'http' => <<'END_OF_FUNC',
2147 sub http {
2148     my ($self,$parameter) = self_or_CGI(@_);
2149     return $ENV{$parameter} if $parameter=~/^HTTP/;
2150     return $ENV{"HTTP_\U$parameter\E"} if $parameter;
2151     my(@p);
2152     foreach (keys %ENV) {
2153         push(@p,$_) if /^HTTP/;
2154     }
2155     return @p;
2156 }
2157 END_OF_FUNC
2158
2159 #### Method: https
2160 # Return the value of HTTPS
2161 ####
2162 'https' => <<'END_OF_FUNC',
2163 sub https {
2164     local($^W)=0;
2165     my ($self,$parameter) = self_or_CGI(@_);
2166     return $ENV{HTTPS} unless $parameter;
2167     return $ENV{$parameter} if $parameter=~/^HTTPS/;
2168     return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
2169     my(@p);
2170     foreach (keys %ENV) {
2171         push(@p,$_) if /^HTTPS/;
2172     }
2173     return @p;
2174 }
2175 END_OF_FUNC
2176
2177 #### Method: protocol
2178 # Return the protocol (http or https currently)
2179 ####
2180 'protocol' => <<'END_OF_FUNC',
2181 sub protocol {
2182     local($^W)=0;
2183     my $self = shift;
2184     return 'https' if $self->https() eq 'ON';
2185     return 'https' if $self->server_port == 443;
2186     my $prot = $self->server_protocol;
2187     my($protocol,$version) = split('/',$prot);
2188     return "\L$protocol\E";
2189 }
2190 END_OF_FUNC
2191
2192 #### Method: remote_ident
2193 # Return the identity of the remote user
2194 # (but only if his host is running identd)
2195 ####
2196 'remote_ident' => <<'END_OF_FUNC',
2197 sub remote_ident {
2198     return $ENV{'REMOTE_IDENT'};
2199 }
2200 END_OF_FUNC
2201
2202
2203 #### Method: auth_type
2204 # Return the type of use verification/authorization in use, if any.
2205 ####
2206 'auth_type' => <<'END_OF_FUNC',
2207 sub auth_type {
2208     return $ENV{'AUTH_TYPE'};
2209 }
2210 END_OF_FUNC
2211
2212
2213 #### Method: remote_user
2214 # Return the authorization name used for user
2215 # verification.
2216 ####
2217 'remote_user' => <<'END_OF_FUNC',
2218 sub remote_user {
2219     return $ENV{'REMOTE_USER'};
2220 }
2221 END_OF_FUNC
2222
2223
2224 #### Method: user_name
2225 # Try to return the remote user's name by hook or by
2226 # crook
2227 ####
2228 'user_name' => <<'END_OF_FUNC',
2229 sub user_name {
2230     my ($self) = self_or_CGI(@_);
2231     return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
2232 }
2233 END_OF_FUNC
2234
2235 #### Method: nph
2236 # Set or return the NPH global flag
2237 ####
2238 'nph' => <<'END_OF_FUNC',
2239 sub nph {
2240     my ($self,$param) = self_or_CGI(@_);
2241     $CGI::nph = $param if defined($param);
2242     return $CGI::nph;
2243 }
2244 END_OF_FUNC
2245
2246 # -------------- really private subroutines -----------------
2247 'previous_or_default' => <<'END_OF_FUNC',
2248 sub previous_or_default {
2249     my($self,$name,$defaults,$override) = @_;
2250     my(%selected);
2251
2252     if (!$override && ($self->{'.fieldnames'}->{$name} ||
2253                        defined($self->param($name)) ) ) {
2254         grep($selected{$_}++,$self->param($name));
2255     } elsif (defined($defaults) && ref($defaults) &&
2256              (ref($defaults) eq 'ARRAY')) {
2257         grep($selected{$_}++,@{$defaults});
2258     } else {
2259         $selected{$defaults}++ if defined($defaults);
2260     }
2261
2262     return %selected;
2263 }
2264 END_OF_FUNC
2265
2266 'register_parameter' => <<'END_OF_FUNC',
2267 sub register_parameter {
2268     my($self,$param) = @_;
2269     $self->{'.parametersToAdd'}->{$param}++;
2270 }
2271 END_OF_FUNC
2272
2273 'get_fields' => <<'END_OF_FUNC',
2274 sub get_fields {
2275     my($self) = @_;
2276     return $self->hidden('-name'=>'.cgifields',
2277                          '-values'=>[keys %{$self->{'.parametersToAdd'}}],
2278                          '-override'=>1);
2279 }
2280 END_OF_FUNC
2281
2282 'read_from_cmdline' => <<'END_OF_FUNC',
2283 sub read_from_cmdline {
2284     require "shellwords.pl";
2285     my($input,@words);
2286     my($query_string);
2287     if (@ARGV) {
2288         $input = join(" ",@ARGV);
2289     } else {
2290         print STDERR "(offline mode: enter name=value pairs on standard input)\n";
2291         chomp(@lines = <>); # remove newlines
2292         $input = join(" ",@lines);
2293     }
2294
2295     # minimal handling of escape characters
2296     $input=~s/\\=/%3D/g;
2297     $input=~s/\\&/%26/g;
2298
2299     @words = &shellwords($input);
2300     if ("@words"=~/=/) {
2301         $query_string = join('&',@words);
2302     } else {
2303         $query_string = join('+',@words);
2304     }
2305     return $query_string;
2306 }
2307 END_OF_FUNC
2308
2309 #####
2310 # subroutine: read_multipart
2311 #
2312 # Read multipart data and store it into our parameters.
2313 # An interesting feature is that if any of the parts is a file, we
2314 # create a temporary file and open up a filehandle on it so that the
2315 # caller can read from it if necessary.
2316 #####
2317 'read_multipart' => <<'END_OF_FUNC',
2318 sub read_multipart {
2319     my($self,$boundary,$length) = @_;
2320     my($buffer) = $self->new_MultipartBuffer($boundary,$length);
2321     return unless $buffer;
2322     my(%header,$body);
2323     while (!$buffer->eof) {
2324         %header = $buffer->readHeader;
2325
2326         # In beta1 it was "Content-disposition".  In beta2 it's "Content-Disposition"
2327         # Sheesh.
2328         my($key) = $header{'Content-disposition'} ? 'Content-disposition' : 'Content-Disposition';
2329         my($param)= $header{$key}=~/ name="([^\"]*)"/;
2330
2331         # possible bug: our regular expression expects the filename= part to fall
2332         # at the end of the line.  Netscape doesn't escape quotation marks in file names!!!
2333         my($filename) = $header{$key}=~/ filename="(.*)"$/;
2334
2335         # add this parameter to our list
2336         $self->add_parameter($param);
2337
2338         # If no filename specified, then just read the data and assign it
2339         # to our parameter list.
2340         unless ($filename) {
2341             my($value) = $buffer->readBody;
2342             push(@{$self->{$param}},$value);
2343             next;
2344         }
2345
2346         # If we get here, then we are dealing with a potentially large
2347         # uploaded form.  Save the data to a temporary file, then open
2348         # the file for reading.
2349         my($tmpfile) = new TempFile;
2350         my $tmp = $tmpfile->as_string;
2351
2352         open (OUT,">$tmp") || die "CGI open of $tmpfile: $!\n";
2353         $CGI::DefaultClass->binmode(OUT) if $CGI::needs_binmode;
2354         chmod 0666,$tmp;    # make sure anyone can delete it.
2355         my $data;
2356         while ($data = $buffer->read) {
2357             print OUT $data;
2358         }
2359         close OUT;
2360
2361         # Now create a new filehandle in the caller's namespace.
2362         # The name of this filehandle just happens to be identical
2363         # to the original filename (NOT the name of the temporary
2364         # file, which is hidden!)
2365         my($filehandle);
2366         if ($filename=~/^[a-zA-Z_]/) {
2367             my($frame,$cp)=(1);
2368             do { $cp = caller($frame++); } until !eval("'$cp'->isaCGI()");
2369             $filehandle = "$cp\:\:$filename";
2370         } else {
2371             $filehandle = "\:\:$filename";
2372         }
2373
2374         open($filehandle,$tmp) || die "CGI open of $tmp: $!\n";
2375         $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2376
2377         push(@{$self->{$param}},$filename);
2378
2379         # Under Unix, it would be safe to let the temporary file
2380         # be deleted immediately.  However, I fear that other operating
2381         # systems are not so forgiving.  Therefore we save a reference
2382         # to the temporary file in the CGI object so that the file
2383         # isn't unlinked until the CGI object itself goes out of
2384         # scope.  This is a bit hacky, but it has the interesting side
2385         # effect that one can access the name of the tmpfile by
2386         # asking for $query->{$query->param('foo')}, where 'foo'
2387         # is the name of the file upload field.
2388         $self->{'.tmpfiles'}->{$filename}= {
2389             name=>$tmpfile,
2390             info=>{%header}
2391         }
2392     }
2393 }
2394 END_OF_FUNC
2395
2396 'tmpFileName' => <<'END_OF_FUNC',
2397 sub tmpFileName {
2398     my($self,$filename) = self_or_default(@_);
2399     return $self->{'.tmpfiles'}->{$filename}->{name}->as_string;
2400 }
2401 END_OF_FUNC
2402
2403 'uploadInfo' => <<'END_OF_FUNC'
2404 sub uploadInfo {
2405     my($self,$filename) = self_or_default(@_);
2406     return $self->{'.tmpfiles'}->{$filename}->{info};
2407 }
2408 END_OF_FUNC
2409
2410 );
2411 END_OF_AUTOLOAD
2412 ;
2413
2414 # Globals and stubs for other packages that we use
2415 package MultipartBuffer;
2416
2417 # how many bytes to read at a time.  We use
2418 # a 5K buffer by default.
2419 $FILLUNIT = 1024 * 5;
2420 $TIMEOUT = 10*60;       # 10 minute timeout
2421 $SPIN_LOOP_MAX = 1000;  # bug fix for some Netscape servers
2422 $CRLF=$CGI::CRLF;
2423
2424 #reuse the autoload function
2425 *MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
2426
2427 ###############################################################################
2428 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
2429 ###############################################################################
2430 $AUTOLOADED_ROUTINES = '';      # prevent -w error
2431 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
2432 %SUBS =  (
2433
2434 'new' => <<'END_OF_FUNC',
2435 sub new {
2436     my($package,$interface,$boundary,$length,$filehandle) = @_;
2437     my $IN;
2438     if ($filehandle) {
2439         my($package) = caller;
2440         # force into caller's package if necessary
2441         $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
2442     }
2443     $IN = "main::STDIN" unless $IN;
2444
2445     $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
2446
2447     # If the user types garbage into the file upload field,
2448     # then Netscape passes NOTHING to the server (not good).
2449     # We may hang on this read in that case. So we implement
2450     # a read timeout.  If nothing is ready to read
2451     # by then, we return.
2452
2453     # Netscape seems to be a little bit unreliable
2454     # about providing boundary strings.
2455     if ($boundary) {
2456
2457         # Under the MIME spec, the boundary consists of the
2458         # characters "--" PLUS the Boundary string
2459         $boundary = "--$boundary";
2460         # Read the topmost (boundary) line plus the CRLF
2461         my($null) = '';
2462         $length -= $interface->read_from_client($IN,\$null,length($boundary)+2,0);
2463
2464     } else { # otherwise we find it ourselves
2465         my($old);
2466         ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
2467         $boundary = <$IN>;      # BUG: This won't work correctly under mod_perl
2468         $length -= length($boundary);
2469         chomp($boundary);               # remove the CRLF
2470         $/ = $old;                      # restore old line separator
2471     }
2472
2473     my $self = {LENGTH=>$length,
2474                 BOUNDARY=>$boundary,
2475                 IN=>$IN,
2476                 INTERFACE=>$interface,
2477                 BUFFER=>'',
2478             };
2479
2480     $FILLUNIT = length($boundary)
2481         if length($boundary) > $FILLUNIT;
2482
2483     return bless $self,ref $package || $package;
2484 }
2485 END_OF_FUNC
2486
2487 'readHeader' => <<'END_OF_FUNC',
2488 sub readHeader {
2489     my($self) = @_;
2490     my($end);
2491     my($ok) = 0;
2492     do {
2493         $self->fillBuffer($FILLUNIT);
2494         $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
2495         $ok++ if $self->{BUFFER} eq '';
2496         $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
2497     } until $ok;
2498
2499     my($header) = substr($self->{BUFFER},0,$end+2);
2500     substr($self->{BUFFER},0,$end+4) = '';
2501     my %return;
2502     while ($header=~/^([\w-]+): (.*)$CRLF/mog) {
2503         $return{$1}=$2;
2504     }
2505     return %return;
2506 }
2507 END_OF_FUNC
2508
2509 # This reads and returns the body as a single scalar value.
2510 'readBody' => <<'END_OF_FUNC',
2511 sub readBody {
2512     my($self) = @_;
2513     my($data);
2514     my($returnval)='';
2515     while (defined($data = $self->read)) {
2516         $returnval .= $data;
2517     }
2518     return $returnval;
2519 }
2520 END_OF_FUNC
2521
2522 # This will read $bytes or until the boundary is hit, whichever happens
2523 # first.  After the boundary is hit, we return undef.  The next read will
2524 # skip over the boundary and begin reading again;
2525 'read' => <<'END_OF_FUNC',
2526 sub read {
2527     my($self,$bytes) = @_;
2528
2529     # default number of bytes to read
2530     $bytes = $bytes || $FILLUNIT;
2531
2532     # Fill up our internal buffer in such a way that the boundary
2533     # is never split between reads.
2534     $self->fillBuffer($bytes);
2535
2536     # Find the boundary in the buffer (it may not be there).
2537     my $start = index($self->{BUFFER},$self->{BOUNDARY});
2538
2539     # If the boundary begins the data, then skip past it
2540     # and return undef.  The +2 here is a fiendish plot to
2541     # remove the CR/LF pair at the end of the boundary.
2542     if ($start == 0) {
2543
2544         # clear us out completely if we've hit the last boundary.
2545         if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
2546             $self->{BUFFER}='';
2547             $self->{LENGTH}=0;
2548             return undef;
2549         }
2550
2551         # just remove the boundary.
2552         substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
2553         return undef;
2554     }
2555
2556     my $bytesToReturn;
2557     if ($start > 0) {           # read up to the boundary
2558         $bytesToReturn = $start > $bytes ? $bytes : $start;
2559     } else {    # read the requested number of bytes
2560         # leave enough bytes in the buffer to allow us to read
2561         # the boundary.  Thanks to Kevin Hendrick for finding
2562         # this one.
2563         $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
2564     }
2565
2566     my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
2567     substr($self->{BUFFER},0,$bytesToReturn)='';
2568
2569     # If we hit the boundary, remove the CRLF from the end.
2570     return ($start > 0) ? substr($returnval,0,-2) : $returnval;
2571 }
2572 END_OF_FUNC
2573
2574
2575 # This fills up our internal buffer in such a way that the
2576 # boundary is never split between reads
2577 'fillBuffer' => <<'END_OF_FUNC',
2578 sub fillBuffer {
2579     my($self,$bytes) = @_;
2580     return unless $self->{LENGTH};
2581
2582     my($boundaryLength) = length($self->{BOUNDARY});
2583     my($bufferLength) = length($self->{BUFFER});
2584     my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
2585     $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
2586
2587     # Try to read some data.  We may hang here if the browser is screwed up.
2588     my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN},
2589                                                          \$self->{BUFFER},
2590                                                          $bytesToRead,
2591                                                          $bufferLength);
2592
2593     # An apparent bug in the Netscape Commerce server causes the read()
2594     # to return zero bytes repeatedly without blocking if the
2595     # remote user aborts during a file transfer.  I don't know how
2596     # they manage this, but the workaround is to abort if we get
2597     # more than SPIN_LOOP_MAX consecutive zero reads.
2598     if ($bytesRead == 0) {
2599         die  "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
2600             if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
2601     } else {
2602         $self->{ZERO_LOOP_COUNTER}=0;
2603     }
2604
2605     $self->{LENGTH} -= $bytesRead;
2606 }
2607 END_OF_FUNC
2608
2609
2610 # Return true when we've finished reading
2611 'eof' => <<'END_OF_FUNC'
2612 sub eof {
2613     my($self) = @_;
2614     return 1 if (length($self->{BUFFER}) == 0)
2615                  && ($self->{LENGTH} <= 0);
2616     undef;
2617 }
2618 END_OF_FUNC
2619
2620 );
2621 END_OF_AUTOLOAD
2622
2623 ####################################################################################
2624 ################################## TEMPORARY FILES #################################
2625 ####################################################################################
2626 package TempFile;
2627
2628 $SL = $CGI::SL;
2629 unless ($TMPDIRECTORY) {
2630     @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp","${SL}tmp","${SL}temp","${SL}Temporary Items");
2631     foreach (@TEMP) {
2632         do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
2633     }
2634 }
2635
2636 $TMPDIRECTORY  = "." unless $TMPDIRECTORY;
2637 $SEQUENCE="CGItemp${$}0000";
2638
2639 # cute feature, but overload implementation broke it
2640 # %OVERLOAD = ('""'=>'as_string');
2641 *TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
2642
2643 ###############################################################################
2644 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
2645 ###############################################################################
2646 $AUTOLOADED_ROUTINES = '';      # prevent -w error
2647 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
2648 %SUBS = (
2649
2650 'new' => <<'END_OF_FUNC',
2651 sub new {
2652     my($package) = @_;
2653     $SEQUENCE++;
2654     my $directory = "${TMPDIRECTORY}${SL}${SEQUENCE}";
2655     return bless \$directory;
2656 }
2657 END_OF_FUNC
2658
2659 'DESTROY' => <<'END_OF_FUNC',
2660 sub DESTROY {
2661     my($self) = @_;
2662     unlink $$self;              # get rid of the file
2663 }
2664 END_OF_FUNC
2665
2666 'as_string' => <<'END_OF_FUNC'
2667 sub as_string {
2668     my($self) = @_;
2669     return $$self;
2670 }
2671 END_OF_FUNC
2672
2673 );
2674 END_OF_AUTOLOAD
2675
2676 package CGI;
2677
2678 # We get a whole bunch of warnings about "possibly uninitialized variables"
2679 # when running with the -w switch.  Touch them all once to get rid of the
2680 # warnings.  This is ugly and I hate it.
2681 if ($^W) {
2682     $CGI::CGI = '';
2683     $CGI::CGI=<<EOF;
2684     $CGI::VERSION;
2685     $MultipartBuffer::SPIN_LOOP_MAX;
2686     $MultipartBuffer::CRLF;
2687     $MultipartBuffer::TIMEOUT;
2688     $MultipartBuffer::FILLUNIT;
2689     $TempFile::SEQUENCE;
2690 EOF
2691     ;
2692 }
2693
2694 $revision;
2695
2696 __END__
2697
2698 =head1 NAME
2699
2700 CGI - Simple Common Gateway Interface Class
2701
2702 =head1 SYNOPSIS
2703
2704   use CGI;
2705   # the rest is too complicated for a synopsis; keep reading
2706
2707 =head1 ABSTRACT
2708
2709 This perl library uses perl5 objects to make it easy to create
2710 Web fill-out forms and parse their contents.  This package
2711 defines CGI objects, entities that contain the values of the
2712 current query string and other state variables.
2713 Using a CGI object's methods, you can examine keywords and parameters
2714 passed to your script, and create forms whose initial values
2715 are taken from the current query (thereby preserving state
2716 information).
2717
2718 The current version of CGI.pm is available at
2719
2720   http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
2721   ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
2722
2723 =head1 INSTALLATION:
2724
2725 To install this package, just change to the directory in which this
2726 file is found and type the following:
2727
2728         perl Makefile.PL
2729         make
2730         make install
2731
2732 This will copy CGI.pm to your perl library directory for use by all
2733 perl scripts.  You probably must be root to do this.   Now you can
2734 load the CGI routines in your Perl scripts with the line:
2735
2736         use CGI;
2737
2738 If you don't have sufficient privileges to install CGI.pm in the Perl
2739 library directory, you can put CGI.pm into some convenient spot, such
2740 as your home directory, or in cgi-bin itself and prefix all Perl
2741 scripts that call it with something along the lines of the following
2742 preamble:
2743
2744         use lib '/home/davis/lib';
2745         use CGI;
2746
2747 If you are using a version of perl earlier than 5.002 (such as NT perl), use
2748 this instead:
2749
2750         BEGIN {
2751                 unshift(@INC,'/home/davis/lib');
2752         }
2753         use CGI;
2754
2755 The CGI distribution also comes with a cute module called L<CGI::Carp>.
2756 It redefines the die(), warn(), confess() and croak() error routines
2757 so that they write nicely formatted error messages into the server's
2758 error log (or to the output stream of your choice).  This avoids long
2759 hours of groping through the error and access logs, trying to figure
2760 out which CGI script is generating  error messages.  If you choose,
2761 you can even have fatal error messages echoed to the browser to avoid
2762 the annoying and uninformative "Server Error" message.
2763
2764 =head1 DESCRIPTION
2765
2766 =head2 CREATING A NEW QUERY OBJECT:
2767
2768      $query = new CGI;
2769
2770 This will parse the input (from both POST and GET methods) and store
2771 it into a perl5 object called $query.
2772
2773 =head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
2774
2775      $query = new CGI(INPUTFILE);
2776
2777 If you provide a file handle to the new() method, it
2778 will read parameters from the file (or STDIN, or whatever).  The
2779 file can be in any of the forms describing below under debugging
2780 (i.e. a series of newline delimited TAG=VALUE pairs will work).
2781 Conveniently, this type of file is created by the save() method
2782 (see below).  Multiple records can be saved and restored.
2783
2784 Perl purists will be pleased to know that this syntax accepts
2785 references to file handles, or even references to filehandle globs,
2786 which is the "official" way to pass a filehandle:
2787
2788     $query = new CGI(\*STDIN);
2789
2790 You can also initialize the query object from an associative array
2791 reference:
2792
2793     $query = new CGI( {'dinosaur'=>'barney',
2794                        'song'=>'I love you',
2795                        'friends'=>[qw/Jessica George Nancy/]}
2796                     );
2797
2798 or from a properly formatted, URL-escaped query string:
2799
2800     $query = new CGI('dinosaur=barney&color=purple');
2801
2802 To create an empty query, initialize it from an empty string or hash:
2803
2804         $empty_query = new CGI("");
2805              -or-
2806         $empty_query = new CGI({});
2807
2808 =head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
2809
2810      @keywords = $query->keywords
2811
2812 If the script was invoked as the result of an <ISINDEX> search, the
2813 parsed keywords can be obtained as an array using the keywords() method.
2814
2815 =head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
2816
2817      @names = $query->param
2818
2819 If the script was invoked with a parameter list
2820 (e.g. "name1=value1&name2=value2&name3=value3"), the param()
2821 method will return the parameter names as a list.  If the
2822 script was invoked as an <ISINDEX> script, there will be a
2823 single parameter named 'keywords'.
2824
2825 NOTE: As of version 1.5, the array of parameter names returned will
2826 be in the same order as they were submitted by the browser.
2827 Usually this order is the same as the order in which the
2828 parameters are defined in the form (however, this isn't part
2829 of the spec, and so isn't guaranteed).
2830
2831 =head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
2832
2833     @values = $query->param('foo');
2834
2835               -or-
2836
2837     $value = $query->param('foo');
2838
2839 Pass the param() method a single argument to fetch the value of the
2840 named parameter. If the parameter is multivalued (e.g. from multiple
2841 selections in a scrolling list), you can ask to receive an array.  Otherwise
2842 the method will return a single value.
2843
2844 =head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
2845
2846     $query->param('foo','an','array','of','values');
2847
2848 This sets the value for the named parameter 'foo' to an array of
2849 values.  This is one way to change the value of a field AFTER
2850 the script has been invoked once before.  (Another way is with
2851 the -override parameter accepted by all methods that generate
2852 form elements.)
2853
2854 param() also recognizes a named parameter style of calling described
2855 in more detail later:
2856
2857     $query->param(-name=>'foo',-values=>['an','array','of','values']);
2858
2859                               -or-
2860
2861     $query->param(-name=>'foo',-value=>'the value');
2862
2863 =head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
2864
2865    $query->append(-name=>;'foo',-values=>['yet','more','values']);
2866
2867 This adds a value or list of values to the named parameter.  The
2868 values are appended to the end of the parameter if it already exists.
2869 Otherwise the parameter is created.  Note that this method only
2870 recognizes the named argument calling syntax.
2871
2872 =head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
2873
2874    $query->import_names('R');
2875
2876 This creates a series of variables in the 'R' namespace.  For example,
2877 $R::foo, @R:foo.  For keyword lists, a variable @R::keywords will appear.
2878 If no namespace is given, this method will assume 'Q'.
2879 WARNING:  don't import anything into 'main'; this is a major security
2880 risk!!!!
2881
2882 In older versions, this method was called B<import()>.  As of version 2.20,
2883 this name has been removed completely to avoid conflict with the built-in
2884 Perl module B<import> operator.
2885
2886 =head2 DELETING A PARAMETER COMPLETELY:
2887
2888     $query->delete('foo');
2889
2890 This completely clears a parameter.  It sometimes useful for
2891 resetting parameters that you don't want passed down between
2892 script invocations.
2893
2894 =head2 DELETING ALL PARAMETERS:
2895
2896 $query->delete_all();
2897
2898 This clears the CGI object completely.  It might be useful to ensure
2899 that all the defaults are taken when you create a fill-out form.
2900
2901 =head2 SAVING THE STATE OF THE FORM TO A FILE:
2902
2903     $query->save(FILEHANDLE)
2904
2905 This will write the current state of the form to the provided
2906 filehandle.  You can read it back in by providing a filehandle
2907 to the new() method.  Note that the filehandle can be a file, a pipe,
2908 or whatever!
2909
2910 The format of the saved file is:
2911
2912         NAME1=VALUE1
2913         NAME1=VALUE1'
2914         NAME2=VALUE2
2915         NAME3=VALUE3
2916         =
2917
2918 Both name and value are URL escaped.  Multi-valued CGI parameters are
2919 represented as repeated names.  A session record is delimited by a
2920 single = symbol.  You can write out multiple records and read them
2921 back in with several calls to B<new>.  You can do this across several
2922 sessions by opening the file in append mode, allowing you to create
2923 primitive guest books, or to keep a history of users' queries.  Here's
2924 a short example of creating multiple session records:
2925
2926    use CGI;
2927
2928    open (OUT,">>test.out") || die;
2929    $records = 5;
2930    foreach (0..$records) {
2931        my $q = new CGI;
2932        $q->param(-name=>'counter',-value=>$_);
2933        $q->save(OUT);
2934    }
2935    close OUT;
2936
2937    # reopen for reading
2938    open (IN,"test.out") || die;
2939    while (!eof(IN)) {
2940        my $q = new CGI(IN);
2941        print $q->param('counter'),"\n";
2942    }
2943
2944 The file format used for save/restore is identical to that used by the
2945 Whitehead Genome Center's data exchange format "Boulderio", and can be
2946 manipulated and even databased using Boulderio utilities.  See
2947
2948   http://www.genome.wi.mit.edu/genome_software/other/boulder.html
2949
2950 for further details.
2951
2952 =head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
2953
2954     $myself = $query->self_url;
2955     print "<A HREF=$myself>I'm talking to myself.</A>";
2956
2957 self_url() will return a URL, that, when selected, will reinvoke
2958 this script with all its state information intact.  This is most
2959 useful when you want to jump around within the document using
2960 internal anchors but you don't want to disrupt the current contents
2961 of the form(s).  Something like this will do the trick.
2962
2963      $myself = $query->self_url;
2964      print "<A HREF=$myself#table1>See table 1</A>";
2965      print "<A HREF=$myself#table2>See table 2</A>";
2966      print "<A HREF=$myself#yourself>See for yourself</A>";
2967
2968 If you don't want to get the whole query string, call
2969 the method url() to return just the URL for the script:
2970
2971     $myself = $query->url;
2972     print "<A HREF=$myself>No query string in this baby!</A>\n";
2973
2974 You can also retrieve the unprocessed query string with query_string():
2975
2976     $the_string = $query->query_string;
2977
2978 =head2 COMPATIBILITY WITH CGI-LIB.PL
2979
2980 To make it easier to port existing programs that use cgi-lib.pl
2981 the compatibility routine "ReadParse" is provided.  Porting is
2982 simple:
2983
2984 OLD VERSION
2985     require "cgi-lib.pl";
2986     &ReadParse;
2987     print "The value of the antique is $in{antique}.\n";
2988
2989 NEW VERSION
2990     use CGI;
2991     CGI::ReadParse
2992     print "The value of the antique is $in{antique}.\n";
2993
2994 CGI.pm's ReadParse() routine creates a tied variable named %in,
2995 which can be accessed to obtain the query variables.  Like
2996 ReadParse, you can also provide your own variable.  Infrequently
2997 used features of ReadParse, such as the creation of @in and $in
2998 variables, are not supported.
2999
3000 Once you use ReadParse, you can retrieve the query object itself
3001 this way:
3002
3003     $q = $in{CGI};
3004     print $q->textfield(-name=>'wow',
3005                         -value=>'does this really work?');
3006
3007 This allows you to start using the more interesting features
3008 of CGI.pm without rewriting your old scripts from scratch.
3009
3010 =head2 CALLING CGI FUNCTIONS THAT TAKE MULTIPLE ARGUMENTS
3011
3012 In versions of CGI.pm prior to 2.0, it could get difficult to remember
3013 the proper order of arguments in CGI function calls that accepted five
3014 or six different arguments.  As of 2.0, there's a better way to pass
3015 arguments to the various CGI functions.  In this style, you pass a
3016 series of name=>argument pairs, like this:
3017
3018    $field = $query->radio_group(-name=>'OS',
3019                                 -values=>[Unix,Windows,Macintosh],
3020                                 -default=>'Unix');
3021
3022 The advantages of this style are that you don't have to remember the
3023 exact order of the arguments, and if you leave out a parameter, in
3024 most cases it will default to some reasonable value.  If you provide
3025 a parameter that the method doesn't recognize, it will usually do
3026 something useful with it, such as incorporating it into the HTML form
3027 tag.  For example if Netscape decides next week to add a new
3028 JUSTIFICATION parameter to the text field tags, you can start using
3029 the feature without waiting for a new version of CGI.pm:
3030
3031    $field = $query->textfield(-name=>'State',
3032                               -default=>'gaseous',
3033                               -justification=>'RIGHT');
3034
3035 This will result in an HTML tag that looks like this:
3036
3037         <INPUT TYPE="textfield" NAME="State" VALUE="gaseous"
3038                JUSTIFICATION="RIGHT">
3039
3040 Parameter names are case insensitive: you can use -name, or -Name or
3041 -NAME.  You don't have to use the hyphen if you don't want to.  After
3042 creating a CGI object, call the B<use_named_parameters()> method with
3043 a nonzero value.  This will tell CGI.pm that you intend to use named
3044 parameters exclusively:
3045
3046    $query = new CGI;
3047    $query->use_named_parameters(1);
3048    $field = $query->radio_group('name'=>'OS',
3049                                 'values'=>['Unix','Windows','Macintosh'],
3050                                 'default'=>'Unix');
3051
3052 Actually, CGI.pm only looks for a hyphen in the first parameter.  So
3053 you can leave it off subsequent parameters if you like.  Something to
3054 be wary of is the potential that a string constant like "values" will
3055 collide with a keyword (and in fact it does!) While Perl usually
3056 figures out when you're referring to a function and when you're
3057 referring to a string, you probably should put quotation marks around
3058 all string constants just to play it safe.
3059
3060 =head2 CREATING THE HTTP HEADER:
3061
3062         print $query->header;
3063
3064              -or-
3065
3066         print $query->header('image/gif');
3067
3068              -or-
3069
3070         print $query->header('text/html','204 No response');
3071
3072              -or-
3073
3074         print $query->header(-type=>'image/gif',
3075                              -nph=>1,
3076                              -status=>'402 Payment required',
3077                              -expires=>'+3d',
3078                              -cookie=>$cookie,
3079                              -Cost=>'$2.00');
3080
3081 header() returns the Content-type: header.  You can provide your own
3082 MIME type if you choose, otherwise it defaults to text/html.  An
3083 optional second parameter specifies the status code and a human-readable
3084 message.  For example, you can specify 204, "No response" to create a
3085 script that tells the browser to do nothing at all.  If you want to
3086 add additional fields to the header, just tack them on to the end:
3087
3088     print $query->header('text/html','200 OK','Content-Length: 3002');
3089
3090 The last example shows the named argument style for passing arguments
3091 to the CGI methods using named parameters.  Recognized parameters are
3092 B<-type>, B<-status>, B<-expires>, and B<-cookie>.  Any other
3093 parameters will be stripped of their initial hyphens and turned into
3094 header fields, allowing you to specify any HTTP header you desire.
3095
3096 Most browsers will not cache the output from CGI scripts.  Every time
3097 the browser reloads the page, the script is invoked anew.  You can
3098 change this behavior with the B<-expires> parameter.  When you specify
3099 an absolute or relative expiration interval with this parameter, some
3100 browsers and proxy servers will cache the script's output until the
3101 indicated expiration date.  The following forms are all valid for the
3102 -expires field:
3103
3104         +30s                              30 seconds from now
3105         +10m                              ten minutes from now
3106         +1h                               one hour from now
3107         -1d                               yesterday (i.e. "ASAP!")
3108         now                               immediately
3109         +3M                               in three months
3110         +10y                              in ten years time
3111         Thursday, 25-Apr-96 00:40:33 GMT  at the indicated time & date
3112
3113 (CGI::expires() is the static function call used internally that turns
3114 relative time intervals into HTTP dates.  You can call it directly if
3115 you wish.)
3116
3117 The B<-cookie> parameter generates a header that tells the browser to provide
3118 a "magic cookie" during all subsequent transactions with your script.
3119 Netscape cookies have a special format that includes interesting attributes
3120 such as expiration time.  Use the cookie() method to create and retrieve
3121 session cookies.
3122
3123 The B<-nph> parameter, if set to a true value, will issue the correct
3124 headers to work with a NPH (no-parse-header) script.  This is important
3125 to use with certain servers, such as Microsoft Internet Explorer, which
3126 expect all their scripts to be NPH.
3127
3128 =head2 GENERATING A REDIRECTION INSTRUCTION
3129
3130    print $query->redirect('http://somewhere.else/in/movie/land');
3131
3132 redirects the browser elsewhere.  If you use redirection like this,
3133 you should B<not> print out a header as well.  As of version 2.0, we
3134 produce both the unofficial Location: header and the official URI:
3135 header.  This should satisfy most servers and browsers.
3136
3137 One hint I can offer is that relative links may not work correctly
3138 when when you generate a redirection to another document on your site.
3139 This is due to a well-intentioned optimization that some servers use.
3140 The solution to this is to use the full URL (including the http: part)
3141 of the document you are redirecting to.
3142
3143 You can use named parameters:
3144
3145     print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
3146                            -nph=>1);
3147
3148 The B<-nph> parameter, if set to a true value, will issue the correct
3149 headers to work with a NPH (no-parse-header) script.  This is important
3150 to use with certain servers, such as Microsoft Internet Explorer, which
3151 expect all their scripts to be NPH.
3152
3153
3154 =head2 CREATING THE HTML HEADER:
3155
3156    print $query->start_html(-title=>'Secrets of the Pyramids',
3157                             -author=>'fred@capricorn.org',
3158                             -base=>'true',
3159                             -target=>'_blank',
3160                             -meta=>{'keywords'=>'pharaoh secret mummy',
3161                                     'copyright'=>'copyright 1996 King Tut'},
3162                             -BGCOLOR=>'blue');
3163
3164    -or-
3165
3166    print $query->start_html('Secrets of the Pyramids',
3167                             'fred@capricorn.org','true',
3168                             'BGCOLOR="blue"');
3169
3170 This will return a canned HTML header and the opening <BODY> tag.
3171 All parameters are optional.   In the named parameter form, recognized
3172 parameters are -title, -author, -base, -xbase and -target (see below for the
3173 explanation).  Any additional parameters you provide, such as the
3174 Netscape unofficial BGCOLOR attribute, are added to the <BODY> tag.
3175
3176 The argument B<-xbase> allows you to provide an HREF for the <BASE> tag
3177 different from the current location, as in
3178
3179     -xbase=>"http://home.mcom.com/"
3180
3181 All relative links will be interpreted relative to this tag.
3182
3183 The argument B<-target> allows you to provide a default target frame
3184 for all the links and fill-out forms on the page.  See the Netscape
3185 documentation on frames for details of how to manipulate this.
3186
3187     -target=>"answer_window"
3188
3189 All relative links will be interpreted relative to this tag.
3190 You add arbitrary meta information to the header with the B<-meta>
3191 argument.  This argument expects a reference to an associative array
3192 containing name/value pairs of meta information.  These will be turned
3193 into a series of header <META> tags that look something like this:
3194
3195     <META NAME="keywords" CONTENT="pharaoh secret mummy">
3196     <META NAME="description" CONTENT="copyright 1996 King Tut">
3197
3198 There is no support for the HTTP-EQUIV type of <META> tag.  This is
3199 because you can modify the HTTP header directly with the B<header()>
3200 method.
3201
3202 JAVASCRIPTING: The B<-script>, B<-onLoad> and B<-onUnload> parameters
3203 are used to add Netscape JavaScript calls to your pages.  B<-script>
3204 should point to a block of text containing JavaScript function
3205 definitions.  This block will be placed within a <SCRIPT> block inside
3206 the HTML (not HTTP) header.  The block is placed in the header in
3207 order to give your page a fighting chance of having all its JavaScript
3208 functions in place even if the user presses the stop button before the
3209 page has loaded completely.  CGI.pm attempts to format the script in
3210 such a way that JavaScript-naive browsers will not choke on the code:
3211 unfortunately there are some browsers, such as Chimera for Unix, that
3212 get confused by it nevertheless.
3213
3214 The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
3215 code to execute when the page is respectively opened and closed by the
3216 browser.  Usually these parameters are calls to functions defined in the
3217 B<-script> field:
3218
3219       $query = new CGI;
3220       print $query->header;
3221       $JSCRIPT=<<END;
3222       // Ask a silly question
3223       function riddle_me_this() {
3224          var r = prompt("What walks on four legs in the morning, " +
3225                        "two legs in the afternoon, " +
3226                        "and three legs in the evening?");
3227          response(r);
3228       }
3229       // Get a silly answer
3230       function response(answer) {
3231          if (answer == "man")
3232             alert("Right you are!");
3233          else
3234             alert("Wrong!  Guess again.");
3235       }
3236       END
3237       print $query->start_html(-title=>'The Riddle of the Sphinx',
3238                                -script=>$JSCRIPT);
3239
3240 See
3241
3242    http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
3243
3244 for more information about JavaScript.
3245
3246 The old-style positional parameters are as follows:
3247
3248 =over 4
3249
3250 =item B<Parameters:>
3251
3252 =item 1.
3253
3254 The title
3255
3256 =item 2.
3257
3258 The author's e-mail address (will create a <LINK REV="MADE"> tag if present
3259
3260 =item 3.
3261
3262 A 'true' flag if you want to include a <BASE> tag in the header.  This
3263 helps resolve relative addresses to absolute ones when the document is moved,
3264 but makes the document hierarchy non-portable.  Use with care!
3265
3266 =item 4, 5, 6...
3267
3268 Any other parameters you want to include in the <BODY> tag.  This is a good
3269 place to put Netscape extensions, such as colors and wallpaper patterns.
3270
3271 =back
3272
3273 =head2 ENDING THE HTML DOCUMENT:
3274
3275         print $query->end_html
3276
3277 This ends an HTML document by printing the </BODY></HTML> tags.
3278
3279 =head1 CREATING FORMS:
3280
3281 I<General note>  The various form-creating methods all return strings
3282 to the caller, containing the tag or tags that will create the requested
3283 form element.  You are responsible for actually printing out these strings.
3284 It's set up this way so that you can place formatting tags
3285 around the form elements.
3286
3287 I<Another note> The default values that you specify for the forms are only
3288 used the B<first> time the script is invoked (when there is no query
3289 string).  On subsequent invocations of the script (when there is a query
3290 string), the former values are used even if they are blank.
3291
3292 If you want to change the value of a field from its previous value, you have two
3293 choices:
3294
3295 (1) call the param() method to set it.
3296
3297 (2) use the -override (alias -force) parameter (a new feature in version 2.15).
3298 This forces the default value to be used, regardless of the previous value:
3299
3300    print $query->textfield(-name=>'field_name',
3301                            -default=>'starting value',
3302                            -override=>1,
3303                            -size=>50,
3304                            -maxlength=>80);
3305
3306 I<Yet another note> By default, the text and labels of form elements are
3307 escaped according to HTML rules.  This means that you can safely use
3308 "<CLICK ME>" as the label for a button.  However, it also interferes with
3309 your ability to incorporate special HTML character sequences, such as &Aacute;,
3310 into your fields.  If you wish to turn off automatic escaping, call the
3311 autoEscape() method with a false value immediately after creating the CGI object:
3312
3313    $query = new CGI;
3314    $query->autoEscape(undef);
3315
3316
3317 =head2 CREATING AN ISINDEX TAG
3318
3319    print $query->isindex(-action=>$action);
3320
3321          -or-
3322
3323    print $query->isindex($action);
3324
3325 Prints out an <ISINDEX> tag.  Not very exciting.  The parameter
3326 -action specifies the URL of the script to process the query.  The
3327 default is to process the query with the current script.
3328
3329 =head2 STARTING AND ENDING A FORM
3330
3331     print $query->startform(-method=>$method,
3332                             -action=>$action,
3333                             -encoding=>$encoding);
3334       <... various form stuff ...>
3335     print $query->endform;
3336
3337         -or-
3338
3339     print $query->startform($method,$action,$encoding);
3340       <... various form stuff ...>
3341     print $query->endform;
3342
3343 startform() will return a <FORM> tag with the optional method,
3344 action and form encoding that you specify.  The defaults are:
3345
3346     method: POST
3347     action: this script
3348     encoding: application/x-www-form-urlencoded
3349
3350 endform() returns the closing </FORM> tag.
3351
3352 Startform()'s encoding method tells the browser how to package the various
3353 fields of the form before sending the form to the server.  Two
3354 values are possible:
3355
3356 =over 4
3357
3358 =item B<application/x-www-form-urlencoded>
3359
3360 This is the older type of encoding used by all browsers prior to
3361 Netscape 2.0.  It is compatible with many CGI scripts and is
3362 suitable for short fields containing text data.  For your
3363 convenience, CGI.pm stores the name of this encoding
3364 type in B<$CGI::URL_ENCODED>.
3365
3366 =item B<multipart/form-data>
3367
3368 This is the newer type of encoding introduced by Netscape 2.0.
3369 It is suitable for forms that contain very large fields or that
3370 are intended for transferring binary data.  Most importantly,
3371 it enables the "file upload" feature of Netscape 2.0 forms.  For
3372 your convenience, CGI.pm stores the name of this encoding type
3373 in B<$CGI::MULTIPART>
3374
3375 Forms that use this type of encoding are not easily interpreted
3376 by CGI scripts unless they use CGI.pm or another library designed
3377 to handle them.
3378
3379 =back
3380
3381 For compatibility, the startform() method uses the older form of
3382 encoding by default.  If you want to use the newer form of encoding
3383 by default, you can call B<start_multipart_form()> instead of
3384 B<startform()>.
3385
3386 JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
3387 for use with JavaScript.  The -name parameter gives the
3388 form a name so that it can be identified and manipulated by
3389 JavaScript functions.  -onSubmit should point to a JavaScript
3390 function that will be executed just before the form is submitted to your
3391 server.  You can use this opportunity to check the contents of the form
3392 for consistency and completeness.  If you find something wrong, you
3393 can put up an alert box or maybe fix things up yourself.  You can
3394 abort the submission by returning false from this function.
3395
3396 Usually the bulk of JavaScript functions are defined in a <SCRIPT>
3397 block in the HTML header and -onSubmit points to one of these function
3398 call.  See start_html() for details.
3399
3400 =head2 CREATING A TEXT FIELD
3401
3402     print $query->textfield(-name=>'field_name',
3403                             -default=>'starting value',
3404                             -size=>50,
3405                             -maxlength=>80);
3406         -or-
3407
3408     print $query->textfield('field_name','starting value',50,80);
3409
3410 textfield() will return a text input field.
3411
3412 =over 4
3413
3414 =item B<Parameters>
3415
3416 =item 1.
3417
3418 The first parameter is the required name for the field (-name).
3419
3420 =item 2.
3421
3422 The optional second parameter is the default starting value for the field
3423 contents (-default).
3424
3425 =item 3.
3426
3427 The optional third parameter is the size of the field in
3428       characters (-size).
3429
3430 =item 4.
3431
3432 The optional fourth parameter is the maximum number of characters the
3433       field will accept (-maxlength).
3434
3435 =back
3436
3437 As with all these methods, the field will be initialized with its
3438 previous contents from earlier invocations of the script.
3439 When the form is processed, the value of the text field can be
3440 retrieved with:
3441
3442        $value = $query->param('foo');
3443
3444 If you want to reset it from its initial value after the script has been
3445 called once, you can do so like this:
3446
3447        $query->param('foo',"I'm taking over this value!");
3448
3449 NEW AS OF VERSION 2.15: If you don't want the field to take on its previous
3450 value, you can force its current value by using the -override (alias -force)
3451 parameter:
3452
3453     print $query->textfield(-name=>'field_name',
3454                             -default=>'starting value',
3455                             -override=>1,
3456                             -size=>50,
3457                             -maxlength=>80);
3458
3459 JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>, B<-onBlur>
3460 and B<-onSelect> parameters to register JavaScript event handlers.
3461 The onChange handler will be called whenever the user changes the
3462 contents of the text field.  You can do text validation if you like.
3463 onFocus and onBlur are called respectively when the insertion point
3464 moves into and out of the text field.  onSelect is called when the
3465 user changes the portion of the text that is selected.
3466
3467 =head2 CREATING A BIG TEXT FIELD
3468
3469    print $query->textarea(-name=>'foo',
3470                           -default=>'starting value',
3471                           -rows=>10,
3472                           -columns=>50);
3473
3474         -or
3475
3476    print $query->textarea('foo','starting value',10,50);
3477
3478 textarea() is just like textfield, but it allows you to specify
3479 rows and columns for a multiline text entry box.  You can provide
3480 a starting value for the field, which can be long and contain
3481 multiple lines.
3482
3483 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
3484 and B<-onSelect> parameters are recognized.  See textfield().
3485
3486 =head2 CREATING A PASSWORD FIELD
3487
3488    print $query->password_field(-name=>'secret',
3489                                 -value=>'starting value',
3490                                 -size=>50,
3491                                 -maxlength=>80);
3492         -or-
3493
3494    print $query->password_field('secret','starting value',50,80);
3495
3496 password_field() is identical to textfield(), except that its contents
3497 will be starred out on the web page.
3498
3499 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
3500 and B<-onSelect> parameters are recognized.  See textfield().
3501
3502 =head2 CREATING A FILE UPLOAD FIELD
3503
3504     print $query->filefield(-name=>'uploaded_file',
3505                             -default=>'starting value',
3506                             -size=>50,
3507                             -maxlength=>80);
3508         -or-
3509
3510     print $query->filefield('uploaded_file','starting value',50,80);
3511
3512 filefield() will return a file upload field for Netscape 2.0 browsers.
3513 In order to take full advantage of this I<you must use the new
3514 multipart encoding scheme> for the form.  You can do this either
3515 by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>,
3516 or by calling the new method B<start_multipart_form()> instead of
3517 vanilla B<startform()>.
3518
3519 =over 4
3520
3521 =item B<Parameters>
3522
3523 =item 1.
3524
3525 The first parameter is the required name for the field (-name).
3526
3527 =item 2.
3528
3529 The optional second parameter is the starting value for the field contents
3530 to be used as the default file name (-default).
3531
3532 The beta2 version of Netscape 2.0 currently doesn't pay any attention
3533 to this field, and so the starting value will always be blank.  Worse,
3534 the field loses its "sticky" behavior and forgets its previous
3535 contents.  The starting value field is called for in the HTML
3536 specification, however, and possibly later versions of Netscape will
3537 honor it.
3538
3539 =item 3.
3540
3541 The optional third parameter is the size of the field in
3542 characters (-size).
3543
3544 =item 4.
3545
3546 The optional fourth parameter is the maximum number of characters the
3547 field will accept (-maxlength).
3548
3549 =back
3550
3551 When the form is processed, you can retrieve the entered filename
3552 by calling param().
3553
3554        $filename = $query->param('uploaded_file');
3555
3556 In Netscape Gold, the filename that gets returned is the full local filename
3557 on the B<remote user's> machine.  If the remote user is on a Unix
3558 machine, the filename will follow Unix conventions:
3559
3560         /path/to/the/file
3561
3562 On an MS-DOS/Windows and OS/2 machines, the filename will follow DOS conventions:
3563
3564         C:\PATH\TO\THE\FILE.MSW
3565
3566 On a Macintosh machine, the filename will follow Mac conventions:
3567
3568         HD 40:Desktop Folder:Sort Through:Reminders
3569
3570 The filename returned is also a file handle.  You can read the contents
3571 of the file using standard Perl file reading calls:
3572
3573         # Read a text file and print it out
3574         while (<$filename>) {
3575            print;
3576         }
3577
3578         # Copy a binary file to somewhere safe
3579         open (OUTFILE,">>/usr/local/web/users/feedback");
3580         while ($bytesread=read($filename,$buffer,1024)) {
3581            print OUTFILE $buffer;
3582         }
3583
3584 When a file is uploaded the browser usually sends along some
3585 information along with it in the format of headers.  The information
3586 usually includes the MIME content type.  Future browsers may send
3587 other information as well (such as modification date and size). To
3588 retrieve this information, call uploadInfo().  It returns a reference to
3589 an associative array containing all the document headers.
3590
3591        $filename = $query->param('uploaded_file');
3592        $type = $query->uploadInfo($filename)->{'Content-Type'};
3593        unless ($type eq 'text/html') {
3594           die "HTML FILES ONLY!";
3595        }
3596
3597 If you are using a machine that recognizes "text" and "binary" data
3598 modes, be sure to understand when and how to use them (see the Camel book).
3599 Otherwise you may find that binary files are corrupted during file uploads.
3600
3601 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
3602 and B<-onSelect> parameters are recognized.  See textfield()
3603 for details.
3604
3605 =head2 CREATING A POPUP MENU
3606
3607    print $query->popup_menu('menu_name',
3608                             ['eenie','meenie','minie'],
3609                             'meenie');
3610
3611       -or-
3612
3613    %labels = ('eenie'=>'your first choice',
3614               'meenie'=>'your second choice',
3615               'minie'=>'your third choice');
3616    print $query->popup_menu('menu_name',
3617                             ['eenie','meenie','minie'],
3618                             'meenie',\%labels);
3619
3620         -or (named parameter style)-
3621
3622    print $query->popup_menu(-name=>'menu_name',
3623                             -values=>['eenie','meenie','minie'],
3624                             -default=>'meenie',
3625                             -labels=>\%labels);
3626
3627 popup_menu() creates a menu.
3628
3629 =over 4
3630
3631 =item 1.
3632
3633 The required first argument is the menu's name (-name).
3634
3635 =item 2.
3636
3637 The required second argument (-values) is an array B<reference>
3638 containing the list of menu items in the menu.  You can pass the
3639 method an anonymous array, as shown in the example, or a reference to
3640 a named array, such as "\@foo".
3641
3642 =item 3.
3643
3644 The optional third parameter (-default) is the name of the default
3645 menu choice.  If not specified, the first item will be the default.
3646 The values of the previous choice will be maintained across queries.
3647
3648 =item 4.
3649
3650 The optional fourth parameter (-labels) is provided for people who
3651 want to use different values for the user-visible label inside the
3652 popup menu nd the value returned to your script.  It's a pointer to an
3653 associative array relating menu values to user-visible labels.  If you
3654 leave this parameter blank, the menu values will be displayed by
3655 default.  (You can also leave a label undefined if you want to).
3656
3657 =back
3658
3659 When the form is processed, the selected value of the popup menu can
3660 be retrieved using:
3661
3662       $popup_menu_value = $query->param('menu_name');
3663
3664 JAVASCRIPTING: popup_menu() recognizes the following event handlers:
3665 B<-onChange>, B<-onFocus>, and B<-onBlur>.  See the textfield()
3666 section for details on when these handlers are called.
3667
3668 =head2 CREATING A SCROLLING LIST
3669
3670    print $query->scrolling_list('list_name',
3671                                 ['eenie','meenie','minie','moe'],
3672                                 ['eenie','moe'],5,'true');
3673       -or-
3674
3675    print $query->scrolling_list('list_name',
3676                                 ['eenie','meenie','minie','moe'],
3677                                 ['eenie','moe'],5,'true',
3678                                 \%labels);
3679
3680         -or-
3681
3682    print $query->scrolling_list(-name=>'list_name',
3683                                 -values=>['eenie','meenie','minie','moe'],
3684                                 -default=>['eenie','moe'],
3685                                 -size=>5,
3686                                 -multiple=>'true',
3687                                 -labels=>\%labels);
3688
3689 scrolling_list() creates a scrolling list.
3690
3691 =over 4
3692
3693 =item B<Parameters:>
3694
3695 =item 1.
3696
3697 The first and second arguments are the list name (-name) and values
3698 (-values).  As in the popup menu, the second argument should be an
3699 array reference.
3700
3701 =item 2.
3702
3703 The optional third argument (-default) can be either a reference to a
3704 list containing the values to be selected by default, or can be a
3705 single value to select.  If this argument is missing or undefined,
3706 then nothing is selected when the list first appears.  In the named
3707 parameter version, you can use the synonym "-defaults" for this
3708 parameter.
3709
3710 =item 3.
3711
3712 The optional fourth argument is the size of the list (-size).
3713
3714 =item 4.
3715
3716 The optional fifth argument can be set to true to allow multiple
3717 simultaneous selections (-multiple).  Otherwise only one selection
3718 will be allowed at a time.
3719
3720 =item 5.
3721
3722 The optional sixth argument is a pointer to an associative array
3723 containing long user-visible labels for the list items (-labels).
3724 If not provided, the values will be displayed.
3725
3726 When this form is processed, all selected list items will be returned as
3727 a list under the parameter name 'list_name'.  The values of the
3728 selected items can be retrieved with:
3729
3730       @selected = $query->param('list_name');
3731
3732 =back
3733
3734 JAVASCRIPTING: scrolling_list() recognizes the following event handlers:
3735 B<-onChange>, B<-onFocus>, and B<-onBlur>.  See textfield() for
3736 the description of when these handlers are called.
3737
3738 =head2 CREATING A GROUP OF RELATED CHECKBOXES
3739
3740    print $query->checkbox_group(-name=>'group_name',
3741                                 -values=>['eenie','meenie','minie','moe'],
3742                                 -default=>['eenie','moe'],
3743                                 -linebreak=>'true',
3744                                 -labels=>\%labels);
3745
3746    print $query->checkbox_group('group_name',
3747                                 ['eenie','meenie','minie','moe'],
3748                                 ['eenie','moe'],'true',\%labels);
3749
3750    HTML3-COMPATIBLE BROWSERS ONLY:
3751
3752    print $query->checkbox_group(-name=>'group_name',
3753                                 -values=>['eenie','meenie','minie','moe'],
3754                                 -rows=2,-columns=>2);
3755
3756
3757 checkbox_group() creates a list of checkboxes that are related
3758 by the same name.
3759
3760 =over 4
3761
3762 =item B<Parameters:>
3763
3764 =item 1.
3765
3766 The first and second arguments are the checkbox name and values,
3767 respectively (-name and -values).  As in the popup menu, the second
3768 argument should be an array reference.  These values are used for the
3769 user-readable labels printed next to the checkboxes as well as for the
3770 values passed to your script in the query string.
3771
3772 =item 2.
3773
3774 The optional third argument (-default) can be either a reference to a
3775 list containing the values to be checked by default, or can be a
3776 single value to checked.  If this argument is missing or undefined,
3777 then nothing is selected when the list first appears.
3778
3779 =item 3.
3780
3781 The optional fourth argument (-linebreak) can be set to true to place
3782 line breaks between the checkboxes so that they appear as a vertical
3783 list.  Otherwise, they will be strung together on a horizontal line.
3784
3785 =item 4.
3786
3787 The optional fifth argument is a pointer to an associative array
3788 relating the checkbox values to the user-visible labels that will will
3789 be printed next to them (-labels).  If not provided, the values will
3790 be used as the default.
3791
3792 =item 5.
3793
3794 B<HTML3-compatible browsers> (such as Netscape) can take advantage
3795 of the optional
3796 parameters B<-rows>, and B<-columns>.  These parameters cause
3797 checkbox_group() to return an HTML3 compatible table containing
3798 the checkbox group formatted with the specified number of rows
3799 and columns.  You can provide just the -columns parameter if you
3800 wish; checkbox_group will calculate the correct number of rows
3801 for you.
3802
3803 To include row and column headings in the returned table, you
3804 can use the B<-rowheader> and B<-colheader> parameters.  Both
3805 of these accept a pointer to an array of headings to use.
3806 The headings are just decorative.  They don't reorganize the
3807 interpretation of the checkboxes -- they're still a single named
3808 unit.
3809
3810 =back
3811
3812 When the form is processed, all checked boxes will be returned as
3813 a list under the parameter name 'group_name'.  The values of the
3814 "on" checkboxes can be retrieved with:
3815
3816       @turned_on = $query->param('group_name');
3817
3818 The value returned by checkbox_group() is actually an array of button
3819 elements.  You can capture them and use them within tables, lists,
3820 or in other creative ways:
3821
3822     @h = $query->checkbox_group(-name=>'group_name',-values=>\@values);
3823     &use_in_creative_way(@h);
3824
3825 JAVASCRIPTING: checkbox_group() recognizes the B<-onClick>
3826 parameter.  This specifies a JavaScript code fragment or
3827 function call to be executed every time the user clicks on
3828 any of the buttons in the group.  You can retrieve the identity
3829 of the particular button clicked on using the "this" variable.
3830
3831 =head2 CREATING A STANDALONE CHECKBOX
3832
3833     print $query->checkbox(-name=>'checkbox_name',
3834                            -checked=>'checked',
3835                            -value=>'ON',
3836                            -label=>'CLICK ME');
3837
3838         -or-
3839
3840     print $query->checkbox('checkbox_name','checked','ON','CLICK ME');
3841
3842 checkbox() is used to create an isolated checkbox that isn't logically
3843 related to any others.
3844
3845 =over 4
3846
3847 =item B<Parameters:>
3848
3849 =item 1.
3850
3851 The first parameter is the required name for the checkbox (-name).  It
3852 will also be used for the user-readable label printed next to the
3853 checkbox.
3854
3855 =item 2.
3856
3857 The optional second parameter (-checked) specifies that the checkbox
3858 is turned on by default.  Synonyms are -selected and -on.
3859
3860 =item 3.
3861
3862 The optional third parameter (-value) specifies the value of the
3863 checkbox when it is checked.  If not provided, the word "on" is
3864 assumed.
3865
3866 =item 4.
3867
3868 The optional fourth parameter (-label) is the user-readable label to
3869 be attached to the checkbox.  If not provided, the checkbox name is
3870 used.
3871
3872 =back
3873
3874 The value of the checkbox can be retrieved using:
3875
3876     $turned_on = $query->param('checkbox_name');
3877
3878 JAVASCRIPTING: checkbox() recognizes the B<-onClick>
3879 parameter.  See checkbox_group() for further details.
3880
3881 =head2 CREATING A RADIO BUTTON GROUP
3882
3883    print $query->radio_group(-name=>'group_name',
3884                              -values=>['eenie','meenie','minie'],
3885                              -default=>'meenie',
3886                              -linebreak=>'true',
3887                              -labels=>\%labels);
3888
3889         -or-
3890
3891    print $query->radio_group('group_name',['eenie','meenie','minie'],
3892                                           'meenie','true',\%labels);
3893
3894
3895    HTML3-COMPATIBLE BROWSERS ONLY:
3896
3897    print $query->radio_group(-name=>'group_name',
3898                              -values=>['eenie','meenie','minie','moe'],
3899                              -rows=2,-columns=>2);
3900
3901 radio_group() creates a set of logically-related radio buttons
3902 (turning one member of the group on turns the others off)
3903
3904 =over 4
3905
3906 =item B<Parameters:>
3907
3908 =item 1.
3909
3910 The first argument is the name of the group and is required (-name).
3911
3912 =item 2.
3913
3914 The second argument (-values) is the list of values for the radio
3915 buttons.  The values and the labels that appear on the page are
3916 identical.  Pass an array I<reference> in the second argument, either
3917 using an anonymous array, as shown, or by referencing a named array as
3918 in "\@foo".
3919
3920 =item 3.
3921
3922 The optional third parameter (-default) is the name of the default
3923 button to turn on. If not specified, the first item will be the
3924 default.  You can provide a nonexistent button name, such as "-" to
3925 start up with no buttons selected.
3926
3927 =item 4.
3928
3929 The optional fourth parameter (-linebreak) can be set to 'true' to put
3930 line breaks between the buttons, creating a vertical list.
3931
3932 =item 5.
3933
3934 The optional fifth parameter (-labels) is a pointer to an associative
3935 array relating the radio button values to user-visible labels to be
3936 used in the display.  If not provided, the values themselves are
3937 displayed.
3938
3939 =item 6.
3940
3941 B<HTML3-compatible browsers> (such as Netscape) can take advantage
3942 of the optional
3943 parameters B<-rows>, and B<-columns>.  These parameters cause
3944 radio_group() to return an HTML3 compatible table containing
3945 the radio group formatted with the specified number of rows
3946 and columns.  You can provide just the -columns parameter if you
3947 wish; radio_group will calculate the correct number of rows
3948 for you.
3949
3950 To include row and column headings in the returned table, you
3951 can use the B<-rowheader> and B<-colheader> parameters.  Both
3952 of these accept a pointer to an array of headings to use.
3953 The headings are just decorative.  They don't reorganize the
3954 interpetation of the radio buttons -- they're still a single named
3955 unit.
3956
3957 =back
3958
3959 When the form is processed, the selected radio button can
3960 be retrieved using:
3961
3962       $which_radio_button = $query->param('group_name');
3963
3964 The value returned by radio_group() is actually an array of button
3965 elements.  You can capture them and use them within tables, lists,
3966 or in other creative ways:
3967
3968     @h = $query->radio_group(-name=>'group_name',-values=>\@values);
3969     &use_in_creative_way(@h);
3970
3971 =head2 CREATING A SUBMIT BUTTON
3972
3973    print $query->submit(-name=>'button_name',
3974                         -value=>'value');
3975
3976         -or-
3977
3978    print $query->submit('button_name','value');
3979
3980 submit() will create the query submission button.  Every form
3981 should have one of these.
3982
3983 =over 4
3984
3985 =item B<Parameters:>
3986
3987 =item 1.
3988
3989 The first argument (-name) is optional.  You can give the button a
3990 name if you have several submission buttons in your form and you want
3991 to distinguish between them.  The name will also be used as the
3992 user-visible label.  Be aware that a few older browsers don't deal with this correctly and
3993 B<never> send back a value from a button.
3994
3995 =item 2.
3996
3997 The second argument (-value) is also optional.  This gives the button
3998 a value that will be passed to your script in the query string.
3999
4000 =back
4001
4002 You can figure out which button was pressed by using different
4003 values for each one:
4004
4005      $which_one = $query->param('button_name');
4006
4007 JAVASCRIPTING: radio_group() recognizes the B<-onClick>
4008 parameter.  See checkbox_group() for further details.
4009
4010 =head2 CREATING A RESET BUTTON
4011
4012    print $query->reset
4013
4014 reset() creates the "reset" button.  Note that it restores the
4015 form to its value from the last time the script was called,
4016 NOT necessarily to the defaults.
4017
4018 =head2 CREATING A DEFAULT BUTTON
4019
4020    print $query->defaults('button_label')
4021
4022 defaults() creates a button that, when invoked, will cause the
4023 form to be completely reset to its defaults, wiping out all the
4024 changes the user ever made.
4025
4026 =head2 CREATING A HIDDEN FIELD
4027
4028         print $query->hidden(-name=>'hidden_name',
4029                              -default=>['value1','value2'...]);
4030
4031                 -or-
4032
4033         print $query->hidden('hidden_name','value1','value2'...);
4034
4035 hidden() produces a text field that can't be seen by the user.  It
4036 is useful for passing state variable information from one invocation
4037 of the script to the next.
4038
4039 =over 4
4040
4041 =item B<Parameters:>
4042
4043 =item 1.
4044
4045 The first argument is required and specifies the name of this
4046 field (-name).
4047
4048 =item 2.
4049
4050 The second argument is also required and specifies its value
4051 (-default).  In the named parameter style of calling, you can provide
4052 a single value here or a reference to a whole list
4053
4054 =back
4055
4056 Fetch the value of a hidden field this way:
4057
4058      $hidden_value = $query->param('hidden_name');
4059
4060 Note, that just like all the other form elements, the value of a
4061 hidden field is "sticky".  If you want to replace a hidden field with
4062 some other values after the script has been called once you'll have to
4063 do it manually:
4064
4065      $query->param('hidden_name','new','values','here');
4066
4067 =head2 CREATING A CLICKABLE IMAGE BUTTON
4068
4069      print $query->image_button(-name=>'button_name',
4070                                 -src=>'/source/URL',
4071                                 -align=>'MIDDLE');
4072
4073         -or-
4074
4075      print $query->image_button('button_name','/source/URL','MIDDLE');
4076
4077 image_button() produces a clickable image.  When it's clicked on the
4078 position of the click is returned to your script as "button_name.x"
4079 and "button_name.y", where "button_name" is the name you've assigned
4080 to it.
4081
4082 JAVASCRIPTING: image_button() recognizes the B<-onClick>
4083 parameter.  See checkbox_group() for further details.
4084
4085 =over 4
4086
4087 =item B<Parameters:>
4088
4089 =item 1.
4090
4091 The first argument (-name) is required and specifies the name of this
4092 field.
4093
4094 =item 2.
4095
4096 The second argument (-src) is also required and specifies the URL
4097
4098 =item 3.
4099 The third option (-align, optional) is an alignment type, and may be
4100 TOP, BOTTOM or MIDDLE
4101
4102 =back
4103
4104 Fetch the value of the button this way:
4105      $x = $query->param('button_name.x');
4106      $y = $query->param('button_name.y');
4107
4108 =head2 CREATING A JAVASCRIPT ACTION BUTTON
4109
4110      print $query->button(-name=>'button_name',
4111                           -value=>'user visible label',
4112                           -onClick=>"do_something()");
4113
4114         -or-
4115
4116      print $query->button('button_name',"do_something()");
4117
4118 button() produces a button that is compatible with Netscape 2.0's
4119 JavaScript.  When it's pressed the fragment of JavaScript code
4120 pointed to by the B<-onClick> parameter will be executed.  On
4121 non-Netscape browsers this form element will probably not even
4122 display.
4123
4124 =head1 NETSCAPE COOKIES
4125
4126 Netscape browsers versions 1.1 and higher support a so-called
4127 "cookie" designed to help maintain state within a browser session.
4128 CGI.pm has several methods that support cookies.
4129
4130 A cookie is a name=value pair much like the named parameters in a CGI
4131 query string.  CGI scripts create one or more cookies and send
4132 them to the browser in the HTTP header.  The browser maintains a list
4133 of cookies that belong to a particular Web server, and returns them
4134 to the CGI script during subsequent interactions.
4135
4136 In addition to the required name=value pair, each cookie has several
4137 optional attributes:
4138
4139 =over 4
4140
4141 =item 1. an expiration time
4142
4143 This is a time/date string (in a special GMT format) that indicates
4144 when a cookie expires.  The cookie will be saved and returned to your
4145 script until this expiration date is reached if the user exits
4146 Netscape and restarts it.  If an expiration date isn't specified, the cookie
4147 will remain active until the user quits Netscape.
4148
4149 =item 2. a domain
4150
4151 This is a partial or complete domain name for which the cookie is
4152 valid.  The browser will return the cookie to any host that matches
4153 the partial domain name.  For example, if you specify a domain name
4154 of ".capricorn.com", then Netscape will return the cookie to
4155 Web servers running on any of the machines "www.capricorn.com",
4156 "www2.capricorn.com", "feckless.capricorn.com", etc.  Domain names
4157 must contain at least two periods to prevent attempts to match
4158 on top level domains like ".edu".  If no domain is specified, then
4159 the browser will only return the cookie to servers on the host the
4160 cookie originated from.
4161
4162 =item 3. a path
4163
4164 If you provide a cookie path attribute, the browser will check it
4165 against your script's URL before returning the cookie.  For example,
4166 if you specify the path "/cgi-bin", then the cookie will be returned
4167 to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
4168 and "/cgi-bin/customer_service/complain.pl", but not to the script
4169 "/cgi-private/site_admin.pl".  By default, path is set to "/", which
4170 causes the cookie to be sent to any CGI script on your site.
4171
4172 =item 4. a "secure" flag
4173
4174 If the "secure" attribute is set, the cookie will only be sent to your
4175 script if the CGI request is occurring on a secure channel, such as SSL.
4176
4177 =back
4178
4179 The interface to Netscape cookies is the B<cookie()> method:
4180
4181     $cookie = $query->cookie(-name=>'sessionID',
4182                              -value=>'xyzzy',
4183                              -expires=>'+1h',
4184                              -path=>'/cgi-bin/database',
4185                              -domain=>'.capricorn.org',
4186                              -secure=>1);
4187     print $query->header(-cookie=>$cookie);
4188
4189 B<cookie()> creates a new cookie.  Its parameters include:
4190
4191 =over 4
4192
4193 =item B<-name>
4194
4195 The name of the cookie (required).  This can be any string at all.
4196 Although Netscape limits its cookie names to non-whitespace
4197 alphanumeric characters, CGI.pm removes this restriction by escaping
4198 and unescaping cookies behind the scenes.
4199
4200 =item B<-value>
4201
4202 The value of the cookie.  This can be any scalar value,
4203 array reference, or even associative array reference.  For example,
4204 you can store an entire associative array into a cookie this way:
4205
4206         $cookie=$query->cookie(-name=>'family information',
4207                                -value=>\%childrens_ages);
4208
4209 =item B<-path>
4210
4211 The optional partial path for which this cookie will be valid, as described
4212 above.
4213
4214 =item B<-domain>
4215
4216 The optional partial domain for which this cookie will be valid, as described
4217 above.
4218
4219 =item B<-expires>
4220
4221 The optional expiration date for this cookie.  The format is as described
4222 in the section on the B<header()> method:
4223
4224         "+1h"  one hour from now
4225
4226 =item B<-secure>
4227
4228 If set to true, this cookie will only be used within a secure
4229 SSL session.
4230
4231 =back
4232
4233 The cookie created by cookie() must be incorporated into the HTTP
4234 header within the string returned by the header() method:
4235
4236         print $query->header(-cookie=>$my_cookie);
4237
4238 To create multiple cookies, give header() an array reference:
4239
4240         $cookie1 = $query->cookie(-name=>'riddle_name',
4241                                   -value=>"The Sphynx's Question");
4242         $cookie2 = $query->cookie(-name=>'answers',
4243                                   -value=>\%answers);
4244         print $query->header(-cookie=>[$cookie1,$cookie2]);
4245
4246 To retrieve a cookie, request it by name by calling cookie()
4247 method without the B<-value> parameter:
4248
4249         use CGI;
4250         $query = new CGI;
4251         %answers = $query->cookie(-name=>'answers');
4252         # $query->cookie('answers') will work too!
4253
4254 The cookie and CGI namespaces are separate.  If you have a parameter
4255 named 'answers' and a cookie named 'answers', the values retrieved by
4256 param() and cookie() are independent of each other.  However, it's
4257 simple to turn a CGI parameter into a cookie, and vice-versa:
4258
4259    # turn a CGI parameter into a cookie
4260    $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]);
4261    # vice-versa
4262    $q->param(-name=>'answers',-value=>[$q->cookie('answers')]);
4263
4264 See the B<cookie.cgi> example script for some ideas on how to use
4265 cookies effectively.
4266
4267 B<NOTE:> There appear to be some (undocumented) restrictions on
4268 Netscape cookies.  In Netscape 2.01, at least, I haven't been able to
4269 set more than three cookies at a time.  There may also be limits on
4270 the length of cookies.  If you need to store a lot of information,
4271 it's probably better to create a unique session ID, store it in a
4272 cookie, and use the session ID to locate an external file/database
4273 saved on the server's side of the connection.
4274
4275 =head1 WORKING WITH NETSCAPE FRAMES
4276
4277 It's possible for CGI.pm scripts to write into several browser
4278 panels and windows using Netscape's frame mechanism.
4279 There are three techniques for defining new frames programmatically:
4280
4281 =over 4
4282
4283 =item 1. Create a <Frameset> document
4284
4285 After writing out the HTTP header, instead of creating a standard
4286 HTML document using the start_html() call, create a <FRAMESET>
4287 document that defines the frames on the page.  Specify your script(s)
4288 (with appropriate parameters) as the SRC for each of the frames.
4289
4290 There is no specific support for creating <FRAMESET> sections
4291 in CGI.pm, but the HTML is very simple to write.  See the frame
4292 documentation in Netscape's home pages for details
4293
4294   http://home.netscape.com/assist/net_sites/frames.html
4295
4296 =item 2. Specify the destination for the document in the HTTP header
4297
4298 You may provide a B<-target> parameter to the header() method:
4299
4300     print $q->header(-target=>'ResultsWindow');
4301
4302 This will tell Netscape to load the output of your script into the
4303 frame named "ResultsWindow".  If a frame of that name doesn't
4304 already exist, Netscape will pop up a new window and load your
4305 script's document into that.  There are a number of magic names
4306 that you can use for targets.  See the frame documents on Netscape's
4307 home pages for details.
4308
4309 =item 3. Specify the destination for the document in the <FORM> tag
4310
4311 You can specify the frame to load in the FORM tag itself.  With
4312 CGI.pm it looks like this:
4313
4314     print $q->startform(-target=>'ResultsWindow');
4315
4316 When your script is reinvoked by the form, its output will be loaded
4317 into the frame named "ResultsWindow".  If one doesn't already exist
4318 a new window will be created.
4319
4320 =back
4321
4322 The script "frameset.cgi" in the examples directory shows one way to
4323 create pages in which the fill-out form and the response live in
4324 side-by-side frames.
4325
4326 =head1 DEBUGGING
4327
4328 If you are running the script
4329 from the command line or in the perl debugger, you can pass the script
4330 a list of keywords or parameter=value pairs on the command line or
4331 from standard input (you don't have to worry about tricking your
4332 script into reading from environment variables).
4333 You can pass keywords like this:
4334
4335     your_script.pl keyword1 keyword2 keyword3
4336
4337 or this:
4338
4339    your_script.pl keyword1+keyword2+keyword3
4340
4341 or this:
4342
4343     your_script.pl name1=value1 name2=value2
4344
4345 or this:
4346
4347     your_script.pl name1=value1&name2=value2
4348
4349 or even as newline-delimited parameters on standard input.
4350
4351 When debugging, you can use quotes and backslashes to escape
4352 characters in the familiar shell manner, letting you place
4353 spaces and other funny characters in your parameter=value
4354 pairs:
4355
4356    your_script.pl "name1='I am a long value'" "name2=two\ words"
4357
4358 =head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
4359
4360 The dump() method produces a string consisting of all the query's
4361 name/value pairs formatted nicely as a nested list.  This is useful
4362 for debugging purposes:
4363
4364     print $query->dump
4365
4366
4367 Produces something that looks like:
4368
4369     <UL>
4370     <LI>name1
4371         <UL>
4372         <LI>value1
4373         <LI>value2
4374         </UL>
4375     <LI>name2
4376         <UL>
4377         <LI>value1
4378         </UL>
4379     </UL>
4380
4381 You can pass a value of 'true' to dump() in order to get it to
4382 print the results out as plain text, suitable for incorporating
4383 into a <PRE> section.
4384
4385 As a shortcut, as of version 1.56 you can interpolate the entire
4386 CGI object into a string and it will be replaced with the
4387 the a nice HTML dump shown above:
4388
4389     $query=new CGI;
4390     print "<H2>Current Values</H2> $query\n";
4391
4392 =head1 FETCHING ENVIRONMENT VARIABLES
4393
4394 Some of the more useful environment variables can be fetched
4395 through this interface.  The methods are as follows:
4396
4397 =over 4
4398
4399 =item B<accept()>
4400
4401 Return a list of MIME types that the remote browser
4402 accepts. If you give this method a single argument
4403 corresponding to a MIME type, as in
4404 $query->accept('text/html'), it will return a
4405 floating point value corresponding to the browser's
4406 preference for this type from 0.0 (don't want) to 1.0.
4407 Glob types (e.g. text/*) in the browser's accept list
4408 are handled correctly.
4409
4410 =item B<raw_cookie()>
4411
4412 Returns the HTTP_COOKIE variable, an HTTP extension
4413 implemented by Netscape browsers version 1.1
4414 and higher.  Cookies have a special format, and this
4415 method call just returns the raw form (?cookie dough).
4416 See cookie() for ways of setting and retrieving
4417 cooked cookies.
4418
4419 =item B<user_agent()>
4420
4421 Returns the HTTP_USER_AGENT variable.  If you give
4422 this method a single argument, it will attempt to
4423 pattern match on it, allowing you to do something
4424 like $query->user_agent(netscape);
4425
4426 =item B<path_info()>
4427
4428 Returns additional path information from the script URL.
4429 E.G. fetching /cgi-bin/your_script/additional/stuff will
4430 result in $query->path_info() returning
4431 "additional/stuff".
4432
4433 NOTE: The Microsoft Internet Information Server
4434 is broken with respect to additional path information.  If
4435 you use the Perl DLL library, the IIS server will attempt to
4436 execute the additional path information as a Perl script.
4437 If you use the ordinary file associations mapping, the
4438 path information will be present in the environment,
4439 but incorrect.  The best thing to do is to avoid using additional
4440 path information in CGI scripts destined for use with IIS.
4441
4442 =item B<path_translated()>
4443
4444 As per path_info() but returns the additional
4445 path information translated into a physical path, e.g.
4446 "/usr/local/etc/httpd/htdocs/additional/stuff".
4447
4448 The Microsoft IIS is broken with respect to the translated
4449 path as well.
4450
4451 =item B<remote_host()>
4452
4453 Returns either the remote host name or IP address.
4454 if the former is unavailable.
4455
4456 =item B<script_name()>
4457 Return the script name as a partial URL, for self-refering
4458 scripts.
4459
4460 =item B<referer()>
4461
4462 Return the URL of the page the browser was viewing
4463 prior to fetching your script.  Not available for all
4464 browsers.
4465
4466 =item B<auth_type ()>
4467
4468 Return the authorization/verification method in use for this
4469 script, if any.
4470
4471 =item B<server_name ()>
4472
4473 Returns the name of the server, usually the machine's host
4474 name.
4475
4476 =item B<virtual_host ()>
4477
4478 When using virtual hosts, returns the name of the host that
4479 the browser attempted to contact
4480
4481 =item B<server_software ()>
4482
4483 Returns the server software and version number.
4484
4485 =item B<remote_user ()>
4486
4487 Return the authorization/verification name used for user
4488 verification, if this script is protected.
4489
4490 =item B<user_name ()>
4491
4492 Attempt to obtain the remote user's name, using a variety
4493 of different techniques.  This only works with older browsers
4494 such as Mosaic.  Netscape does not reliably report the user
4495 name!
4496
4497 =item B<request_method()>
4498
4499 Returns the method used to access your script, usually
4500 one of 'POST', 'GET' or 'HEAD'.
4501
4502 =back
4503
4504 =head1 CREATING HTML ELEMENTS:
4505
4506 In addition to its shortcuts for creating form elements, CGI.pm
4507 defines general HTML shortcut methods as well.  HTML shortcuts are
4508 named after a single HTML element and return a fragment of HTML text
4509 that you can then print or manipulate as you like.
4510
4511 This example shows how to use the HTML methods:
4512
4513         $q = new CGI;
4514         print $q->blockquote(
4515                              "Many years ago on the island of",
4516                              $q->a({href=>"http://crete.org/"},"Crete"),
4517                              "there lived a minotaur named",
4518                              $q->strong("Fred."),
4519                             ),
4520                $q->hr;
4521
4522 This results in the following HTML code (extra newlines have been
4523 added for readability):
4524
4525         <blockquote>
4526         Many years ago on the island of
4527         <a HREF="http://crete.org/">Crete</a> there lived
4528         a minotaur named <strong>Fred.</strong>
4529         </blockquote>
4530         <hr>
4531
4532 If you find the syntax for calling the HTML shortcuts awkward, you can
4533 import them into your namespace and dispense with the object syntax
4534 completely (see the next section for more details):
4535
4536         use CGI shortcuts;      # IMPORT HTML SHORTCUTS
4537         print blockquote(
4538                      "Many years ago on the island of",
4539                      a({href=>"http://crete.org/"},"Crete"),
4540                      "there lived a minotaur named",
4541                      strong("Fred."),
4542                      ),
4543                hr;
4544
4545 =head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
4546
4547 The HTML methods will accept zero, one or multiple arguments.  If you
4548 provide no arguments, you get a single tag:
4549
4550         print hr;
4551         #  gives "<hr>"
4552
4553 If you provide one or more string arguments, they are concatenated
4554 together with spaces and placed between opening and closing tags:
4555
4556         print h1("Chapter","1");
4557         # gives "<h1>Chapter 1</h1>"
4558
4559 If the first argument is an associative array reference, then the keys
4560 and values of the associative array become the HTML tag's attributes:
4561
4562         print a({href=>'fred.html',target=>'_new'},
4563                 "Open a new frame");
4564         # gives <a href="fred.html",target="_new">Open a new frame</a>
4565
4566 You are free to use CGI.pm-style dashes in front of the attribute
4567 names if you prefer:
4568
4569         print img {-src=>'fred.gif',-align=>'LEFT'};
4570         # gives <img ALIGN="LEFT" SRC="fred.gif">
4571
4572 =head2 Generating new HTML tags
4573
4574 Since no mere mortal can keep up with Netscape and Microsoft as they
4575 battle it out for control of HTML, the code that generates HTML tags
4576 is general and extensible.  You can create new HTML tags freely just
4577 by referring to them on the import line:
4578
4579         use CGI shortcuts,winkin,blinkin,nod;
4580
4581 Now, in addition to the standard CGI shortcuts, you've created HTML
4582 tags named "winkin", "blinkin" and "nod".  You can use them like this:
4583
4584         print blinkin {color=>'blue',rate=>'fast'},"Yahoo!";
4585         # <blinkin COLOR="blue" RATE="fast">Yahoo!</blinkin>
4586
4587 =head1 IMPORTING CGI METHOD CALLS INTO YOUR NAME SPACE
4588
4589 As a convenience, you can import most of the CGI method calls directly
4590 into your name space.  The syntax for doing this is:
4591
4592         use CGI <list of methods>;
4593
4594 The listed methods will be imported into the current package; you can
4595 call them directly without creating a CGI object first.  This example
4596 shows how to import the B<param()> and B<header()>
4597 methods, and then use them directly:
4598
4599         use CGI param,header;
4600         print header('text/plain');
4601         $zipcode = param('zipcode');
4602
4603 You can import groups of methods by referring to a number of special
4604 names:
4605
4606 =over 4
4607
4608 =item B<cgi>
4609
4610 Import all CGI-handling methods, such as B<param()>, B<path_info()>
4611 and the like.
4612
4613 =item B<form>
4614
4615 Import all fill-out form generating methods, such as B<textfield()>.
4616
4617 =item B<html2>
4618
4619 Import all methods that generate HTML 2.0 standard elements.
4620
4621 =item B<html3>
4622
4623 Import all methods that generate HTML 3.0 proposed elements (such as
4624 <table>, <super> and <sub>).
4625
4626 =item B<netscape>
4627
4628 Import all methods that generate Netscape-specific HTML extensions.
4629
4630 =item B<shortcuts>
4631
4632 Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
4633 'netscape')...
4634
4635 =item B<standard>
4636
4637 Import "standard" features, 'html2', 'form' and 'cgi'.
4638
4639 =item B<all>
4640
4641 Import all the available methods.  For the full list, see the CGI.pm
4642 code, where the variable %TAGS is defined.
4643
4644 =back
4645
4646 Note that in the interests of execution speed CGI.pm does B<not> use
4647 the standard L<Exporter> syntax for specifying load symbols.  This may
4648 change in the future.
4649
4650 If you import any of the state-maintaining CGI or form-generating
4651 methods, a default CGI object will be created and initialized
4652 automatically the first time you use any of the methods that require
4653 one to be present.  This includes B<param()>, B<textfield()>,
4654 B<submit()> and the like.  (If you need direct access to the CGI
4655 object, you can find it in the global variable B<$CGI::Q>).  By
4656 importing CGI.pm methods, you can create visually elegant scripts:
4657
4658    use CGI standard,html2;
4659    print
4660        header,
4661        start_html('Simple Script'),
4662        h1('Simple Script'),
4663        start_form,
4664        "What's your name? ",textfield('name'),p,
4665        "What's the combination?",
4666        checkbox_group(-name=>'words',
4667                       -values=>['eenie','meenie','minie','moe'],
4668                       -defaults=>['eenie','moe']),p,
4669        "What's your favorite color?",
4670        popup_menu(-name=>'color',
4671                   -values=>['red','green','blue','chartreuse']),p,
4672        submit,
4673        end_form,
4674        hr,"\n";
4675
4676     if (param) {
4677        print
4678            "Your name is ",em(param('name')),p,
4679            "The keywords are: ",em(join(", ",param('words'))),p,
4680            "Your favorite color is ",em(param('color')),".\n";
4681     }
4682     print end_html;
4683
4684 =head1 USING NPH SCRIPTS
4685
4686 NPH, or "no-parsed-header", scripts bypass the server completely by
4687 sending the complete HTTP header directly to the browser.  This has
4688 slight performance benefits, but is of most use for taking advantage
4689 of HTTP extensions that are not directly supported by your server,
4690 such as server push and PICS headers.
4691
4692 Servers use a variety of conventions for designating CGI scripts as
4693 NPH.  Many Unix servers look at the beginning of the script's name for
4694 the prefix "nph-".  The Macintosh WebSTAR server and Microsoft's
4695 Internet Information Server, in contrast, try to decide whether a
4696 program is an NPH script by examining the first line of script output.
4697
4698
4699 CGI.pm supports NPH scripts with a special NPH mode.  When in this
4700 mode, CGI.pm will output the necessary extra header information when
4701 the header() and redirect() methods are
4702 called.
4703
4704 The Microsoft Internet Information Server requires NPH mode.  As of version
4705 2.30, CGI.pm will automatically detect when the script is running under IIS
4706 and put itself into this mode.  You do not need to do this manually, although
4707 it won't hurt anything if you do.
4708
4709 There are a number of ways to put CGI.pm into NPH mode:
4710
4711 =over 4
4712
4713 =item In the B<use> statement
4714 Simply add ":nph" to the list of symbols to be imported into your script:
4715
4716       use CGI qw(:standard :nph)
4717
4718 =item By calling the B<nph()> method:
4719
4720 Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
4721
4722       CGI->nph(1)
4723
4724 =item By using B<-nph> parameters in the B<header()> and B<redirect()>  statements:
4725
4726       print $q->header(-nph=&gt;1);
4727
4728 =back
4729
4730 =head1 AUTHOR INFORMATION
4731
4732 Copyright 1995,1996, Lincoln D. Stein.  All rights reserved.  It may
4733 be used and modified freely, but I do request that this copyright
4734 notice remain attached to the file.  You may modify this module as you
4735 wish, but if you redistribute a modified version, please attach a note
4736 listing the modifications you have made.
4737
4738 Address bug reports and comments to:
4739 lstein@genome.wi.mit.edu
4740
4741 =head1 CREDITS
4742
4743 Thanks very much to:
4744
4745 =over 4
4746
4747 =item Matt Heffron (heffron@falstaff.css.beckman.com)
4748
4749 =item James Taylor (james.taylor@srs.gov)
4750
4751 =item Scott Anguish <sanguish@digifix.com>
4752
4753 =item Mike Jewell (mlj3u@virginia.edu)
4754
4755 =item Timothy Shimmin (tes@kbs.citri.edu.au)
4756
4757 =item Joergen Haegg (jh@axis.se)
4758
4759 =item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu)
4760
4761 =item Richard Resnick (applepi1@aol.com)
4762
4763 =item Craig Bishop (csb@barwonwater.vic.gov.au)
4764
4765 =item Tony Curtis (tc@vcpc.univie.ac.at)
4766
4767 =item Tim Bunce (Tim.Bunce@ig.co.uk)
4768
4769 =item Tom Christiansen (tchrist@convex.com)
4770
4771 =item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
4772
4773 =item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
4774
4775 =item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
4776
4777 =item Stephen Dahmen (joyfire@inxpress.net)
4778
4779 =item Ed Jordan (ed@fidalgo.net)
4780
4781 =item David Alan Pisoni (david@cnation.com)
4782
4783 =item ...and many many more...
4784
4785 for suggestions and bug fixes.
4786
4787 =back
4788
4789 =head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
4790
4791
4792         #!/usr/local/bin/perl
4793
4794         use CGI;
4795
4796         $query = new CGI;
4797
4798         print $query->header;
4799         print $query->start_html("Example CGI.pm Form");
4800         print "<H1> Example CGI.pm Form</H1>\n";
4801         &print_prompt($query);
4802         &do_work($query);
4803         &print_tail;
4804         print $query->end_html;
4805
4806         sub print_prompt {
4807            my($query) = @_;
4808
4809            print $query->startform;
4810            print "<EM>What's your name?</EM><BR>";
4811            print $query->textfield('name');
4812            print $query->checkbox('Not my real name');
4813
4814            print "<P><EM>Where can you find English Sparrows?</EM><BR>";
4815            print $query->checkbox_group(
4816                                  -name=>'Sparrow locations',
4817                                  -values=>[England,France,Spain,Asia,Hoboken],
4818                                  -linebreak=>'yes',
4819                                  -defaults=>[England,Asia]);
4820
4821            print "<P><EM>How far can they fly?</EM><BR>",
4822                 $query->radio_group(
4823                         -name=>'how far',
4824                         -values=>['10 ft','1 mile','10 miles','real far'],
4825                         -default=>'1 mile');
4826
4827            print "<P><EM>What's your favorite color?</EM>  ";
4828            print $query->popup_menu(-name=>'Color',
4829                                     -values=>['black','brown','red','yellow'],
4830                                     -default=>'red');
4831
4832            print $query->hidden('Reference','Monty Python and the Holy Grail');
4833
4834            print "<P><EM>What have you got there?</EM><BR>";
4835            print $query->scrolling_list(
4836                          -name=>'possessions',
4837                          -values=>['A Coconut','A Grail','An Icon',
4838                                    'A Sword','A Ticket'],
4839                          -size=>5,
4840                          -multiple=>'true');
4841
4842            print "<P><EM>Any parting comments?</EM><BR>";
4843            print $query->textarea(-name=>'Comments',
4844                                   -rows=>10,
4845                                   -columns=>50);
4846
4847            print "<P>",$query->reset;
4848            print $query->submit('Action','Shout');
4849            print $query->submit('Action','Scream');
4850            print $query->endform;
4851            print "<HR>\n";
4852         }
4853
4854         sub do_work {
4855            my($query) = @_;
4856            my(@values,$key);
4857
4858            print "<H2>Here are the current settings in this form</H2>";
4859
4860            foreach $key ($query->param) {
4861               print "<STRONG>$key</STRONG> -> ";
4862               @values = $query->param($key);
4863               print join(", ",@values),"<BR>\n";
4864           }
4865         }
4866
4867         sub print_tail {
4868            print <<END;
4869         <HR>
4870         <ADDRESS>Lincoln D. Stein</ADDRESS><BR>
4871         <A HREF="/">Home Page</A>
4872         END
4873         }
4874
4875 =head1 BUGS
4876
4877 This module has grown large and monolithic.  Furthermore it's doing many
4878 things, such as handling URLs, parsing CGI input, writing HTML, etc., that
4879 are also done in the LWP modules. It should be discarded in favor of
4880 the CGI::* modules, but somehow I continue to work on it.
4881
4882 Note that the code is truly contorted in order to avoid spurious
4883 warnings when programs are run with the B<-w> switch.
4884
4885 =head1 SEE ALSO
4886
4887 L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>,
4888 L<CGI::Base>, L<CGI::Form>, L<CGI::Apache>, L<CGI::Switch>,
4889 L<CGI::Push>, L<CGI::Fast>
4890
4891 =cut
4892