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