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                &nb