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