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