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