File Coverage

CGI.pm
Criterion Covered Total %
statement n/a
branch n/a
condition n/a
subroutine n/a
pod n/a
total n/a


line stmt bran cond sub pod time code
1             package CGI;
2             require 5.004;
3             use Carp 'croak';
4              
5             # See the bottom of this file for the POD documentation. Search for the
6             # string '=head'.
7              
8             # You can run this file through either pod2man or pod2html to produce pretty
9             # documentation in manual or html file format (these utilities are part of the
10             # Perl 5 distribution).
11              
12             # Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
13             # It may be used and modified freely, but I do request that this copyright
14             # notice remain attached to the file. You may modify this module as you
15             # wish, but if you redistribute a modified version, please attach a note
16             # listing the modifications you have made.
17              
18             # The most recent version and complete docs are available at:
19             # http://stein.cshl.org/WWW/software/CGI/
20              
21             $CGI::revision = '$Id: CGI.pm,v 1.227 2007/02/23 23:03:16 lstein Exp $';
22             $CGI::VERSION='3.27';
23              
24             # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
25             # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
26             # $CGITempFile::TMPDIRECTORY = '/usr/tmp';
27             use CGI::Util qw(rearrange make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
28              
29             #use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
30             # 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
31              
32             use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
33                                        'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
34              
35             {
36               local $^W = 0;
37               $TAINTED = substr("$0$^X",0,0);
38             }
39              
40             $MOD_PERL = 0; # no mod_perl by default
41             @SAVED_SYMBOLS = ();
42              
43              
44             # >>>>> Here are some globals that you might want to adjust <<<<<<
45             sub initialize_globals {
46             # Set this to 1 to enable copious autoloader debugging messages
47                 $AUTOLOAD_DEBUG = 0;
48              
49             # Set this to 1 to generate XTML-compatible output
50                 $XHTML = 1;
51              
52             # Change this to the preferred DTD to print in start_html()
53             # or use default_dtd('text of DTD to use');
54                 $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
55             'http://www.w3.org/TR/html4/loose.dtd' ] ;
56              
57             # Set this to 1 to enable NOSTICKY scripts
58             # or:
59             # 1) use CGI qw(-nosticky)
60             # 2) $CGI::nosticky(1)
61                 $NOSTICKY = 0;
62              
63             # Set this to 1 to enable NPH scripts
64             # or:
65             # 1) use CGI qw(-nph)
66             # 2) CGI::nph(1)
67             # 3) print header(-nph=>1)
68                 $NPH = 0;
69              
70             # Set this to 1 to enable debugging from @ARGV
71             # Set to 2 to enable debugging from STDIN
72                 $DEBUG = 1;
73              
74             # Set this to 1 to make the temporary files created
75             # during file uploads safe from prying eyes
76             # or do...
77             # 1) use CGI qw(:private_tempfiles)
78             # 2) CGI::private_tempfiles(1);
79                 $PRIVATE_TEMPFILES = 0;
80              
81             # Set this to 1 to generate automatic tab indexes
82                 $TABINDEX = 0;
83              
84             # Set this to 1 to cause files uploaded in multipart documents
85             # to be closed, instead of caching the file handle
86             # or:
87             # 1) use CGI qw(:close_upload_files)
88             # 2) $CGI::close_upload_files(1);
89             # Uploads with many files run out of file handles.
90             # Also, for performance, since the file is already on disk,
91             # it can just be renamed, instead of read and written.
92                 $CLOSE_UPLOAD_FILES = 0;
93              
94             # Set this to a positive value to limit the size of a POSTing
95             # to a certain number of bytes:
96                 $POST_MAX = -1;
97              
98             # Change this to 1 to disable uploads entirely:
99                 $DISABLE_UPLOADS = 0;
100              
101             # Automatically determined -- don't change
102                 $EBCDIC = 0;
103              
104             # Change this to 1 to suppress redundant HTTP headers
105                 $HEADERS_ONCE = 0;
106              
107             # separate the name=value pairs by semicolons rather than ampersands
108                 $USE_PARAM_SEMICOLONS = 1;
109              
110             # Do not include undefined params parsed from query string
111             # use CGI qw(-no_undef_params);
112                 $NO_UNDEF_PARAMS = 0;
113              
114             # Other globals that you shouldn't worry about.
115                 undef $Q;
116                 $BEEN_THERE = 0;
117                 $DTD_PUBLIC_IDENTIFIER = "";
118                 undef @QUERY_PARAM;
119                 undef %EXPORT;
120                 undef $QUERY_CHARSET;
121                 undef %QUERY_FIELDNAMES;
122              
123             # prevent complaints by mod_perl
124                 1;
125             }
126              
127             # ------------------ START OF THE LIBRARY ------------
128              
129             *end_form = \&endform;
130              
131             # make mod_perlhappy
132             initialize_globals();
133              
134             # FIGURE OUT THE OS WE'RE RUNNING UNDER
135             # Some systems support the $^O variable. If not
136             # available then require() the Config library
137             unless ($OS) {
138                 unless ($OS = $^O) {
139             require Config;
140             $OS = $Config::Config{'osname'};
141                 }
142             }
143             if ($OS =~ /^MSWin/i) {
144               $OS = 'WINDOWS';
145             } elsif ($OS =~ /^VMS/i) {
146               $OS = 'VMS';
147             } elsif ($OS =~ /^dos/i) {
148               $OS = 'DOS';
149             } elsif ($OS =~ /^MacOS/i) {
150                 $OS = 'MACINTOSH';
151             } elsif ($OS =~ /^os2/i) {
152                 $OS = 'OS2';
153             } elsif ($OS =~ /^epoc/i) {
154                 $OS = 'EPOC';
155             } elsif ($OS =~ /^cygwin/i) {
156                 $OS = 'CYGWIN';
157             } else {
158                 $OS = 'UNIX';
159             }
160              
161             # Some OS logic. Binary mode enabled on DOS, NT and VMS
162             $needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN)/;
163              
164             # This is the default class for the CGI object to use when all else fails.
165             $DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
166              
167             # This is where to look for autoloaded routines.
168             $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
169              
170             # The path separator is a slash, backslash or semicolon, depending
171             # on the paltform.
172             $SL = {
173                  UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/',
174                  WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
175                 }->{$OS};
176              
177             # This no longer seems to be necessary
178             # Turn on NPH scripts by default when running under IIS server!
179             # $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
180             $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
181              
182             # Turn on special checking for Doug MacEachern's modperl
183             if (exists $ENV{MOD_PERL}) {
184             # mod_perl handlers may run system() on scripts using CGI.pm;
185             # Make sure so we don't get fooled by inherited $ENV{MOD_PERL}
186               if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
187                 $MOD_PERL = 2;
188                 require Apache2::Response;
189                 require Apache2::RequestRec;
190                 require Apache2::RequestUtil;
191                 require Apache2::RequestIO;
192                 require APR::Pool;
193               } else {
194                 $MOD_PERL = 1;
195                 require Apache;
196               }
197             }
198              
199             # Turn on special checking for ActiveState's PerlEx
200             $PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
201              
202             # Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
203             # of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
204             # and sometimes CR). The most popular VMS web server
205             # doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
206             # use ASCII, so \015\012 means something different. I find this all
207             # really annoying.
208             $EBCDIC = "\t" ne "\011";
209             if ($OS eq 'VMS') {
210               $CRLF = "\n";
211             } elsif ($EBCDIC) {
212               $CRLF= "\r\n";
213             } else {
214               $CRLF = "\015\012";
215             }
216              
217             if ($needs_binmode) {
218                 $CGI::DefaultClass->binmode(\*main::STDOUT);
219                 $CGI::DefaultClass->binmode(\*main::STDIN);
220                 $CGI::DefaultClass->binmode(\*main::STDERR);
221             }
222              
223             %EXPORT_TAGS = (
224             ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
225             tt u i b blockquote pre img a address cite samp dfn html head
226             base body Link nextid title meta kbd start_html end_html
227             input Select option comment charset escapeHTML/],
228             ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param
229             embed basefont style span layer ilayer font frameset frame script small big Area Map/],
230                             ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
231             ins label legend noframes noscript object optgroup Q
232             thead tbody tfoot/], 
233             ':netscape'=>[qw/blink fontsize center/],
234             ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
235             submit reset defaults radio_group popup_menu button autoEscape
236             scrolling_list image_button start_form end_form startform endform
237             start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
238             ':cgi'=>[qw/param upload path_info path_translated request_uri url self_url script_name
239             cookie Dump
240             raw_cookie request_method query_string Accept user_agent remote_host content_type
241             remote_addr referer server_name server_software server_port server_protocol virtual_port
242             virtual_host remote_ident auth_type http append
243             save_parameters restore_parameters param_fetch
244             remote_user user_name header redirect import_names put
245             Delete Delete_all url_param cgi_error/],
246             ':ssl' => [qw/https/],
247             ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
248             ':html' => [qw/:html2 :html3 :html4 :netscape/],
249             ':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
250             ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
251             ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/]
252             );
253              
254             # Custom 'can' method for both autoloaded and non-autoloaded subroutines.
255             # Author: Cees Hek <cees@sitesuite.com.au>
256              
257             sub can {
258             my($class, $method) = @_;
259              
260             # See if UNIVERSAL::can finds it.
261              
262             if (my $func = $class -> SUPER::can($method) ){
263             return $func;
264             }
265              
266             # Try to compile the function.
267              
268             eval {
269             # _compile looks at $AUTOLOAD for the function name.
270              
271             local $AUTOLOAD = join "::", $class, $method;
272             &_compile;
273             };
274              
275             # Now that the function is loaded (if it exists)
276             # just use UNIVERSAL::can again to do the work.
277              
278             return $class -> SUPER::can($method);
279             }
280              
281             # to import symbols into caller
282             sub import {
283                 my $self = shift;
284              
285             # This causes modules to clash.
286                 undef %EXPORT_OK;
287                 undef %EXPORT;
288              
289                 $self->_setup_symbols(@_);
290                 my ($callpack, $callfile, $callline) = caller;
291              
292             # To allow overriding, search through the packages
293             # Till we find one in which the correct subroutine is defined.
294                 my @packages = ($self,@{"$self\:\:ISA"});
295                 foreach $sym (keys %EXPORT) {
296             my $pck;
297             my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
298             foreach $pck (@packages) {
299             if (defined(&{"$pck\:\:$sym"})) {
300             $def = $pck;
301             last;
302             }
303             }
304             *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
305                 }
306             }
307              
308             sub compile {
309                 my $pack = shift;
310                 $pack->_setup_symbols('-compile',@_);
311             }
312              
313             sub expand_tags {
314                 my($tag) = @_;
315                 return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
316                 my(@r);
317                 return ($tag) unless $EXPORT_TAGS{$tag};
318                 foreach (@{$EXPORT_TAGS{$tag}}) {
319             push(@r,&expand_tags($_));
320                 }
321                 return @r;
322             }
323              
324             #### Method: new
325             # The new routine. This will check the current environment
326             # for an existing query string, and initialize itself, if so.
327             ####
328             sub new {
329               my($class,@initializer) = @_;
330               my $self = {};
331              
332               bless $self,ref $class || $class || $DefaultClass;
333              
334             # always use a tempfile
335               $self->{'use_tempfile'} = 1;
336              
337               if (ref($initializer[0])
338                   && (UNIVERSAL::isa($initializer[0],'Apache')
339             ||
340             UNIVERSAL::isa($initializer[0],'Apache2::RequestRec')
341             )) {
342                 $self->r(shift @initializer);
343               }
344              if (ref($initializer[0])
345                  && (UNIVERSAL::isa($initializer[0],'CODE'))) {
346                 $self->upload_hook(shift @initializer, shift @initializer);
347                 $self->{'use_tempfile'} = shift @initializer if (@initializer > 0);
348               }
349               if ($MOD_PERL) {
350                 if ($MOD_PERL == 1) {
351                   $self->r(Apache->request) unless $self->r;
352                   my $r = $self->r;
353                   $r->register_cleanup(\&CGI::_reset_globals);
354                 }
355                 else {
356             # XXX: once we have the new API
357             # will do a real PerlOptions -SetupEnv check
358                   $self->r(Apache2::RequestUtil->request) unless $self->r;
359                   my $r = $self->r;
360                   $r->subprocess_env unless exists $ENV{REQUEST_METHOD};
361                   $r->pool->cleanup_register(\&CGI::_reset_globals);
362                 }
363                 undef $NPH;
364               }
365               $self->_reset_globals if $PERLEX;
366               $self->init(@initializer);
367               return $self;
368             }
369              
370             # We provide a DESTROY method so that we can ensure that
371             # temporary files are closed (via Fh->DESTROY) before they
372             # are unlinked (via CGITempFile->DESTROY) because it is not
373             # possible to unlink an open file on Win32. We explicitly
374             # call DESTROY on each, rather than just undefing them and
375             # letting Perl DESTROY them by garbage collection, in case the
376             # user is still holding any reference to them as well.
377             sub DESTROY {
378               my $self = shift;
379               if ($OS eq 'WINDOWS') {
380                 foreach my $href (values %{$self->{'.tmpfiles'}}) {
381                   $href->{hndl}->DESTROY if defined $href->{hndl};
382                   $href->{name}->DESTROY if defined $href->{name};
383                 }
384               }
385             }
386              
387             sub r {
388               my $self = shift;
389               my $r = $self->{'.r'};
390               $self->{'.r'} = shift if @_;
391               $r;
392             }
393              
394             sub upload_hook {
395               my $self;
396               if (ref $_[0] eq 'CODE') {
397                 $CGI::Q = $self = $CGI::DefaultClass->new(@_);
398               } else {
399                 $self = shift;
400               }
401               my ($hook,$data,$use_tempfile) = @_;
402               $self->{'.upload_hook'} = $hook;
403               $self->{'.upload_data'} = $data;
404               $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile;
405             }
406              
407             #### Method: param
408             # Returns the value(s)of a named parameter.
409             # If invoked in a list context, returns the
410             # entire list. Otherwise returns the first
411             # member of the list.
412             # If name is not provided, return a list of all
413             # the known parameters names available.
414             # If more than one argument is provided, the
415             # second and subsequent arguments are used to
416             # set the value of the parameter.
417             ####
418             sub param {
419                 my($self,@p) = self_or_default(@_);
420                 return $self->all_parameters unless @p;
421                 my($name,$value,@other);
422              
423             # For compatibility between old calling style and use_named_parameters() style,
424             # we have to special case for a single parameter present.
425                 if (@p > 1) {
426             ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
427             my(@values);
428              
429             if (substr($p[0],0,1) eq '-') {
430             @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
431             } else {
432             foreach ($value,@other) {
433             push(@values,$_) if defined($_);
434             }
435             }
436             # If values is provided, then we set it.
437             if (@values or defined $value) {
438             $self->add_parameter($name);
439             $self->{$name}=[@values];
440             }
441                 } else {
442             $name = $p[0];
443                 }
444              
445                 return unless defined($name) && $self->{$name};
446              
447                 my $charset = $self->charset || '';
448                 my $utf8 = $charset eq 'utf-8';
449                 if ($utf8) {
450                   eval "require Encode; 1;" if $utf8 && !Encode->can('decode'); # bring in these functions
451                   return wantarray ? map {Encode::decode(utf8=>$_) } @{$self->{$name}}
452                                    : Encode::decode(utf8=>$self->{$name}->[0]);
453                 } else {
454                   return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
455                 }
456             }
457              
458             sub self_or_default {
459                 return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
460                 unless (defined($_[0]) &&
461             (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
462             ) {
463             $Q = $CGI::DefaultClass->new unless defined($Q);
464             unshift(@_,$Q);
465                 }
466                 return wantarray ? @_ : $Q;
467             }
468              
469             sub self_or_CGI {
470                 local $^W=0; # prevent a warning
471                 if (defined($_[0]) &&
472             (substr(ref($_[0]),0,3) eq 'CGI'
473             || UNIVERSAL::isa($_[0],'CGI'))) {
474             return @_;
475                 } else {
476             return ($DefaultClass,@_);
477                 }
478             }
479              
480             ########################################
481             # THESE METHODS ARE MORE OR LESS PRIVATE
482             # GO TO THE __DATA__ SECTION TO SEE MORE
483             # PUBLIC METHODS
484             ########################################
485              
486             # Initialize the query object from the environment.
487             # If a parameter list is found, this object will be set
488             # to an associative array in which parameter names are keys
489             # and the values are stored as lists
490             # If a keyword list is found, this method creates a bogus
491             # parameter list with the single parameter 'keywords'.
492              
493             sub init {
494               my $self = shift;
495               my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
496              
497               my $is_xforms;
498              
499               my $initializer = shift; # for backward compatibility
500               local($/) = "\n";
501              
502             # set autoescaping on by default
503                 $self->{'escape'} = 1;
504              
505             # if we get called more than once, we want to initialize
506             # ourselves from the original query (which may be gone
507             # if it was read from STDIN originally.)
508                 if (defined(@QUERY_PARAM) && !defined($initializer)) {
509             foreach (@QUERY_PARAM) {
510             $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
511             }
512             $self->charset($QUERY_CHARSET);
513             $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
514             return;
515                 }
516              
517                 $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
518                 $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
519              
520                 $fh = to_filehandle($initializer) if $initializer;
521              
522             # set charset to the safe ISO-8859-1
523                 $self->charset('ISO-8859-1');
524              
525               METHOD: {
526              
527             # avoid unreasonably large postings
528                   if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
529             #discard the post, unread
530             $self->cgi_error("413 Request entity too large");
531             last METHOD;
532                   }
533              
534             # Process multipart postings, but only if the initializer is
535             # not defined.
536                   if ($meth eq 'POST'
537             && defined($ENV{'CONTENT_TYPE'})
538             && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
539             && !defined($initializer)
540             ) {
541             my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
542             $self->read_multipart($boundary,$content_length);
543             last METHOD;
544                   }
545              
546             # Process XForms postings. We know that we have XForms in the
547             # following cases:
548             # method eq 'POST' && content-type eq 'application/xml'
549             # method eq 'POST' && content-type =~ /multipart\/related.+start=/
550             # There are more cases, actually, but for now, we don't support other
551             # methods for XForm posts.
552             # In a XForm POST, the QUERY_STRING is parsed normally.
553             # If the content-type is 'application/xml', we just set the param
554             # XForms:Model (referring to the xml syntax) param containing the
555             # unparsed XML data.
556             # In the case of multipart/related we set XForms:Model as above, but
557             # the other parts are available as uploads with the Content-ID as the
558             # the key.
559             # See the URL below for XForms specs on this issue.
560             # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options
561                   if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) {
562                           if ($ENV{'CONTENT_TYPE'} eq 'application/xml') {
563                                   my($param) = 'XForms:Model';
564                                   my($value) = '';
565                                   $self->add_parameter($param);
566                                   $self->read_from_client(\$value,$content_length,0)
567                                     if $content_length > 0;
568                                   push (@{$self->{$param}},$value);
569                                   $is_xforms = 1;
570                           } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\<?([^\"\>]+)\>?\"?/) {
571                                   my($boundary,$start) = ($1,$2);
572                                   my($param) = 'XForms:Model';
573                                   $self->add_parameter($param);
574                                   my($value) = $self->read_multipart_related($start,$boundary,$content_length,0);
575                                   push (@{$self->{$param}},$value);
576                                   if ($MOD_PERL) {
577                                           $query_string = $self->r->args;
578                                   } else {
579                                           $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
580                                           $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
581                                   }
582                                   $is_xforms = 1;
583                           }
584                   }
585              
586              
587             # If initializer is defined, then read parameters
588             # from it.
589                   if (!$is_xforms && defined($initializer)) {
590             if (UNIVERSAL::isa($initializer,'CGI')) {
591             $query_string = $initializer->query_string;
592             last METHOD;
593             }
594             if (ref($initializer) && ref($initializer) eq 'HASH') {
595             foreach (keys %$initializer) {
596             $self->param('-name'=>$_,'-value'=>$initializer->{$_});
597             }
598             last METHOD;
599             }
600            
601             if (defined($fh) && ($fh ne '')) {
602             while (<$fh>) {
603             chomp;
604             last if /^=/;
605             push(@lines,$_);
606             }
607             # massage back into standard format
608             if ("@lines" =~ /=/) {
609             $query_string=join("&",@lines);
610             } else {
611             $query_string=join("+",@lines);
612             }
613             last METHOD;
614             }
615              
616                       if (defined($fh) && ($fh ne '')) {
617                           while (<$fh>) {
618                               chomp;
619                               last if /^=/;
620                               push(@lines,$_);
621                           }
622             # massage back into standard format
623                           if ("@lines" =~ /=/) {
624                               $query_string=join("&",@lines);
625                           } else {
626                               $query_string=join("+",@lines);
627                           }
628                           last METHOD;
629                       }
630              
631             # last chance -- treat it as a string
632             $initializer = $$initializer if ref($initializer) eq 'SCALAR';
633             $query_string = $initializer;
634              
635             last METHOD;
636                   }
637              
638             # If method is GET or HEAD, fetch the query from
639             # the environment.
640                   if ($is_xforms || $meth=~/^(GET|HEAD)$/) {
641             if ($MOD_PERL) {
642             $query_string = $self->r->args;
643             } else {
644             $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
645             $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
646             }
647             last METHOD;
648                   }
649              
650                   if ($meth eq 'POST') {
651             $self->read_from_client(\$query_string,$content_length,0)
652             if $content_length > 0;
653             # Some people want to have their cake and eat it too!
654             # Uncomment this line to have the contents of the query string
655             # APPENDED to the POST data.
656             # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
657             last METHOD;
658                   }
659              
660             # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
661             # Check the command line and then the standard input for data.
662             # We use the shellwords package in order to behave the way that
663             # UN*X programmers expect.
664                   if ($DEBUG)
665                   {
666                       my $cmdline_ret = read_from_cmdline();
667                       $query_string = $cmdline_ret->{'query_string'};
668                       if (defined($cmdline_ret->{'subpath'}))
669                       {
670                           $self->path_info($cmdline_ret->{'subpath'});
671                       }
672                   }
673               }
674              
675             # YL: Begin Change for XML handler 10/19/2001
676                 if (!$is_xforms && $meth eq 'POST'
677                     && defined($ENV{'CONTENT_TYPE'})
678                     && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
679             && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
680                     my($param) = 'POSTDATA' ;
681                     $self->add_parameter($param) ;
682                   push (@{$self->{$param}},$query_string);
683                   undef $query_string ;
684                 }
685             # YL: End Change for XML handler 10/19/2001
686              
687             # We now have the query string in hand. We do slightly
688             # different things for keyword lists and parameter lists.
689                 if (defined $query_string && length $query_string) {
690             if ($query_string =~ /[&=;]/) {
691             $self->parse_params($query_string);
692             } else {
693             $self->add_parameter('keywords');
694             $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
695             }
696                 }
697              
698             # Special case. Erase everything if there is a field named
699             # .defaults.
700                 if ($self->param('.defaults')) {
701                   $self->delete_all();
702                 }
703              
704             # Associative array containing our defined fieldnames
705                 $self->{'.fieldnames'} = {};
706                 foreach ($self->param('.cgifields')) {
707             $self->{'.fieldnames'}->{$_}++;
708                 }
709                 
710             # Clear out our default submission button flag if present
711                 $self->delete('.submit');
712                 $self->delete('.cgifields');
713              
714                 $self->save_request unless defined $initializer;
715             }
716              
717             # FUNCTIONS TO OVERRIDE:
718             # Turn a string into a filehandle
719             sub to_filehandle {
720                 my $thingy = shift;
721                 return undef unless $thingy;
722                 return $thingy if UNIVERSAL::isa($thingy,'GLOB');
723                 return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
724                 if (!ref($thingy)) {
725             my $caller = 1;
726             while (my $package = caller($caller++)) {
727             my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
728             return $tmp if defined(fileno($tmp));
729             }
730                 }
731                 return undef;
732             }
733              
734             # send output to the browser
735             sub put {
736                 my($self,@p) = self_or_default(@_);
737                 $self->print(@p);
738             }
739              
740             # print to standard output (for overriding in mod_perl)
741             sub print {
742                 shift;
743                 CORE::print(@_);
744             }
745              
746             # get/set last cgi_error
747             sub cgi_error {
748                 my ($self,$err) = self_or_default(@_);
749                 $self->{'.cgi_error'} = $err if defined $err;
750                 return $self->{'.cgi_error'};
751             }
752              
753             sub save_request {
754                 my($self) = @_;
755             # We're going to play with the package globals now so that if we get called
756             # again, we initialize ourselves in exactly the same way. This allows
757             # us to have several of these objects.
758                 @QUERY_PARAM = $self->param; # save list of parameters
759                 foreach (@QUERY_PARAM) {
760                   next unless defined $_;
761                   $QUERY_PARAM{$_}=$self->{$_};
762                 }
763                 $QUERY_CHARSET = $self->charset;
764                 %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
765             }
766              
767             sub parse_params {
768                 my($self,$tosplit) = @_;
769                 my(@pairs) = split(/[&;]/,$tosplit);
770                 my($param,$value);
771                 foreach (@pairs) {
772             ($param,$value) = split('=',$_,2);
773             next unless defined $param;
774             next if $NO_UNDEF_PARAMS and not defined $value;
775             $value = '' unless defined $value;
776             $param = unescape($param);
777             $value = unescape($value);
778             $self->add_parameter($param);
779             push (@{$self->{$param}},$value);
780                 }
781             }
782              
783             sub add_parameter {
784                 my($self,$param)=@_;
785                 return unless defined $param;
786                 push (@{$self->{'.parameters'}},$param)
787             unless defined($self->{$param});
788             }
789              
790             sub all_parameters {
791                 my $self = shift;
792                 return () unless defined($self) && $self->{'.parameters'};
793                 return () unless @{$self->{'.parameters'}};
794                 return @{$self->{'.parameters'}};
795             }
796              
797             # put a filehandle into binary mode (DOS)
798             sub binmode {
799                 return unless defined($_[1]) && defined fileno($_[1]);
800                 CORE::binmode($_[1]);
801             }
802              
803             sub _make_tag_func {
804                 my ($self,$tagname) = @_;
805                 my $func = qq(
806             sub $tagname {
807             my (\$q,\$a,\@rest) = self_or_default(\@_);
808             my(\$attr) = '';
809             if (ref(\$a) && ref(\$a) eq 'HASH') {
810             my(\@attr) = make_attributes(\$a,\$q->{'escape'});
811             \$attr = " \@attr" if \@attr;
812             } else {
813             unshift \@rest,\$a if defined \$a;
814             }
815             );
816                 if ($tagname=~/start_(\w+)/i) {
817             $func .= qq! return "<\L$1\E\$attr>";} !;
818                 } elsif ($tagname=~/end_(\w+)/i) {
819             $func .= qq! return "<\L/$1\E>"; } !;
820                 } else {
821             $func .= qq#
822             return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest;
823             my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
824             my \@result = map { "\$tag\$_\$untag" }
825             (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
826             return "\@result";
827             }#;
828                 }
829             return $func;
830             }
831              
832             sub AUTOLOAD {
833                 print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
834                 my $func = &_compile;
835                 goto &$func;
836             }
837              
838             sub _compile {
839                 my($func) = $AUTOLOAD;
840                 my($pack,$func_name);
841                 {
842             local($1,$2); # this fixes an obscure variable suicide problem.
843             $func=~/(.+)::([^:]+)$/;
844             ($pack,$func_name) = ($1,$2);
845             $pack=~s/::SUPER$//; # fix another obscure problem
846             $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
847             unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
848              
849                     my($sub) = \%{"$pack\:\:SUBS"};
850                     unless (%$sub) {
851             my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
852             local ($@,$!);
853             eval "package $pack; $$auto";
854             croak("$AUTOLOAD: $@") if $@;
855                        $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
856                    }
857                    my($code) = $sub->{$func_name};
858              
859                    $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
860                    if (!$code) {
861             (my $base = $func_name) =~ s/^(start_|end_)//i;
862             if ($EXPORT{':any'} ||
863             $EXPORT{'-any'} ||
864             $EXPORT{$base} ||
865             (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
866             && $EXPORT_OK{$base}) {
867             $code = $CGI::DefaultClass->_make_tag_func($func_name);
868             }
869                    }
870                    croak("Undefined subroutine $AUTOLOAD\n") unless $code;
871                    local ($@,$!);
872                    eval "package $pack; $code";
873                    if ($@) {
874             $@ =~ s/ at .*\n//;
875             croak("$AUTOLOAD: $@");
876                    }
877                 }
878                 CORE::delete($sub->{$func_name}); #free storage
879                 return "$pack\:\:$func_name";
880             }
881              
882             sub _selected {
883               my $self = shift;
884               my $value = shift;
885               return '' unless $value;
886               return $XHTML ? qq(selected="selected" ) : qq(selected );
887             }
888              
889             sub _checked {
890               my $self = shift;
891               my $value = shift;
892               return '' unless $value;
893               return $XHTML ? qq(checked="checked" ) : qq(checked );
894             }
895              
896             sub _reset_globals { initialize_globals(); }
897              
898             sub _setup_symbols {
899                 my $self = shift;
900                 my $compile = 0;
901              
902             # to avoid reexporting unwanted variables
903                 undef %EXPORT;
904              
905                 foreach (@_) {
906             $HEADERS_ONCE++,         next if /^[:-]unique_headers$/;
907             $NPH++,                  next if /^[:-]nph$/;
908             $NOSTICKY++,             next if /^[:-]nosticky$/;
909             $DEBUG=0,                next if /^[:-]no_?[Dd]ebug$/;
910             $DEBUG=2,                next if /^[:-][Dd]ebug$/;
911             $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
912             $XHTML++,                next if /^[:-]xhtml$/;
913             $XHTML=0,                next if /^[:-]no_?xhtml$/;
914             $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
915             $PRIVATE_TEMPFILES++,    next if /^[:-]private_tempfiles$/;
916             $TABINDEX++,             next if /^[:-]tabindex$/;
917             $CLOSE_UPLOAD_FILES++,   next if /^[:-]close_upload_files$/;
918             $EXPORT{$_}++,           next if /^[:-]any$/;
919             $compile++,              next if /^[:-]compile$/;
920             $NO_UNDEF_PARAMS++,      next if /^[:-]no_undef_params$/;
921            
922             # This is probably extremely evil code -- to be deleted some day.
923             if (/^[-]autoload$/) {
924             my($pkg) = caller(1);
925             *{"${pkg}::AUTOLOAD"} = sub {
926             my($routine) = $AUTOLOAD;
927             $routine =~ s/^.*::/CGI::/;
928             &$routine;
929             };
930             next;
931             }
932              
933             foreach (&expand_tags($_)) {
934             tr/a-zA-Z0-9_//cd;  # don't allow weird function names
935             $EXPORT{$_}++;
936             }
937                 }
938                 _compile_all(keys %EXPORT) if $compile;
939                 @SAVED_SYMBOLS = @_;
940             }
941              
942             sub charset {
943               my ($self,$charset) = self_or_default(@_);
944               $self->{'.charset'} = $charset if defined $charset;
945               $self->{'.charset'};
946             }
947              
948             sub element_id {
949               my ($self,$new_value) = self_or_default(@_);
950               $self->{'.elid'} = $new_value if defined $new_value;
951               sprintf('%010d',$self->{'.elid'}++);
952             }
953              
954             sub element_tab {
955               my ($self,$new_value) = self_or_default(@_);
956               $self->{'.etab'} ||= 1;
957               $self->{'.etab'} = $new_value if defined $new_value;
958               my $tab = $self->{'.etab'}++;
959               return '' unless $TABINDEX or defined $new_value;
960               return qq(tabindex="$tab" );
961             }
962              
963             ###############################################################################
964             ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
965             ###############################################################################
966             $AUTOLOADED_ROUTINES = ''; # get rid of -w warning
967             $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
968            
969             %SUBS = (
970            
971             'URL_ENCODED'=> <<'END_OF_FUNC',
972             sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
973             END_OF_FUNC
974            
975             'MULTIPART' => <<'END_OF_FUNC',
976             sub MULTIPART { 'multipart/form-data'; }
977             END_OF_FUNC
978            
979             'SERVER_PUSH' => <<'END_OF_FUNC',
980             sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
981             END_OF_FUNC
982            
983             'new_MultipartBuffer' => <<'END_OF_FUNC',
984             # Create a new multipart buffer
985             sub new_MultipartBuffer {
986             my($self,$boundary,$length) = @_;
987             return MultipartBuffer->new($self,$boundary,$length);
988             }
989             END_OF_FUNC
990            
991             'read_from_client' => <<'END_OF_FUNC',
992             # Read data from a file handle
993             sub read_from_client {
994             my($self, $buff, $len, $offset) = @_;
995             local $^W=0; # prevent a warning
996             return $MOD_PERL
997             ? $self->r->read($$buff, $len, $offset)
998             : read(\*STDIN, $$buff, $len, $offset);
999             }
1000             END_OF_FUNC
1001            
1002             'delete' => <<'END_OF_FUNC',
1003             #### Method: delete
1004             # Deletes the named parameter entirely.
1005             ####
1006             sub delete {
1007             my($self,@p) = self_or_default(@_);
1008             my(@names) = rearrange([NAME],@p);
1009             my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
1010             my %to_delete;
1011             foreach my $name (@to_delete)
1012             {
1013             CORE::delete $self->{$name};
1014             CORE::delete $self->{'.fieldnames'}->{$name};
1015             $to_delete{$name}++;
1016             }
1017             @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
1018             return;
1019             }
1020             END_OF_FUNC
1021            
1022             #### Method: import_names
1023             # Import all parameters into the given namespace.
1024             # Assumes namespace 'Q' if not specified
1025             ####
1026             'import_names' => <<'END_OF_FUNC',
1027             sub import_names {
1028             my($self,$namespace,$delete) = self_or_default(@_);
1029             $namespace = 'Q' unless defined($namespace);
1030             die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
1031             if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
1032             # can anyone find an easier way to do this?
1033             foreach (keys %{"${namespace}::"}) {
1034             local *symbol = "${namespace}::${_}";
1035             undef $symbol;
1036             undef @symbol;
1037             undef %symbol;
1038             }
1039             }
1040             my($param,@value,$var);
1041             foreach $param ($self->param) {
1042             # protect against silly names
1043             ($var = $param)=~tr/a-zA-Z0-9_/_/c;
1044             $var =~ s/^(?=\d)/_/;
1045             local *symbol = "${namespace}::$var";
1046             @value = $self->param($param);
1047             @symbol = @value;
1048             $symbol = $value[0];
1049             }
1050             }
1051             END_OF_FUNC
1052            
1053             #### Method: keywords
1054             # Keywords acts a bit differently. Calling it in a list context
1055             # returns the list of keywords.
1056             # Calling it in a scalar context gives you the size of the list.
1057             ####
1058             'keywords' => <<'END_OF_FUNC',
1059             sub keywords {
1060             my($self,@values) = self_or_default(@_);
1061             # If values is provided, then we set it.
1062             $self->{'keywords'}=[@values] if @values;
1063             my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
1064             @result;
1065             }
1066             END_OF_FUNC
1067            
1068             # These are some tie() interfaces for compatibility
1069             # with Steve Brenner's cgi-lib.pl routines
1070             'Vars' => <<'END_OF_FUNC',
1071             sub Vars {
1072             my $q = shift;
1073             my %in;
1074             tie(%in,CGI,$q);
1075             return %in if wantarray;
1076             return \%in;
1077             }
1078             END_OF_FUNC
1079            
1080             # These are some tie() interfaces for compatibility
1081             # with Steve Brenner's cgi-lib.pl routines
1082             'ReadParse' => <<'END_OF_FUNC',
1083             sub ReadParse {
1084             local(*in);
1085             if (@_) {
1086             *in = $_[0];
1087             } else {
1088             my $pkg = caller();
1089             *in=*{"${pkg}::in"};
1090             }
1091             tie(%in,CGI);
1092             return scalar(keys %in);
1093             }
1094             END_OF_FUNC
1095            
1096             'PrintHeader' => <<'END_OF_FUNC',
1097             sub PrintHeader {
1098             my($self) = self_or_default(@_);
1099             return $self->header();
1100             }
1101             END_OF_FUNC
1102            
1103             'HtmlTop' => <<'END_OF_FUNC',
1104             sub HtmlTop {
1105             my($self,@p) = self_or_default(@_);
1106             return $self->start_html(@p);
1107             }
1108             END_OF_FUNC
1109            
1110             'HtmlBot' => <<'END_OF_FUNC',
1111             sub HtmlBot {
1112             my($self,@p) = self_or_default(@_);
1113             return $self->end_html(@p);
1114             }
1115             END_OF_FUNC
1116            
1117             'SplitParam' => <<'END_OF_FUNC',
1118             sub SplitParam {
1119             my ($param) = @_;
1120             my (@params) = split ("\0", $param);
1121             return (wantarray ? @params : $params[0]);
1122             }
1123             END_OF_FUNC
1124            
1125             'MethGet' => <<'END_OF_FUNC',
1126             sub MethGet {
1127             return request_method() eq 'GET';
1128             }
1129             END_OF_FUNC
1130            
1131             'MethPost' => <<'END_OF_FUNC',
1132             sub MethPost {
1133             return request_method() eq 'POST';
1134             }
1135             END_OF_FUNC
1136            
1137             'TIEHASH' => <<'END_OF_FUNC',
1138             sub TIEHASH {
1139             my $class = shift;
1140             my $arg = $_[0];
1141             if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
1142             return $arg;
1143             }
1144             return $Q ||= $class->new(@_);
1145             }
1146             END_OF_FUNC
1147            
1148             'STORE' => <<'END_OF_FUNC',
1149             sub STORE {
1150             my $self = shift;
1151             my $tag = shift;
1152             my $vals = shift;
1153             my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
1154             $self->param(-name=>$tag,-value=>\@vals);
1155             }
1156             END_OF_FUNC
1157            
1158             'FETCH' => <<'END_OF_FUNC',
1159             sub FETCH {
1160             return $_[0] if $_[1] eq 'CGI';
1161             return undef unless defined $_[0]->param($_[1]);
1162             return join("\0",$_[0]->param($_[1]));
1163             }
1164             END_OF_FUNC
1165            
1166             'FIRSTKEY' => <<'END_OF_FUNC',
1167             sub FIRSTKEY {
1168             $_[0]->{'.iterator'}=0;
1169             $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1170             }
1171             END_OF_FUNC
1172            
1173             'NEXTKEY' => <<'END_OF_FUNC',
1174             sub NEXTKEY {
1175             $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1176             }
1177             END_OF_FUNC
1178            
1179             'EXISTS' => <<'END_OF_FUNC',
1180             sub EXISTS {
1181             exists $_[0]->{$_[1]};
1182             }
1183             END_OF_FUNC
1184            
1185             'DELETE' => <<'END_OF_FUNC',
1186             sub DELETE {
1187             $_[0]->delete($_[1]);
1188             }
1189             END_OF_FUNC
1190            
1191             'CLEAR' => <<'END_OF_FUNC',
1192             sub CLEAR {
1193             %{$_[0]}=();
1194             }
1195             ####
1196             END_OF_FUNC
1197            
1198             ####
1199             # Append a new value to an existing query
1200             ####
1201             'append' => <<'EOF',
1202             sub append {
1203             my($self,@p) = self_or_default(@_);
1204             my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
1205             my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
1206             if (@values) {
1207             $self->add_parameter($name);
1208             push(@{$self->{$name}},@values);
1209             }
1210             return $self->param($name);
1211             }
1212             EOF
1213            
1214             #### Method: delete_all
1215             # Delete all parameters
1216             ####
1217             'delete_all' => <<'EOF',
1218             sub delete_all {
1219             my($self) = self_or_default(@_);
1220             my @param = $self->param();
1221             $self->delete(@param);
1222             }
1223             EOF
1224            
1225             'Delete' => <<'EOF',
1226             sub Delete {
1227             my($self,@p) = self_or_default(@_);
1228             $self->delete(@p);
1229             }
1230             EOF
1231            
1232             'Delete_all' => <<'EOF',
1233             sub Delete_all {
1234             my($self,@p) = self_or_default(@_);
1235             $self->delete_all(@p);
1236             }
1237             EOF
1238            
1239             #### Method: autoescape
1240             # If you want to turn off the autoescaping features,
1241             # call this method with undef as the argument
1242             'autoEscape' => <<'END_OF_FUNC',
1243             sub autoEscape {
1244             my($self,$escape) = self_or_default(@_);
1245             my $d = $self->{'escape'};
1246             $self->{'escape'} = $escape;
1247             $d;
1248             }
1249             END_OF_FUNC
1250            
1251            
1252             #### Method: version
1253             # Return the current version
1254             ####
1255             'version' => <<'END_OF_FUNC',
1256             sub version {
1257             return $VERSION;
1258             }
1259             END_OF_FUNC
1260            
1261             #### Method: url_param
1262             # Return a parameter in the QUERY_STRING, regardless of
1263             # whether this was a POST or a GET
1264             ####
1265             'url_param' => <<'END_OF_FUNC',
1266             sub url_param {
1267             my ($self,@p) = self_or_default(@_);
1268             my $name = shift(@p);
1269             return undef unless exists($ENV{QUERY_STRING});
1270             unless (exists($self->{'.url_param'})) {
1271             $self->{'.url_param'}={}; # empty hash
1272             if ($ENV{QUERY_STRING} =~ /=/) {
1273             my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
1274             my($param,$value);
1275             foreach (@pairs) {
1276             ($param,$value) = split('=',$_,2);
1277             $param = unescape($param);
1278             $value = unescape($value);
1279             push(@{$self->{'.url_param'}->{$param}},$value);
1280             }
1281             } else {
1282             $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
1283             }
1284             }
1285             return keys %{$self->{'.url_param'}} unless defined($name);
1286             return () unless $self->{'.url_param'}->{$name};
1287             return wantarray ? @{$self->{'.url_param'}->{$name}}
1288             : $self->{'.url_param'}->{$name}->[0];
1289             }
1290             END_OF_FUNC
1291            
1292             #### Method: Dump
1293             # Returns a string in which all the known parameter/value
1294             # pairs are represented as nested lists, mainly for the purposes
1295             # of debugging.
1296             ####
1297             'Dump' => <<'END_OF_FUNC',
1298             sub Dump {
1299             my($self) = self_or_default(@_);
1300             my($param,$value,@result);
1301             return '<ul></ul>' unless $self->param;
1302             push(@result,"<ul>");
1303             foreach $param ($self->param) {
1304             my($name)=$self->escapeHTML($param);
1305             push(@result,"<li><strong>$param</strong></li>");
1306             push(@result,"<ul>");
1307             foreach $value ($self->param($param)) {
1308             $value = $self->escapeHTML($value);
1309             $value =~ s/\n/<br \/>\n/g;
1310             push(@result,"<li>$value</li>");
1311             }
1312             push(@result,"</ul>");
1313             }
1314             push(@result,"</ul>");
1315             return join("\n",@result);
1316             }
1317             END_OF_FUNC
1318            
1319             #### Method as_string
1320             #
1321             # synonym for "dump"
1322             ####
1323             'as_string' => <<'END_OF_FUNC',
1324             sub as_string {
1325             &Dump(@_);
1326             }
1327             END_OF_FUNC
1328            
1329             #### Method: save
1330             # Write values out to a filehandle in such a way that they can
1331             # be reinitialized by the filehandle form of the new() method
1332             ####
1333             'save' => <<'END_OF_FUNC',
1334             sub save {
1335             my($self,$filehandle) = self_or_default(@_);
1336             $filehandle = to_filehandle($filehandle);
1337             my($param);
1338             local($,) = ''; # set print field separator back to a sane value
1339             local($\) = ''; # set output line separator to a sane value
1340             foreach $param ($self->param) {
1341             my($escaped_param) = escape($param);
1342             my($value);
1343             foreach $value ($self->param($param)) {
1344             print $filehandle "$escaped_param=",escape("$value"),"\n";
1345             }
1346             }
1347             foreach (keys %{$self->{'.fieldnames'}}) {
1348             print $filehandle ".cgifields=",escape("$_"),"\n";
1349             }
1350             print $filehandle "=\n"; # end of record
1351             }
1352             END_OF_FUNC
1353            
1354            
1355             #### Method: save_parameters
1356             # An alias for save() that is a better name for exportation.
1357             # Only intended to be used with the function (non-OO) interface.
1358             ####
1359             'save_parameters' => <<'END_OF_FUNC',
1360             sub save_parameters {
1361             my $fh = shift;
1362             return save(to_filehandle($fh));
1363             }
1364             END_OF_FUNC
1365            
1366             #### Method: restore_parameters
1367             # A way to restore CGI parameters from an initializer.
1368             # Only intended to be used with the function (non-OO) interface.
1369             ####
1370             'restore_parameters' => <<'END_OF_FUNC',
1371             sub restore_parameters {
1372             $Q = $CGI::DefaultClass->new(@_);
1373             }
1374             END_OF_FUNC
1375            
1376             #### Method: multipart_init
1377             # Return a Content-Type: style header for server-push
1378             # This has to be NPH on most web servers, and it is advisable to set $| = 1
1379             #
1380             # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1381             # contribution, updated by Andrew Benham (adsb@bigfoot.com)
1382             ####
1383             'multipart_init' => <<'END_OF_FUNC',
1384             sub multipart_init {
1385             my($self,@p) = self_or_default(@_);
1386             my($boundary,@other) = rearrange([BOUNDARY],@p);
1387             $boundary = $boundary || '------- =_aaaaaaaaaa0';
1388             $self->{'separator'} = "$CRLF--$boundary$CRLF";
1389             $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
1390             $type = SERVER_PUSH($boundary);
1391             return $self->header(
1392             -nph => 0,
1393             -type => $type,
1394             (map { split "=", $_, 2 } @other),
1395             ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
1396             }
1397             END_OF_FUNC
1398            
1399            
1400             #### Method: multipart_start
1401             # Return a Content-Type: style header for server-push, start of section
1402             #
1403             # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1404             # contribution, updated by Andrew Benham (adsb@bigfoot.com)
1405             ####
1406             'multipart_start' => <<'END_OF_FUNC',
1407             sub multipart_start {
1408             my(@header);
1409             my($self,@p) = self_or_default(@_);
1410             my($type,@other) = rearrange([TYPE],@p);
1411             $type = $type || 'text/html';
1412             push(@header,"Content-Type: $type");
1413            
1414             # rearrange() was designed for the HTML portion, so we
1415             # need to fix it up a little.
1416             foreach (@other) {
1417             # Don't use \s because of perl bug 21951
1418             next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
1419             ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
1420             }
1421             push(@header,@other);
1422             my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1423             return $header;
1424             }
1425             END_OF_FUNC
1426            
1427            
1428             #### Method: multipart_end
1429             # Return a MIME boundary separator for server-push, end of section
1430             #
1431             # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1432             # contribution
1433             ####
1434             'multipart_end' => <<'END_OF_FUNC',
1435             sub multipart_end {
1436             my($self,@p) = self_or_default(@_);
1437             return $self->{'separator'};
1438             }
1439             END_OF_FUNC
1440            
1441            
1442             #### Method: multipart_final
1443             # Return a MIME boundary separator for server-push, end of all sections
1444             #
1445             # Contributed by Andrew Benham (adsb@bigfoot.com)
1446             ####
1447             'multipart_final' => <<'END_OF_FUNC',
1448             sub multipart_final {
1449             my($self,@p) = self_or_default(@_);
1450             return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
1451             }
1452             END_OF_FUNC
1453            
1454            
1455             #### Method: header
1456             # Return a Content-Type: style header
1457             #
1458             ####
1459             'header' => <<'END_OF_FUNC',
1460             sub header {
1461             my($self,@p) = self_or_default(@_);
1462             my(@header);
1463            
1464             return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
1465            
1466             my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
1467             rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
1468             'STATUS',['COOKIE','COOKIES'],'TARGET',
1469             'EXPIRES','NPH','CHARSET',
1470             'ATTACHMENT','P3P'],@p);
1471            
1472             $nph ||= $NPH;
1473            
1474             $type ||= 'text/html' unless defined($type);
1475            
1476             if (defined $charset) {
1477             $self->charset($charset);
1478             } else {
1479             $charset = $self->charset if $type =~ /^text\//;
1480             }
1481             $charset ||= '';
1482            
1483             # rearrange() was designed for the HTML portion, so we
1484             # need to fix it up a little.
1485             foreach (@other) {
1486             # Don't use \s because of perl bug 21951
1487             next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
1488             ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
1489             }
1490            
1491             $type .= "; charset=$charset"
1492             if $type ne ''
1493             and $type !~ /\bcharset\b/
1494             and defined $charset
1495             and $charset ne '';
1496            
1497             # Maybe future compatibility. Maybe not.
1498             my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
1499             push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
1500             push(@header,"Server: " . &server_software()) if $nph;
1501            
1502             push(@header,"Status: $status") if $status;
1503             push(@header,"Window-Target: $target") if $target;
1504             if ($p3p) {
1505             $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
1506             push(@header,qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p"));
1507             }
1508             # push all the cookies -- there may be several
1509             if ($cookie) {
1510             my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
1511             foreach (@cookie) {
1512             my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
1513             push(@header,"Set-Cookie: $cs") if $cs ne '';
1514             }
1515             }
1516             # if the user indicates an expiration time, then we need
1517             # both an Expires and a Date header (so that the browser is
1518             # uses OUR clock)
1519             push(@header,"Expires: " . expires($expires,'http'))
1520             if $expires;
1521             push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
1522             push(@header,"Pragma: no-cache") if $self->cache();
1523             push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
1524             push(@header,map {ucfirst $_} @other);
1525             push(@header,"Content-Type: $type") if $type ne '';
1526             my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1527             if ($MOD_PERL and not $nph) {
1528             $self->r->send_cgi_header($header);
1529             return '';
1530             }
1531             return $header;
1532             }
1533             END_OF_FUNC
1534            
1535            
1536             #### Method: cache
1537             # Control whether header() will produce the no-cache
1538             # Pragma directive.
1539             ####
1540             'cache' => <<'END_OF_FUNC',
1541             sub cache {
1542             my($self,$new_value) = self_or_default(@_);
1543             $new_value = '' unless $new_value;
1544             if ($new_value ne '') {
1545             $self->{'cache'} = $new_value;
1546             }
1547             return $self->{'cache'};
1548             }
1549             END_OF_FUNC
1550            
1551            
1552             #### Method: redirect
1553             # Return a Location: style header
1554