lib/CGI.pm

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