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