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