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