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