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