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