lib/CGI.pm

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