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