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