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