lib/CGI.pm

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