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