This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add VMS' default to the CGI.pm temp list (should update to File::Spec)
[perl5.git] / lib / CGI.pm
1 package CGI;
2 require 5.004;
3
4 # See the bottom of this file for the POD documentation.  Search for the
5 # string '=head'.
6
7 # You can run this file through either pod2man or pod2html to produce pretty
8 # documentation in manual or html file format (these utilities are part of the
9 # Perl 5 distribution).
10
11 # Copyright 1995-1998 Lincoln D. Stein.  All rights reserved.
12 # It may be used and modified freely, but I do request that this copyright
13 # notice remain attached to the file.  You may modify this module as you 
14 # wish, but if you redistribute a modified version, please attach a note
15 # listing the modifications you have made.
16
17 # The most recent version and complete docs are available at:
18 #   http://stein.cshl.org/WWW/software/CGI/
19
20 $CGI::revision = '$Id: CGI.pm,v 1.19 1999/08/31 17:04:37 lstein Exp $';
21 $CGI::VERSION='2.56';
22
23 # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
24 # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
25 # $TempFile::TMPDIRECTORY = '/usr/tmp';
26
27 # >>>>> Here are some globals that you might want to adjust <<<<<<
28 sub initialize_globals {
29     # Set this to 1 to enable copious autoloader debugging messages
30     $AUTOLOAD_DEBUG = 0;
31
32     # Change this to the preferred DTD to print in start_html()
33     # or use default_dtd('text of DTD to use');
34     $DEFAULT_DTD = '-//IETF//DTD HTML//EN';
35
36     # Set this to 1 to enable NPH scripts
37     # or: 
38     #    1) use CGI qw(-nph)
39     #    2) $CGI::nph(1)
40     #    3) print header(-nph=>1)
41     $NPH = 0;
42
43     # Set this to 1 to disable debugging from the
44     # command line
45     $NO_DEBUG = 0;
46
47     # Set this to 1 to make the temporary files created
48     # during file uploads safe from prying eyes
49     # or do...
50     #    1) use CGI qw(:private_tempfiles)
51     #    2) $CGI::private_tempfiles(1);
52     $PRIVATE_TEMPFILES = 0;
53
54     # Set this to a positive value to limit the size of a POSTing
55     # to a certain number of bytes:
56     $POST_MAX = -1;
57
58     # Change this to 1 to disable uploads entirely:
59     $DISABLE_UPLOADS = 0;
60
61     # Automatically determined -- don't change
62     $EBCDIC = 0;
63
64     # Change this to 1 to suppress redundant HTTP headers
65     $HEADERS_ONCE = 0;
66
67     # separate the name=value pairs by semicolons rather than ampersands
68     $USE_PARAM_SEMICOLONS = 0;
69
70     # Other globals that you shouldn't worry about.
71     undef $Q;
72     $BEEN_THERE = 0;
73     undef @QUERY_PARAM;
74     undef %EXPORT;
75
76     # prevent complaints by mod_perl
77     1;
78 }
79
80 # ------------------ START OF THE LIBRARY ------------
81
82 # make mod_perlhappy
83 initialize_globals();
84
85 # FIGURE OUT THE OS WE'RE RUNNING UNDER
86 # Some systems support the $^O variable.  If not
87 # available then require() the Config library
88 unless ($OS) {
89     unless ($OS = $^O) {
90         require Config;
91         $OS = $Config::Config{'osname'};
92     }
93 }
94 if ($OS=~/Win/i) {
95   $OS = 'WINDOWS';
96 } elsif ($OS=~/vms/i) {
97   $OS = 'VMS';
98 } elsif ($OS=~/bsdos/i) {
99   $OS = 'UNIX';
100 } elsif ($OS=~/dos/i) {
101   $OS = 'DOS';
102 } elsif ($OS=~/^MacOS$/i) {
103     $OS = 'MACINTOSH';
104 } elsif ($OS=~/os2/i) {
105     $OS = 'OS2';
106 } else {
107     $OS = 'UNIX';
108 }
109
110 # Some OS logic.  Binary mode enabled on DOS, NT and VMS
111 $needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/;
112
113 # This is the default class for the CGI object to use when all else fails.
114 $DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
115
116 # This is where to look for autoloaded routines.
117 $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
118
119 # The path separator is a slash, backslash or semicolon, depending
120 # on the paltform.
121 $SL = {
122     UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
123     }->{$OS};
124
125 # This no longer seems to be necessary
126 # Turn on NPH scripts by default when running under IIS server!
127 # $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
128 $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
129
130 # Turn on special checking for Doug MacEachern's modperl
131 if (exists $ENV{'GATEWAY_INTERFACE'} 
132     && 
133     ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
134 {
135     $| = 1;
136     require Apache;
137 }
138 # Turn on special checking for ActiveState's PerlEx
139 $PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
140
141 # Define the CRLF sequence.  I can't use a simple "\r\n" because the meaning
142 # of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
143 # and sometimes CR).  The most popular VMS web server
144 # doesn't accept CRLF -- instead it wants a LR.  EBCDIC machines don't
145 # use ASCII, so \015\012 means something different.  I find this all 
146 # really annoying.
147 $EBCDIC = "\t" ne "\011";
148 if ($OS eq 'VMS') {
149   $CRLF = "\n";
150 } elsif ($EBCDIC) {
151   $CRLF= "\r\n";
152 } else {
153   $CRLF = "\015\012";
154 }
155
156 if ($EBCDIC) {
157 @A2E = (
158   0,  1,  2,  3, 55, 45, 46, 47, 22,  5, 21, 11, 12, 13, 14, 15,
159  16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
160  64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
161 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
162 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
163 215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
164 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
165 151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161,  7,
166  32, 33, 34, 35, 36, 37,  6, 23, 40, 41, 42, 43, 44,  9, 10, 27,
167  48, 49, 26, 51, 52, 53, 54,  8, 56, 57, 58, 59,  4, 20, 62,255,
168  65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
169 144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
170 100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
171 172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
172  68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
173 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
174       );
175 }
176
177 if ($needs_binmode) {
178     $CGI::DefaultClass->binmode(main::STDOUT);
179     $CGI::DefaultClass->binmode(main::STDIN);
180     $CGI::DefaultClass->binmode(main::STDERR);
181 }
182
183 %EXPORT_TAGS = (
184                 ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
185                            tt u i b blockquote pre img a address cite samp dfn html head
186                            base body Link nextid title meta kbd start_html end_html
187                            input Select option comment/],
188                 ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param 
189                            embed basefont style span layer ilayer font frameset frame script small big/],
190                 ':netscape'=>[qw/blink fontsize center/],
191                 ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group 
192                           submit reset defaults radio_group popup_menu button autoEscape
193                           scrolling_list image_button start_form end_form startform endform
194                           start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
195                 ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump
196                          raw_cookie request_method query_string Accept user_agent remote_host content_type
197                          remote_addr referer server_name server_software server_port server_protocol
198                          virtual_host remote_ident auth_type http use_named_parameters 
199                          save_parameters restore_parameters param_fetch
200                          remote_user user_name header redirect import_names put 
201                          Delete Delete_all url_param cgi_error/],
202                 ':ssl' => [qw/https/],
203                 ':imagemap' => [qw/Area Map/],
204                 ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
205                 ':html' => [qw/:html2 :html3 :netscape/],
206                 ':standard' => [qw/:html2 :html3 :form :cgi/],
207                 ':push' => [qw/multipart_init multipart_start multipart_end/],
208                 ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/]
209                 );
210
211 # to import symbols into caller
212 sub import {
213     my $self = shift;
214
215 # This causes modules to clash.  
216 #    undef %EXPORT_OK;
217 #    undef %EXPORT;
218
219     $self->_setup_symbols(@_);
220     my ($callpack, $callfile, $callline) = caller;
221
222     # To allow overriding, search through the packages
223     # Till we find one in which the correct subroutine is defined.
224     my @packages = ($self,@{"$self\:\:ISA"});
225     foreach $sym (keys %EXPORT) {
226         my $pck;
227         my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
228         foreach $pck (@packages) {
229             if (defined(&{"$pck\:\:$sym"})) {
230                 $def = $pck;
231                 last;
232             }
233         }
234         *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
235     }
236 }
237
238 sub compile {
239     my $pack = shift;
240     $pack->_setup_symbols('-compile',@_);
241 }
242
243 sub expand_tags {
244     my($tag) = @_;
245     return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
246     my(@r);
247     return ($tag) unless $EXPORT_TAGS{$tag};
248     foreach (@{$EXPORT_TAGS{$tag}}) {
249         push(@r,&expand_tags($_));
250     }
251     return @r;
252 }
253
254 #### Method: new
255 # The new routine.  This will check the current environment
256 # for an existing query string, and initialize itself, if so.
257 ####
258 sub new {
259     my($class,$initializer) = @_;
260     my $self = {};
261     bless $self,ref $class || $class || $DefaultClass;
262     if ($MOD_PERL) {
263         Apache->request->register_cleanup(\&CGI::_reset_globals);
264         undef $NPH;
265     }
266     $self->_reset_globals if $PERLEX;
267     $self->init($initializer);
268     return $self;
269 }
270
271 # We provide a DESTROY method so that the autoloader
272 # doesn't bother trying to find it.
273 sub DESTROY { }
274
275 #### Method: param
276 # Returns the value(s)of a named parameter.
277 # If invoked in a list context, returns the
278 # entire list.  Otherwise returns the first
279 # member of the list.
280 # If name is not provided, return a list of all
281 # the known parameters names available.
282 # If more than one argument is provided, the
283 # second and subsequent arguments are used to
284 # set the value of the parameter.
285 ####
286 sub param {
287     my($self,@p) = self_or_default(@_);
288     return $self->all_parameters unless @p;
289     my($name,$value,@other);
290
291     # For compatibility between old calling style and use_named_parameters() style, 
292     # we have to special case for a single parameter present.
293     if (@p > 1) {
294         ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
295         my(@values);
296
297         if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
298             @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
299         } else {
300             foreach ($value,@other) {
301                 push(@values,$_) if defined($_);
302             }
303         }
304         # If values is provided, then we set it.
305         if (@values) {
306             $self->add_parameter($name);
307             $self->{$name}=[@values];
308         }
309     } else {
310         $name = $p[0];
311     }
312
313     return unless defined($name) && $self->{$name};
314     return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
315 }
316
317 sub self_or_default {
318     return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
319     unless (defined($_[0]) && 
320             (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
321             ) {
322         $Q = $CGI::DefaultClass->new unless defined($Q);
323         unshift(@_,$Q);
324     }
325     return @_;
326 }
327
328 sub self_or_CGI {
329     local $^W=0;                # prevent a warning
330     if (defined($_[0]) &&
331         (substr(ref($_[0]),0,3) eq 'CGI' 
332          || UNIVERSAL::isa($_[0],'CGI'))) {
333         return @_;
334     } else {
335         return ($DefaultClass,@_);
336     }
337 }
338
339 ########################################
340 # THESE METHODS ARE MORE OR LESS PRIVATE
341 # GO TO THE __DATA__ SECTION TO SEE MORE
342 # PUBLIC METHODS
343 ########################################
344
345 # Initialize the query object from the environment.
346 # If a parameter list is found, this object will be set
347 # to an associative array in which parameter names are keys
348 # and the values are stored as lists
349 # If a keyword list is found, this method creates a bogus
350 # parameter list with the single parameter 'keywords'.
351
352 sub init {
353     my($self,$initializer) = @_;
354     my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
355     local($/) = "\n";
356
357     # if we get called more than once, we want to initialize
358     # ourselves from the original query (which may be gone
359     # if it was read from STDIN originally.)
360     if (@QUERY_PARAM && !defined($initializer)) {
361         foreach (@QUERY_PARAM) {
362             $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
363         }
364         return;
365     }
366
367     $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
368     $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
369
370     $fh = to_filehandle($initializer) if $initializer;
371
372   METHOD: {
373
374       # avoid unreasonably large postings
375       if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
376           $self->cgi_error("413 Request entity too large");
377           last METHOD;
378       }
379
380       # Process multipart postings, but only if the initializer is
381       # not defined.
382       if ($meth eq 'POST'
383           && defined($ENV{'CONTENT_TYPE'})
384           && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
385           && !defined($initializer)
386           ) {
387           my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
388           $self->read_multipart($boundary,$content_length);
389           last METHOD;
390       } 
391
392       # If initializer is defined, then read parameters
393       # from it.
394       if (defined($initializer)) {
395           if (UNIVERSAL::isa($initializer,'CGI')) {
396               $query_string = $initializer->query_string;
397               last METHOD;
398           }
399           if (ref($initializer) && ref($initializer) eq 'HASH') {
400               foreach (keys %$initializer) {
401                   $self->param('-name'=>$_,'-value'=>$initializer->{$_});
402               }
403               last METHOD;
404           }
405           
406           if (defined($fh) && ($fh ne '')) {
407               while (<$fh>) {
408                   chomp;
409                   last if /^=/;
410                   push(@lines,$_);
411               }
412               # massage back into standard format
413               if ("@lines" =~ /=/) {
414                   $query_string=join("&",@lines);
415               } else {
416                   $query_string=join("+",@lines);
417               }
418               last METHOD;
419           }
420
421           # last chance -- treat it as a string
422           $initializer = $$initializer if ref($initializer) eq 'SCALAR';
423           $query_string = $initializer;
424
425           last METHOD;
426       }
427
428       # If method is GET or HEAD, fetch the query from
429       # the environment.
430       if ($meth=~/^(GET|HEAD)$/) {
431           if ($MOD_PERL) {
432               $query_string = Apache->request->args;
433           } else {
434               $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
435           }
436           last METHOD;
437       }
438
439       if ($meth eq 'POST') {
440           $self->read_from_client(\*STDIN,\$query_string,$content_length,0)
441               if $content_length > 0;
442           # Some people want to have their cake and eat it too!
443           # Uncomment this line to have the contents of the query string
444           # APPENDED to the POST data.
445           # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
446           last METHOD;
447       }
448
449       # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
450       # Check the command line and then the standard input for data.
451       # We use the shellwords package in order to behave the way that
452       # UN*X programmers expect.
453       $query_string = read_from_cmdline() unless $NO_DEBUG;
454   }
455
456     # We now have the query string in hand.  We do slightly
457     # different things for keyword lists and parameter lists.
458     if (defined $query_string && $query_string) {
459         if ($query_string =~ /=/) {
460             $self->parse_params($query_string);
461         } else {
462             $self->add_parameter('keywords');
463             $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
464         }
465     }
466
467     # Special case.  Erase everything if there is a field named
468     # .defaults.
469     if ($self->param('.defaults')) {
470         undef %{$self};
471     }
472
473     # Associative array containing our defined fieldnames
474     $self->{'.fieldnames'} = {};
475     foreach ($self->param('.cgifields')) {
476         $self->{'.fieldnames'}->{$_}++;
477     }
478     
479     # Clear out our default submission button flag if present
480     $self->delete('.submit');
481     $self->delete('.cgifields');
482     $self->save_request unless $initializer;
483 }
484
485 # FUNCTIONS TO OVERRIDE:
486 # Turn a string into a filehandle
487 sub to_filehandle {
488     my $thingy = shift;
489     return undef unless $thingy;
490     return $thingy if UNIVERSAL::isa($thingy,'GLOB');
491     return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
492     if (!ref($thingy)) {
493         my $caller = 1;
494         while (my $package = caller($caller++)) {
495             my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; 
496             return $tmp if defined(fileno($tmp));
497         }
498     }
499     return undef;
500 }
501
502 # send output to the browser
503 sub put {
504     my($self,@p) = self_or_default(@_);
505     $self->print(@p);
506 }
507
508 # print to standard output (for overriding in mod_perl)
509 sub print {
510     shift;
511     CORE::print(@_);
512 }
513
514 # get/set last cgi_error
515 sub cgi_error {
516     my ($self,$err) = self_or_default(@_);
517     $self->{'.cgi_error'} = $err if defined $err;
518     return $self->{'.cgi_error'};
519 }
520
521 # unescape URL-encoded data
522 sub unescape {
523   shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass);
524   my $todecode = shift;
525   return undef unless defined($todecode);
526   $todecode =~ tr/+/ /;       # pluses become spaces
527     if ($EBCDIC) {
528       $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",$A2E[hex($1)])/ge;
529     } else {
530       $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
531     }
532   return $todecode;
533 }
534
535 # URL-encode data
536 sub escape {
537   shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass);
538   my $toencode = shift;
539   return undef unless defined($toencode);
540   $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
541   return $toencode;
542 }
543
544 sub save_request {
545     my($self) = @_;
546     # We're going to play with the package globals now so that if we get called
547     # again, we initialize ourselves in exactly the same way.  This allows
548     # us to have several of these objects.
549     @QUERY_PARAM = $self->param; # save list of parameters
550     foreach (@QUERY_PARAM) {
551         $QUERY_PARAM{$_}=$self->{$_};
552     }
553 }
554
555 sub parse_params {
556     my($self,$tosplit) = @_;
557     my(@pairs) = split(/[&;]/,$tosplit);
558     my($param,$value);
559     foreach (@pairs) {
560         ($param,$value) = split('=',$_,2);
561         $param = unescape($param);
562         $value = unescape($value);
563         $self->add_parameter($param);
564         push (@{$self->{$param}},$value);
565     }
566 }
567
568 sub add_parameter {
569     my($self,$param)=@_;
570     push (@{$self->{'.parameters'}},$param) 
571         unless defined($self->{$param});
572 }
573
574 sub all_parameters {
575     my $self = shift;
576     return () unless defined($self) && $self->{'.parameters'};
577     return () unless @{$self->{'.parameters'}};
578     return @{$self->{'.parameters'}};
579 }
580
581 # put a filehandle into binary mode (DOS)
582 sub binmode {
583     CORE::binmode($_[1]);
584 }
585
586 sub _make_tag_func {
587     my ($self,$tagname) = @_;
588     my $func = qq(
589         sub $tagname { 
590             shift if \$_[0] && 
591 #               (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) ||
592                     (ref(\$_[0]) &&
593                      (substr(ref(\$_[0]),0,3) eq 'CGI' ||
594                     UNIVERSAL::isa(\$_[0],'CGI')));
595             
596             my(\$attr) = '';
597             if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') {
598                 my(\@attr) = make_attributes( '',shift() );
599                 \$attr = " \@attr" if \@attr;
600             }
601         );
602     if ($tagname=~/start_(\w+)/i) {
603         $func .= qq! return "<\U$1\E\$attr>";} !;
604     } elsif ($tagname=~/end_(\w+)/i) {
605         $func .= qq! return "<\U/$1\E>"; } !;
606     } else {
607         $func .= qq#
608             my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U</$tagname>\E");
609             return \$tag unless \@_;
610             my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
611             return "\@result";
612             }#;
613     }
614 return $func;
615 }
616
617 sub AUTOLOAD {
618     print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
619     my $func = &_compile;
620     goto &$func;
621 }
622
623 # PRIVATE SUBROUTINE
624 # Smart rearrangement of parameters to allow named parameter
625 # calling.  We do the rearangement if:
626 # 1. The first parameter begins with a -
627 # 2. The use_named_parameters() method returns true
628 sub rearrange {
629     my($self,$order,@param) = @_;
630     return () unless @param;
631
632     if (ref($param[0]) eq 'HASH') {
633         @param = %{$param[0]};
634     } else {
635         return @param 
636             unless (defined($param[0]) && substr($param[0],0,1) eq '-')
637                 || $self->use_named_parameters;
638     }
639
640     # map parameters into positional indices
641     my ($i,%pos);
642     $i = 0;
643     foreach (@$order) {
644         foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; }
645         $i++;
646     }
647
648     my (@result,%leftover);
649     $#result = $#$order;  # preextend
650     while (@param) {
651         my $key = uc(shift(@param));
652         $key =~ s/^\-//;
653         if (exists $pos{$key}) {
654             $result[$pos{$key}] = shift(@param);
655         } else {
656             $leftover{$key} = shift(@param);
657         }
658     }
659
660     push (@result,$self->make_attributes(\%leftover)) if %leftover;
661     @result;
662 }
663
664 sub _compile {
665     my($func) = $AUTOLOAD;
666     my($pack,$func_name);
667     {
668         local($1,$2); # this fixes an obscure variable suicide problem.
669         $func=~/(.+)::([^:]+)$/;
670         ($pack,$func_name) = ($1,$2);
671         $pack=~s/::SUPER$//;    # fix another obscure problem
672         $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
673             unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
674
675         my($sub) = \%{"$pack\:\:SUBS"};
676         unless (%$sub) {
677            my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
678            eval "package $pack; $$auto";
679            die $@ if $@;
680            $$auto = '';  # Free the unneeded storage (but don't undef it!!!)
681        }
682        my($code) = $sub->{$func_name};
683
684        $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
685        if (!$code) {
686            (my $base = $func_name) =~ s/^(start_|end_)//i;
687            if ($EXPORT{':any'} || 
688                $EXPORT{'-any'} ||
689                $EXPORT{$base} || 
690                (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
691                    && $EXPORT_OK{$base}) {
692                $code = $CGI::DefaultClass->_make_tag_func($func_name);
693            }
694        }
695        die "Undefined subroutine $AUTOLOAD\n" unless $code;
696        eval "package $pack; $code";
697        if ($@) {
698            $@ =~ s/ at .*\n//;
699            die $@;
700        }
701     }       
702     CORE::delete($sub->{$func_name});  #free storage
703     return "$pack\:\:$func_name";
704 }
705
706 sub _reset_globals { initialize_globals(); }
707
708 sub _setup_symbols {
709     my $self = shift;
710     my $compile = 0;
711     foreach (@_) {
712         $HEADERS_ONCE++,         next if /^[:-]unique_headers$/;
713         $NPH++,                  next if /^[:-]nph$/;
714         $NO_DEBUG++,             next if /^[:-]no_?[Dd]ebug$/;
715         $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
716         $PRIVATE_TEMPFILES++,    next if /^[:-]private_tempfiles$/;
717         $EXPORT{$_}++,           next if /^[:-]any$/;
718         $compile++,              next if /^[:-]compile$/;
719         
720         # This is probably extremely evil code -- to be deleted some day.
721         if (/^[-]autoload$/) {
722             my($pkg) = caller(1);
723             *{"${pkg}::AUTOLOAD"} = sub { 
724                 my($routine) = $AUTOLOAD;
725                 $routine =~ s/^.*::/CGI::/;
726                 &$routine;
727             };
728             next;
729         }
730
731         foreach (&expand_tags($_)) {
732             tr/a-zA-Z0-9_//cd;  # don't allow weird function names
733             $EXPORT{$_}++;
734         }
735     }
736     _compile_all(keys %EXPORT) if $compile;
737 }
738
739 ###############################################################################
740 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
741 ###############################################################################
742 $AUTOLOADED_ROUTINES = '';      # get rid of -w warning
743 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
744
745 %SUBS = (
746
747 'URL_ENCODED'=> <<'END_OF_FUNC',
748 sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
749 END_OF_FUNC
750
751 'MULTIPART' => <<'END_OF_FUNC',
752 sub MULTIPART {  'multipart/form-data'; }
753 END_OF_FUNC
754
755 'SERVER_PUSH' => <<'END_OF_FUNC',
756 sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; }
757 END_OF_FUNC
758
759 'use_named_parameters' => <<'END_OF_FUNC',
760 #### Method: use_named_parameters
761 # Force CGI.pm to use named parameter-style method calls
762 # rather than positional parameters.  The same effect
763 # will happen automatically if the first parameter
764 # begins with a -.
765 sub use_named_parameters {
766     my($self,$use_named) = self_or_default(@_);
767     return $self->{'.named'} unless defined ($use_named);
768
769     # stupidity to avoid annoying warnings
770     return $self->{'.named'}=$use_named;
771 }
772 END_OF_FUNC
773
774 'new_MultipartBuffer' => <<'END_OF_FUNC',
775 # Create a new multipart buffer
776 sub new_MultipartBuffer {
777     my($self,$boundary,$length,$filehandle) = @_;
778     return MultipartBuffer->new($self,$boundary,$length,$filehandle);
779 }
780 END_OF_FUNC
781
782 'read_from_client' => <<'END_OF_FUNC',
783 # Read data from a file handle
784 sub read_from_client {
785     my($self, $fh, $buff, $len, $offset) = @_;
786     local $^W=0;                # prevent a warning
787     return undef unless defined($fh);
788     return read($fh, $$buff, $len, $offset);
789 }
790 END_OF_FUNC
791
792 'delete' => <<'END_OF_FUNC',
793 #### Method: delete
794 # Deletes the named parameter entirely.
795 ####
796 sub delete {
797     my($self,$name) = self_or_default(@_);
798     CORE::delete $self->{$name};
799     CORE::delete $self->{'.fieldnames'}->{$name};
800     @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
801     return wantarray ? () : undef;
802 }
803 END_OF_FUNC
804
805 #### Method: import_names
806 # Import all parameters into the given namespace.
807 # Assumes namespace 'Q' if not specified
808 ####
809 'import_names' => <<'END_OF_FUNC',
810 sub import_names {
811     my($self,$namespace,$delete) = self_or_default(@_);
812     $namespace = 'Q' unless defined($namespace);
813     die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
814     if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
815         # can anyone find an easier way to do this?
816         foreach (keys %{"${namespace}::"}) {
817             local *symbol = "${namespace}::${_}";
818             undef $symbol;
819             undef @symbol;
820             undef %symbol;
821         }
822     }
823     my($param,@value,$var);
824     foreach $param ($self->param) {
825         # protect against silly names
826         ($var = $param)=~tr/a-zA-Z0-9_/_/c;
827         $var =~ s/^(?=\d)/_/;
828         local *symbol = "${namespace}::$var";
829         @value = $self->param($param);
830         @symbol = @value;
831         $symbol = $value[0];
832     }
833 }
834 END_OF_FUNC
835
836 #### Method: keywords
837 # Keywords acts a bit differently.  Calling it in a list context
838 # returns the list of keywords.  
839 # Calling it in a scalar context gives you the size of the list.
840 ####
841 'keywords' => <<'END_OF_FUNC',
842 sub keywords {
843     my($self,@values) = self_or_default(@_);
844     # If values is provided, then we set it.
845     $self->{'keywords'}=[@values] if @values;
846     my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
847     @result;
848 }
849 END_OF_FUNC
850
851 # These are some tie() interfaces for compatibility
852 # with Steve Brenner's cgi-lib.pl routines
853 'Vars' => <<'END_OF_FUNC',
854 sub Vars {
855     my $q = shift;
856     my %in;
857     tie(%in,CGI,$q);
858     return %in if wantarray;
859     return \%in;
860 }
861 END_OF_FUNC
862
863 # These are some tie() interfaces for compatibility
864 # with Steve Brenner's cgi-lib.pl routines
865 'ReadParse' => <<'END_OF_FUNC',
866 sub ReadParse {
867     local(*in);
868     if (@_) {
869         *in = $_[0];
870     } else {
871         my $pkg = caller();
872         *in=*{"${pkg}::in"};
873     }
874     tie(%in,CGI);
875     return scalar(keys %in);
876 }
877 END_OF_FUNC
878
879 'PrintHeader' => <<'END_OF_FUNC',
880 sub PrintHeader {
881     my($self) = self_or_default(@_);
882     return $self->header();
883 }
884 END_OF_FUNC
885
886 'HtmlTop' => <<'END_OF_FUNC',
887 sub HtmlTop {
888     my($self,@p) = self_or_default(@_);
889     return $self->start_html(@p);
890 }
891 END_OF_FUNC
892
893 'HtmlBot' => <<'END_OF_FUNC',
894 sub HtmlBot {
895     my($self,@p) = self_or_default(@_);
896     return $self->end_html(@p);
897 }
898 END_OF_FUNC
899
900 'SplitParam' => <<'END_OF_FUNC',
901 sub SplitParam {
902     my ($param) = @_;
903     my (@params) = split ("\0", $param);
904     return (wantarray ? @params : $params[0]);
905 }
906 END_OF_FUNC
907
908 'MethGet' => <<'END_OF_FUNC',
909 sub MethGet {
910     return request_method() eq 'GET';
911 }
912 END_OF_FUNC
913
914 'MethPost' => <<'END_OF_FUNC',
915 sub MethPost {
916     return request_method() eq 'POST';
917 }
918 END_OF_FUNC
919
920 'TIEHASH' => <<'END_OF_FUNC',
921 sub TIEHASH { 
922     return $_[1] if defined $_[1];
923     return $Q || new shift;
924 }
925 END_OF_FUNC
926
927 'STORE' => <<'END_OF_FUNC',
928 sub STORE {
929     $_[0]->param($_[1],split("\0",$_[2]));
930 }
931 END_OF_FUNC
932
933 'FETCH' => <<'END_OF_FUNC',
934 sub FETCH {
935     return $_[0] if $_[1] eq 'CGI';
936     return undef unless defined $_[0]->param($_[1]);
937     return join("\0",$_[0]->param($_[1]));
938 }
939 END_OF_FUNC
940
941 'FIRSTKEY' => <<'END_OF_FUNC',
942 sub FIRSTKEY {
943     $_[0]->{'.iterator'}=0;
944     $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
945 }
946 END_OF_FUNC
947
948 'NEXTKEY' => <<'END_OF_FUNC',
949 sub NEXTKEY {
950     $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
951 }
952 END_OF_FUNC
953
954 'EXISTS' => <<'END_OF_FUNC',
955 sub EXISTS {
956     exists $_[0]->{$_[1]};
957 }
958 END_OF_FUNC
959
960 'DELETE' => <<'END_OF_FUNC',
961 sub DELETE {
962     $_[0]->delete($_[1]);
963 }
964 END_OF_FUNC
965
966 'CLEAR' => <<'END_OF_FUNC',
967 sub CLEAR {
968     %{$_[0]}=();
969 }
970 ####
971 END_OF_FUNC
972
973 ####
974 # Append a new value to an existing query
975 ####
976 'append' => <<'EOF',
977 sub append {
978     my($self,@p) = @_;
979     my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
980     my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
981     if (@values) {
982         $self->add_parameter($name);
983         push(@{$self->{$name}},@values);
984     }
985     return $self->param($name);
986 }
987 EOF
988
989 #### Method: delete_all
990 # Delete all parameters
991 ####
992 'delete_all' => <<'EOF',
993 sub delete_all {
994     my($self) = self_or_default(@_);
995     undef %{$self};
996 }
997 EOF
998
999 'Delete' => <<'EOF',
1000 sub Delete {
1001     my($self,@p) = self_or_default(@_);
1002     $self->delete(@p);
1003 }
1004 EOF
1005
1006 'Delete_all' => <<'EOF',
1007 sub Delete_all {
1008     my($self,@p) = self_or_default(@_);
1009     $self->delete_all(@p);
1010 }
1011 EOF
1012
1013 #### Method: autoescape
1014 # If you want to turn off the autoescaping features,
1015 # call this method with undef as the argument
1016 'autoEscape' => <<'END_OF_FUNC',
1017 sub autoEscape {
1018     my($self,$escape) = self_or_default(@_);
1019     $self->{'dontescape'}=!$escape;
1020 }
1021 END_OF_FUNC
1022
1023
1024 #### Method: version
1025 # Return the current version
1026 ####
1027 'version' => <<'END_OF_FUNC',
1028 sub version {
1029     return $VERSION;
1030 }
1031 END_OF_FUNC
1032
1033 'make_attributes' => <<'END_OF_FUNC',
1034 sub make_attributes {
1035     my($self,$attr) = @_;
1036     return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
1037     my(@att);
1038     foreach (keys %{$attr}) {
1039         my($key) = $_;
1040         $key=~s/^\-//;     # get rid of initial - if present
1041         $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
1042         push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/);
1043     }
1044     return @att;
1045 }
1046 END_OF_FUNC
1047
1048 #### Method: url_param
1049 # Return a parameter in the QUERY_STRING, regardless of
1050 # whether this was a POST or a GET
1051 ####
1052 'url_param' => <<'END_OF_FUNC',
1053 sub url_param {
1054     my ($self,@p) = self_or_default(@_);
1055     my $name = shift(@p);
1056     return undef unless exists($ENV{QUERY_STRING});
1057     unless (exists($self->{'.url_param'})) {
1058         $self->{'.url_param'}={}; # empty hash
1059         if ($ENV{QUERY_STRING} =~ /=/) {
1060             my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
1061             my($param,$value);
1062             foreach (@pairs) {
1063                 ($param,$value) = split('=',$_,2);
1064                 $param = unescape($param);
1065                 $value = unescape($value);
1066                 push(@{$self->{'.url_param'}->{$param}},$value);
1067             }
1068         } else {
1069             $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
1070         }
1071     }
1072     return keys %{$self->{'.url_param'}} unless defined($name);
1073     return () unless $self->{'.url_param'}->{$name};
1074     return wantarray ? @{$self->{'.url_param'}->{$name}}
1075                      : $self->{'.url_param'}->{$name}->[0];
1076 }
1077 END_OF_FUNC
1078
1079 #### Method: dump
1080 # Returns a string in which all the known parameter/value 
1081 # pairs are represented as nested lists, mainly for the purposes 
1082 # of debugging.
1083 ####
1084 'dump' => <<'END_OF_FUNC',
1085 sub dump {
1086     my($self) = self_or_default(@_);
1087     my($param,$value,@result);
1088     return '<UL></UL>' unless $self->param;
1089     push(@result,"<UL>");
1090     foreach $param ($self->param) {
1091         my($name)=$self->escapeHTML($param);
1092         push(@result,"<LI><STRONG>$param</STRONG>");
1093         push(@result,"<UL>");
1094         foreach $value ($self->param($param)) {
1095             $value = $self->escapeHTML($value);
1096             $value =~ s/\n/<BR>\n/g;
1097             push(@result,"<LI>$value");
1098         }
1099         push(@result,"</UL>");
1100     }
1101     push(@result,"</UL>\n");
1102     return join("\n",@result);
1103 }
1104 END_OF_FUNC
1105
1106 #### Method as_string
1107 #
1108 # synonym for "dump"
1109 ####
1110 'as_string' => <<'END_OF_FUNC',
1111 sub as_string {
1112     &dump(@_);
1113 }
1114 END_OF_FUNC
1115
1116 #### Method: save
1117 # Write values out to a filehandle in such a way that they can
1118 # be reinitialized by the filehandle form of the new() method
1119 ####
1120 'save' => <<'END_OF_FUNC',
1121 sub save {
1122     my($self,$filehandle) = self_or_default(@_);
1123     $filehandle = to_filehandle($filehandle);
1124     my($param);
1125     local($,) = '';  # set print field separator back to a sane value
1126     local($\) = '';  # set output line separator to a sane value
1127     foreach $param ($self->param) {
1128         my($escaped_param) = escape($param);
1129         my($value);
1130         foreach $value ($self->param($param)) {
1131             print $filehandle "$escaped_param=",escape("$value"),"\n";
1132         }
1133     }
1134     print $filehandle "=\n";    # end of record
1135 }
1136 END_OF_FUNC
1137
1138
1139 #### Method: save_parameters
1140 # An alias for save() that is a better name for exportation.
1141 # Only intended to be used with the function (non-OO) interface.
1142 ####
1143 'save_parameters' => <<'END_OF_FUNC',
1144 sub save_parameters {
1145     my $fh = shift;
1146     return save(to_filehandle($fh));
1147 }
1148 END_OF_FUNC
1149
1150 #### Method: restore_parameters
1151 # A way to restore CGI parameters from an initializer.
1152 # Only intended to be used with the function (non-OO) interface.
1153 ####
1154 'restore_parameters' => <<'END_OF_FUNC',
1155 sub restore_parameters {
1156     $Q = $CGI::DefaultClass->new(@_);
1157 }
1158 END_OF_FUNC
1159
1160 #### Method: multipart_init
1161 # Return a Content-Type: style header for server-push
1162 # This has to be NPH, and it is advisable to set $| = 1
1163 #
1164 # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1165 # contribution
1166 ####
1167 'multipart_init' => <<'END_OF_FUNC',
1168 sub multipart_init {
1169     my($self,@p) = self_or_default(@_);
1170     my($boundary,@other) = $self->rearrange([BOUNDARY],@p);
1171     $boundary = $boundary || '------- =_aaaaaaaaaa0';
1172     $self->{'separator'} = "\n--$boundary\n";
1173     $type = SERVER_PUSH($boundary);
1174     return $self->header(
1175         -nph => 1,
1176         -type => $type,
1177         (map { split "=", $_, 2 } @other),
1178     ) . $self->multipart_end;
1179 }
1180 END_OF_FUNC
1181
1182
1183 #### Method: multipart_start
1184 # Return a Content-Type: style header for server-push, start of section
1185 #
1186 # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1187 # contribution
1188 ####
1189 'multipart_start' => <<'END_OF_FUNC',
1190 sub multipart_start {
1191     my($self,@p) = self_or_default(@_);
1192     my($type,@other) = $self->rearrange([TYPE],@p);
1193     $type = $type || 'text/html';
1194     return $self->header(
1195         -type => $type,
1196         (map { split "=", $_, 2 } @other),
1197     );
1198 }
1199 END_OF_FUNC
1200
1201
1202 #### Method: multipart_end
1203 # Return a Content-Type: style header for server-push, end of section
1204 #
1205 # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1206 # contribution
1207 ####
1208 'multipart_end' => <<'END_OF_FUNC',
1209 sub multipart_end {
1210     my($self,@p) = self_or_default(@_);
1211     return $self->{'separator'};
1212 }
1213 END_OF_FUNC
1214
1215
1216 #### Method: header
1217 # Return a Content-Type: style header
1218 #
1219 ####
1220 'header' => <<'END_OF_FUNC',
1221 sub header {
1222     my($self,@p) = self_or_default(@_);
1223     my(@header);
1224
1225     return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
1226
1227     my($type,$status,$cookie,$target,$expires,$nph,@other) = 
1228         $self->rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
1229                           STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
1230
1231     $nph ||= $NPH;
1232     # rearrange() was designed for the HTML portion, so we
1233     # need to fix it up a little.
1234     foreach (@other) {
1235         next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
1236         ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e;
1237     }
1238
1239     $type ||= 'text/html' unless defined($type);
1240
1241     # Maybe future compatibility.  Maybe not.
1242     my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
1243     push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
1244
1245     push(@header,"Status: $status") if $status;
1246     push(@header,"Window-Target: $target") if $target;
1247     # push all the cookies -- there may be several
1248     if ($cookie) {
1249         my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
1250         foreach (@cookie) {
1251             my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
1252             push(@header,"Set-Cookie: $cs") if $cs ne '';
1253         }
1254     }
1255     # if the user indicates an expiration time, then we need
1256     # both an Expires and a Date header (so that the browser is
1257     # uses OUR clock)
1258     push(@header,"Expires: " . expires($expires,'http'))
1259         if $expires;
1260     push(@header,"Date: " . expires(0,'http')) if $expires || $cookie;
1261     push(@header,"Pragma: no-cache") if $self->cache();
1262     push(@header,@other);
1263     push(@header,"Content-Type: $type") if $type ne '';
1264
1265     my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1266     if ($MOD_PERL and not $nph) {
1267         my $r = Apache->request;
1268         $r->send_cgi_header($header);
1269         return '';
1270     }
1271     return $header;
1272 }
1273 END_OF_FUNC
1274
1275
1276 #### Method: cache
1277 # Control whether header() will produce the no-cache
1278 # Pragma directive.
1279 ####
1280 'cache' => <<'END_OF_FUNC',
1281 sub cache {
1282     my($self,$new_value) = self_or_default(@_);
1283     $new_value = '' unless $new_value;
1284     if ($new_value ne '') {
1285         $self->{'cache'} = $new_value;
1286     }
1287     return $self->{'cache'};
1288 }
1289 END_OF_FUNC
1290
1291
1292 #### Method: redirect
1293 # Return a Location: style header
1294 #
1295 ####
1296 'redirect' => <<'END_OF_FUNC',
1297 sub redirect {
1298     my($self,@p) = self_or_default(@_);
1299     my($url,$target,$cookie,$nph,@other) = $self->rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p);
1300     $url = $url || $self->self_url;
1301     my(@o);
1302     foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
1303     unshift(@o,
1304          '-Status'=>'302 Moved',
1305          '-Location'=>$url,
1306          '-nph'=>$nph);
1307     unshift(@o,'-Target'=>$target) if $target;
1308     unshift(@o,'-Cookie'=>$cookie) if $cookie;
1309     unshift(@o,'-Type'=>'');
1310     return $self->header(@o);
1311 }
1312 END_OF_FUNC
1313
1314
1315 #### Method: start_html
1316 # Canned HTML header
1317 #
1318 # Parameters:
1319 # $title -> (optional) The title for this HTML document (-title)
1320 # $author -> (optional) e-mail address of the author (-author)
1321 # $base -> (optional) if set to true, will enter the BASE address of this document
1322 #          for resolving relative references (-base) 
1323 # $xbase -> (optional) alternative base at some remote location (-xbase)
1324 # $target -> (optional) target window to load all links into (-target)
1325 # $script -> (option) Javascript code (-script)
1326 # $no_script -> (option) Javascript <noscript> tag (-noscript)
1327 # $meta -> (optional) Meta information tags
1328 # $head -> (optional) any other elements you'd like to incorporate into the <HEAD> tag
1329 #           (a scalar or array ref)
1330 # $style -> (optional) reference to an external style sheet
1331 # @other -> (optional) any other named parameters you'd like to incorporate into
1332 #           the <BODY> tag.
1333 ####
1334 'start_html' => <<'END_OF_FUNC',
1335 sub start_html {
1336     my($self,@p) = &self_or_default(@_);
1337     my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,@other) = 
1338         $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD],@p);
1339
1340     # strangely enough, the title needs to be escaped as HTML
1341     # while the author needs to be escaped as a URL
1342     $title = $self->escapeHTML($title || 'Untitled Document');
1343     $author = $self->escape($author);
1344     my(@result);
1345     $dtd = $DEFAULT_DTD unless $dtd && $dtd =~ m|^-//|;
1346     push(@result,qq(<!DOCTYPE HTML PUBLIC "$dtd">)) if $dtd;
1347     push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
1348     push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if defined $author;
1349
1350     if ($base || $xbase || $target) {
1351         my $href = $xbase || $self->url('-path'=>1);
1352         my $t = $target ? qq/ TARGET="$target"/ : '';
1353         push(@result,qq/<BASE HREF="$href"$t>/);
1354     }
1355
1356     if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
1357         foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
1358     }
1359
1360     push(@result,ref($head) ? @$head : $head) if $head;
1361
1362     # handle the infrequently-used -style and -script parameters
1363     push(@result,$self->_style($style)) if defined $style;
1364     push(@result,$self->_script($script)) if defined $script;
1365
1366     # handle -noscript parameter
1367     push(@result,<<END) if $noscript;
1368 <NOSCRIPT>
1369 $noscript
1370 </NOSCRIPT>
1371 END
1372     ;
1373     my($other) = @other ? " @other" : '';
1374     push(@result,"</HEAD><BODY$other>");
1375     return join("\n",@result);
1376 }
1377 END_OF_FUNC
1378
1379 ### Method: _style
1380 # internal method for generating a CSS style section
1381 ####
1382 '_style' => <<'END_OF_FUNC',
1383 sub _style {
1384     my ($self,$style) = @_;
1385     my (@result);
1386     my $type = 'text/css';
1387     if (ref($style)) {
1388         my($src,$code,$stype,@other) =
1389             $self->rearrange([SRC,CODE,TYPE],
1390                              '-foo'=>'bar',     # a trick to allow the '-' to be omitted
1391                              ref($style) eq 'ARRAY' ? @$style : %$style);
1392         $type = $stype if $stype;
1393         push(@result,qq/<LINK REL="stylesheet" TYPE="$type" HREF="$src">/) if $src;
1394         push(@result,style({'type'=>$type},"<!--\n$code\n-->")) if $code;
1395     } else {
1396         push(@result,style({'type'=>$type},"<!--\n$style\n-->"));
1397     }
1398     @result;
1399 }
1400 END_OF_FUNC
1401
1402
1403 '_script' => <<'END_OF_FUNC',
1404 sub _script {
1405     my ($self,$script) = @_;
1406     my (@result);
1407     my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
1408     foreach $script (@scripts) {
1409         my($src,$code,$language);
1410         if (ref($script)) { # script is a hash
1411             ($src,$code,$language) =
1412                 $self->rearrange([SRC,CODE,LANGUAGE],
1413                                  '-foo'=>'bar', # a trick to allow the '-' to be omitted
1414                                  ref($script) eq 'ARRAY' ? @$script : %$script);
1415             
1416         } else {
1417             ($src,$code,$language) = ('',$script,'JavaScript');
1418         }
1419         my(@satts);
1420         push(@satts,'src'=>$src) if $src;
1421         push(@satts,'language'=>$language || 'JavaScript');
1422         $code = "<!-- Hide script\n$code\n// End script hiding -->"
1423             if $code && $language=~/javascript/i;
1424         $code = "<!-- Hide script\n$code\n\# End script hiding -->"
1425             if $code && $language=~/perl/i;
1426         push(@result,script({@satts},$code || ''));
1427     }
1428     @result;
1429 }
1430 END_OF_FUNC
1431
1432 #### Method: end_html
1433 # End an HTML document.
1434 # Trivial method for completeness.  Just returns "</BODY>"
1435 ####
1436 'end_html' => <<'END_OF_FUNC',
1437 sub end_html {
1438     return "</BODY></HTML>";
1439 }
1440 END_OF_FUNC
1441
1442
1443 ################################
1444 # METHODS USED IN BUILDING FORMS
1445 ################################
1446
1447 #### Method: isindex
1448 # Just prints out the isindex tag.
1449 # Parameters:
1450 #  $action -> optional URL of script to run
1451 # Returns:
1452 #   A string containing a <ISINDEX> tag
1453 'isindex' => <<'END_OF_FUNC',
1454 sub isindex {
1455     my($self,@p) = self_or_default(@_);
1456     my($action,@other) = $self->rearrange([ACTION],@p);
1457     $action = qq/ACTION="$action"/ if $action;
1458     my($other) = @other ? " @other" : '';
1459     return "<ISINDEX $action$other>";
1460 }
1461 END_OF_FUNC
1462
1463
1464 #### Method: startform
1465 # Start a form
1466 # Parameters:
1467 #   $method -> optional submission method to use (GET or POST)
1468 #   $action -> optional URL of script to run
1469 #   $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1470 'startform' => <<'END_OF_FUNC',
1471 sub startform {
1472     my($self,@p) = self_or_default(@_);
1473
1474     my($method,$action,$enctype,@other) = 
1475         $self->rearrange([METHOD,ACTION,ENCTYPE],@p);
1476
1477     $method = $method || 'POST';
1478     $enctype = $enctype || &URL_ENCODED;
1479     $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
1480         'ACTION="'.$self->script_name.'"' : '';
1481     my($other) = @other ? " @other" : '';
1482     $self->{'.parametersToAdd'}={};
1483     return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
1484 }
1485 END_OF_FUNC
1486
1487
1488 #### Method: start_form
1489 # synonym for startform
1490 'start_form' => <<'END_OF_FUNC',
1491 sub start_form {
1492     &startform;
1493 }
1494 END_OF_FUNC
1495
1496 'end_multipart_form' => <<'END_OF_FUNC',
1497 sub end_multipart_form {
1498     &endform;
1499 }
1500 END_OF_FUNC
1501
1502 #### Method: start_multipart_form
1503 # synonym for startform
1504 'start_multipart_form' => <<'END_OF_FUNC',
1505 sub start_multipart_form {
1506     my($self,@p) = self_or_default(@_);
1507     if ($self->use_named_parameters || 
1508         (defined($param[0]) && substr($param[0],0,1) eq '-')) {
1509         my(%p) = @p;
1510         $p{'-enctype'}=&MULTIPART;
1511         return $self->startform(%p);
1512     } else {
1513         my($method,$action,@other) = 
1514             $self->rearrange([METHOD,ACTION],@p);
1515         return $self->startform($method,$action,&MULTIPART,@other);
1516     }
1517 }
1518 END_OF_FUNC
1519
1520
1521 #### Method: endform
1522 # End a form
1523 'endform' => <<'END_OF_FUNC',
1524 sub endform {
1525     my($self,@p) = self_or_default(@_);    
1526     return wantarray ? ($self->get_fields,"</FORM>") : 
1527                         $self->get_fields ."\n</FORM>";
1528 }
1529 END_OF_FUNC
1530
1531
1532 #### Method: end_form
1533 # synonym for endform
1534 'end_form' => <<'END_OF_FUNC',
1535 sub end_form {
1536     &endform;
1537 }
1538 END_OF_FUNC
1539
1540
1541 '_textfield' => <<'END_OF_FUNC',
1542 sub _textfield {
1543     my($self,$tag,@p) = self_or_default(@_);
1544     my($name,$default,$size,$maxlength,$override,@other) = 
1545         $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1546
1547     my $current = $override ? $default : 
1548         (defined($self->param($name)) ? $self->param($name) : $default);
1549
1550     $current = defined($current) ? $self->escapeHTML($current) : '';
1551     $name = defined($name) ? $self->escapeHTML($name) : '';
1552     my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1553     my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
1554     my($other) = @other ? " @other" : '';
1555     # this entered at cristy's request to fix problems with file upload fields
1556     # and WebTV -- not sure it won't break stuff
1557     my($value) = $current ne '' ? qq(VALUE="$current") : '';
1558     return qq/<INPUT TYPE="$tag" NAME="$name" $value$s$m$other>/;
1559 }
1560 END_OF_FUNC
1561
1562 #### Method: textfield
1563 # Parameters:
1564 #   $name -> Name of the text field
1565 #   $default -> Optional default value of the field if not
1566 #                already defined.
1567 #   $size ->  Optional width of field in characaters.
1568 #   $maxlength -> Optional maximum number of characters.
1569 # Returns:
1570 #   A string containing a <INPUT TYPE="text"> field
1571 #
1572 'textfield' => <<'END_OF_FUNC',
1573 sub textfield {
1574     my($self,@p) = self_or_default(@_);
1575     $self->_textfield('text',@p);
1576 }
1577 END_OF_FUNC
1578
1579
1580 #### Method: filefield
1581 # Parameters:
1582 #   $name -> Name of the file upload field
1583 #   $size ->  Optional width of field in characaters.
1584 #   $maxlength -> Optional maximum number of characters.
1585 # Returns:
1586 #   A string containing a <INPUT TYPE="text"> field
1587 #
1588 'filefield' => <<'END_OF_FUNC',
1589 sub filefield {
1590     my($self,@p) = self_or_default(@_);
1591     $self->_textfield('file',@p);
1592 }
1593 END_OF_FUNC
1594
1595
1596 #### Method: password
1597 # Create a "secret password" entry field
1598 # Parameters:
1599 #   $name -> Name of the field
1600 #   $default -> Optional default value of the field if not
1601 #                already defined.
1602 #   $size ->  Optional width of field in characters.
1603 #   $maxlength -> Optional maximum characters that can be entered.
1604 # Returns:
1605 #   A string containing a <INPUT TYPE="password"> field
1606 #
1607 'password_field' => <<'END_OF_FUNC',
1608 sub password_field {
1609     my ($self,@p) = self_or_default(@_);
1610     $self->_textfield('password',@p);
1611 }
1612 END_OF_FUNC
1613
1614 #### Method: textarea
1615 # Parameters:
1616 #   $name -> Name of the text field
1617 #   $default -> Optional default value of the field if not
1618 #                already defined.
1619 #   $rows ->  Optional number of rows in text area
1620 #   $columns -> Optional number of columns in text area
1621 # Returns:
1622 #   A string containing a <TEXTAREA></TEXTAREA> tag
1623 #
1624 'textarea' => <<'END_OF_FUNC',
1625 sub textarea {
1626     my($self,@p) = self_or_default(@_);
1627     
1628     my($name,$default,$rows,$cols,$override,@other) =
1629         $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
1630
1631     my($current)= $override ? $default :
1632         (defined($self->param($name)) ? $self->param($name) : $default);
1633
1634     $name = defined($name) ? $self->escapeHTML($name) : '';
1635     $current = defined($current) ? $self->escapeHTML($current) : '';
1636     my($r) = $rows ? " ROWS=$rows" : '';
1637     my($c) = $cols ? " COLS=$cols" : '';
1638     my($other) = @other ? " @other" : '';
1639     return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
1640 }
1641 END_OF_FUNC
1642
1643
1644 #### Method: button
1645 # Create a javascript button.
1646 # Parameters:
1647 #   $name ->  (optional) Name for the button. (-name)
1648 #   $value -> (optional) Value of the button when selected (and visible name) (-value)
1649 #   $onclick -> (optional) Text of the JavaScript to run when the button is
1650 #                clicked.
1651 # Returns:
1652 #   A string containing a <INPUT TYPE="button"> tag
1653 ####
1654 'button' => <<'END_OF_FUNC',
1655 sub button {
1656     my($self,@p) = self_or_default(@_);
1657
1658     my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
1659                                                          [ONCLICK,SCRIPT]],@p);
1660
1661     $label=$self->escapeHTML($label);
1662     $value=$self->escapeHTML($value);
1663     $script=$self->escapeHTML($script);
1664
1665     my($name) = '';
1666     $name = qq/ NAME="$label"/ if $label;
1667     $value = $value || $label;
1668     my($val) = '';
1669     $val = qq/ VALUE="$value"/ if $value;
1670     $script = qq/ ONCLICK="$script"/ if $script;
1671     my($other) = @other ? " @other" : '';
1672     return qq/<INPUT TYPE="button"$name$val$script$other>/;
1673 }
1674 END_OF_FUNC
1675
1676
1677 #### Method: submit
1678 # Create a "submit query" button.
1679 # Parameters:
1680 #   $name ->  (optional) Name for the button.
1681 #   $value -> (optional) Value of the button when selected (also doubles as label).
1682 #   $label -> (optional) Label printed on the button(also doubles as the value).
1683 # Returns:
1684 #   A string containing a <INPUT TYPE="submit"> tag
1685 ####
1686 'submit' => <<'END_OF_FUNC',
1687 sub submit {
1688     my($self,@p) = self_or_default(@_);
1689
1690     my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p);
1691
1692     $label=$self->escapeHTML($label);
1693     $value=$self->escapeHTML($value);
1694
1695     my($name) = ' NAME=".submit"';
1696     $name = qq/ NAME="$label"/ if defined($label);
1697     $value = defined($value) ? $value : $label;
1698     my($val) = '';
1699     $val = qq/ VALUE="$value"/ if defined($value);
1700     my($other) = @other ? " @other" : '';
1701     return qq/<INPUT TYPE="submit"$name$val$other>/;
1702 }
1703 END_OF_FUNC
1704
1705
1706 #### Method: reset
1707 # Create a "reset" button.
1708 # Parameters:
1709 #   $name -> (optional) Name for the button.
1710 # Returns:
1711 #   A string containing a <INPUT TYPE="reset"> tag
1712 ####
1713 'reset' => <<'END_OF_FUNC',
1714 sub reset {
1715     my($self,@p) = self_or_default(@_);
1716     my($label,@other) = $self->rearrange([NAME],@p);
1717     $label=$self->escapeHTML($label);
1718     my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
1719     my($other) = @other ? " @other" : '';
1720     return qq/<INPUT TYPE="reset"$value$other>/;
1721 }
1722 END_OF_FUNC
1723
1724
1725 #### Method: defaults
1726 # Create a "defaults" button.
1727 # Parameters:
1728 #   $name -> (optional) Name for the button.
1729 # Returns:
1730 #   A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
1731 #
1732 # Note: this button has a special meaning to the initialization script,
1733 # and tells it to ERASE the current query string so that your defaults
1734 # are used again!
1735 ####
1736 'defaults' => <<'END_OF_FUNC',
1737 sub defaults {
1738     my($self,@p) = self_or_default(@_);
1739
1740     my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
1741
1742     $label=$self->escapeHTML($label);
1743     $label = $label || "Defaults";
1744     my($value) = qq/ VALUE="$label"/;
1745     my($other) = @other ? " @other" : '';
1746     return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
1747 }
1748 END_OF_FUNC
1749
1750
1751 #### Method: comment
1752 # Create an HTML <!-- comment -->
1753 # Parameters: a string
1754 'comment' => <<'END_OF_FUNC',
1755 sub comment {
1756     my($self,@p) = self_or_CGI(@_);
1757     return "<!-- @p -->";
1758 }
1759 END_OF_FUNC
1760
1761 #### Method: checkbox
1762 # Create a checkbox that is not logically linked to any others.
1763 # The field value is "on" when the button is checked.
1764 # Parameters:
1765 #   $name -> Name of the checkbox
1766 #   $checked -> (optional) turned on by default if true
1767 #   $value -> (optional) value of the checkbox, 'on' by default
1768 #   $label -> (optional) a user-readable label printed next to the box.
1769 #             Otherwise the checkbox name is used.
1770 # Returns:
1771 #   A string containing a <INPUT TYPE="checkbox"> field
1772 ####
1773 'checkbox' => <<'END_OF_FUNC',
1774 sub checkbox {
1775     my($self,@p) = self_or_default(@_);
1776
1777     my($name,$checked,$value,$label,$override,@other) = 
1778         $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
1779     
1780     $value = defined $value ? $value : 'on';
1781
1782     if (!$override && ($self->{'.fieldnames'}->{$name} || 
1783                        defined $self->param($name))) {
1784         $checked = grep($_ eq $value,$self->param($name)) ? ' CHECKED' : '';
1785     } else {
1786         $checked = $checked ? ' CHECKED' : '';
1787     }
1788     my($the_label) = defined $label ? $label : $name;
1789     $name = $self->escapeHTML($name);
1790     $value = $self->escapeHTML($value);
1791     $the_label = $self->escapeHTML($the_label);
1792     my($other) = @other ? " @other" : '';
1793     $self->register_parameter($name);
1794     return qq{<INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label};
1795 }
1796 END_OF_FUNC
1797
1798
1799 #### Method: checkbox_group
1800 # Create a list of logically-linked checkboxes.
1801 # Parameters:
1802 #   $name -> Common name for all the check boxes
1803 #   $values -> A pointer to a regular array containing the
1804 #             values for each checkbox in the group.
1805 #   $defaults -> (optional)
1806 #             1. If a pointer to a regular array of checkbox values,
1807 #             then this will be used to decide which
1808 #             checkboxes to turn on by default.
1809 #             2. If a scalar, will be assumed to hold the
1810 #             value of a single checkbox in the group to turn on. 
1811 #   $linebreak -> (optional) Set to true to place linebreaks
1812 #             between the buttons.
1813 #   $labels -> (optional)
1814 #             A pointer to an associative array of labels to print next to each checkbox
1815 #             in the form $label{'value'}="Long explanatory label".
1816 #             Otherwise the provided values are used as the labels.
1817 # Returns:
1818 #   An ARRAY containing a series of <INPUT TYPE="checkbox"> fields
1819 ####
1820 'checkbox_group' => <<'END_OF_FUNC',
1821 sub checkbox_group {
1822     my($self,@p) = self_or_default(@_);
1823
1824     my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
1825        $rowheaders,$colheaders,$override,$nolabels,@other) =
1826         $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1827                           LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
1828                           ROWHEADERS,COLHEADERS,
1829                           [OVERRIDE,FORCE],NOLABELS],@p);
1830
1831     my($checked,$break,$result,$label);
1832
1833     my(%checked) = $self->previous_or_default($name,$defaults,$override);
1834
1835     $break = $linebreak ? "<BR>" : '';
1836     $name=$self->escapeHTML($name);
1837
1838     # Create the elements
1839     my(@elements,@values);
1840
1841     @values = $self->_set_values_and_labels($values,\$labels,$name);
1842
1843     my($other) = @other ? " @other" : '';
1844     foreach (@values) {
1845         $checked = $checked{$_} ? ' CHECKED' : '';
1846         $label = '';
1847         unless (defined($nolabels) && $nolabels) {
1848             $label = $_;
1849             $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1850             $label = $self->escapeHTML($label);
1851         }
1852         $_ = $self->escapeHTML($_);
1853         push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label}${break}/);
1854     }
1855     $self->register_parameter($name);
1856     return wantarray ? @elements : join(' ',@elements)            
1857         unless defined($columns) || defined($rows);
1858     return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1859 }
1860 END_OF_FUNC
1861
1862 # Escape HTML -- used internally
1863 'escapeHTML' => <<'END_OF_FUNC',
1864 sub escapeHTML {
1865     my ($self,$toencode) = self_or_default(@_);
1866     return undef unless defined($toencode);
1867     return $toencode if ref($self) && $self->{'dontescape'};
1868
1869     $toencode=~s/&/&amp;/g;
1870     $toencode=~s/\"/&quot;/g;
1871     $toencode=~s/>/&gt;/g;
1872     $toencode=~s/</&lt;/g;
1873     return $toencode;
1874 }
1875 END_OF_FUNC
1876
1877 # unescape HTML -- used internally
1878 'unescapeHTML' => <<'END_OF_FUNC',
1879 sub unescapeHTML {
1880     my $string = ref($_[0]) ? $_[1] : $_[0];
1881     return undef unless defined($string);
1882     # thanks to Randal Schwartz for the correct solution to this one
1883     $string=~ s[&(.*?);]{
1884         local $_ = $1;
1885         /^amp$/i        ? "&" :
1886         /^quot$/i       ? '"' :
1887         /^gt$/i         ? ">" :
1888         /^lt$/i         ? "<" :
1889         /^#(\d+)$/      ? chr($1) :
1890         /^#x([0-9a-f]+)$/i ? chr(hex($1)) :
1891         $_
1892         }gex;
1893     return $string;
1894 }
1895 END_OF_FUNC
1896
1897 # Internal procedure - don't use
1898 '_tableize' => <<'END_OF_FUNC',
1899 sub _tableize {
1900     my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
1901     my($result);
1902
1903     if (defined($columns)) {
1904         $rows = int(0.99 + @elements/$columns) unless defined($rows);
1905     }
1906     if (defined($rows)) {
1907         $columns = int(0.99 + @elements/$rows) unless defined($columns);
1908     }
1909     
1910     # rearrange into a pretty table
1911     $result = "<TABLE>";
1912     my($row,$column);
1913     unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
1914     $result .= "<TR>" if @$colheaders;
1915     foreach (@{$colheaders}) {
1916         $result .= "<TH>$_</TH>";
1917     }
1918     for ($row=0;$row<$rows;$row++) {
1919         $result .= "<TR>";
1920         $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
1921         for ($column=0;$column<$columns;$column++) {
1922             $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>"
1923                 if defined($elements[$column*$rows + $row]);
1924         }
1925         $result .= "</TR>";
1926     }
1927     $result .= "</TABLE>";
1928     return $result;
1929 }
1930 END_OF_FUNC
1931
1932
1933 #### Method: radio_group
1934 # Create a list of logically-linked radio buttons.
1935 # Parameters:
1936 #   $name -> Common name for all the buttons.
1937 #   $values -> A pointer to a regular array containing the
1938 #             values for each button in the group.
1939 #   $default -> (optional) Value of the button to turn on by default.  Pass '-'
1940 #               to turn _nothing_ on.
1941 #   $linebreak -> (optional) Set to true to place linebreaks
1942 #             between the buttons.
1943 #   $labels -> (optional)
1944 #             A pointer to an associative array of labels to print next to each checkbox
1945 #             in the form $label{'value'}="Long explanatory label".
1946 #             Otherwise the provided values are used as the labels.
1947 # Returns:
1948 #   An ARRAY containing a series of <INPUT TYPE="radio"> fields
1949 ####
1950 'radio_group' => <<'END_OF_FUNC',
1951 sub radio_group {
1952     my($self,@p) = self_or_default(@_);
1953
1954     my($name,$values,$default,$linebreak,$labels,
1955        $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
1956         $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
1957                           ROWS,[COLUMNS,COLS],
1958                           ROWHEADERS,COLHEADERS,
1959                           [OVERRIDE,FORCE],NOLABELS],@p);
1960     my($result,$checked);
1961
1962     if (!$override && defined($self->param($name))) {
1963         $checked = $self->param($name);
1964     } else {
1965         $checked = $default;
1966     }
1967     my(@elements,@values);
1968     @values = $self->_set_values_and_labels($values,\$labels,$name);
1969
1970     # If no check array is specified, check the first by default
1971     $checked = $values[0] unless defined($checked) && $checked ne '';
1972     $name=$self->escapeHTML($name);
1973
1974     my($other) = @other ? " @other" : '';
1975     foreach (@values) {
1976         my($checkit) = $checked eq $_ ? ' CHECKED' : '';
1977         my($break) = $linebreak ? '<BR>' : '';
1978         my($label)='';
1979         unless (defined($nolabels) && $nolabels) {
1980             $label = $_;
1981             $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1982             $label = $self->escapeHTML($label);
1983         }
1984         $_=$self->escapeHTML($_);
1985         push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label}${break}/);
1986     }
1987     $self->register_parameter($name);
1988     return wantarray ? @elements : join(' ',@elements) 
1989            unless defined($columns) || defined($rows);
1990     return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1991 }
1992 END_OF_FUNC
1993
1994
1995 #### Method: popup_menu
1996 # Create a popup menu.
1997 # Parameters:
1998 #   $name -> Name for all the menu
1999 #   $values -> A pointer to a regular array containing the
2000 #             text of each menu item.
2001 #   $default -> (optional) Default item to display
2002 #   $labels -> (optional)
2003 #             A pointer to an associative array of labels to print next to each checkbox
2004 #             in the form $label{'value'}="Long explanatory label".
2005 #             Otherwise the provided values are used as the labels.
2006 # Returns:
2007 #   A string containing the definition of a popup menu.
2008 ####
2009 'popup_menu' => <<'END_OF_FUNC',
2010 sub popup_menu {
2011     my($self,@p) = self_or_default(@_);
2012
2013     my($name,$values,$default,$labels,$override,@other) =
2014         $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
2015     my($result,$selected);
2016
2017     if (!$override && defined($self->param($name))) {
2018         $selected = $self->param($name);
2019     } else {
2020         $selected = $default;
2021     }
2022     $name=$self->escapeHTML($name);
2023     my($other) = @other ? " @other" : '';
2024
2025     my(@values);
2026     @values = $self->_set_values_and_labels($values,\$labels,$name);
2027
2028     $result = qq/<SELECT NAME="$name"$other>\n/;
2029     foreach (@values) {
2030         my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
2031         my($label) = $_;
2032         $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2033         my($value) = $self->escapeHTML($_);
2034         $label=$self->escapeHTML($label);
2035         $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
2036     }
2037
2038     $result .= "</SELECT>\n";
2039     return $result;
2040 }
2041 END_OF_FUNC
2042
2043
2044 #### Method: scrolling_list
2045 # Create a scrolling list.
2046 # Parameters:
2047 #   $name -> name for the list
2048 #   $values -> A pointer to a regular array containing the
2049 #             values for each option line in the list.
2050 #   $defaults -> (optional)
2051 #             1. If a pointer to a regular array of options,
2052 #             then this will be used to decide which
2053 #             lines to turn on by default.
2054 #             2. Otherwise holds the value of the single line to turn on.
2055 #   $size -> (optional) Size of the list.
2056 #   $multiple -> (optional) If set, allow multiple selections.
2057 #   $labels -> (optional)
2058 #             A pointer to an associative array of labels to print next to each checkbox
2059 #             in the form $label{'value'}="Long explanatory label".
2060 #             Otherwise the provided values are used as the labels.
2061 # Returns:
2062 #   A string containing the definition of a scrolling list.
2063 ####
2064 'scrolling_list' => <<'END_OF_FUNC',
2065 sub scrolling_list {
2066     my($self,@p) = self_or_default(@_);
2067     my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
2068         = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
2069                             SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
2070
2071     my($result,@values);
2072     @values = $self->_set_values_and_labels($values,\$labels,$name);
2073
2074     $size = $size || scalar(@values);
2075
2076     my(%selected) = $self->previous_or_default($name,$defaults,$override);
2077     my($is_multiple) = $multiple ? ' MULTIPLE' : '';
2078     my($has_size) = $size ? " SIZE=$size" : '';
2079     my($other) = @other ? " @other" : '';
2080
2081     $name=$self->escapeHTML($name);
2082     $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
2083     foreach (@values) {
2084         my($selectit) = $selected{$_} ? 'SELECTED' : '';
2085         my($label) = $_;
2086         $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2087         $label=$self->escapeHTML($label);
2088         my($value)=$self->escapeHTML($_);
2089         $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
2090     }
2091     $result .= "</SELECT>\n";
2092     $self->register_parameter($name);
2093     return $result;
2094 }
2095 END_OF_FUNC
2096
2097
2098 #### Method: hidden
2099 # Parameters:
2100 #   $name -> Name of the hidden field
2101 #   @default -> (optional) Initial values of field (may be an array)
2102 #      or
2103 #   $default->[initial values of field]
2104 # Returns:
2105 #   A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
2106 ####
2107 'hidden' => <<'END_OF_FUNC',
2108 sub hidden {
2109     my($self,@p) = self_or_default(@_);
2110
2111     # this is the one place where we departed from our standard
2112     # calling scheme, so we have to special-case (darn)
2113     my(@result,@value);
2114     my($name,$default,$override,@other) = 
2115         $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
2116
2117     my $do_override = 0;
2118     if ( ref($p[0]) || substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
2119         @value = ref($default) ? @{$default} : $default;
2120         $do_override = $override;
2121     } else {
2122         foreach ($default,$override,@other) {
2123             push(@value,$_) if defined($_);
2124         }
2125     }
2126
2127     # use previous values if override is not set
2128     my @prev = $self->param($name);
2129     @value = @prev if !$do_override && @prev;
2130
2131     $name=$self->escapeHTML($name);
2132     foreach (@value) {
2133         $_ = defined($_) ? $self->escapeHTML($_) : '';
2134         push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
2135     }
2136     return wantarray ? @result : join('',@result);
2137 }
2138 END_OF_FUNC
2139
2140
2141 #### Method: image_button
2142 # Parameters:
2143 #   $name -> Name of the button
2144 #   $src ->  URL of the image source
2145 #   $align -> Alignment style (TOP, BOTTOM or MIDDLE)
2146 # Returns:
2147 #   A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment">
2148 ####
2149 'image_button' => <<'END_OF_FUNC',
2150 sub image_button {
2151     my($self,@p) = self_or_default(@_);
2152
2153     my($name,$src,$alignment,@other) =
2154         $self->rearrange([NAME,SRC,ALIGN],@p);
2155
2156     my($align) = $alignment ? " ALIGN=\U$alignment" : '';
2157     my($other) = @other ? " @other" : '';
2158     $name=$self->escapeHTML($name);
2159     return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/;
2160 }
2161 END_OF_FUNC
2162
2163
2164 #### Method: self_url
2165 # Returns a URL containing the current script and all its
2166 # param/value pairs arranged as a query.  You can use this
2167 # to create a link that, when selected, will reinvoke the
2168 # script with all its state information preserved.
2169 ####
2170 'self_url' => <<'END_OF_FUNC',
2171 sub self_url {
2172     my($self,@p) = self_or_default(@_);
2173     return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
2174 }
2175 END_OF_FUNC
2176
2177
2178 # This is provided as a synonym to self_url() for people unfortunate
2179 # enough to have incorporated it into their programs already!
2180 'state' => <<'END_OF_FUNC',
2181 sub state {
2182     &self_url;
2183 }
2184 END_OF_FUNC
2185
2186
2187 #### Method: url
2188 # Like self_url, but doesn't return the query string part of
2189 # the URL.
2190 ####
2191 'url' => <<'END_OF_FUNC',
2192 sub url {
2193     my($self,@p) = self_or_default(@_);
2194     my ($relative,$absolute,$full,$path_info,$query) = 
2195         $self->rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING']],@p);
2196     my $url;
2197     $full++ if !($relative || $absolute);
2198
2199     my $path = $self->path_info;
2200     my $script_name;
2201     if (exists($ENV{REQUEST_URI})) {
2202         my $index;
2203         $script_name = $ENV{REQUEST_URI};
2204         # strip query string
2205         substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0;
2206         # and path
2207         substr($script_name,$index) = '' if exists($ENV{PATH_INFO})
2208                                      and ($index = rindex($script_name,$ENV{PATH_INFO})) >= 0;
2209     } else {
2210         $script_name = $self->script_name;
2211     }
2212
2213     if ($full) {
2214         my $protocol = $self->protocol();
2215         $url = "$protocol://";
2216         my $vh = http('host');
2217         if ($vh) {
2218             $url .= $vh;
2219         } else {
2220             $url .= server_name();
2221             my $port = $self->server_port;
2222             $url .= ":" . $port
2223                 unless (lc($protocol) eq 'http' && $port == 80)
2224                     || (lc($protocol) eq 'https' && $port == 443);
2225         }
2226         $url .= $script_name;
2227     } elsif ($relative) {
2228         ($url) = $script_name =~ m!([^/]+)$!;
2229     } elsif ($absolute) {
2230         $url = $script_name;
2231     }
2232     $url .= $path if $path_info and defined $path;
2233     $url .= "?" . $self->query_string if $query and $self->query_string;
2234     return $url;
2235 }
2236
2237 END_OF_FUNC
2238
2239 #### Method: cookie
2240 # Set or read a cookie from the specified name.
2241 # Cookie can then be passed to header().
2242 # Usual rules apply to the stickiness of -value.
2243 #  Parameters:
2244 #   -name -> name for this cookie (optional)
2245 #   -value -> value of this cookie (scalar, array or hash) 
2246 #   -path -> paths for which this cookie is valid (optional)
2247 #   -domain -> internet domain in which this cookie is valid (optional)
2248 #   -secure -> if true, cookie only passed through secure channel (optional)
2249 #   -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
2250 ####
2251 'cookie' => <<'END_OF_FUNC',
2252 sub cookie {
2253     my($self,@p) = self_or_default(@_);
2254     my($name,$value,$path,$domain,$secure,$expires) =
2255         $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
2256
2257     require CGI::Cookie;
2258
2259     # if no value is supplied, then we retrieve the
2260     # value of the cookie, if any.  For efficiency, we cache the parsed
2261     # cookies in our state variables.
2262     unless ( defined($value) ) {
2263         $self->{'.cookies'} = CGI::Cookie->fetch
2264             unless $self->{'.cookies'};
2265
2266         # If no name is supplied, then retrieve the names of all our cookies.
2267         return () unless $self->{'.cookies'};
2268         return keys %{$self->{'.cookies'}} unless $name;
2269         return () unless $self->{'.cookies'}->{$name};
2270         return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
2271     }
2272
2273     # If we get here, we're creating a new cookie
2274     return undef unless $name;  # this is an error
2275
2276     my @param;
2277     push(@param,'-name'=>$name);
2278     push(@param,'-value'=>$value);
2279     push(@param,'-domain'=>$domain) if $domain;
2280     push(@param,'-path'=>$path) if $path;
2281     push(@param,'-expires'=>$expires) if $expires;
2282     push(@param,'-secure'=>$secure) if $secure;
2283
2284     return CGI::Cookie->new(@param);
2285 }
2286 END_OF_FUNC
2287
2288 # This internal routine creates an expires time exactly some number of
2289 # hours from the current time.  It incorporates modifications from 
2290 # Mark Fisher.
2291 'expire_calc' => <<'END_OF_FUNC',
2292 sub expire_calc {
2293     my($time) = @_;
2294     my(%mult) = ('s'=>1,
2295                  'm'=>60,
2296                  'h'=>60*60,
2297                  'd'=>60*60*24,
2298                  'M'=>60*60*24*30,
2299                  'y'=>60*60*24*365);
2300     # format for time can be in any of the forms...
2301     # "now" -- expire immediately
2302     # "+180s" -- in 180 seconds
2303     # "+2m" -- in 2 minutes
2304     # "+12h" -- in 12 hours
2305     # "+1d"  -- in 1 day
2306     # "+3M"  -- in 3 months
2307     # "+2y"  -- in 2 years
2308     # "-3m"  -- 3 minutes ago(!)
2309     # If you don't supply one of these forms, we assume you are
2310     # specifying the date yourself
2311     my($offset);
2312     if (!$time || (lc($time) eq 'now')) {
2313         $offset = 0;
2314     } elsif ($time=~/^\d+/) {
2315         return $time;
2316     } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
2317         $offset = ($mult{$2} || 1)*$1;
2318     } else {
2319         return $time;
2320     }
2321     return (time+$offset);
2322 }
2323 END_OF_FUNC
2324
2325 # This internal routine creates date strings suitable for use in
2326 # cookies and HTTP headers.  (They differ, unfortunately.)
2327 # Thanks to Mark Fisher for this.
2328 'expires' => <<'END_OF_FUNC',
2329 sub expires {
2330     my($time,$format) = @_;
2331     $format ||= 'http';
2332
2333     my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
2334     my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
2335
2336     # pass through preformatted dates for the sake of expire_calc()
2337     $time = expire_calc($time);
2338     return $time unless $time =~ /^\d+$/;
2339
2340     # make HTTP/cookie date string from GMT'ed time
2341     # (cookies use '-' as date separator, HTTP uses ' ')
2342     my($sc) = ' ';
2343     $sc = '-' if $format eq "cookie";
2344     my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
2345     $year += 1900;
2346     return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
2347                    $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
2348 }
2349 END_OF_FUNC
2350
2351 'parse_keywordlist' => <<'END_OF_FUNC',
2352 sub parse_keywordlist {
2353     my($self,$tosplit) = @_;
2354     $tosplit = unescape($tosplit); # unescape the keywords
2355     $tosplit=~tr/+/ /;          # pluses to spaces
2356     my(@keywords) = split(/\s+/,$tosplit);
2357     return @keywords;
2358 }
2359 END_OF_FUNC
2360
2361 'param_fetch' => <<'END_OF_FUNC',
2362 sub param_fetch {
2363     my($self,@p) = self_or_default(@_);
2364     my($name) = $self->rearrange([NAME],@p);
2365     unless (exists($self->{$name})) {
2366         $self->add_parameter($name);
2367         $self->{$name} = [];
2368     }
2369     
2370     return $self->{$name};
2371 }
2372 END_OF_FUNC
2373
2374 ###############################################
2375 # OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
2376 ###############################################
2377
2378 #### Method: path_info
2379 # Return the extra virtual path information provided
2380 # after the URL (if any)
2381 ####
2382 'path_info' => <<'END_OF_FUNC',
2383 sub path_info {
2384     my ($self,$info) = self_or_default(@_);
2385     if (defined($info)) {
2386         $info = "/$info" if $info ne '' &&  substr($info,0,1) ne '/';
2387         $self->{'.path_info'} = $info;
2388     } elsif (! defined($self->{'.path_info'}) ) {
2389         $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ? 
2390             $ENV{'PATH_INFO'} : '';
2391
2392         # hack to fix broken path info in IIS
2393         $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
2394
2395     }
2396     return $self->{'.path_info'};
2397 }
2398 END_OF_FUNC
2399
2400
2401 #### Method: request_method
2402 # Returns 'POST', 'GET', 'PUT' or 'HEAD'
2403 ####
2404 'request_method' => <<'END_OF_FUNC',
2405 sub request_method {
2406     return $ENV{'REQUEST_METHOD'};
2407 }
2408 END_OF_FUNC
2409
2410 #### Method: content_type
2411 # Returns the content_type string
2412 ####
2413 'content_type' => <<'END_OF_FUNC',
2414 sub content_type {
2415     return $ENV{'CONTENT_TYPE'};
2416 }
2417 END_OF_FUNC
2418
2419 #### Method: path_translated
2420 # Return the physical path information provided
2421 # by the URL (if any)
2422 ####
2423 'path_translated' => <<'END_OF_FUNC',
2424 sub path_translated {
2425     return $ENV{'PATH_TRANSLATED'};
2426 }
2427 END_OF_FUNC
2428
2429
2430 #### Method: query_string
2431 # Synthesize a query string from our current
2432 # parameters
2433 ####
2434 'query_string' => <<'END_OF_FUNC',
2435 sub query_string {
2436     my($self) = self_or_default(@_);
2437     my($param,$value,@pairs);
2438     foreach $param ($self->param) {
2439         my($eparam) = escape($param);
2440         foreach $value ($self->param($param)) {
2441             $value = escape($value);
2442             next unless defined $value;
2443             push(@pairs,"$eparam=$value");
2444         }
2445     }
2446     return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
2447 }
2448 END_OF_FUNC
2449
2450
2451 #### Method: accept
2452 # Without parameters, returns an array of the
2453 # MIME types the browser accepts.
2454 # With a single parameter equal to a MIME
2455 # type, will return undef if the browser won't
2456 # accept it, 1 if the browser accepts it but
2457 # doesn't give a preference, or a floating point
2458 # value between 0.0 and 1.0 if the browser
2459 # declares a quantitative score for it.
2460 # This handles MIME type globs correctly.
2461 ####
2462 'Accept' => <<'END_OF_FUNC',
2463 sub Accept {
2464     my($self,$search) = self_or_CGI(@_);
2465     my(%prefs,$type,$pref,$pat);
2466     
2467     my(@accept) = split(',',$self->http('accept'));
2468
2469     foreach (@accept) {
2470         ($pref) = /q=(\d\.\d+|\d+)/;
2471         ($type) = m#(\S+/[^;]+)#;
2472         next unless $type;
2473         $prefs{$type}=$pref || 1;
2474     }
2475
2476     return keys %prefs unless $search;
2477     
2478     # if a search type is provided, we may need to
2479     # perform a pattern matching operation.
2480     # The MIME types use a glob mechanism, which
2481     # is easily translated into a perl pattern match
2482
2483     # First return the preference for directly supported
2484     # types:
2485     return $prefs{$search} if $prefs{$search};
2486
2487     # Didn't get it, so try pattern matching.
2488     foreach (keys %prefs) {
2489         next unless /\*/;       # not a pattern match
2490         ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2491         $pat =~ s/\*/.*/g; # turn it into a pattern
2492         return $prefs{$_} if $search=~/$pat/;
2493     }
2494 }
2495 END_OF_FUNC
2496
2497
2498 #### Method: user_agent
2499 # If called with no parameters, returns the user agent.
2500 # If called with one parameter, does a pattern match (case
2501 # insensitive) on the user agent.
2502 ####
2503 'user_agent' => <<'END_OF_FUNC',
2504 sub user_agent {
2505     my($self,$match)=self_or_CGI(@_);
2506     return $self->http('user_agent') unless $match;
2507     return $self->http('user_agent') =~ /$match/i;
2508 }
2509 END_OF_FUNC
2510
2511
2512 #### Method: raw_cookie
2513 # Returns the magic cookies for the session.
2514 # The cookies are not parsed or altered in any way, i.e.
2515 # cookies are returned exactly as given in the HTTP
2516 # headers.  If a cookie name is given, only that cookie's
2517 # value is returned, otherwise the entire raw cookie
2518 # is returned.
2519 ####
2520 'raw_cookie' => <<'END_OF_FUNC',
2521 sub raw_cookie {
2522     my($self,$key) = self_or_CGI(@_);
2523
2524     require CGI::Cookie;
2525
2526     if (defined($key)) {
2527         $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
2528             unless $self->{'.raw_cookies'};
2529
2530         return () unless $self->{'.raw_cookies'};
2531         return () unless $self->{'.raw_cookies'}->{$key};
2532         return $self->{'.raw_cookies'}->{$key};
2533     }
2534     return $self->http('cookie') || $ENV{'COOKIE'} || '';
2535 }
2536 END_OF_FUNC
2537
2538 #### Method: virtual_host
2539 # Return the name of the virtual_host, which
2540 # is not always the same as the server
2541 ######
2542 'virtual_host' => <<'END_OF_FUNC',
2543 sub virtual_host {
2544     my $vh = http('host') || server_name();
2545     $vh =~ s/:\d+$//;           # get rid of port number
2546     return $vh;
2547 }
2548 END_OF_FUNC
2549
2550 #### Method: remote_host
2551 # Return the name of the remote host, or its IP
2552 # address if unavailable.  If this variable isn't
2553 # defined, it returns "localhost" for debugging
2554 # purposes.
2555 ####
2556 'remote_host' => <<'END_OF_FUNC',
2557 sub remote_host {
2558     return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} 
2559     || 'localhost';
2560 }
2561 END_OF_FUNC
2562
2563
2564 #### Method: remote_addr
2565 # Return the IP addr of the remote host.
2566 ####
2567 'remote_addr' => <<'END_OF_FUNC',
2568 sub remote_addr {
2569     return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
2570 }
2571 END_OF_FUNC
2572
2573
2574 #### Method: script_name
2575 # Return the partial URL to this script for
2576 # self-referencing scripts.  Also see
2577 # self_url(), which returns a URL with all state information
2578 # preserved.
2579 ####
2580 'script_name' => <<'END_OF_FUNC',
2581 sub script_name {
2582     return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'});
2583     # These are for debugging
2584     return "/$0" unless $0=~/^\//;
2585     return $0;
2586 }
2587 END_OF_FUNC
2588
2589
2590 #### Method: referer
2591 # Return the HTTP_REFERER: useful for generating
2592 # a GO BACK button.
2593 ####
2594 'referer' => <<'END_OF_FUNC',
2595 sub referer {
2596     my($self) = self_or_CGI(@_);
2597     return $self->http('referer');
2598 }
2599 END_OF_FUNC
2600
2601
2602 #### Method: server_name
2603 # Return the name of the server
2604 ####
2605 'server_name' => <<'END_OF_FUNC',
2606 sub server_name {
2607     return $ENV{'SERVER_NAME'} || 'localhost';
2608 }
2609 END_OF_FUNC
2610
2611 #### Method: server_software
2612 # Return the name of the server software
2613 ####
2614 'server_software' => <<'END_OF_FUNC',
2615 sub server_software {
2616     return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
2617 }
2618 END_OF_FUNC
2619
2620 #### Method: server_port
2621 # Return the tcp/ip port the server is running on
2622 ####
2623 'server_port' => <<'END_OF_FUNC',
2624 sub server_port {
2625     return $ENV{'SERVER_PORT'} || 80; # for debugging
2626 }
2627 END_OF_FUNC
2628
2629 #### Method: server_protocol
2630 # Return the protocol (usually HTTP/1.0)
2631 ####
2632 'server_protocol' => <<'END_OF_FUNC',
2633 sub server_protocol {
2634     return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
2635 }
2636 END_OF_FUNC
2637
2638 #### Method: http
2639 # Return the value of an HTTP variable, or
2640 # the list of variables if none provided
2641 ####
2642 'http' => <<'END_OF_FUNC',
2643 sub http {
2644     my ($self,$parameter) = self_or_CGI(@_);
2645     return $ENV{$parameter} if $parameter=~/^HTTP/;
2646     $parameter =~ tr/-/_/;
2647     return $ENV{"HTTP_\U$parameter\E"} if $parameter;
2648     my(@p);
2649     foreach (keys %ENV) {
2650         push(@p,$_) if /^HTTP/;
2651     }
2652     return @p;
2653 }
2654 END_OF_FUNC
2655
2656 #### Method: https
2657 # Return the value of HTTPS
2658 ####
2659 'https' => <<'END_OF_FUNC',
2660 sub https {
2661     local($^W)=0;
2662     my ($self,$parameter) = self_or_CGI(@_);
2663     return $ENV{HTTPS} unless $parameter;
2664     return $ENV{$parameter} if $parameter=~/^HTTPS/;
2665     $parameter =~ tr/-/_/;
2666     return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
2667     my(@p);
2668     foreach (keys %ENV) {
2669         push(@p,$_) if /^HTTPS/;
2670     }
2671     return @p;
2672 }
2673 END_OF_FUNC
2674
2675 #### Method: protocol
2676 # Return the protocol (http or https currently)
2677 ####
2678 'protocol' => <<'END_OF_FUNC',
2679 sub protocol {
2680     local($^W)=0;
2681     my $self = shift;
2682     return 'https' if uc($self->https()) eq 'ON'; 
2683     return 'https' if $self->server_port == 443;
2684     my $prot = $self->server_protocol;
2685     my($protocol,$version) = split('/',$prot);
2686     return "\L$protocol\E";
2687 }
2688 END_OF_FUNC
2689
2690 #### Method: remote_ident
2691 # Return the identity of the remote user
2692 # (but only if his host is running identd)
2693 ####
2694 'remote_ident' => <<'END_OF_FUNC',
2695 sub remote_ident {
2696     return $ENV{'REMOTE_IDENT'};
2697 }
2698 END_OF_FUNC
2699
2700
2701 #### Method: auth_type
2702 # Return the type of use verification/authorization in use, if any.
2703 ####
2704 'auth_type' => <<'END_OF_FUNC',
2705 sub auth_type {
2706     return $ENV{'AUTH_TYPE'};
2707 }
2708 END_OF_FUNC
2709
2710
2711 #### Method: remote_user
2712 # Return the authorization name used for user
2713 # verification.
2714 ####
2715 'remote_user' => <<'END_OF_FUNC',
2716 sub remote_user {
2717     return $ENV{'REMOTE_USER'};
2718 }
2719 END_OF_FUNC
2720
2721
2722 #### Method: user_name
2723 # Try to return the remote user's name by hook or by
2724 # crook
2725 ####
2726 'user_name' => <<'END_OF_FUNC',
2727 sub user_name {
2728     my ($self) = self_or_CGI(@_);
2729     return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
2730 }
2731 END_OF_FUNC
2732
2733 #### Method: nph
2734 # Set or return the NPH global flag
2735 ####
2736 'nph' => <<'END_OF_FUNC',
2737 sub nph {
2738     my ($self,$param) = self_or_CGI(@_);
2739     $CGI::NPH = $param if defined($param);
2740     return $CGI::NPH;
2741 }
2742 END_OF_FUNC
2743
2744 #### Method: private_tempfiles
2745 # Set or return the private_tempfiles global flag
2746 ####
2747 'private_tempfiles' => <<'END_OF_FUNC',
2748 sub private_tempfiles {
2749     my ($self,$param) = self_or_CGI(@_);
2750     $CGI::PRIVATE_TEMPFILES = $param if defined($param);
2751     return $CGI::PRIVATE_TEMPFILES;
2752 }
2753 END_OF_FUNC
2754
2755 #### Method: default_dtd
2756 # Set or return the default_dtd global
2757 ####
2758 'default_dtd' => <<'END_OF_FUNC',
2759 sub default_dtd {
2760     my ($self,$param) = self_or_CGI(@_);
2761     $CGI::DEFAULT_DTD = $param if defined($param);
2762     return $CGI::DEFAULT_DTD;
2763 }
2764 END_OF_FUNC
2765
2766 # -------------- really private subroutines -----------------
2767 'previous_or_default' => <<'END_OF_FUNC',
2768 sub previous_or_default {
2769     my($self,$name,$defaults,$override) = @_;
2770     my(%selected);
2771
2772     if (!$override && ($self->{'.fieldnames'}->{$name} || 
2773                        defined($self->param($name)) ) ) {
2774         grep($selected{$_}++,$self->param($name));
2775     } elsif (defined($defaults) && ref($defaults) && 
2776              (ref($defaults) eq 'ARRAY')) {
2777         grep($selected{$_}++,@{$defaults});
2778     } else {
2779         $selected{$defaults}++ if defined($defaults);
2780     }
2781
2782     return %selected;
2783 }
2784 END_OF_FUNC
2785
2786 'register_parameter' => <<'END_OF_FUNC',
2787 sub register_parameter {
2788     my($self,$param) = @_;
2789     $self->{'.parametersToAdd'}->{$param}++;
2790 }
2791 END_OF_FUNC
2792
2793 'get_fields' => <<'END_OF_FUNC',
2794 sub get_fields {
2795     my($self) = @_;
2796     return $self->CGI::hidden('-name'=>'.cgifields',
2797                               '-values'=>[keys %{$self->{'.parametersToAdd'}}],
2798                               '-override'=>1);
2799 }
2800 END_OF_FUNC
2801
2802 'read_from_cmdline' => <<'END_OF_FUNC',
2803 sub read_from_cmdline {
2804     my($input,@words);
2805     my($query_string);
2806     if (@ARGV) {
2807         @words = @ARGV;
2808     } else {
2809         require "shellwords.pl";
2810         print STDERR "(offline mode: enter name=value pairs on standard input)\n";
2811         chomp(@lines = <STDIN>); # remove newlines
2812         $input = join(" ",@lines);
2813         @words = &shellwords($input);    
2814     }
2815     foreach (@words) {
2816         s/\\=/%3D/g;
2817         s/\\&/%26/g;        
2818     }
2819
2820     if ("@words"=~/=/) {
2821         $query_string = join('&',@words);
2822     } else {
2823         $query_string = join('+',@words);
2824     }
2825     return $query_string;
2826 }
2827 END_OF_FUNC
2828
2829 #####
2830 # subroutine: read_multipart
2831 #
2832 # Read multipart data and store it into our parameters.
2833 # An interesting feature is that if any of the parts is a file, we
2834 # create a temporary file and open up a filehandle on it so that the
2835 # caller can read from it if necessary.
2836 #####
2837 'read_multipart' => <<'END_OF_FUNC',
2838 sub read_multipart {
2839     my($self,$boundary,$length,$filehandle) = @_;
2840     my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle);
2841     return unless $buffer;
2842     my(%header,$body);
2843     my $filenumber = 0;
2844     while (!$buffer->eof) {
2845         %header = $buffer->readHeader;
2846
2847         unless (%header) {
2848             $self->cgi_error("400 Bad request (malformed multipart POST)");
2849             return;
2850         }
2851
2852         my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
2853
2854         # Bug:  Netscape doesn't escape quotation marks in file names!!!
2855         my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/;
2856
2857         # add this parameter to our list
2858         $self->add_parameter($param);
2859
2860         # If no filename specified, then just read the data and assign it
2861         # to our parameter list.
2862         if ( !defined($filename) || $filename eq '' ) {
2863             my($value) = $buffer->readBody;
2864             push(@{$self->{$param}},$value);
2865             next;
2866         }
2867
2868         my ($tmpfile,$tmp,$filehandle);
2869       UPLOADS: {
2870           # If we get here, then we are dealing with a potentially large
2871           # uploaded form.  Save the data to a temporary file, then open
2872           # the file for reading.
2873
2874           # skip the file if uploads disabled
2875           if ($DISABLE_UPLOADS) {
2876               while (defined($data = $buffer->read)) { }
2877               last UPLOADS;
2878           }
2879
2880           # choose a relatively unpredictable tmpfile sequence number
2881           my $seqno = unpack("%16C*",join('',localtime,values %ENV));
2882           for (my $cnt=10;$cnt>0;$cnt--) {
2883             next unless $tmpfile = new TempFile($seqno);
2884             $tmp = $tmpfile->as_string;
2885             last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
2886             $seqno += int rand(100);
2887           }
2888           die "CGI open of tmpfile: $!\n" unless $filehandle;
2889           $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2890
2891           my ($data);
2892           local($\) = '';
2893           while (defined($data = $buffer->read)) {
2894               print $filehandle $data;
2895           }
2896
2897           # back up to beginning of file
2898           seek($filehandle,0,0);
2899           $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2900
2901           # Save some information about the uploaded file where we can get
2902           # at it later.
2903           $self->{'.tmpfiles'}->{fileno($filehandle)}= {
2904               name => $tmpfile,
2905               info => {%header},
2906           };
2907           push(@{$self->{$param}},$filehandle);
2908       }
2909     }
2910 }
2911 END_OF_FUNC
2912
2913 'upload' =><<'END_OF_FUNC',
2914 sub upload {
2915     my($self,$param_name) = self_or_default(@_);
2916     my $param = $self->param($param_name);
2917     return unless $param;
2918     return unless ref($param) && fileno($param);
2919     return $param;
2920 }
2921 END_OF_FUNC
2922
2923 'tmpFileName' => <<'END_OF_FUNC',
2924 sub tmpFileName {
2925     my($self,$filename) = self_or_default(@_);
2926     return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ?
2927         $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string
2928             : '';
2929 }
2930 END_OF_FUNC
2931
2932 'uploadInfo' => <<'END_OF_FUNC',
2933 sub uploadInfo {
2934     my($self,$filename) = self_or_default(@_);
2935     return $self->{'.tmpfiles'}->{fileno($filename)}->{info};
2936 }
2937 END_OF_FUNC
2938
2939 # internal routine, don't use
2940 '_set_values_and_labels' => <<'END_OF_FUNC',
2941 sub _set_values_and_labels {
2942     my $self = shift;
2943     my ($v,$l,$n) = @_;
2944     $$l = $v if ref($v) eq 'HASH' && !ref($$l);
2945     return $self->param($n) if !defined($v);
2946     return $v if !ref($v);
2947     return ref($v) eq 'HASH' ? keys %$v : @$v;
2948 }
2949 END_OF_FUNC
2950
2951 '_compile_all' => <<'END_OF_FUNC',
2952 sub _compile_all {
2953     foreach (@_) {
2954         next if defined(&$_);
2955         $AUTOLOAD = "CGI::$_";
2956         _compile();
2957     }
2958 }
2959 END_OF_FUNC
2960
2961 );
2962 END_OF_AUTOLOAD
2963 ;
2964
2965 #########################################################
2966 # Globals and stubs for other packages that we use.
2967 #########################################################
2968
2969 ################### Fh -- lightweight filehandle ###############
2970 package Fh;
2971 use overload 
2972     '""'  => \&asString,
2973     'cmp' => \&compare,
2974     'fallback'=>1;
2975
2976 $FH='fh00000';
2977
2978 *Fh::AUTOLOAD = \&CGI::AUTOLOAD;
2979
2980 $AUTOLOADED_ROUTINES = '';      # prevent -w error
2981 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
2982 %SUBS =  (
2983 'asString' => <<'END_OF_FUNC',
2984 sub asString {
2985     my $self = shift;
2986     # get rid of package name
2987     (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//; 
2988     $i =~ s/\\(.)/$1/g;
2989     return $i;
2990 # BEGIN DEAD CODE
2991 # This was an extremely clever patch that allowed "use strict refs".
2992 # Unfortunately it relied on another bug that caused leaky file descriptors.
2993 # The underlying bug has been fixed, so this no longer works.  However
2994 # "strict refs" still works for some reason.
2995 #    my $self = shift;
2996 #    return ${*{$self}{SCALAR}};
2997 # END DEAD CODE
2998 }
2999 END_OF_FUNC
3000
3001 'compare' => <<'END_OF_FUNC',
3002 sub compare {
3003     my $self = shift;
3004     my $value = shift;
3005     return "$self" cmp $value;
3006 }
3007 END_OF_FUNC
3008
3009 'new'  => <<'END_OF_FUNC',
3010 sub new {
3011     my($pack,$name,$file,$delete) = @_;
3012     require Fcntl unless defined &Fcntl::O_RDWR;
3013     my $ref = \*{'Fh::' .  ++$FH . quotemeta($name)};
3014     sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
3015     unlink($file) if $delete;
3016     CORE::delete $Fh::{$FH};
3017     return bless $ref,$pack;
3018 }
3019 END_OF_FUNC
3020
3021 'DESTROY'  => <<'END_OF_FUNC',
3022 sub DESTROY {
3023     my $self = shift;
3024     close $self;
3025 }
3026 END_OF_FUNC
3027
3028 );
3029 END_OF_AUTOLOAD
3030
3031 ######################## MultipartBuffer ####################
3032 package MultipartBuffer;
3033
3034 # how many bytes to read at a time.  We use
3035 # a 4K buffer by default.
3036 $INITIAL_FILLUNIT = 1024 * 4;
3037 $TIMEOUT = 240*60;       # 4 hour timeout for big files
3038 $SPIN_LOOP_MAX = 2000;  # bug fix for some Netscape servers
3039 $CRLF=$CGI::CRLF;
3040
3041 #reuse the autoload function
3042 *MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
3043
3044 # avoid autoloader warnings
3045 sub DESTROY {}
3046
3047 ###############################################################################
3048 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3049 ###############################################################################
3050 $AUTOLOADED_ROUTINES = '';      # prevent -w error
3051 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3052 %SUBS =  (
3053
3054 'new' => <<'END_OF_FUNC',
3055 sub new {
3056     my($package,$interface,$boundary,$length,$filehandle) = @_;
3057     $FILLUNIT = $INITIAL_FILLUNIT;
3058     my $IN;
3059     if ($filehandle) {
3060         my($package) = caller;
3061         # force into caller's package if necessary
3062         $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; 
3063     }
3064     $IN = "main::STDIN" unless $IN;
3065
3066     $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
3067     
3068     # If the user types garbage into the file upload field,
3069     # then Netscape passes NOTHING to the server (not good).
3070     # We may hang on this read in that case. So we implement
3071     # a read timeout.  If nothing is ready to read
3072     # by then, we return.
3073
3074     # Netscape seems to be a little bit unreliable
3075     # about providing boundary strings.
3076     if ($boundary) {
3077
3078         # Under the MIME spec, the boundary consists of the 
3079         # characters "--" PLUS the Boundary string
3080
3081         # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
3082         # the two extra hyphens.  We do a special case here on the user-agent!!!!
3083         $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac');
3084
3085     } else { # otherwise we find it ourselves
3086         my($old);
3087         ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
3088         $boundary = <$IN>;      # BUG: This won't work correctly under mod_perl
3089         $length -= length($boundary);
3090         chomp($boundary);               # remove the CRLF
3091         $/ = $old;                      # restore old line separator
3092     }
3093
3094     my $self = {LENGTH=>$length,
3095                 BOUNDARY=>$boundary,
3096                 IN=>$IN,
3097                 INTERFACE=>$interface,
3098                 BUFFER=>'',
3099             };
3100
3101     $FILLUNIT = length($boundary)
3102         if length($boundary) > $FILLUNIT;
3103
3104     my $retval = bless $self,ref $package || $package;
3105
3106     # Read the preamble and the topmost (boundary) line plus the CRLF.
3107     while ($self->read(0)) { }
3108     die "Malformed multipart POST\n" if $self->eof;
3109
3110     return $retval;
3111 }
3112 END_OF_FUNC
3113
3114 'readHeader' => <<'END_OF_FUNC',
3115 sub readHeader {
3116     my($self) = @_;
3117     my($end);
3118     my($ok) = 0;
3119     my($bad) = 0;
3120
3121     if ($CGI::OS eq 'VMS') {  # tssk, tssk: inconsistency alert!
3122         local($CRLF) = "\015\012";
3123     }
3124
3125     do {
3126         $self->fillBuffer($FILLUNIT);
3127         $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
3128         $ok++ if $self->{BUFFER} eq '';
3129         $bad++ if !$ok && $self->{LENGTH} <= 0;
3130         # this was a bad idea
3131         # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; 
3132     } until $ok || $bad;
3133     return () if $bad;
3134
3135     my($header) = substr($self->{BUFFER},0,$end+2);
3136     substr($self->{BUFFER},0,$end+4) = '';
3137     my %return;
3138
3139     
3140     # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
3141     #   (Folding Long Header Fields), 3.4.3 (Comments)
3142     #   and 3.4.5 (Quoted-Strings).
3143
3144     my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
3145     $header=~s/$CRLF\s+/ /og;           # merge continuation lines
3146     while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
3147         my ($field_name,$field_value) = ($1,$2); # avoid taintedness
3148         $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
3149         $return{$field_name}=$field_value;
3150     }
3151     return %return;
3152 }
3153 END_OF_FUNC
3154
3155 # This reads and returns the body as a single scalar value.
3156 'readBody' => <<'END_OF_FUNC',
3157 sub readBody {
3158     my($self) = @_;
3159     my($data);
3160     my($returnval)='';
3161     while (defined($data = $self->read)) {
3162         $returnval .= $data;
3163     }
3164     return $returnval;
3165 }
3166 END_OF_FUNC
3167
3168 # This will read $bytes or until the boundary is hit, whichever happens
3169 # first.  After the boundary is hit, we return undef.  The next read will
3170 # skip over the boundary and begin reading again;
3171 'read' => <<'END_OF_FUNC',
3172 sub read {
3173     my($self,$bytes) = @_;
3174
3175     # default number of bytes to read
3176     $bytes = $bytes || $FILLUNIT;       
3177
3178     # Fill up our internal buffer in such a way that the boundary
3179     # is never split between reads.
3180     $self->fillBuffer($bytes);
3181
3182     # Find the boundary in the buffer (it may not be there).
3183     my $start = index($self->{BUFFER},$self->{BOUNDARY});
3184     # protect against malformed multipart POST operations
3185     die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
3186
3187     # If the boundary begins the data, then skip past it
3188     # and return undef.  The +2 here is a fiendish plot to
3189     # remove the CR/LF pair at the end of the boundary.
3190     if ($start == 0) {
3191
3192         # clear us out completely if we've hit the last boundary.
3193         if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
3194             $self->{BUFFER}='';
3195             $self->{LENGTH}=0;
3196             return undef;
3197         }
3198
3199         # just remove the boundary.
3200         substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
3201         return undef;
3202     }
3203
3204     my $bytesToReturn;    
3205     if ($start > 0) {           # read up to the boundary
3206         $bytesToReturn = $start > $bytes ? $bytes : $start;
3207     } else {    # read the requested number of bytes
3208         # leave enough bytes in the buffer to allow us to read
3209         # the boundary.  Thanks to Kevin Hendrick for finding
3210         # this one.
3211         $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
3212     }
3213
3214     my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
3215     substr($self->{BUFFER},0,$bytesToReturn)='';
3216     
3217     # If we hit the boundary, remove the CRLF from the end.
3218     return ($start > 0) ? substr($returnval,0,-2) : $returnval;
3219 }
3220 END_OF_FUNC
3221
3222
3223 # This fills up our internal buffer in such a way that the
3224 # boundary is never split between reads
3225 'fillBuffer' => <<'END_OF_FUNC',
3226 sub fillBuffer {
3227     my($self,$bytes) = @_;
3228     return unless $self->{LENGTH};
3229
3230     my($boundaryLength) = length($self->{BOUNDARY});
3231     my($bufferLength) = length($self->{BUFFER});
3232     my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
3233     $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
3234
3235     # Try to read some data.  We may hang here if the browser is screwed up.  
3236     my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN},
3237                                                          \$self->{BUFFER},
3238                                                          $bytesToRead,
3239                                                          $bufferLength);
3240     $self->{BUFFER} = '' unless defined $self->{BUFFER};
3241
3242     # An apparent bug in the Apache server causes the read()
3243     # to return zero bytes repeatedly without blocking if the
3244     # remote user aborts during a file transfer.  I don't know how
3245     # they manage this, but the workaround is to abort if we get
3246     # more than SPIN_LOOP_MAX consecutive zero reads.
3247     if ($bytesRead == 0) {
3248         die  "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
3249             if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
3250     } else {
3251         $self->{ZERO_LOOP_COUNTER}=0;
3252     }
3253
3254     $self->{LENGTH} -= $bytesRead;
3255 }
3256 END_OF_FUNC
3257
3258
3259 # Return true when we've finished reading
3260 'eof' => <<'END_OF_FUNC'
3261 sub eof {
3262     my($self) = @_;
3263     return 1 if (length($self->{BUFFER}) == 0)
3264                  && ($self->{LENGTH} <= 0);
3265     undef;
3266 }
3267 END_OF_FUNC
3268
3269 );
3270 END_OF_AUTOLOAD
3271
3272 ####################################################################################
3273 ################################## TEMPORARY FILES #################################
3274 ####################################################################################
3275 package TempFile;
3276
3277 $SL = $CGI::SL;
3278 $MAC = $CGI::OS eq 'MACINTOSH';
3279 my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
3280 unless ($TMPDIRECTORY) {
3281     @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
3282            "C:${SL}temp","${SL}tmp","${SL}temp",
3283            "${vol}${SL}Temporary Items","${SL}sys\$scratch",
3284            "${SL}WWW_ROOT");
3285     unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'};
3286
3287     #
3288     #    unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
3289     # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
3290     #    : can generate a 'getpwuid() not implemented' exception, even though
3291     #    : it's never called.  Found under DOS/Win with the DJGPP perl port.
3292     #    : Refer to getpwuid() only at run-time if we're fortunate and have  UNIX.
3293     unshift(@TEMP,(eval {(getpwuid($<))[7]}).'/tmp') if $CGI::OS eq 'UNIX';
3294
3295     foreach (@TEMP) {
3296         do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
3297     }
3298 }
3299
3300 $TMPDIRECTORY  = $MAC ? "" : "." unless $TMPDIRECTORY;
3301 $MAXTRIES = 5000;
3302
3303 # cute feature, but overload implementation broke it
3304 # %OVERLOAD = ('""'=>'as_string');
3305 *TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
3306
3307 ###############################################################################
3308 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3309 ###############################################################################
3310 $AUTOLOADED_ROUTINES = '';      # prevent -w error
3311 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3312 %SUBS = (
3313
3314 'new' => <<'END_OF_FUNC',
3315 sub new {
3316     my($package,$sequence) = @_;
3317     my $filename;
3318     for (my $i = 0; $i < $MAXTRIES; $i++) {
3319         last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
3320     }
3321     # untaint the darn thing
3322     return unless $filename =~ m!^([a-zA-Z0-9_ '":/\\]+)$!;
3323     $filename = $1;
3324     return bless \$filename;
3325 }
3326 END_OF_FUNC
3327
3328 'DESTROY' => <<'END_OF_FUNC',
3329 sub DESTROY {
3330     my($self) = @_;
3331     unlink $$self;              # get rid of the file
3332 }
3333 END_OF_FUNC
3334
3335 'as_string' => <<'END_OF_FUNC'
3336 sub as_string {
3337     my($self) = @_;
3338     return $$self;
3339 }
3340 END_OF_FUNC
3341
3342 );
3343 END_OF_AUTOLOAD
3344
3345 package CGI;
3346
3347 # We get a whole bunch of warnings about "possibly uninitialized variables"
3348 # when running with the -w switch.  Touch them all once to get rid of the
3349 # warnings.  This is ugly and I hate it.
3350 if ($^W) {
3351     $CGI::CGI = '';
3352     $CGI::CGI=<<EOF;
3353     $CGI::VERSION;
3354     $MultipartBuffer::SPIN_LOOP_MAX;
3355     $MultipartBuffer::CRLF;
3356     $MultipartBuffer::TIMEOUT;
3357     $MultipartBuffer::INITIAL_FILLUNIT;
3358 EOF
3359     ;
3360 }
3361
3362 1;
3363
3364 __END__
3365
3366 =head1 NAME
3367
3368 CGI - Simple Common Gateway Interface Class
3369
3370 =head1 SYNOPSIS
3371
3372   # CGI script that creates a fill-out form
3373   # and echoes back its values.
3374
3375   use CGI qw/:standard/;
3376   print header,
3377         start_html('A Simple Example'),
3378         h1('A Simple Example'),
3379         start_form,
3380         "What's your name? ",textfield('name'),p,
3381         "What's the combination?", p,
3382         checkbox_group(-name=>'words',
3383                        -values=>['eenie','meenie','minie','moe'],
3384                        -defaults=>['eenie','minie']), p,
3385         "What's your favorite color? ",
3386         popup_menu(-name=>'color',
3387                    -values=>['red','green','blue','chartreuse']),p,
3388         submit,
3389         end_form,
3390         hr;
3391
3392    if (param()) {
3393        print "Your name is",em(param('name')),p,
3394              "The keywords are: ",em(join(", ",param('words'))),p,
3395              "Your favorite color is ",em(param('color')),
3396              hr;
3397    }
3398
3399 =head1 ABSTRACT
3400
3401 This perl library uses perl5 objects to make it easy to create Web
3402 fill-out forms and parse their contents.  This package defines CGI
3403 objects, entities that contain the values of the current query string
3404 and other state variables.  Using a CGI object's methods, you can
3405 examine keywords and parameters passed to your script, and create
3406 forms whose initial values are taken from the current query (thereby
3407 preserving state information).  The module provides shortcut functions
3408 that produce boilerplate HTML, reducing typing and coding errors. It
3409 also provides functionality for some of the more advanced features of
3410 CGI scripting, including support for file uploads, cookies, cascading
3411 style sheets, server push, and frames.
3412
3413 CGI.pm also provides a simple function-oriented programming style for
3414 those who don't need its object-oriented features.
3415
3416 The current version of CGI.pm is available at
3417
3418   http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
3419   ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
3420
3421 =head1 DESCRIPTION
3422
3423 =head2 PROGRAMMING STYLE
3424
3425 There are two styles of programming with CGI.pm, an object-oriented
3426 style and a function-oriented style.  In the object-oriented style you
3427 create one or more CGI objects and then use object methods to create
3428 the various elements of the page.  Each CGI object starts out with the
3429 list of named parameters that were passed to your CGI script by the
3430 server.  You can modify the objects, save them to a file or database
3431 and recreate them.  Because each object corresponds to the "state" of
3432 the CGI script, and because each object's parameter list is
3433 independent of the others, this allows you to save the state of the
3434 script and restore it later.
3435
3436 For example, using the object oriented style, here is how you create
3437 a simple "Hello World" HTML page:
3438
3439    #!/usr/local/bin/perl -w
3440    use CGI;                             # load CGI routines
3441    $q = new CGI;                        # create new CGI object
3442    print $q->header,                    # create the HTTP header
3443          $q->start_html('hello world'), # start the HTML
3444          $q->h1('hello world'),         # level 1 header
3445          $q->end_html;                  # end the HTML
3446
3447 In the function-oriented style, there is one default CGI object that
3448 you rarely deal with directly.  Instead you just call functions to
3449 retrieve CGI parameters, create HTML tags, manage cookies, and so
3450 on.  This provides you with a cleaner programming interface, but
3451 limits you to using one CGI object at a time.  The following example
3452 prints the same page, but uses the function-oriented interface.
3453 The main differences are that we now need to import a set of functions
3454 into our name space (usually the "standard" functions), and we don't
3455 need to create the CGI object.
3456
3457    #!/usr/local/bin/perl
3458    use CGI qw/:standard/;           # load standard CGI routines
3459    print header,                    # create the HTTP header
3460          start_html('hello world'), # start the HTML
3461          h1('hello world'),         # level 1 header
3462          end_html;                  # end the HTML
3463
3464 The examples in this document mainly use the object-oriented style.
3465 See HOW TO IMPORT FUNCTIONS for important information on
3466 function-oriented programming in CGI.pm
3467
3468 =head2 CALLING CGI.PM ROUTINES
3469
3470 Most CGI.pm routines accept several arguments, sometimes as many as 20
3471 optional ones!  To simplify this interface, all routines use a named
3472 argument calling style that looks like this:
3473
3474    print $q->header(-type=>'image/gif',-expires=>'+3d');
3475
3476 Each argument name is preceded by a dash.  Neither case nor order
3477 matters in the argument list.  -type, -Type, and -TYPE are all
3478 acceptable.  In fact, only the first argument needs to begin with a
3479 dash.  If a dash is present in the first argument, CGI.pm assumes
3480 dashes for the subsequent ones.
3481
3482 You don't have to use the hyphen at all if you don't want to.  After
3483 creating a CGI object, call the B<use_named_parameters()> method with
3484 a nonzero value.  This will tell CGI.pm that you intend to use named
3485 parameters exclusively:
3486
3487    $query = new CGI;
3488    $query->use_named_parameters(1);
3489    $field = $query->radio_group('name'=>'OS',
3490                                 'values'=>['Unix','Windows','Macintosh'],
3491                                 'default'=>'Unix');
3492
3493 Several routines are commonly called with just one argument.  In the
3494 case of these routines you can provide the single argument without an
3495 argument name.  header() happens to be one of these routines.  In this
3496 case, the single argument is the document type.
3497
3498    print $q->header('text/html');
3499
3500 Other such routines are documented below.
3501
3502 Sometimes named arguments expect a scalar, sometimes a reference to an
3503 array, and sometimes a reference to a hash.  Often, you can pass any
3504 type of argument and the routine will do whatever is most appropriate.
3505 For example, the param() routine is used to set a CGI parameter to a
3506 single or a multi-valued value.  The two cases are shown below:
3507
3508    $q->param(-name=>'veggie',-value=>'tomato');
3509    $q->param(-name=>'veggie',-value=>'[tomato','tomahto','potato','potahto']);
3510
3511 A large number of routines in CGI.pm actually aren't specifically
3512 defined in the module, but are generated automatically as needed.
3513 These are the "HTML shortcuts," routines that generate HTML tags for
3514 use in dynamically-generated pages.  HTML tags have both attributes
3515 (the attribute="value" pairs within the tag itself) and contents (the
3516 part between the opening and closing pairs.)  To distinguish between
3517 attributes and contents, CGI.pm uses the convention of passing HTML
3518 attributes as a hash reference as the first argument, and the
3519 contents, if any, as any subsequent arguments.  It works out like
3520 this:
3521
3522    Code                           Generated HTML
3523    ----                           --------------
3524    h1()                           <H1>
3525    h1('some','contents');         <H1>some contents</H1>
3526    h1({-align=>left});            <H1 ALIGN="LEFT">
3527    h1({-align=>left},'contents'); <H1 ALIGN="LEFT">contents</H1>
3528
3529 HTML tags are described in more detail later.  
3530
3531 Many newcomers to CGI.pm are puzzled by the difference between the
3532 calling conventions for the HTML shortcuts, which require curly braces
3533 around the HTML tag attributes, and the calling conventions for other
3534 routines, which manage to generate attributes without the curly
3535 brackets.  Don't be confused.  As a convenience the curly braces are
3536 optional in all but the HTML shortcuts.  If you like, you can use
3537 curly braces when calling any routine that takes named arguments.  For
3538 example:
3539
3540    print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
3541
3542 If you use the B<-w> switch, you will be warned that some CGI.pm argument
3543 names conflict with built-in Perl functions.  The most frequent of
3544 these is the -values argument, used to create multi-valued menus,
3545 radio button clusters and the like.  To get around this warning, you
3546 have several choices:
3547
3548 =over 4
3549
3550 =item 1. Use another name for the argument, if one is available.  For
3551 example, -value is an alias for -values.
3552
3553 =item 2. Change the capitalization, e.g. -Values
3554
3555 =item 3. Put quotes around the argument name, e.g. '-values'
3556
3557 =back
3558
3559 Many routines will do something useful with a named argument that it
3560 doesn't recognize.  For example, you can produce non-standard HTTP
3561 header fields by providing them as named arguments:
3562
3563   print $q->header(-type  =>  'text/html',
3564                    -cost  =>  'Three smackers',
3565                    -annoyance_level => 'high',
3566                    -complaints_to   => 'bit bucket');
3567
3568 This will produce the following nonstandard HTTP header:
3569
3570    HTTP/1.0 200 OK
3571    Cost: Three smackers
3572    Annoyance-level: high
3573    Complaints-to: bit bucket
3574    Content-type: text/html
3575
3576 Notice the way that underscores are translated automatically into
3577 hyphens.  HTML-generating routines perform a different type of
3578 translation. 
3579
3580 This feature allows you to keep up with the rapidly changing HTTP and
3581 HTML "standards".
3582
3583 =head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
3584
3585      $query = new CGI;
3586
3587 This will parse the input (from both POST and GET methods) and store
3588 it into a perl5 object called $query.  
3589
3590 =head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
3591
3592      $query = new CGI(INPUTFILE);
3593
3594 If you provide a file handle to the new() method, it will read
3595 parameters from the file (or STDIN, or whatever).  The file can be in
3596 any of the forms describing below under debugging (i.e. a series of
3597 newline delimited TAG=VALUE pairs will work).  Conveniently, this type
3598 of file is created by the save() method (see below).  Multiple records
3599 can be saved and restored.
3600
3601 Perl purists will be pleased to know that this syntax accepts
3602 references to file handles, or even references to filehandle globs,
3603 which is the "official" way to pass a filehandle:
3604
3605     $query = new CGI(\*STDIN);
3606
3607 You can also initialize the CGI object with a FileHandle or IO::File
3608 object.
3609
3610 If you are using the function-oriented interface and want to
3611 initialize CGI state from a file handle, the way to do this is with
3612 B<restore_parameters()>.  This will (re)initialize the
3613 default CGI object from the indicated file handle.
3614
3615     open (IN,"test.in") || die;
3616     restore_parameters(IN);
3617     close IN;
3618
3619 You can also initialize the query object from an associative array
3620 reference:
3621
3622     $query = new CGI( {'dinosaur'=>'barney',
3623                        'song'=>'I love you',
3624                        'friends'=>[qw/Jessica George Nancy/]}
3625                     );
3626
3627 or from a properly formatted, URL-escaped query string:
3628
3629     $query = new CGI('dinosaur=barney&color=purple');
3630
3631 or from a previously existing CGI object (currently this clones the
3632 parameter list, but none of the other object-specific fields, such as
3633 autoescaping):
3634
3635     $old_query = new CGI;
3636     $new_query = new CGI($old_query);
3637
3638 To create an empty query, initialize it from an empty string or hash:
3639
3640    $empty_query = new CGI("");
3641
3642        -or-
3643
3644    $empty_query = new CGI({});
3645
3646 =head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
3647
3648      @keywords = $query->keywords
3649
3650 If the script was invoked as the result of an <ISINDEX> search, the
3651 parsed keywords can be obtained as an array using the keywords() method.
3652
3653 =head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
3654
3655      @names = $query->param
3656
3657 If the script was invoked with a parameter list
3658 (e.g. "name1=value1&name2=value2&name3=value3"), the param()
3659 method will return the parameter names as a list.  If the
3660 script was invoked as an <ISINDEX> script, there will be a
3661 single parameter named 'keywords'.
3662
3663 NOTE: As of version 1.5, the array of parameter names returned will
3664 be in the same order as they were submitted by the browser.
3665 Usually this order is the same as the order in which the 
3666 parameters are defined in the form (however, this isn't part
3667 of the spec, and so isn't guaranteed).
3668
3669 =head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
3670
3671     @values = $query->param('foo');
3672
3673               -or-
3674
3675     $value = $query->param('foo');
3676
3677 Pass the param() method a single argument to fetch the value of the
3678 named parameter. If the parameter is multivalued (e.g. from multiple
3679 selections in a scrolling list), you can ask to receive an array.  Otherwise
3680 the method will return a single value.
3681
3682 =head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
3683
3684     $query->param('foo','an','array','of','values');
3685
3686 This sets the value for the named parameter 'foo' to an array of
3687 values.  This is one way to change the value of a field AFTER
3688 the script has been invoked once before.  (Another way is with
3689 the -override parameter accepted by all methods that generate
3690 form elements.)
3691
3692 param() also recognizes a named parameter style of calling described
3693 in more detail later:
3694
3695     $query->param(-name=>'foo',-values=>['an','array','of','values']);
3696
3697                               -or-
3698
3699     $query->param(-name=>'foo',-value=>'the value');
3700
3701 =head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
3702
3703    $query->append(-name=>'foo',-values=>['yet','more','values']);
3704
3705 This adds a value or list of values to the named parameter.  The
3706 values are appended to the end of the parameter if it already exists.
3707 Otherwise the parameter is created.  Note that this method only
3708 recognizes the named argument calling syntax.
3709
3710 =head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
3711
3712    $query->import_names('R');
3713
3714 This creates a series of variables in the 'R' namespace.  For example,
3715 $R::foo, @R:foo.  For keyword lists, a variable @R::keywords will appear.
3716 If no namespace is given, this method will assume 'Q'.
3717 WARNING:  don't import anything into 'main'; this is a major security
3718 risk!!!!
3719
3720 In older versions, this method was called B<import()>.  As of version 2.20, 
3721 this name has been removed completely to avoid conflict with the built-in
3722 Perl module B<import> operator.
3723
3724 =head2 DELETING A PARAMETER COMPLETELY:
3725
3726     $query->delete('foo');
3727
3728 This completely clears a parameter.  It sometimes useful for
3729 resetting parameters that you don't want passed down between
3730 script invocations.
3731
3732 If you are using the function call interface, use "Delete()" instead
3733 to avoid conflicts with Perl's built-in delete operator.
3734
3735 =head2 DELETING ALL PARAMETERS:
3736
3737    $query->delete_all();
3738
3739 This clears the CGI object completely.  It might be useful to ensure
3740 that all the defaults are taken when you create a fill-out form.
3741
3742 Use Delete_all() instead if you are using the function call interface.
3743
3744 =head2 DIRECT ACCESS TO THE PARAMETER LIST:
3745
3746    $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
3747    unshift @{$q->param_fetch(-name=>'address')},'George Munster';
3748
3749 If you need access to the parameter list in a way that isn't covered
3750 by the methods above, you can obtain a direct reference to it by
3751 calling the B<param_fetch()> method with the name of the .  This
3752 will return an array reference to the named parameters, which you then
3753 can manipulate in any way you like.
3754
3755 You can also use a named argument style using the B<-name> argument.
3756
3757 =head2 FETCHING THE PARAMETER LIST AS A HASH:
3758
3759     $params = $q->Vars;
3760     print $params->{'address'};
3761     @foo = split("\0",$params->{'foo'});
3762     %params = $q->Vars;
3763
3764     use CGI ':cgi-lib';
3765     $params = Vars;
3766
3767 Many people want to fetch the entire parameter list as a hash in which
3768 the keys are the names of the CGI parameters, and the values are the
3769 parameters' values.  The Vars() method does this.  Called in a scalar
3770 context, it returns the parameter list as a tied hash reference.
3771 Changing a key changes the value of the parameter in the underlying
3772 CGI parameter list.  Called in an array context, it returns the
3773 parameter list as an ordinary hash.  This allows you to read the
3774 contents of the parameter list, but not to change it.
3775
3776 When using this, the thing you must watch out for are multivalued CGI
3777 parameters.  Because a hash cannot distinguish between scalar and
3778 array context, multivalued parameters will be returned as a packed
3779 string, separated by the "\0" (null) character.  You must split this
3780 packed string in order to get at the individual values.  This is the
3781 convention introduced long ago by Steve Brenner in his cgi-lib.pl
3782 module for Perl version 4.
3783
3784 If you wish to use Vars() as a function, import the I<:cgi-lib> set of
3785 function calls (also see the section on CGI-LIB compatibility).
3786
3787 =head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
3788
3789     $query->save(FILEHANDLE)
3790
3791 This will write the current state of the form to the provided
3792 filehandle.  You can read it back in by providing a filehandle
3793 to the new() method.  Note that the filehandle can be a file, a pipe,
3794 or whatever!
3795
3796 The format of the saved file is:
3797
3798         NAME1=VALUE1
3799         NAME1=VALUE1'
3800         NAME2=VALUE2
3801         NAME3=VALUE3
3802         =
3803
3804 Both name and value are URL escaped.  Multi-valued CGI parameters are
3805 represented as repeated names.  A session record is delimited by a
3806 single = symbol.  You can write out multiple records and read them
3807 back in with several calls to B<new>.  You can do this across several
3808 sessions by opening the file in append mode, allowing you to create
3809 primitive guest books, or to keep a history of users' queries.  Here's
3810 a short example of creating multiple session records:
3811
3812    use CGI;
3813
3814    open (OUT,">>test.out") || die;
3815    $records = 5;
3816    foreach (0..$records) {
3817        my $q = new CGI;
3818        $q->param(-name=>'counter',-value=>$_);
3819        $q->save(OUT);
3820    }
3821    close OUT;
3822
3823    # reopen for reading
3824    open (IN,"test.out") || die;
3825    while (!eof(IN)) {
3826        my $q = new CGI(IN);
3827        print $q->param('counter'),"\n";
3828    }
3829
3830 The file format used for save/restore is identical to that used by the
3831 Whitehead Genome Center's data exchange format "Boulderio", and can be
3832 manipulated and even databased using Boulderio utilities.  See
3833
3834   http://stein.cshl.org/boulder/
3835
3836 for further details.
3837
3838 If you wish to use this method from the function-oriented (non-OO)
3839 interface, the exported name for this method is B<save_parameters()>.
3840
3841 =head2 RETRIEVING CGI ERRORS
3842
3843 Errors can occur while processing user input, particularly when
3844 processing uploaded files.  When these errors occur, CGI will stop
3845 processing and return an empty parameter list.  You can test for
3846 the existence and nature of errors using the I<cgi_error()> function.
3847 The error messages are formatted as HTTP status codes. You can either
3848 incorporate the error text into an HTML page, or use it as the value
3849 of the HTTP status:
3850
3851     my $error = $q->cgi_error;
3852     if ($error) {
3853         print $q->header(-status=>$error),
3854               $q->start_html('Problems'),
3855               $q->h2('Request not processed'),
3856               $q->strong($error);
3857         exit 0;
3858     }
3859
3860 When using the function-oriented interface (see the next section),
3861 errors may only occur the first time you call I<param()>. Be ready
3862 for this!
3863
3864 =head2 USING THE FUNCTION-ORIENTED INTERFACE
3865
3866 To use the function-oriented interface, you must specify which CGI.pm
3867 routines or sets of routines to import into your script's namespace.
3868 There is a small overhead associated with this importation, but it
3869 isn't much.
3870
3871    use CGI <list of methods>;
3872
3873 The listed methods will be imported into the current package; you can
3874 call them directly without creating a CGI object first.  This example
3875 shows how to import the B<param()> and B<header()>
3876 methods, and then use them directly:
3877
3878    use CGI 'param','header';
3879    print header('text/plain');
3880    $zipcode = param('zipcode');
3881
3882 More frequently, you'll import common sets of functions by referring
3883 to the groups by name.  All function sets are preceded with a ":"
3884 character as in ":html3" (for tags defined in the HTML 3 standard).
3885
3886 Here is a list of the function sets you can import:
3887
3888 =over 4
3889
3890 =item B<:cgi>
3891
3892 Import all CGI-handling methods, such as B<param()>, B<path_info()>
3893 and the like.
3894
3895 =item B<:form>
3896
3897 Import all fill-out form generating methods, such as B<textfield()>.
3898
3899 =item B<:html2>
3900
3901 Import all methods that generate HTML 2.0 standard elements.
3902
3903 =item B<:html3>
3904
3905 Import all methods that generate HTML 3.0 proposed elements (such as
3906 <table>, <super> and <sub>).
3907
3908 =item B<:netscape>
3909
3910 Import all methods that generate Netscape-specific HTML extensions.
3911
3912 =item B<:html>
3913
3914 Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
3915 'netscape')...
3916
3917 =item B<:standard>
3918
3919 Import "standard" features, 'html2', 'html3', 'form' and 'cgi'.
3920
3921 =item B<:all>
3922
3923 Import all the available methods.  For the full list, see the CGI.pm
3924 code, where the variable %EXPORT_TAGS is defined.
3925
3926 =back
3927
3928 If you import a function name that is not part of CGI.pm, the module
3929 will treat it as a new HTML tag and generate the appropriate
3930 subroutine.  You can then use it like any other HTML tag.  This is to
3931 provide for the rapidly-evolving HTML "standard."  For example, say
3932 Microsoft comes out with a new tag called <GRADIENT> (which causes the
3933 user's desktop to be flooded with a rotating gradient fill until his
3934 machine reboots).  You don't need to wait for a new version of CGI.pm
3935 to start using it immediately:
3936
3937    use CGI qw/:standard :html3 gradient/;
3938    print gradient({-start=>'red',-end=>'blue'});
3939
3940 Note that in the interests of execution speed CGI.pm does B<not> use
3941 the standard L<Exporter> syntax for specifying load symbols.  This may
3942 change in the future.
3943
3944 If you import any of the state-maintaining CGI or form-generating
3945 methods, a default CGI object will be created and initialized
3946 automatically the first time you use any of the methods that require
3947 one to be present.  This includes B<param()>, B<textfield()>,
3948 B<submit()> and the like.  (If you need direct access to the CGI
3949 object, you can find it in the global variable B<$CGI::Q>).  By
3950 importing CGI.pm methods, you can create visually elegant scripts:
3951
3952    use CGI qw/:standard/;
3953    print 
3954        header,
3955        start_html('Simple Script'),
3956        h1('Simple Script'),
3957        start_form,
3958        "What's your name? ",textfield('name'),p,
3959        "What's the combination?",
3960        checkbox_group(-name=>'words',
3961                       -values=>['eenie','meenie','minie','moe'],
3962                       -defaults=>['eenie','moe']),p,
3963        "What's your favorite color?",
3964        popup_menu(-name=>'color',
3965                   -values=>['red','green','blue','chartreuse']),p,
3966        submit,
3967        end_form,
3968        hr,"\n";
3969
3970     if (param) {
3971        print 
3972            "Your name is ",em(param('name')),p,
3973            "The keywords are: ",em(join(", ",param('words'))),p,
3974            "Your favorite color is ",em(param('color')),".\n";
3975     }
3976     print end_html;
3977
3978 =head2 PRAGMAS
3979
3980 In addition to the function sets, there are a number of pragmas that
3981 you can import.  Pragmas, which are always preceded by a hyphen,
3982 change the way that CGI.pm functions in various ways.  Pragmas,
3983 function sets, and individual functions can all be imported in the
3984 same use() line.  For example, the following use statement imports the
3985 standard set of functions and disables debugging mode (pragma
3986 -no_debug):
3987
3988    use CGI qw/:standard -no_debug/;
3989
3990 The current list of pragmas is as follows:
3991
3992 =over 4
3993
3994 =item -any
3995
3996 When you I<use CGI -any>, then any method that the query object
3997 doesn't recognize will be interpreted as a new HTML tag.  This allows
3998 you to support the next I<ad hoc> Netscape or Microsoft HTML
3999 extension.  This lets you go wild with new and unsupported tags:
4000
4001    use CGI qw(-any);
4002    $q=new CGI;
4003    print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
4004
4005 Since using <cite>any</cite> causes any mistyped method name
4006 to be interpreted as an HTML tag, use it with care or not at
4007 all.
4008
4009 =item -compile
4010
4011 This causes the indicated autoloaded methods to be compiled up front,
4012 rather than deferred to later.  This is useful for scripts that run
4013 for an extended period of time under FastCGI or mod_perl, and for
4014 those destined to be crunched by Malcom Beattie's Perl compiler.  Use
4015 it in conjunction with the methods or method families you plan to use.
4016
4017    use CGI qw(-compile :standard :html3);
4018
4019 or even
4020
4021    use CGI qw(-compile :all);
4022
4023 Note that using the -compile pragma in this way will always have
4024 the effect of importing the compiled functions into the current
4025 namespace.  If you want to compile without importing use the
4026 compile() method instead (see below).
4027
4028 =item -nph
4029
4030 This makes CGI.pm produce a header appropriate for an NPH (no
4031 parsed header) script.  You may need to do other things as well
4032 to tell the server that the script is NPH.  See the discussion
4033 of NPH scripts below.
4034
4035 =item -newstyle_urls
4036
4037 Separate the name=value pairs in CGI parameter query strings with
4038 semicolons rather than ampersands.  For example:
4039
4040    ?name=fred;age=24;favorite_color=3
4041
4042 Semicolon-delimited query strings are always accepted, but will not be
4043 emitted by self_url() and query_string() unless the -newstyle_urls
4044 pragma is specified.
4045
4046 =item -autoload
4047
4048 This overrides the autoloader so that any function in your program
4049 that is not recognized is referred to CGI.pm for possible evaluation.
4050 This allows you to use all the CGI.pm functions without adding them to
4051 your symbol table, which is of concern for mod_perl users who are
4052 worried about memory consumption.  I<Warning:> when
4053 I<-autoload> is in effect, you cannot use "poetry mode"
4054 (functions without the parenthesis).  Use I<hr()> rather
4055 than I<hr>, or add something like I<use subs qw/hr p header/> 
4056 to the top of your script.
4057
4058 =item -no_debug
4059
4060 This turns off the command-line processing features.  If you want to
4061 run a CGI.pm script from the command line to produce HTML, and you
4062 don't want it pausing to request CGI parameters from standard input or
4063 the command line, then use this pragma:
4064
4065    use CGI qw(-no_debug :standard);
4066
4067 If you'd like to process the command-line parameters but not standard
4068 input, this should work:
4069
4070    use CGI qw(-no_debug :standard);
4071    restore_parameters(join('&',@ARGV));
4072
4073 See the section on debugging for more details.
4074
4075 =item -private_tempfiles
4076
4077 CGI.pm can process uploaded file. Ordinarily it spools the uploaded
4078 file to a temporary directory, then deletes the file when done.
4079 However, this opens the risk of eavesdropping as described in the file
4080 upload section.  Another CGI script author could peek at this data
4081 during the upload, even if it is confidential information. On Unix
4082 systems, the -private_tempfiles pragma will cause the temporary file
4083 to be unlinked as soon as it is opened and before any data is written
4084 into it, reducing, but not eliminating the risk of eavesdropping
4085 (there is still a potential race condition).  To make life harder for
4086 the attacker, the program chooses tempfile names by calculating a 32
4087 bit checksum of the incoming HTTP headers.
4088
4089 To ensure that the temporary file cannot be read by other CGI scripts,
4090 use suEXEC or a CGI wrapper program to run your script.  The temporary
4091 file is created with mode 0600 (neither world nor group readable).
4092
4093 The temporary directory is selected using the following algorithm:
4094
4095     1. if the current user (e.g. "nobody") has a directory named
4096     "tmp" in its home directory, use that (Unix systems only).
4097
4098     2. if the environment variable TMPDIR exists, use the location
4099     indicated.
4100
4101     3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp,
4102     /tmp, /temp, ::Temporary Items, and \WWW_ROOT.
4103
4104 Each of these locations is checked that it is a directory and is
4105 writable.  If not, the algorithm tries the next choice.
4106
4107 =back
4108
4109 =head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS
4110
4111 Many of the methods generate HTML tags.  As described below, tag
4112 functions automatically generate both the opening and closing tags.
4113 For example:
4114
4115   print h1('Level 1 Header');
4116
4117 produces
4118
4119   <H1>Level 1 Header</H1>
4120
4121 There will be some times when you want to produce the start and end
4122 tags yourself.  In this case, you can use the form start_I<tag_name>
4123 and end_I<tag_name>, as in:
4124
4125   print start_h1,'Level 1 Header',end_h1;
4126
4127 With a few exceptions (described below), start_I<tag_name> and
4128 end_I<tag_name> functions are not generated automatically when you
4129 I<use CGI>.  However, you can specify the tags you want to generate
4130 I<start/end> functions for by putting an asterisk in front of their
4131 name, or, alternatively, requesting either "start_I<tag_name>" or
4132 "end_I<tag_name>" in the import list.
4133
4134 Example:
4135
4136   use CGI qw/:standard *table start_ul/;
4137
4138 In this example, the following functions are generated in addition to
4139 the standard ones:
4140
4141 =over 4
4142
4143 =item 1. start_table() (generates a <TABLE> tag)
4144
4145 =item 2. end_table() (generates a </TABLE> tag)
4146
4147 =item 3. start_ul() (generates a <UL> tag)
4148
4149 =item 4. end_ul() (generates a </UL> tag)
4150
4151 =back
4152
4153 =head1 GENERATING DYNAMIC DOCUMENTS
4154
4155 Most of CGI.pm's functions deal with creating documents on the fly.
4156 Generally you will produce the HTTP header first, followed by the
4157 document itself.  CGI.pm provides functions for generating HTTP
4158 headers of various types as well as for generating HTML.  For creating
4159 GIF images, see the GD.pm module.
4160
4161 Each of these functions produces a fragment of HTML or HTTP which you
4162 can print out directly so that it displays in the browser window,
4163 append to a string, or save to a file for later use.
4164
4165 =head2 CREATING A STANDARD HTTP HEADER:
4166
4167 Normally the first thing you will do in any CGI script is print out an
4168 HTTP header.  This tells the browser what type of document to expect,
4169 and gives other optional information, such as the language, expiration
4170 date, and whether to cache the document.  The header can also be
4171 manipulated for special purposes, such as server push and pay per view
4172 pages.
4173
4174         print $query->header;
4175
4176              -or-
4177
4178         print $query->header('image/gif');
4179
4180              -or-
4181
4182         print $query->header('text/html','204 No response');
4183
4184              -or-
4185
4186         print $query->header(-type=>'image/gif',
4187                              -nph=>1,
4188                              -status=>'402 Payment required',
4189                              -expires=>'+3d',
4190                              -cookie=>$cookie,
4191                              -Cost=>'$2.00');
4192
4193 header() returns the Content-type: header.  You can provide your own
4194 MIME type if you choose, otherwise it defaults to text/html.  An
4195 optional second parameter specifies the status code and a human-readable
4196 message.  For example, you can specify 204, "No response" to create a
4197 script that tells the browser to do nothing at all.
4198
4199 The last example shows the named argument style for passing arguments
4200 to the CGI methods using named parameters.  Recognized parameters are
4201 B<-type>, B<-status>, B<-expires>, and B<-cookie>.  Any other named
4202 parameters will be stripped of their initial hyphens and turned into
4203 header fields, allowing you to specify any HTTP header you desire.
4204 Internal underscores will be turned into hyphens:
4205
4206     print $query->header(-Content_length=>3002);
4207
4208 Most browsers will not cache the output from CGI scripts.  Every time
4209 the browser reloads the page, the script is invoked anew.  You can
4210 change this behavior with the B<-expires> parameter.  When you specify
4211 an absolute or relative expiration interval with this parameter, some
4212 browsers and proxy servers will cache the script's output until the
4213 indicated expiration date.  The following forms are all valid for the
4214 -expires field:
4215
4216         +30s                              30 seconds from now
4217         +10m                              ten minutes from now
4218         +1h                               one hour from now
4219         -1d                               yesterday (i.e. "ASAP!")
4220         now                               immediately
4221         +3M                               in three months
4222         +10y                              in ten years time
4223         Thursday, 25-Apr-1999 00:40:33 GMT  at the indicated time & date
4224
4225 The B<-cookie> parameter generates a header that tells the browser to provide
4226 a "magic cookie" during all subsequent transactions with your script.
4227 Netscape cookies have a special format that includes interesting attributes
4228 such as expiration time.  Use the cookie() method to create and retrieve
4229 session cookies.
4230
4231 The B<-nph> parameter, if set to a true value, will issue the correct
4232 headers to work with a NPH (no-parse-header) script.  This is important
4233 to use with certain servers, such as Microsoft Internet Explorer, which
4234 expect all their scripts to be NPH.
4235
4236 =head2 GENERATING A REDIRECTION HEADER
4237
4238    print $query->redirect('http://somewhere.else/in/movie/land');
4239
4240 Sometimes you don't want to produce a document yourself, but simply
4241 redirect the browser elsewhere, perhaps choosing a URL based on the
4242 time of day or the identity of the user.  
4243
4244 The redirect() function redirects the browser to a different URL.  If
4245 you use redirection like this, you should B<not> print out a header as
4246 well.  As of version 2.0, we produce both the unofficial Location:
4247 header and the official URI: header.  This should satisfy most servers
4248 and browsers.
4249
4250 One hint I can offer is that relative links may not work correctly
4251 when you generate a redirection to another document on your site.
4252 This is due to a well-intentioned optimization that some servers use.
4253 The solution to this is to use the full URL (including the http: part)
4254 of the document you are redirecting to.
4255
4256 You can also use named arguments:
4257
4258     print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
4259                            -nph=>1);
4260
4261 The B<-nph> parameter, if set to a true value, will issue the correct
4262 headers to work with a NPH (no-parse-header) script.  This is important
4263 to use with certain servers, such as Microsoft Internet Explorer, which
4264 expect all their scripts to be NPH.
4265
4266 =head2 CREATING THE HTML DOCUMENT HEADER
4267
4268    print $query->start_html(-title=>'Secrets of the Pyramids',
4269                             -author=>'fred@capricorn.org',
4270                             -base=>'true',
4271                             -target=>'_blank',
4272                             -meta=>{'keywords'=>'pharaoh secret mummy',
4273                                     'copyright'=>'copyright 1996 King Tut'},
4274                             -style=>{'src'=>'/styles/style1.css'},
4275                             -BGCOLOR=>'blue');
4276
4277 After creating the HTTP header, most CGI scripts will start writing
4278 out an HTML document.  The start_html() routine creates the top of the
4279 page, along with a lot of optional information that controls the
4280 page's appearance and behavior.
4281
4282 This method returns a canned HTML header and the opening <BODY> tag.
4283 All parameters are optional.  In the named parameter form, recognized
4284 parameters are -title, -author, -base, -xbase and -target (see below
4285 for the explanation).  Any additional parameters you provide, such as
4286 the Netscape unofficial BGCOLOR attribute, are added to the <BODY>
4287 tag.  Additional parameters must be proceeded by a hyphen.
4288
4289 The argument B<-xbase> allows you to provide an HREF for the <BASE> tag
4290 different from the current location, as in
4291
4292     -xbase=>"http://home.mcom.com/"
4293
4294 All relative links will be interpreted relative to this tag.
4295
4296 The argument B<-target> allows you to provide a default target frame
4297 for all the links and fill-out forms on the page.  See the Netscape
4298 documentation on frames for details of how to manipulate this.
4299
4300     -target=>"answer_window"
4301
4302 All relative links will be interpreted relative to this tag.
4303 You add arbitrary meta information to the header with the B<-meta>
4304 argument.  This argument expects a reference to an associative array
4305 containing name/value pairs of meta information.  These will be turned
4306 into a series of header <META> tags that look something like this:
4307
4308     <META NAME="keywords" CONTENT="pharaoh secret mummy">
4309     <META NAME="description" CONTENT="copyright 1996 King Tut">
4310
4311 There is no support for the HTTP-EQUIV type of <META> tag.  This is
4312 because you can modify the HTTP header directly with the B<header()>
4313 method.  For example, if you want to send the Refresh: header, do it
4314 in the header() method:
4315
4316     print $q->header(-Refresh=>'10; URL=http://www.capricorn.com');
4317
4318 The B<-style> tag is used to incorporate cascading stylesheets into
4319 your code.  See the section on CASCADING STYLESHEETS for more information.
4320
4321 You can place other arbitrary HTML elements to the <HEAD> section with the
4322 B<-head> tag.  For example, to place the rarely-used <LINK> element in the
4323 head section, use this:
4324
4325     print start_html(-head=>Link({-rel=>'next',
4326                      -href=>'http://www.capricorn.com/s2.html'}));
4327
4328 To incorporate multiple HTML elements into the <HEAD> section, just pass an
4329 array reference:
4330
4331     print start_html(-head=>[ 
4332                              Link({-rel=>'next',
4333                                    -href=>'http://www.capricorn.com/s2.html'}),
4334                              Link({-rel=>'previous',
4335                                    -href=>'http://www.capricorn.com/s1.html'})
4336                              ]
4337                      );
4338
4339 JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
4340 B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
4341 to add Netscape JavaScript calls to your pages.  B<-script> should
4342 point to a block of text containing JavaScript function definitions.
4343 This block will be placed within a <SCRIPT> block inside the HTML (not
4344 HTTP) header.  The block is placed in the header in order to give your
4345 page a fighting chance of having all its JavaScript functions in place
4346 even if the user presses the stop button before the page has loaded
4347 completely.  CGI.pm attempts to format the script in such a way that
4348 JavaScript-naive browsers will not choke on the code: unfortunately
4349 there are some browsers, such as Chimera for Unix, that get confused
4350 by it nevertheless.
4351
4352 The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
4353 code to execute when the page is respectively opened and closed by the
4354 browser.  Usually these parameters are calls to functions defined in the
4355 B<-script> field:
4356
4357       $query = new CGI;
4358       print $query->header;
4359       $JSCRIPT=<<END;
4360       // Ask a silly question
4361       function riddle_me_this() {
4362          var r = prompt("What walks on four legs in the morning, " +
4363                        "two legs in the afternoon, " +
4364                        "and three legs in the evening?");
4365          response(r);
4366       }
4367       // Get a silly answer
4368       function response(answer) {
4369          if (answer == "man")
4370             alert("Right you are!");
4371          else
4372             alert("Wrong!  Guess again.");
4373       }
4374       END
4375       print $query->start_html(-title=>'The Riddle of the Sphinx',
4376                                -script=>$JSCRIPT);
4377
4378 Use the B<-noScript> parameter to pass some HTML text that will be displayed on 
4379 browsers that do not have JavaScript (or browsers where JavaScript is turned
4380 off).
4381
4382 Netscape 3.0 recognizes several attributes of the <SCRIPT> tag,
4383 including LANGUAGE and SRC.  The latter is particularly interesting,
4384 as it allows you to keep the JavaScript code in a file or CGI script
4385 rather than cluttering up each page with the source.  To use these
4386 attributes pass a HASH reference in the B<-script> parameter containing
4387 one or more of -language, -src, or -code:
4388
4389     print $q->start_html(-title=>'The Riddle of the Sphinx',
4390                          -script=>{-language=>'JAVASCRIPT',
4391                                    -src=>'/javascript/sphinx.js'}
4392                          );
4393
4394     print $q->(-title=>'The Riddle of the Sphinx',
4395                -script=>{-language=>'PERLSCRIPT',
4396                          -code=>'print "hello world!\n;"'}
4397                );
4398
4399
4400 A final feature allows you to incorporate multiple <SCRIPT> sections into the
4401 header.  Just pass the list of script sections as an array reference.
4402 this allows you to specify different source files for different dialects
4403 of JavaScript.  Example:     
4404
4405      print $q->start_html(-title=>'The Riddle of the Sphinx',
4406                           -script=>[
4407                                     { -language => 'JavaScript1.0',
4408                                       -src      => '/javascript/utilities10.js'
4409                                     },
4410                                     { -language => 'JavaScript1.1',
4411                                       -src      => '/javascript/utilities11.js'
4412                                     },
4413                                     { -language => 'JavaScript1.2',
4414                                       -src      => '/javascript/utilities12.js'
4415                                     },
4416                                     { -language => 'JavaScript28.2',
4417                                       -src      => '/javascript/utilities219.js'
4418                                     }
4419                                  ]
4420                              );
4421      </pre>
4422
4423 If this looks a bit extreme, take my advice and stick with straight CGI scripting.  
4424
4425 See
4426
4427    http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
4428
4429 for more information about JavaScript.
4430
4431 The old-style positional parameters are as follows:
4432
4433 =over 4
4434
4435 =item B<Parameters:>
4436
4437 =item 1.
4438
4439 The title
4440
4441 =item 2.
4442
4443 The author's e-mail address (will create a <LINK REV="MADE"> tag if present
4444
4445 =item 3.
4446
4447 A 'true' flag if you want to include a <BASE> tag in the header.  This
4448 helps resolve relative addresses to absolute ones when the document is moved, 
4449 but makes the document hierarchy non-portable.  Use with care!
4450
4451 =item 4, 5, 6...
4452
4453 Any other parameters you want to include in the <BODY> tag.  This is a good
4454 place to put Netscape extensions, such as colors and wallpaper patterns.
4455
4456 =back
4457
4458 =head2 ENDING THE HTML DOCUMENT:
4459
4460         print $query->end_html
4461
4462 This ends an HTML document by printing the </BODY></HTML> tags.
4463
4464 =head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
4465
4466     $myself = $query->self_url;
4467     print "<A HREF=$myself>I'm talking to myself.</A>";
4468
4469 self_url() will return a URL, that, when selected, will reinvoke
4470 this script with all its state information intact.  This is most
4471 useful when you want to jump around within the document using
4472 internal anchors but you don't want to disrupt the current contents
4473 of the form(s).  Something like this will do the trick.
4474
4475      $myself = $query->self_url;
4476      print "<A HREF=$myself#table1>See table 1</A>";
4477      print "<A HREF=$myself#table2>See table 2</A>";
4478      print "<A HREF=$myself#yourself>See for yourself</A>";
4479
4480 If you want more control over what's returned, using the B<url()>
4481 method instead.
4482
4483 You can also retrieve the unprocessed query string with query_string():
4484
4485     $the_string = $query->query_string;
4486
4487 =head2 OBTAINING THE SCRIPT'S URL
4488
4489     $full_url      = $query->url();
4490     $full_url      = $query->url(-full=>1);  #alternative syntax
4491     $relative_url  = $query->url(-relative=>1);
4492     $absolute_url  = $query->url(-absolute=>1);
4493     $url_with_path = $query->url(-path_info=>1);
4494     $url_with_path_and_query = $query->url(-path_info=>1,-query=>1);
4495
4496 B<url()> returns the script's URL in a variety of formats.  Called
4497 without any arguments, it returns the full form of the URL, including
4498 host name and port number
4499
4500     http://your.host.com/path/to/script.cgi
4501
4502 You can modify this format with the following named arguments:
4503
4504 =over 4
4505
4506 =item B<-absolute>
4507
4508 If true, produce an absolute URL, e.g.
4509
4510     /path/to/script.cgi
4511
4512 =item B<-relative>
4513
4514 Produce a relative URL.  This is useful if you want to reinvoke your
4515 script with different parameters. For example:
4516
4517     script.cgi
4518
4519 =item B<-full>
4520
4521 Produce the full URL, exactly as if called without any arguments.
4522 This overrides the -relative and -absolute arguments.
4523
4524 =item B<-path> (B<-path_info>)
4525
4526 Append the additional path information to the URL.  This can be
4527 combined with B<-full>, B<-absolute> or B<-relative>.  B<-path_info>
4528 is provided as a synonym.
4529
4530 =item B<-query> (B<-query_string>)
4531
4532 Append the query string to the URL.  This can be combined with
4533 B<-full>, B<-absolute> or B<-relative>.  B<-query_string> is provided
4534 as a synonym.
4535
4536 =back
4537
4538 =head2 MIXING POST AND URL PARAMETERS
4539
4540    $color = $query-&gt;url_param('color');
4541
4542 It is possible for a script to receive CGI parameters in the URL as
4543 well as in the fill-out form by creating a form that POSTs to a URL
4544 containing a query string (a "?" mark followed by arguments).  The
4545 B<param()> method will always return the contents of the POSTed
4546 fill-out form, ignoring the URL's query string.  To retrieve URL
4547 parameters, call the B<url_param()> method.  Use it in the same way as
4548 B<param()>.  The main difference is that it allows you to read the
4549 parameters, but not set them.
4550
4551
4552 Under no circumstances will the contents of the URL query string
4553 interfere with similarly-named CGI parameters in POSTed forms.  If you
4554 try to mix a URL query string with a form submitted with the GET
4555 method, the results will not be what you expect.
4556
4557 =head1 CREATING STANDARD HTML ELEMENTS:
4558
4559 CGI.pm defines general HTML shortcut methods for most, if not all of
4560 the HTML 3 and HTML 4 tags.  HTML shortcuts are named after a single
4561 HTML element and return a fragment of HTML text that you can then
4562 print or manipulate as you like.  Each shortcut returns a fragment of
4563 HTML code that you can append to a string, save to a file, or, most
4564 commonly, print out so that it displays in the browser window.
4565
4566 This example shows how to use the HTML methods:
4567
4568    $q = new CGI;
4569    print $q->blockquote(
4570                      "Many years ago on the island of",
4571                      $q->a({href=>"http://crete.org/"},"Crete"),
4572                      "there lived a Minotaur named",
4573                      $q->strong("Fred."),
4574                     ),
4575        $q->hr;
4576
4577 This results in the following HTML code (extra newlines have been
4578 added for readability):
4579
4580    <blockquote>
4581    Many years ago on the island of
4582    <a HREF="http://crete.org/">Crete</a> there lived
4583    a minotaur named <strong>Fred.</strong> 
4584    </blockquote>
4585    <hr>
4586
4587 If you find the syntax for calling the HTML shortcuts awkward, you can
4588 import them into your namespace and dispense with the object syntax
4589 completely (see the next section for more details):
4590
4591    use CGI ':standard';
4592    print blockquote(
4593       "Many years ago on the island of",
4594       a({href=>"http://crete.org/"},"Crete"),
4595       "there lived a minotaur named",
4596       strong("Fred."),
4597       ),
4598       hr;
4599
4600 =head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
4601
4602 The HTML methods will accept zero, one or multiple arguments.  If you
4603 provide no arguments, you get a single tag:
4604
4605    print hr;    #  <HR>
4606
4607 If you provide one or more string arguments, they are concatenated
4608 together with spaces and placed between opening and closing tags:
4609
4610    print h1("Chapter","1"); # <H1>Chapter 1</H1>"
4611
4612 If the first argument is an associative array reference, then the keys
4613 and values of the associative array become the HTML tag's attributes:
4614
4615    print a({-href=>'fred.html',-target=>'_new'},
4616       "Open a new frame");
4617
4618             <A HREF="fred.html",TARGET="_new">Open a new frame</A>
4619
4620 You may dispense with the dashes in front of the attribute names if
4621 you prefer:
4622
4623    print img {src=>'fred.gif',align=>'LEFT'};
4624
4625            <IMG ALIGN="LEFT" SRC="fred.gif">
4626
4627 Sometimes an HTML tag attribute has no argument.  For example, ordered
4628 lists can be marked as COMPACT.  The syntax for this is an argument that
4629 that points to an undef string:
4630
4631    print ol({compact=>undef},li('one'),li('two'),li('three'));
4632
4633 Prior to CGI.pm version 2.41, providing an empty ('') string as an
4634 attribute argument was the same as providing undef.  However, this has
4635 changed in order to accommodate those who want to create tags of the form 
4636 <IMG ALT="">.  The difference is shown in these two pieces of code:
4637
4638    CODE                   RESULT
4639    img({alt=>undef})      <IMG ALT>
4640    img({alt=>''})         <IMT ALT="">
4641
4642 =head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
4643
4644 One of the cool features of the HTML shortcuts is that they are
4645 distributive.  If you give them an argument consisting of a
4646 B<reference> to a list, the tag will be distributed across each
4647 element of the list.  For example, here's one way to make an ordered
4648 list:
4649
4650    print ul(
4651              li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']);
4652            );
4653
4654 This example will result in HTML output that looks like this:
4655
4656    <UL>
4657      <LI TYPE="disc">Sneezy</LI>
4658      <LI TYPE="disc">Doc</LI>
4659      <LI TYPE="disc">Sleepy</LI>
4660      <LI TYPE="disc">Happy</LI>
4661    </UL>
4662
4663 This is extremely useful for creating tables.  For example:
4664
4665    print table({-border=>undef},
4666            caption('When Should You Eat Your Vegetables?'),
4667            Tr({-align=>CENTER,-valign=>TOP},
4668            [
4669               th(['Vegetable', 'Breakfast','Lunch','Dinner']),
4670               td(['Tomatoes' , 'no', 'yes', 'yes']),
4671               td(['Broccoli' , 'no', 'no',  'yes']),
4672               td(['Onions'   , 'yes','yes', 'yes'])
4673            ]
4674            )
4675         );
4676
4677 =head2 HTML SHORTCUTS AND LIST INTERPOLATION
4678
4679 Consider this bit of code:
4680
4681    print blockquote(em('Hi'),'mom!'));
4682
4683 It will ordinarily return the string that you probably expect, namely:
4684
4685    <BLOCKQUOTE><EM>Hi</EM> mom!</BLOCKQUOTE>
4686
4687 Note the space between the element "Hi" and the element "mom!".
4688 CGI.pm puts the extra space there using array interpolation, which is
4689 controlled by the magic $" variable.  Sometimes this extra space is
4690 not what you want, for example, when you are trying to align a series
4691 of images.  In this case, you can simply change the value of $" to an
4692 empty string.
4693
4694    {
4695       local($") = '';
4696       print blockquote(em('Hi'),'mom!'));
4697     }
4698
4699 I suggest you put the code in a block as shown here.  Otherwise the
4700 change to $" will affect all subsequent code until you explicitly
4701 reset it.
4702
4703 =head2 NON-STANDARD HTML SHORTCUTS
4704
4705 A few HTML tags don't follow the standard pattern for various
4706 reasons.  
4707
4708 B<comment()> generates an HTML comment (<!-- comment -->).  Call it
4709 like
4710
4711     print comment('here is my comment');
4712
4713 Because of conflicts with built-in Perl functions, the following functions
4714 begin with initial caps:
4715
4716     Select
4717     Tr
4718     Link
4719     Delete
4720     Accept
4721     Sub
4722
4723 In addition, start_html(), end_html(), start_form(), end_form(),
4724 start_multipart_form() and all the fill-out form tags are special.
4725 See their respective sections.
4726
4727 =head2 PRETTY-PRINTING HTML
4728
4729 By default, all the HTML produced by these functions comes out as one
4730 long line without carriage returns or indentation. This is yuck, but
4731 it does reduce the size of the documents by 10-20%.  To get
4732 pretty-printed output, please use L<CGI::Pretty>, a subclass
4733 contributed by Brian Paulsen.
4734
4735 =head1 CREATING FILL-OUT FORMS:
4736
4737 I<General note>  The various form-creating methods all return strings
4738 to the caller, containing the tag or tags that will create the requested
4739 form element.  You are responsible for actually printing out these strings.
4740 It's set up this way so that you can place formatting tags
4741 around the form elements.
4742
4743 I<Another note> The default values that you specify for the forms are only
4744 used the B<first> time the script is invoked (when there is no query
4745 string).  On subsequent invocations of the script (when there is a query
4746 string), the former values are used even if they are blank.  
4747
4748 If you want to change the value of a field from its previous value, you have two
4749 choices:
4750
4751 (1) call the param() method to set it.
4752
4753 (2) use the -override (alias -force) parameter (a new feature in version 2.15).
4754 This forces the default value to be used, regardless of the previous value:
4755
4756    print $query->textfield(-name=>'field_name',
4757                            -default=>'starting value',
4758                            -override=>1,
4759                            -size=>50,
4760                            -maxlength=>80);
4761
4762 I<Yet another note> By default, the text and labels of form elements are
4763 escaped according to HTML rules.  This means that you can safely use
4764 "<CLICK ME>" as the label for a button.  However, it also interferes with
4765 your ability to incorporate special HTML character sequences, such as &Aacute;,
4766 into your fields.  If you wish to turn off automatic escaping, call the
4767 autoEscape() method with a false value immediately after creating the CGI object:
4768
4769    $query = new CGI;
4770    $query->autoEscape(undef);
4771
4772
4773 =head2 CREATING AN ISINDEX TAG
4774
4775    print $query->isindex(-action=>$action);
4776
4777          -or-
4778
4779    print $query->isindex($action);
4780
4781 Prints out an <ISINDEX> tag.  Not very exciting.  The parameter
4782 -action specifies the URL of the script to process the query.  The
4783 default is to process the query with the current script.
4784
4785 =head2 STARTING AND ENDING A FORM
4786
4787     print $query->startform(-method=>$method,
4788                             -action=>$action,
4789                             -enctype=>$encoding);
4790       <... various form stuff ...>
4791     print $query->endform;
4792
4793         -or-
4794
4795     print $query->startform($method,$action,$encoding);
4796       <... various form stuff ...>
4797     print $query->endform;
4798
4799 startform() will return a <FORM> tag with the optional method,
4800 action and form encoding that you specify.  The defaults are:
4801
4802     method: POST
4803     action: this script
4804     enctype: application/x-www-form-urlencoded
4805
4806 endform() returns the closing </FORM> tag.  
4807
4808 Startform()'s enctype argument tells the browser how to package the various
4809 fields of the form before sending the form to the server.  Two
4810 values are possible:
4811
4812 =over 4
4813
4814 =item B<application/x-www-form-urlencoded>
4815
4816 This is the older type of encoding used by all browsers prior to
4817 Netscape 2.0.  It is compatible with many CGI scripts and is
4818 suitable for short fields containing text data.  For your
4819 convenience, CGI.pm stores the name of this encoding
4820 type in B<$CGI::URL_ENCODED>.
4821
4822 =item B<multipart/form-data>
4823
4824 This is the newer type of encoding introduced by Netscape 2.0.
4825 It is suitable for forms that contain very large fields or that
4826 are intended for transferring binary data.  Most importantly,
4827 it enables the "file upload" feature of Netscape 2.0 forms.  For
4828 your convenience, CGI.pm stores the name of this encoding type
4829 in B<&CGI::MULTIPART>
4830
4831 Forms that use this type of encoding are not easily interpreted
4832 by CGI scripts unless they use CGI.pm or another library designed
4833 to handle them.
4834
4835 =back
4836
4837 For compatibility, the startform() method uses the older form of
4838 encoding by default.  If you want to use the newer form of encoding
4839 by default, you can call B<start_multipart_form()> instead of
4840 B<startform()>.
4841
4842 JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
4843 for use with JavaScript.  The -name parameter gives the
4844 form a name so that it can be identified and manipulated by
4845 JavaScript functions.  -onSubmit should point to a JavaScript
4846 function that will be executed just before the form is submitted to your
4847 server.  You can use this opportunity to check the contents of the form 
4848 for consistency and completeness.  If you find something wrong, you
4849 can put up an alert box or maybe fix things up yourself.  You can 
4850 abort the submission by returning false from this function.  
4851
4852 Usually the bulk of JavaScript functions are defined in a <SCRIPT>
4853 block in the HTML header and -onSubmit points to one of these function
4854 call.  See start_html() for details.
4855
4856 =head2 CREATING A TEXT FIELD
4857
4858     print $query->textfield(-name=>'field_name',
4859                             -default=>'starting value',
4860                             -size=>50,
4861                             -maxlength=>80);
4862         -or-
4863
4864     print $query->textfield('field_name','starting value',50,80);
4865
4866 textfield() will return a text input field.  
4867
4868 =over 4
4869
4870 =item B<Parameters>
4871
4872 =item 1.
4873
4874 The first parameter is the required name for the field (-name).  
4875
4876 =item 2.
4877
4878 The optional second parameter is the default starting value for the field
4879 contents (-default).  
4880
4881 =item 3.
4882
4883 The optional third parameter is the size of the field in
4884       characters (-size).
4885
4886 =item 4.
4887
4888 The optional fourth parameter is the maximum number of characters the
4889       field will accept (-maxlength).
4890
4891 =back
4892
4893 As with all these methods, the field will be initialized with its 
4894 previous contents from earlier invocations of the script.
4895 When the form is processed, the value of the text field can be
4896 retrieved with:
4897
4898        $value = $query->param('foo');
4899
4900 If you want to reset it from its initial value after the script has been
4901 called once, you can do so like this:
4902
4903        $query->param('foo',"I'm taking over this value!");
4904
4905 NEW AS OF VERSION 2.15: If you don't want the field to take on its previous
4906 value, you can force its current value by using the -override (alias -force)
4907 parameter:
4908
4909     print $query->textfield(-name=>'field_name',
4910                             -default=>'starting value',
4911                             -override=>1,
4912                             -size=>50,
4913                             -maxlength=>80);
4914
4915 JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>,
4916 B<-onBlur>, B<-onMouseOver>, B<-onMouseOut> and B<-onSelect>
4917 parameters to register JavaScript event handlers.  The onChange
4918 handler will be called whenever the user changes the contents of the
4919 text field.  You can do text validation if you like.  onFocus and
4920 onBlur are called respectively when the insertion point moves into and
4921 out of the text field.  onSelect is called when the user changes the
4922 portion of the text that is selected.
4923
4924 =head2 CREATING A BIG TEXT FIELD
4925
4926    print $query->textarea(-name=>'foo',
4927                           -default=>'starting value',
4928                           -rows=>10,
4929                           -columns=>50);
4930
4931         -or
4932
4933    print $query->textarea('foo','starting value',10,50);
4934
4935 textarea() is just like textfield, but it allows you to specify
4936 rows and columns for a multiline text entry box.  You can provide
4937 a starting value for the field, which can be long and contain
4938 multiple lines.
4939
4940 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> ,
4941 B<-onMouseOver>, B<-onMouseOut>, and B<-onSelect> parameters are
4942 recognized.  See textfield().
4943
4944 =head2 CREATING A PASSWORD FIELD
4945
4946    print $query->password_field(-name=>'secret',
4947                                 -value=>'starting value',
4948                                 -size=>50,
4949                                 -maxlength=>80);
4950         -or-
4951
4952    print $query->password_field('secret','starting value',50,80);
4953
4954 password_field() is identical to textfield(), except that its contents 
4955 will be starred out on the web page.
4956
4957 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
4958 B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
4959 recognized.  See textfield().
4960
4961 =head2 CREATING A FILE UPLOAD FIELD
4962
4963     print $query->filefield(-name=>'uploaded_file',
4964                             -default=>'starting value',
4965                             -size=>50,
4966                             -maxlength=>80);
4967         -or-
4968
4969     print $query->filefield('uploaded_file','starting value',50,80);
4970
4971 filefield() will return a file upload field for Netscape 2.0 browsers.
4972 In order to take full advantage of this I<you must use the new 
4973 multipart encoding scheme> for the form.  You can do this either
4974 by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>,
4975 or by calling the new method B<start_multipart_form()> instead of
4976 vanilla B<startform()>.
4977
4978 =over 4
4979
4980 =item B<Parameters>
4981
4982 =item 1.
4983
4984 The first parameter is the required name for the field (-name).