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