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