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