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