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