This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to CGI-3.20
[perl5.git] / lib / CGI.pm
CommitLineData
54310121 1package CGI;
424ec8fa 2require 5.004;
ba056755 3use Carp 'croak';
54310121 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
424ec8fa 12# Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
54310121 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:
71f3e297 19# http://stein.cshl.org/WWW/software/CGI/
54310121 20
adb86593
SP
21$CGI::revision = '$Id: CGI.pm,v 1.208 2006/04/23 14:25:14 lstein Exp $';
22$CGI::VERSION='3.20';
54310121 23
24# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
25# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
ac734d8b 26# $CGITempFile::TMPDIRECTORY = '/usr/tmp';
2ed511ec 27use CGI::Util qw(rearrange make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
54310121 28
3acbd4f5
JH
29#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
30# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
31
32use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
33 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
6b4ac661 34
8f3ccfa2
JH
35{
36 local $^W = 0;
37 $TAINTED = substr("$0$^X",0,0);
38}
188ba755 39
8f3ccfa2 40$MOD_PERL = 0; # no mod_perl by default
13548fdf 41@SAVED_SYMBOLS = ();
8f3ccfa2 42
adb86593 43
424ec8fa
GS
44# >>>>> Here are some globals that you might want to adjust <<<<<<
45sub initialize_globals {
46 # Set this to 1 to enable copious autoloader debugging messages
47 $AUTOLOAD_DEBUG = 0;
2371fea9 48
6b4ac661
JH
49 # Set this to 1 to generate XTML-compatible output
50 $XHTML = 1;
424ec8fa
GS
51
52 # Change this to the preferred DTD to print in start_html()
53 # or use default_dtd('text of DTD to use');
3d1a2ec4
GS
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;
424ec8fa
GS
62
63 # Set this to 1 to enable NPH scripts
64 # or:
65 # 1) use CGI qw(-nph)
3d1a2ec4 66 # 2) CGI::nph(1)
424ec8fa
GS
67 # 3) print header(-nph=>1)
68 $NPH = 0;
69
3d1a2ec4
GS
70 # Set this to 1 to enable debugging from @ARGV
71 # Set to 2 to enable debugging from STDIN
72 $DEBUG = 1;
424ec8fa
GS
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)
3d1a2ec4 78 # 2) CGI::private_tempfiles(1);
424ec8fa
GS
79 $PRIVATE_TEMPFILES = 0;
80
0a9bdad4
SP
81 # Set this to 1 to generate automatic tab indexes
82 $TABINDEX = 0;
83
8f3ccfa2
JH
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
424ec8fa
GS
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
3538e1d5
GS
101 # Automatically determined -- don't change
102 $EBCDIC = 0;
103
71f3e297
JH
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
3d1a2ec4 108 $USE_PARAM_SEMICOLONS = 1;
71f3e297 109
2371fea9
JH
110 # Do not include undefined params parsed from query string
111 # use CGI qw(-no_undef_params);
112 $NO_UNDEF_PARAMS = 0;
199d4a26 113
424ec8fa
GS
114 # Other globals that you shouldn't worry about.
115 undef $Q;
116 $BEEN_THERE = 0;
13548fdf 117 $DTD_PUBLIC_IDENTIFIER = "";
424ec8fa
GS
118 undef @QUERY_PARAM;
119 undef %EXPORT;
d45d855d
JH
120 undef $QUERY_CHARSET;
121 undef %QUERY_FIELDNAMES;
424ec8fa
GS
122
123 # prevent complaints by mod_perl
124 1;
125}
126
54310121 127# ------------------ START OF THE LIBRARY ------------
128
13548fdf
RGS
129*end_form = \&endform;
130
424ec8fa
GS
131# make mod_perlhappy
132initialize_globals();
133
54310121 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
137unless ($OS) {
138 unless ($OS = $^O) {
139 require Config;
140 $OS = $Config::Config{'osname'};
141 }
142}
ac1855b3 143if ($OS =~ /^MSWin/i) {
3538e1d5 144 $OS = 'WINDOWS';
ac1855b3 145} elsif ($OS =~ /^VMS/i) {
3538e1d5 146 $OS = 'VMS';
ac1855b3 147} elsif ($OS =~ /^dos/i) {
3538e1d5 148 $OS = 'DOS';
ac1855b3 149} elsif ($OS =~ /^MacOS/i) {
54310121 150 $OS = 'MACINTOSH';
ac1855b3 151} elsif ($OS =~ /^os2/i) {
54310121 152 $OS = 'OS2';
ac1855b3 153} elsif ($OS =~ /^epoc/i) {
fa6a1c44 154 $OS = 'EPOC';
188ba755
JH
155} elsif ($OS =~ /^cygwin/i) {
156 $OS = 'CYGWIN';
54310121 157} else {
158 $OS = 'UNIX';
159}
160
161# Some OS logic. Binary mode enabled on DOS, NT and VMS
188ba755 162$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN)/;
54310121 163
164# This is the default class for the CGI object to use when all else fails.
165$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
424ec8fa 166
54310121 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 = {
8f3ccfa2
JH
173 UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/',
174 WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
54310121 175 }->{$OS};
176
424ec8fa 177# This no longer seems to be necessary
54310121 178# Turn on NPH scripts by default when running under IIS server!
424ec8fa
GS
179# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
180$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
54310121 181
182# Turn on special checking for Doug MacEachern's modperl
8f3ccfa2 183if (exists $ENV{MOD_PERL}) {
8f3ccfa2
JH
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}
70194bd6 186 if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
741ff09d
RGS
187 $MOD_PERL = 2;
188 require Apache2::Response;
189 require Apache2::RequestRec;
190 require Apache2::RequestUtil;
70194bd6 191 require Apache2::RequestIO;
741ff09d
RGS
192 require APR::Pool;
193 } else {
194 $MOD_PERL = 1;
195 require Apache;
188ba755 196 }
8f3ccfa2 197}
188ba755 198
424ec8fa
GS
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";
209if ($OS eq 'VMS') {
3538e1d5 210 $CRLF = "\n";
424ec8fa 211} elsif ($EBCDIC) {
3538e1d5 212 $CRLF= "\r\n";
424ec8fa 213} else {
3538e1d5
GS
214 $CRLF = "\015\012";
215}
216
54310121 217if ($needs_binmode) {
2ed511ec
RGS
218 $CGI::DefaultClass->binmode(\*main::STDOUT);
219 $CGI::DefaultClass->binmode(\*main::STDIN);
220 $CGI::DefaultClass->binmode(\*main::STDERR);
54310121 221}
222
54310121 223%EXPORT_TAGS = (
424ec8fa
GS
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
3d1a2ec4 227 input Select option comment charset escapeHTML/],
71f3e297 228 ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param
1c87da1d 229 embed basefont style span layer ilayer font frameset frame script small big Area Map/],
3acbd4f5
JH
230 ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
231 ins label legend noframes noscript object optgroup Q
232 thead tbody tfoot/],
424ec8fa
GS
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
71f3e297 237 start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
7dc108d1
SP
238 ':cgi'=>[qw/param upload path_info path_translated request_uri url self_url script_name
239 cookie Dump
3538e1d5 240 raw_cookie request_method query_string Accept user_agent remote_host content_type
2ed511ec
RGS
241 remote_addr referer server_name server_software server_port server_protocol virtual_port
242 virtual_host remote_ident auth_type http append
424ec8fa 243 save_parameters restore_parameters param_fetch
3538e1d5
GS
244 remote_user user_name header redirect import_names put
245 Delete Delete_all url_param cgi_error/],
424ec8fa 246 ':ssl' => [qw/https/],
3538e1d5 247 ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
3acbd4f5
JH
248 ':html' => [qw/:html2 :html3 :html4 :netscape/],
249 ':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
ba056755 250 ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
3acbd4f5 251 ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/]
424ec8fa 252 );
54310121 253
29ddc2a4
RGS
254# Custom 'can' method for both autoloaded and non-autoloaded subroutines.
255# Author: Cees Hek <cees@sitesuite.com.au>
256
257sub 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
54310121 281# to import symbols into caller
282sub import {
283 my $self = shift;
424ec8fa 284
188ba755 285 # This causes modules to clash.
b2d0d414
JH
286 undef %EXPORT_OK;
287 undef %EXPORT;
424ec8fa
GS
288
289 $self->_setup_symbols(@_);
54310121 290 my ($callpack, $callfile, $callline) = caller;
424ec8fa 291
54310121 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
424ec8fa
GS
308sub compile {
309 my $pack = shift;
310 $pack->_setup_symbols('-compile',@_);
311}
312
54310121 313sub expand_tags {
314 my($tag) = @_;
71f3e297 315 return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
54310121 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####
328sub new {
8f3ccfa2
JH
329 my($class,@initializer) = @_;
330 my $self = {};
2ed511ec 331
8f3ccfa2 332 bless $self,ref $class || $class || $DefaultClass;
cb3b230c
SP
333
334 # always use a tempfile
335 $self->{'use_tempfile'} = 1;
336
8f3ccfa2
JH
337 if (ref($initializer[0])
338 && (UNIVERSAL::isa($initializer[0],'Apache')
339 ||
741ff09d 340 UNIVERSAL::isa($initializer[0],'Apache2::RequestRec')
8f3ccfa2
JH
341 )) {
342 $self->r(shift @initializer);
343 }
efc8e943
NC
344 if (ref($initializer[0])
345 && (UNIVERSAL::isa($initializer[0],'CODE'))) {
346 $self->upload_hook(shift @initializer, shift @initializer);
cb3b230c 347 $self->{'use_tempfile'} = shift @initializer if (@initializer > 0);
efc8e943 348 }
8f3ccfa2 349 if ($MOD_PERL) {
8f3ccfa2 350 if ($MOD_PERL == 1) {
741ff09d
RGS
351 $self->r(Apache->request) unless $self->r;
352 my $r = $self->r;
8f3ccfa2
JH
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
741ff09d
RGS
358 $self->r(Apache2::RequestUtil->request) unless $self->r;
359 my $r = $self->r;
8f3ccfa2
JH
360 $r->subprocess_env unless exists $ENV{REQUEST_METHOD};
361 $r->pool->cleanup_register(\&CGI::_reset_globals);
424ec8fa 362 }
8f3ccfa2
JH
363 undef $NPH;
364 }
365 $self->_reset_globals if $PERLEX;
366 $self->init(@initializer);
367 return $self;
54310121 368}
369
2ed511ec
RGS
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.
377sub DESTROY {
378 my $self = shift;
0a9bdad4
SP
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 }
2ed511ec
RGS
384 }
385}
54310121 386
8f3ccfa2
JH
387sub r {
388 my $self = shift;
389 my $r = $self->{'.r'};
390 $self->{'.r'} = shift if @_;
391 $r;
392}
393
2ed511ec 394sub upload_hook {
0a9bdad4
SP
395 my $self;
396 if (ref $_[0] eq 'CODE') {
397 $CGI::Q = $self = $CGI::DefaultClass->new(@_);
398 } else {
399 $self = shift;
400 }
cb3b230c 401 my ($hook,$data,$use_tempfile) = @_;
2ed511ec
RGS
402 $self->{'.upload_hook'} = $hook;
403 $self->{'.upload_data'} = $data;
cb3b230c 404 $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile;
2ed511ec
RGS
405}
406
54310121 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####
418sub 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) {
3d1a2ec4 426 ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
54310121 427 my(@values);
428
3d1a2ec4 429 if (substr($p[0],0,1) eq '-') {
54310121 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.
cb3b230c 437 if (defined $value) {
54310121 438 $self->add_parameter($name);
439 $self->{$name}=[@values];
440 }
441 } else {
442 $name = $p[0];
443 }
444
71f3e297 445 return unless defined($name) && $self->{$name};
54310121 446 return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
447}
448
54310121 449sub self_or_default {
424ec8fa 450 return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
54310121 451 unless (defined($_[0]) &&
424ec8fa
GS
452 (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
453 ) {
54310121 454 $Q = $CGI::DefaultClass->new unless defined($Q);
455 unshift(@_,$Q);
456 }
3d1a2ec4 457 return wantarray ? @_ : $Q;
54310121 458}
459
54310121 460sub self_or_CGI {
461 local $^W=0; # prevent a warning
462 if (defined($_[0]) &&
463 (substr(ref($_[0]),0,3) eq 'CGI'
424ec8fa 464 || UNIVERSAL::isa($_[0],'CGI'))) {
54310121 465 return @_;
466 } else {
467 return ($DefaultClass,@_);
468 }
469}
470
54310121 471########################################
472# THESE METHODS ARE MORE OR LESS PRIVATE
473# GO TO THE __DATA__ SECTION TO SEE MORE
474# PUBLIC METHODS
475########################################
476
477# Initialize the query object from the environment.
478# If a parameter list is found, this object will be set
479# to an associative array in which parameter names are keys
480# and the values are stored as lists
481# If a keyword list is found, this method creates a bogus
482# parameter list with the single parameter 'keywords'.
483
484sub init {
8f3ccfa2
JH
485 my $self = shift;
486 my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
487
488 my $initializer = shift; # for backward compatibility
489 local($/) = "\n";
490
491 # set autoescaping on by default
492 $self->{'escape'} = 1;
54310121 493
494 # if we get called more than once, we want to initialize
495 # ourselves from the original query (which may be gone
496 # if it was read from STDIN originally.)
d45d855d 497 if (defined(@QUERY_PARAM) && !defined($initializer)) {
54310121 498 foreach (@QUERY_PARAM) {
499 $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
500 }
d45d855d
JH
501 $self->charset($QUERY_CHARSET);
502 $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
54310121 503 return;
504 }
505
506 $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
424ec8fa 507 $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
3538e1d5 508
424ec8fa 509 $fh = to_filehandle($initializer) if $initializer;
54310121 510
a3b3a725
JH
511 # set charset to the safe ISO-8859-1
512 $self->charset('ISO-8859-1');
513
54310121 514 METHOD: {
54310121 515
3538e1d5
GS
516 # avoid unreasonably large postings
517 if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
1c87da1d
JH
518 # quietly read and discard the post
519 my $buffer;
0a9bdad4
SP
520 my $tmplength = $content_length;
521 while($tmplength > 0) {
522 my $maxbuffer = ($tmplength < 10000)?$tmplength:10000;
523 my $bytesread = $MOD_PERL ? $self->r->read($buffer,$maxbuffer) : read(STDIN,$buffer,$maxbuffer);
524 $tmplength -= $bytesread;
525 }
526 $self->cgi_error("413 Request entity too large");
527 last METHOD;
528 }
3538e1d5 529
424ec8fa
GS
530 # Process multipart postings, but only if the initializer is
531 # not defined.
532 if ($meth eq 'POST'
533 && defined($ENV{'CONTENT_TYPE'})
534 && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
535 && !defined($initializer)
536 ) {
71f3e297 537 my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
424ec8fa
GS
538 $self->read_multipart($boundary,$content_length);
539 last METHOD;
540 }
541
542 # If initializer is defined, then read parameters
543 # from it.
544 if (defined($initializer)) {
545 if (UNIVERSAL::isa($initializer,'CGI')) {
546 $query_string = $initializer->query_string;
547 last METHOD;
548 }
54310121 549 if (ref($initializer) && ref($initializer) eq 'HASH') {
550 foreach (keys %$initializer) {
551 $self->param('-name'=>$_,'-value'=>$initializer->{$_});
552 }
553 last METHOD;
554 }
555
424ec8fa
GS
556 if (defined($fh) && ($fh ne '')) {
557 while (<$fh>) {
54310121 558 chomp;
559 last if /^=/;
560 push(@lines,$_);
561 }
562 # massage back into standard format
563 if ("@lines" =~ /=/) {
564 $query_string=join("&",@lines);
565 } else {
566 $query_string=join("+",@lines);
567 }
568 last METHOD;
569 }
424ec8fa 570
2ed511ec
RGS
571 if (defined($fh) && ($fh ne '')) {
572 while (<$fh>) {
573 chomp;
574 last if /^=/;
575 push(@lines,$_);
576 }
577 # massage back into standard format
578 if ("@lines" =~ /=/) {
579 $query_string=join("&",@lines);
580 } else {
581 $query_string=join("+",@lines);
582 }
583 last METHOD;
584 }
585
424ec8fa
GS
586 # last chance -- treat it as a string
587 $initializer = $$initializer if ref($initializer) eq 'SCALAR';
54310121 588 $query_string = $initializer;
424ec8fa 589
54310121 590 last METHOD;
591 }
54310121 592
424ec8fa
GS
593 # If method is GET or HEAD, fetch the query from
594 # the environment.
595 if ($meth=~/^(GET|HEAD)$/) {
3538e1d5 596 if ($MOD_PERL) {
8f3ccfa2 597 $query_string = $self->r->args;
3538e1d5
GS
598 } else {
599 $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
3d1a2ec4 600 $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
3538e1d5 601 }
424ec8fa
GS
602 last METHOD;
603 }
54310121 604
424ec8fa 605 if ($meth eq 'POST') {
2ed511ec 606 $self->read_from_client(\$query_string,$content_length,0)
424ec8fa 607 if $content_length > 0;
54310121 608 # Some people want to have their cake and eat it too!
609 # Uncomment this line to have the contents of the query string
610 # APPENDED to the POST data.
424ec8fa 611 # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
54310121 612 last METHOD;
613 }
424ec8fa
GS
614
615 # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
54310121 616 # Check the command line and then the standard input for data.
617 # We use the shellwords package in order to behave the way that
618 # UN*X programmers expect.
2ed511ec
RGS
619 if ($DEBUG)
620 {
621 my $cmdline_ret = read_from_cmdline();
622 $query_string = $cmdline_ret->{'query_string'};
623 if (defined($cmdline_ret->{'subpath'}))
624 {
625 $self->path_info($cmdline_ret->{'subpath'});
626 }
627 }
54310121 628 }
424ec8fa 629
8f3ccfa2
JH
630# YL: Begin Change for XML handler 10/19/2001
631 if ($meth eq 'POST'
632 && defined($ENV{'CONTENT_TYPE'})
1c87da1d
JH
633 && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
634 && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
8f3ccfa2
JH
635 my($param) = 'POSTDATA' ;
636 $self->add_parameter($param) ;
637 push (@{$self->{$param}},$query_string);
638 undef $query_string ;
639 }
640# YL: End Change for XML handler 10/19/2001
641
54310121 642 # We now have the query string in hand. We do slightly
643 # different things for keyword lists and parameter lists.
ba056755 644 if (defined $query_string && length $query_string) {
3d1a2ec4 645 if ($query_string =~ /[&=;]/) {
54310121 646 $self->parse_params($query_string);
647 } else {
648 $self->add_parameter('keywords');
649 $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
650 }
651 }
652
653 # Special case. Erase everything if there is a field named
654 # .defaults.
655 if ($self->param('.defaults')) {
e70cb7eb 656 $self->delete_all();
54310121 657 }
658
659 # Associative array containing our defined fieldnames
660 $self->{'.fieldnames'} = {};
661 foreach ($self->param('.cgifields')) {
662 $self->{'.fieldnames'}->{$_}++;
663 }
664
665 # Clear out our default submission button flag if present
666 $self->delete('.submit');
667 $self->delete('.cgifields');
3d1a2ec4 668
8f3ccfa2 669 $self->save_request unless defined $initializer;
54310121 670}
671
54310121 672# FUNCTIONS TO OVERRIDE:
54310121 673# Turn a string into a filehandle
674sub to_filehandle {
424ec8fa
GS
675 my $thingy = shift;
676 return undef unless $thingy;
677 return $thingy if UNIVERSAL::isa($thingy,'GLOB');
678 return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
679 if (!ref($thingy)) {
680 my $caller = 1;
681 while (my $package = caller($caller++)) {
682 my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
683 return $tmp if defined(fileno($tmp));
684 }
54310121 685 }
424ec8fa 686 return undef;
54310121 687}
688
689# send output to the browser
690sub put {
691 my($self,@p) = self_or_default(@_);
692 $self->print(@p);
693}
694
695# print to standard output (for overriding in mod_perl)
696sub print {
697 shift;
698 CORE::print(@_);
699}
700
3538e1d5
GS
701# get/set last cgi_error
702sub cgi_error {
703 my ($self,$err) = self_or_default(@_);
704 $self->{'.cgi_error'} = $err if defined $err;
705 return $self->{'.cgi_error'};
706}
707
54310121 708sub save_request {
709 my($self) = @_;
710 # We're going to play with the package globals now so that if we get called
711 # again, we initialize ourselves in exactly the same way. This allows
712 # us to have several of these objects.
713 @QUERY_PARAM = $self->param; # save list of parameters
714 foreach (@QUERY_PARAM) {
3d1a2ec4
GS
715 next unless defined $_;
716 $QUERY_PARAM{$_}=$self->{$_};
54310121 717 }
d45d855d
JH
718 $QUERY_CHARSET = $self->charset;
719 %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
54310121 720}
721
54310121 722sub parse_params {
723 my($self,$tosplit) = @_;
71f3e297 724 my(@pairs) = split(/[&;]/,$tosplit);
54310121 725 my($param,$value);
726 foreach (@pairs) {
424ec8fa 727 ($param,$value) = split('=',$_,2);
b2d0d414 728 next unless defined $param;
69c89ae7 729 next if $NO_UNDEF_PARAMS and not defined $value;
3d1a2ec4 730 $value = '' unless defined $value;
424ec8fa
GS
731 $param = unescape($param);
732 $value = unescape($value);
54310121 733 $self->add_parameter($param);
734 push (@{$self->{$param}},$value);
735 }
736}
737
738sub add_parameter {
739 my($self,$param)=@_;
3d1a2ec4 740 return unless defined $param;
54310121 741 push (@{$self->{'.parameters'}},$param)
742 unless defined($self->{$param});
743}
744
745sub all_parameters {
746 my $self = shift;
747 return () unless defined($self) && $self->{'.parameters'};
748 return () unless @{$self->{'.parameters'}};
749 return @{$self->{'.parameters'}};
750}
751
424ec8fa
GS
752# put a filehandle into binary mode (DOS)
753sub binmode {
2ed511ec 754 return unless defined($_[1]) && defined fileno($_[1]);
424ec8fa
GS
755 CORE::binmode($_[1]);
756}
757
758sub _make_tag_func {
71f3e297 759 my ($self,$tagname) = @_;
3538e1d5 760 my $func = qq(
3d1a2ec4 761 sub $tagname {
8f3ccfa2
JH
762 my (\$q,\$a,\@rest) = self_or_default(\@_);
763 my(\$attr) = '';
764 if (ref(\$a) && ref(\$a) eq 'HASH') {
765 my(\@attr) = make_attributes(\$a,\$q->{'escape'});
766 \$attr = " \@attr" if \@attr;
767 } else {
1c87da1d 768 unshift \@rest,\$a if defined \$a;
8f3ccfa2 769 }
3538e1d5 770 );
71f3e297 771 if ($tagname=~/start_(\w+)/i) {
6b4ac661 772 $func .= qq! return "<\L$1\E\$attr>";} !;
71f3e297 773 } elsif ($tagname=~/end_(\w+)/i) {
6b4ac661 774 $func .= qq! return "<\L/$1\E>"; } !;
71f3e297
JH
775 } else {
776 $func .= qq#
1c87da1d 777 return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest;
6b4ac661 778 my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
3d1a2ec4 779 my \@result = map { "\$tag\$_\$untag" }
8f3ccfa2 780 (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
424ec8fa 781 return "\@result";
71f3e297
JH
782 }#;
783 }
784return $func;
54310121 785}
786
787sub AUTOLOAD {
788 print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
424ec8fa
GS
789 my $func = &_compile;
790 goto &$func;
54310121 791}
792
424ec8fa
GS
793sub _compile {
794 my($func) = $AUTOLOAD;
795 my($pack,$func_name);
796 {
797 local($1,$2); # this fixes an obscure variable suicide problem.
798 $func=~/(.+)::([^:]+)$/;
799 ($pack,$func_name) = ($1,$2);
800 $pack=~s/::SUPER$//; # fix another obscure problem
801 $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
802 unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
803
804 my($sub) = \%{"$pack\:\:SUBS"};
805 unless (%$sub) {
806 my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
29ddc2a4 807 local ($@,$!);
424ec8fa 808 eval "package $pack; $$auto";
ba056755 809 croak("$AUTOLOAD: $@") if $@;
424ec8fa
GS
810 $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
811 }
812 my($code) = $sub->{$func_name};
813
814 $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
815 if (!$code) {
71f3e297 816 (my $base = $func_name) =~ s/^(start_|end_)//i;
424ec8fa
GS
817 if ($EXPORT{':any'} ||
818 $EXPORT{'-any'} ||
71f3e297 819 $EXPORT{$base} ||
424ec8fa 820 (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
71f3e297
JH
821 && $EXPORT_OK{$base}) {
822 $code = $CGI::DefaultClass->_make_tag_func($func_name);
424ec8fa
GS
823 }
824 }
ba056755 825 croak("Undefined subroutine $AUTOLOAD\n") unless $code;
29ddc2a4 826 local ($@,$!);
424ec8fa
GS
827 eval "package $pack; $code";
828 if ($@) {
829 $@ =~ s/ at .*\n//;
ba056755 830 croak("$AUTOLOAD: $@");
424ec8fa
GS
831 }
832 }
3538e1d5 833 CORE::delete($sub->{$func_name}); #free storage
424ec8fa
GS
834 return "$pack\:\:$func_name";
835}
836
3acbd4f5
JH
837sub _selected {
838 my $self = shift;
839 my $value = shift;
840 return '' unless $value;
0a9bdad4 841 return $XHTML ? qq(selected="selected" ) : qq(selected );
3acbd4f5
JH
842}
843
844sub _checked {
845 my $self = shift;
846 my $value = shift;
847 return '' unless $value;
0a9bdad4 848 return $XHTML ? qq(checked="checked" ) : qq(checked );
3acbd4f5
JH
849}
850
424ec8fa
GS
851sub _reset_globals { initialize_globals(); }
852
853sub _setup_symbols {
854 my $self = shift;
855 my $compile = 0;
b2d0d414
JH
856
857 # to avoid reexporting unwanted variables
858 undef %EXPORT;
859
424ec8fa 860 foreach (@_) {
71f3e297
JH
861 $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
862 $NPH++, next if /^[:-]nph$/;
3d1a2ec4
GS
863 $NOSTICKY++, next if /^[:-]nosticky$/;
864 $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
865 $DEBUG=2, next if /^[:-][Dd]ebug$/;
71f3e297 866 $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
6b4ac661
JH
867 $XHTML++, next if /^[:-]xhtml$/;
868 $XHTML=0, next if /^[:-]no_?xhtml$/;
3d1a2ec4 869 $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
71f3e297 870 $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
0a9bdad4 871 $TABINDEX++, next if /^[:-]tabindex$/;
13548fdf 872 $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
71f3e297
JH
873 $EXPORT{$_}++, next if /^[:-]any$/;
874 $compile++, next if /^[:-]compile$/;
199d4a26 875 $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
424ec8fa 876
71f3e297 877 # This is probably extremely evil code -- to be deleted some day.
424ec8fa
GS
878 if (/^[-]autoload$/) {
879 my($pkg) = caller(1);
880 *{"${pkg}::AUTOLOAD"} = sub {
881 my($routine) = $AUTOLOAD;
882 $routine =~ s/^.*::/CGI::/;
883 &$routine;
884 };
885 next;
886 }
887
888 foreach (&expand_tags($_)) {
889 tr/a-zA-Z0-9_//cd; # don't allow weird function names
890 $EXPORT{$_}++;
54310121 891 }
54310121 892 }
424ec8fa 893 _compile_all(keys %EXPORT) if $compile;
188ba755 894 @SAVED_SYMBOLS = @_;
54310121 895}
896
3d1a2ec4
GS
897sub charset {
898 my ($self,$charset) = self_or_default(@_);
899 $self->{'.charset'} = $charset if defined $charset;
900 $self->{'.charset'};
901}
902
29ddc2a4
RGS
903sub element_id {
904 my ($self,$new_value) = self_or_default(@_);
905 $self->{'.elid'} = $new_value if defined $new_value;
906 sprintf('%010d',$self->{'.elid'}++);
907}
908
909sub element_tab {
910 my ($self,$new_value) = self_or_default(@_);
70194bd6 911 $self->{'.etab'} ||= 1;
29ddc2a4 912 $self->{'.etab'} = $new_value if defined $new_value;
0a9bdad4
SP
913 my $tab = $self->{'.etab'}++;
914 return '' unless $TABINDEX or defined $new_value;
915 return qq(tabindex="$tab" );
29ddc2a4
RGS
916}
917
54310121 918###############################################################################
919################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
920###############################################################################
921$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
922$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
923
924%SUBS = (
925
926'URL_ENCODED'=> <<'END_OF_FUNC',
927sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
928END_OF_FUNC
929
930'MULTIPART' => <<'END_OF_FUNC',
931sub MULTIPART { 'multipart/form-data'; }
932END_OF_FUNC
933
424ec8fa 934'SERVER_PUSH' => <<'END_OF_FUNC',
ba056755 935sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
424ec8fa
GS
936END_OF_FUNC
937
424ec8fa
GS
938'new_MultipartBuffer' => <<'END_OF_FUNC',
939# Create a new multipart buffer
940sub new_MultipartBuffer {
2ed511ec
RGS
941 my($self,$boundary,$length) = @_;
942 return MultipartBuffer->new($self,$boundary,$length);
424ec8fa
GS
943}
944END_OF_FUNC
945
946'read_from_client' => <<'END_OF_FUNC',
947# Read data from a file handle
948sub read_from_client {
2ed511ec 949 my($self, $buff, $len, $offset) = @_;
424ec8fa 950 local $^W=0; # prevent a warning
2ed511ec
RGS
951 return $MOD_PERL
952 ? $self->r->read($$buff, $len, $offset)
953 : read(\*STDIN, $$buff, $len, $offset);
424ec8fa
GS
954}
955END_OF_FUNC
956
957'delete' => <<'END_OF_FUNC',
958#### Method: delete
959# Deletes the named parameter entirely.
960####
961sub delete {
6b4ac661 962 my($self,@p) = self_or_default(@_);
1c87da1d
JH
963 my(@names) = rearrange([NAME],@p);
964 my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
8f3ccfa2
JH
965 my %to_delete;
966 foreach my $name (@to_delete)
967 {
968 CORE::delete $self->{$name};
969 CORE::delete $self->{'.fieldnames'}->{$name};
970 $to_delete{$name}++;
188ba755 971 }
8f3ccfa2 972 @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
13548fdf 973 return;
424ec8fa
GS
974}
975END_OF_FUNC
976
977#### Method: import_names
978# Import all parameters into the given namespace.
979# Assumes namespace 'Q' if not specified
980####
981'import_names' => <<'END_OF_FUNC',
982sub import_names {
983 my($self,$namespace,$delete) = self_or_default(@_);
984 $namespace = 'Q' unless defined($namespace);
985 die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
3538e1d5 986 if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
424ec8fa
GS
987 # can anyone find an easier way to do this?
988 foreach (keys %{"${namespace}::"}) {
989 local *symbol = "${namespace}::${_}";
990 undef $symbol;
991 undef @symbol;
992 undef %symbol;
54310121 993 }
424ec8fa
GS
994 }
995 my($param,@value,$var);
996 foreach $param ($self->param) {
997 # protect against silly names
998 ($var = $param)=~tr/a-zA-Z0-9_/_/c;
999 $var =~ s/^(?=\d)/_/;
1000 local *symbol = "${namespace}::$var";
1001 @value = $self->param($param);
1002 @symbol = @value;
1003 $symbol = $value[0];
54310121 1004 }
1005}
1006END_OF_FUNC
1007
1008#### Method: keywords
1009# Keywords acts a bit differently. Calling it in a list context
1010# returns the list of keywords.
1011# Calling it in a scalar context gives you the size of the list.
1012####
1013'keywords' => <<'END_OF_FUNC',
1014sub keywords {
1015 my($self,@values) = self_or_default(@_);
1016 # If values is provided, then we set it.
475342a6 1017 $self->{'keywords'}=[@values] if @values;
424ec8fa 1018 my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
54310121 1019 @result;
1020}
1021END_OF_FUNC
1022
1023# These are some tie() interfaces for compatibility
1024# with Steve Brenner's cgi-lib.pl routines
3538e1d5
GS
1025'Vars' => <<'END_OF_FUNC',
1026sub Vars {
ffd2dff2 1027 my $q = shift;
3538e1d5 1028 my %in;
ffd2dff2 1029 tie(%in,CGI,$q);
3538e1d5
GS
1030 return %in if wantarray;
1031 return \%in;
1032}
1033END_OF_FUNC
1034
1035# These are some tie() interfaces for compatibility
1036# with Steve Brenner's cgi-lib.pl routines
54310121 1037'ReadParse' => <<'END_OF_FUNC',
1038sub ReadParse {
1039 local(*in);
1040 if (@_) {
1041 *in = $_[0];
1042 } else {
1043 my $pkg = caller();
1044 *in=*{"${pkg}::in"};
1045 }
1046 tie(%in,CGI);
424ec8fa 1047 return scalar(keys %in);
54310121 1048}
1049END_OF_FUNC
1050
1051'PrintHeader' => <<'END_OF_FUNC',
1052sub PrintHeader {
1053 my($self) = self_or_default(@_);
1054 return $self->header();
1055}
1056END_OF_FUNC
1057
1058'HtmlTop' => <<'END_OF_FUNC',
1059sub HtmlTop {
1060 my($self,@p) = self_or_default(@_);
1061 return $self->start_html(@p);
1062}
1063END_OF_FUNC
1064
1065'HtmlBot' => <<'END_OF_FUNC',
1066sub HtmlBot {
1067 my($self,@p) = self_or_default(@_);
1068 return $self->end_html(@p);
1069}
1070END_OF_FUNC
1071
1072'SplitParam' => <<'END_OF_FUNC',
1073sub SplitParam {
1074 my ($param) = @_;
1075 my (@params) = split ("\0", $param);
1076 return (wantarray ? @params : $params[0]);
1077}
1078END_OF_FUNC
1079
1080'MethGet' => <<'END_OF_FUNC',
1081sub MethGet {
1082 return request_method() eq 'GET';
1083}
1084END_OF_FUNC
1085
1086'MethPost' => <<'END_OF_FUNC',
1087sub MethPost {
1088 return request_method() eq 'POST';
1089}
1090END_OF_FUNC
1091
1092'TIEHASH' => <<'END_OF_FUNC',
8f3ccfa2
JH
1093sub TIEHASH {
1094 my $class = shift;
1095 my $arg = $_[0];
1096 if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
1097 return $arg;
1098 }
1099 return $Q ||= $class->new(@_);
54310121 1100}
1101END_OF_FUNC
1102
1103'STORE' => <<'END_OF_FUNC',
1104sub STORE {
3d1a2ec4
GS
1105 my $self = shift;
1106 my $tag = shift;
6b4ac661
JH
1107 my $vals = shift;
1108 my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
3d1a2ec4 1109 $self->param(-name=>$tag,-value=>\@vals);
54310121 1110}
1111END_OF_FUNC
1112
1113'FETCH' => <<'END_OF_FUNC',
1114sub FETCH {
1115 return $_[0] if $_[1] eq 'CGI';
1116 return undef unless defined $_[0]->param($_[1]);
1117 return join("\0",$_[0]->param($_[1]));
1118}
1119END_OF_FUNC
1120
1121'FIRSTKEY' => <<'END_OF_FUNC',
1122sub FIRSTKEY {
1123 $_[0]->{'.iterator'}=0;
1124 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1125}
1126END_OF_FUNC
1127
1128'NEXTKEY' => <<'END_OF_FUNC',
1129sub NEXTKEY {
1130 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1131}
1132END_OF_FUNC
1133
1134'EXISTS' => <<'END_OF_FUNC',
1135sub EXISTS {
1136 exists $_[0]->{$_[1]};
1137}
1138END_OF_FUNC
1139
1140'DELETE' => <<'END_OF_FUNC',
1141sub DELETE {
1142 $_[0]->delete($_[1]);
1143}
1144END_OF_FUNC
1145
1146'CLEAR' => <<'END_OF_FUNC',
1147sub CLEAR {
1148 %{$_[0]}=();
1149}
1150####
1151END_OF_FUNC
1152
1153####
1154# Append a new value to an existing query
1155####
1156'append' => <<'EOF',
1157sub append {
7dc108d1 1158 my($self,@p) = self_or_default(@_);
3d1a2ec4 1159 my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
54310121 1160 my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
1161 if (@values) {
1162 $self->add_parameter($name);
1163 push(@{$self->{$name}},@values);
1164 }
1165 return $self->param($name);
1166}
1167EOF
1168
1169#### Method: delete_all
1170# Delete all parameters
1171####
1172'delete_all' => <<'EOF',
1173sub delete_all {
1174 my($self) = self_or_default(@_);
1c87da1d 1175 my @param = $self->param();
8f3ccfa2 1176 $self->delete(@param);
54310121 1177}
1178EOF
1179
424ec8fa
GS
1180'Delete' => <<'EOF',
1181sub Delete {
1182 my($self,@p) = self_or_default(@_);
1183 $self->delete(@p);
1184}
1185EOF
1186
1187'Delete_all' => <<'EOF',
1188sub Delete_all {
1189 my($self,@p) = self_or_default(@_);
1190 $self->delete_all(@p);
1191}
1192EOF
1193
54310121 1194#### Method: autoescape
1195# If you want to turn off the autoescaping features,
1196# call this method with undef as the argument
1197'autoEscape' => <<'END_OF_FUNC',
1198sub autoEscape {
1199 my($self,$escape) = self_or_default(@_);
188ba755
JH
1200 my $d = $self->{'escape'};
1201 $self->{'escape'} = $escape;
1202 $d;
54310121 1203}
1204END_OF_FUNC
1205
1206
1207#### Method: version
1208# Return the current version
1209####
1210'version' => <<'END_OF_FUNC',
1211sub version {
1212 return $VERSION;
1213}
1214END_OF_FUNC
1215
424ec8fa
GS
1216#### Method: url_param
1217# Return a parameter in the QUERY_STRING, regardless of
1218# whether this was a POST or a GET
1219####
1220'url_param' => <<'END_OF_FUNC',
1221sub url_param {
1222 my ($self,@p) = self_or_default(@_);
1223 my $name = shift(@p);
1224 return undef unless exists($ENV{QUERY_STRING});
1225 unless (exists($self->{'.url_param'})) {
1226 $self->{'.url_param'}={}; # empty hash
1227 if ($ENV{QUERY_STRING} =~ /=/) {
71f3e297 1228 my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
424ec8fa
GS
1229 my($param,$value);
1230 foreach (@pairs) {
1231 ($param,$value) = split('=',$_,2);
1232 $param = unescape($param);
1233 $value = unescape($value);
1234 push(@{$self->{'.url_param'}->{$param}},$value);
1235 }
1236 } else {
1237 $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
1238 }
1239 }
1240 return keys %{$self->{'.url_param'}} unless defined($name);
1241 return () unless $self->{'.url_param'}->{$name};
1242 return wantarray ? @{$self->{'.url_param'}->{$name}}
1243 : $self->{'.url_param'}->{$name}->[0];
1244}
1245END_OF_FUNC
1246
3d1a2ec4 1247#### Method: Dump
54310121 1248# Returns a string in which all the known parameter/value
1249# pairs are represented as nested lists, mainly for the purposes
1250# of debugging.
1251####
3d1a2ec4
GS
1252'Dump' => <<'END_OF_FUNC',
1253sub Dump {
54310121 1254 my($self) = self_or_default(@_);
1255 my($param,$value,@result);
3acbd4f5
JH
1256 return '<ul></ul>' unless $self->param;
1257 push(@result,"<ul>");
54310121 1258 foreach $param ($self->param) {
1259 my($name)=$self->escapeHTML($param);
1c87da1d 1260 push(@result,"<li><strong>$param</strong></li>");
3acbd4f5 1261 push(@result,"<ul>");
54310121 1262 foreach $value ($self->param($param)) {
1263 $value = $self->escapeHTML($value);
58129083 1264 $value =~ s/\n/<br \/>\n/g;
1c87da1d 1265 push(@result,"<li>$value</li>");
54310121 1266 }
3acbd4f5 1267 push(@result,"</ul>");
54310121 1268 }
3acbd4f5 1269 push(@result,"</ul>");
54310121 1270 return join("\n",@result);
1271}
1272END_OF_FUNC
1273
424ec8fa
GS
1274#### Method as_string
1275#
1276# synonym for "dump"
1277####
1278'as_string' => <<'END_OF_FUNC',
1279sub as_string {
3d1a2ec4 1280 &Dump(@_);
424ec8fa
GS
1281}
1282END_OF_FUNC
1283
1284#### Method: save
1285# Write values out to a filehandle in such a way that they can
1286# be reinitialized by the filehandle form of the new() method
54310121 1287####
1288'save' => <<'END_OF_FUNC',
1289sub save {
1290 my($self,$filehandle) = self_or_default(@_);
54310121 1291 $filehandle = to_filehandle($filehandle);
424ec8fa
GS
1292 my($param);
1293 local($,) = ''; # set print field separator back to a sane value
71f3e297 1294 local($\) = ''; # set output line separator to a sane value
54310121 1295 foreach $param ($self->param) {
424ec8fa 1296 my($escaped_param) = escape($param);
54310121 1297 my($value);
1298 foreach $value ($self->param($param)) {
3538e1d5 1299 print $filehandle "$escaped_param=",escape("$value"),"\n";
54310121 1300 }
1301 }
d45d855d
JH
1302 foreach (keys %{$self->{'.fieldnames'}}) {
1303 print $filehandle ".cgifields=",escape("$_"),"\n";
1304 }
54310121 1305 print $filehandle "=\n"; # end of record
1306}
1307END_OF_FUNC
1308
1309
424ec8fa
GS
1310#### Method: save_parameters
1311# An alias for save() that is a better name for exportation.
1312# Only intended to be used with the function (non-OO) interface.
1313####
1314'save_parameters' => <<'END_OF_FUNC',
1315sub save_parameters {
1316 my $fh = shift;
1317 return save(to_filehandle($fh));
1318}
1319END_OF_FUNC
1320
1321#### Method: restore_parameters
1322# A way to restore CGI parameters from an initializer.
1323# Only intended to be used with the function (non-OO) interface.
1324####
1325'restore_parameters' => <<'END_OF_FUNC',
1326sub restore_parameters {
1327 $Q = $CGI::DefaultClass->new(@_);
1328}
1329END_OF_FUNC
1330
1331#### Method: multipart_init
1332# Return a Content-Type: style header for server-push
ba056755 1333# This has to be NPH on most web servers, and it is advisable to set $| = 1
424ec8fa
GS
1334#
1335# Many thanks to Ed Jordan <ed@fidalgo.net> for this
ba056755 1336# contribution, updated by Andrew Benham (adsb@bigfoot.com)
424ec8fa
GS
1337####
1338'multipart_init' => <<'END_OF_FUNC',
1339sub multipart_init {
1340 my($self,@p) = self_or_default(@_);
3d1a2ec4 1341 my($boundary,@other) = rearrange([BOUNDARY],@p);
424ec8fa 1342 $boundary = $boundary || '------- =_aaaaaaaaaa0';
ba056755
JH
1343 $self->{'separator'} = "$CRLF--$boundary$CRLF";
1344 $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
424ec8fa
GS
1345 $type = SERVER_PUSH($boundary);
1346 return $self->header(
13548fdf 1347 -nph => 0,
424ec8fa
GS
1348 -type => $type,
1349 (map { split "=", $_, 2 } @other),
ba056755 1350 ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
424ec8fa
GS
1351}
1352END_OF_FUNC
1353
1354
1355#### Method: multipart_start
1356# Return a Content-Type: style header for server-push, start of section
1357#
1358# Many thanks to Ed Jordan <ed@fidalgo.net> for this
ba056755 1359# contribution, updated by Andrew Benham (adsb@bigfoot.com)
424ec8fa
GS
1360####
1361'multipart_start' => <<'END_OF_FUNC',
1362sub multipart_start {
ba056755 1363 my(@header);
424ec8fa 1364 my($self,@p) = self_or_default(@_);
3d1a2ec4 1365 my($type,@other) = rearrange([TYPE],@p);
424ec8fa 1366 $type = $type || 'text/html';
ba056755
JH
1367 push(@header,"Content-Type: $type");
1368
1369 # rearrange() was designed for the HTML portion, so we
1370 # need to fix it up a little.
1371 foreach (@other) {
8f3ccfa2
JH
1372 # Don't use \s because of perl bug 21951
1373 next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
ba056755
JH
1374 ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
1375 }
1376 push(@header,@other);
1377 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1378 return $header;
424ec8fa
GS
1379}
1380END_OF_FUNC
1381
1382
1383#### Method: multipart_end
ba056755 1384# Return a MIME boundary separator for server-push, end of section
424ec8fa
GS
1385#
1386# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1387# contribution
1388####
1389'multipart_end' => <<'END_OF_FUNC',
1390sub multipart_end {
1391 my($self,@p) = self_or_default(@_);
1392 return $self->{'separator'};
1393}
1394END_OF_FUNC
1395
1396
ba056755
JH
1397#### Method: multipart_final
1398# Return a MIME boundary separator for server-push, end of all sections
1399#
1400# Contributed by Andrew Benham (adsb@bigfoot.com)
1401####
1402'multipart_final' => <<'END_OF_FUNC',
1403sub multipart_final {
1404 my($self,@p) = self_or_default(@_);
1405 return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
1406}
1407END_OF_FUNC
1408
1409
54310121 1410#### Method: header
1411# Return a Content-Type: style header
1412#
1413####
1414'header' => <<'END_OF_FUNC',
1415sub header {
1416 my($self,@p) = self_or_default(@_);
1417 my(@header);
1418
2ed511ec 1419 return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
71f3e297 1420
8f3ccfa2 1421 my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
3d1a2ec4
GS
1422 rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
1423 'STATUS',['COOKIE','COOKIES'],'TARGET',
6b4ac661 1424 'EXPIRES','NPH','CHARSET',
8f3ccfa2 1425 'ATTACHMENT','P3P'],@p);
3d1a2ec4
GS
1426
1427 $nph ||= $NPH;
55b5d700
SP
1428
1429 $type ||= 'text/html' unless defined($type);
1430
3d1a2ec4
GS
1431 if (defined $charset) {
1432 $self->charset($charset);
1433 } else {
55b5d700 1434 $charset = $self->charset if $type =~ /^text\//;
3d1a2ec4 1435 }
cb3b230c 1436 $charset ||= '';
54310121 1437
1438 # rearrange() was designed for the HTML portion, so we
1439 # need to fix it up a little.
1440 foreach (@other) {
8f3ccfa2
JH
1441 # Don't use \s because of perl bug 21951
1442 next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
1443 ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
54310121 1444 }
1445
cd755de4
JJ
1446 $type .= "; charset=$charset"
1447 if $type ne ''
1448 and $type !~ /\bcharset\b/
1449 and defined $charset
1450 and $charset ne '';
54310121 1451
424ec8fa
GS
1452 # Maybe future compatibility. Maybe not.
1453 my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
1454 push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
ba056755 1455 push(@header,"Server: " . &server_software()) if $nph;
424ec8fa 1456
54310121 1457 push(@header,"Status: $status") if $status;
424ec8fa 1458 push(@header,"Window-Target: $target") if $target;
8f3ccfa2
JH
1459 if ($p3p) {
1460 $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
1461 push(@header,qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p"));
1462 }
54310121 1463 # push all the cookies -- there may be several
1464 if ($cookie) {
424ec8fa 1465 my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
54310121 1466 foreach (@cookie) {
71f3e297
JH
1467 my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
1468 push(@header,"Set-Cookie: $cs") if $cs ne '';
54310121 1469 }
1470 }
1471 # if the user indicates an expiration time, then we need
1472 # both an Expires and a Date header (so that the browser is
1473 # uses OUR clock)
424ec8fa 1474 push(@header,"Expires: " . expires($expires,'http'))
7d37aa8e 1475 if $expires;
ba056755 1476 push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
54310121 1477 push(@header,"Pragma: no-cache") if $self->cache();
6b4ac661 1478 push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
69c89ae7 1479 push(@header,map {ucfirst $_} @other);
71f3e297 1480 push(@header,"Content-Type: $type") if $type ne '';
424ec8fa
GS
1481 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1482 if ($MOD_PERL and not $nph) {
8f3ccfa2
JH
1483 $self->r->send_cgi_header($header);
1484 return '';
424ec8fa
GS
1485 }
1486 return $header;
54310121 1487}
1488END_OF_FUNC
1489
1490
1491#### Method: cache
1492# Control whether header() will produce the no-cache
1493# Pragma directive.
1494####
1495'cache' => <<'END_OF_FUNC',
1496sub cache {
1497 my($self,$new_value) = self_or_default(@_);
1498 $new_value = '' unless $new_value;
1499 if ($new_value ne '') {
1500 $self->{'cache'} = $new_value;
1501 }
1502 return $self->{'cache'};
1503}
1504END_OF_FUNC
1505
1506
1507#### Method: redirect
1508# Return a Location: style header
1509#
1510####
1511'redirect' => <<'END_OF_FUNC',
1512sub redirect {
1513 my($self,@p) = self_or_default(@_);
13548fdf
RGS
1514 my($url,$target,$status,$cookie,$nph,@other) =
1515 rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p);
55b5d700 1516 $status = '302 Found' unless defined $status;
6b4ac661 1517 $url ||= $self->self_url;
54310121 1518 my(@o);
424ec8fa
GS
1519 foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
1520 unshift(@o,
13548fdf 1521 '-Status' => $status,
8f3ccfa2
JH
1522 '-Location'=> $url,
1523 '-nph' => $nph);
424ec8fa 1524 unshift(@o,'-Target'=>$target) if $target;
71f3e297 1525 unshift(@o,'-Type'=>'');
8f3ccfa2
JH
1526 my @unescaped;
1527 unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
1528 return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
54310121 1529}
1530END_OF_FUNC
1531
1532
1533#### Method: start_html
1534# Canned HTML header
1535#
1536# Parameters:
1537# $title -> (optional) The title for this HTML document (-title)
1538# $author -> (optional) e-mail address of the author (-author)
1539# $base -> (optional) if set to true, will enter the BASE address of this document
1540# for resolving relative references (-base)
1541# $xbase -> (optional) alternative base at some remote location (-xbase)
1542# $target -> (optional) target window to load all links into (-target)
1543# $script -> (option) Javascript code (-script)
47e3cabd 1544# $no_script -> (option) Javascript <noscript> tag (-noscript)
54310121 1545# $meta -> (optional) Meta information tags
3acbd4f5 1546# $head -> (optional) any other elements you'd like to incorporate into the <head> tag
7d37aa8e
LS
1547# (a scalar or array ref)
1548# $style -> (optional) reference to an external style sheet
54310121 1549# @other -> (optional) any other named parameters you'd like to incorporate into
3acbd4f5 1550# the <body> tag.
54310121 1551####
1552'start_html' => <<'END_OF_FUNC',
1553sub start_html {
1554 my($self,@p) = &self_or_default(@_);
ac734d8b 1555 my($title,$author,$base,$xbase,$script,$noscript,
29ddc2a4
RGS
1556 $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) =
1557 rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,
1558 META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p);
1559
1560 $self->element_id(0);
1561 $self->element_tab(0);
ac734d8b 1562
55b5d700 1563 $encoding = lc($self->charset) unless defined $encoding;
54310121 1564
13548fdf 1565 # Need to sort out the DTD before it's okay to call escapeHTML().
ba056755 1566 my(@result,$xml_dtd);
3d1a2ec4 1567 if ($dtd) {
6b4ac661 1568 if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
3d1a2ec4
GS
1569 $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
1570 } else {
1571 $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
1572 }
1573 } else {
6b4ac661 1574 $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
3d1a2ec4 1575 }
ba056755
JH
1576
1577 $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
1578 $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
29ddc2a4 1579 push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml;
ba056755 1580
3d1a2ec4 1581 if (ref($dtd) && ref($dtd) eq 'ARRAY') {
b2d0d414 1582 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
13548fdf 1583 $DTD_PUBLIC_IDENTIFIER = $dtd->[0];
3d1a2ec4 1584 } else {
03b9648d 1585 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
13548fdf
RGS
1586 $DTD_PUBLIC_IDENTIFIER = $dtd;
1587 }
1588
1589 # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
1590 # call escapeHTML(). Strangely enough, the title needs to be escaped as
1591 # HTML while the author needs to be escaped as a URL.
1592 $title = $self->escapeHTML($title || 'Untitled Document');
1593 $author = $self->escape($author);
1594
1595 if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2)/i) {
1596 $lang = "" unless defined $lang;
1597 $XHTML = 0;
3d1a2ec4 1598 }
13548fdf
RGS
1599 else {
1600 $lang = 'en-US' unless defined $lang;
1601 }
1602
29ddc2a4
RGS
1603 my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : '';
1604 my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />)
1605 if $XHTML && $encoding && !$declare_xml;
1606
1607 push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>)
1608 : ($lang ? qq(<html lang="$lang">) : "<html>")
8f3ccfa2 1609 . "<head><title>$title</title>");
6b4ac661
JH
1610 if (defined $author) {
1611 push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
29ddc2a4 1612 : "<link rev=\"made\" href=\"mailto:$author\">");
6b4ac661 1613 }
54310121 1614
1615 if ($base || $xbase || $target) {
424ec8fa 1616 my $href = $xbase || $self->url('-path'=>1);
6b4ac661
JH
1617 my $t = $target ? qq/ target="$target"/ : '';
1618 push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
54310121 1619 }
1620
1621 if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
6b4ac661
JH
1622 foreach (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
1623 : qq(<meta name="$_" content="$meta->{$_}">)); }
54310121 1624 }
7d37aa8e
LS
1625
1626 push(@result,ref($head) ? @$head : $head) if $head;
1627
424ec8fa 1628 # handle the infrequently-used -style and -script parameters
13548fdf 1629 push(@result,$self->_style($style)) if defined $style;
424ec8fa 1630 push(@result,$self->_script($script)) if defined $script;
29ddc2a4 1631 push(@result,$meta_bits) if defined $meta_bits;
424ec8fa
GS
1632
1633 # handle -noscript parameter
1634 push(@result,<<END) if $noscript;
6b4ac661 1635<noscript>
424ec8fa 1636$noscript
6b4ac661 1637</noscript>
424ec8fa
GS
1638END
1639 ;
1640 my($other) = @other ? " @other" : '';
29ddc2a4 1641 push(@result,"</head>\n<body$other>\n");
424ec8fa
GS
1642 return join("\n",@result);
1643}
1644END_OF_FUNC
1645
1646### Method: _style
1647# internal method for generating a CSS style section
1648####
1649'_style' => <<'END_OF_FUNC',
1650sub _style {
1651 my ($self,$style) = @_;
1652 my (@result);
1653 my $type = 'text/css';
a3b3a725
JH
1654
1655 my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
1656 my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
1657
13548fdf
RGS
1658 my @s = ref($style) eq 'ARRAY' ? @$style : $style;
1659
1660 for my $s (@s) {
1661 if (ref($s)) {
1662 my($src,$code,$verbatim,$stype,$foo,@other) =
1663 rearrange([qw(SRC CODE VERBATIM TYPE FOO)],
1664 ('-foo'=>'bar',
1665 ref($s) eq 'ARRAY' ? @$s : %$s));
1666 $type = $stype if $stype;
1667 my $other = @other ? join ' ',@other : '';
1668
1669 if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
1670 { # If it is, push a LINK tag for each one
1671 foreach $src (@$src)
1672 {
1673 push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
1c87da1d 1674 : qq(<link rel="stylesheet" type="$type" href="$src"$other>)) if $src;
13548fdf 1675 }
6b4ac661 1676 }
13548fdf
RGS
1677 else
1678 { # Otherwise, push the single -src, if it exists.
1c87da1d 1679 push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
13548fdf
RGS
1680 : qq(<link rel="stylesheet" type="$type" href="$src"$other>)
1681 ) if $src;
1682 }
1683 if ($verbatim) {
1684 my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim;
1685 push(@result, "<style type=\"text/css\">\n$_\n</style>") foreach @v;
1686 }
1687 my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code;
1688 push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) foreach @c;
1689
1690 } else {
1691 my $src = $s;
1692 push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
1693 : qq(<link rel="stylesheet" type="$type" href="$src"$other>));
1694 }
7d37aa8e 1695 }
424ec8fa
GS
1696 @result;
1697}
1698END_OF_FUNC
1699
424ec8fa
GS
1700'_script' => <<'END_OF_FUNC',
1701sub _script {
1702 my ($self,$script) = @_;
1703 my (@result);
a3b3a725 1704
424ec8fa
GS
1705 my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
1706 foreach $script (@scripts) {
7d37aa8e
LS
1707 my($src,$code,$language);
1708 if (ref($script)) { # script is a hash
3d1a2ec4
GS
1709 ($src,$code,$language, $type) =
1710 rearrange([SRC,CODE,LANGUAGE,TYPE],
7d37aa8e 1711 '-foo'=>'bar', # a trick to allow the '-' to be omitted
3538e1d5 1712 ref($script) eq 'ARRAY' ? @$script : %$script);
3d1a2ec4
GS
1713 # User may not have specified language
1714 $language ||= 'JavaScript';
1715 unless (defined $type) {
1716 $type = lc $language;
1717 # strip '1.2' from 'javascript1.2'
1718 $type =~ s/^(\D+).*$/text\/$1/;
1719 }
7d37aa8e 1720 } else {
3d1a2ec4 1721 ($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript');
7d37aa8e 1722 }
a3b3a725
JH
1723
1724 my $comment = '//'; # javascript by default
1725 $comment = '#' if $type=~/perl|tcl/i;
1726 $comment = "'" if $type=~/vbscript/i;
1727
58129083
JH
1728 my ($cdata_start,$cdata_end);
1729 if ($XHTML) {
1730 $cdata_start = "$comment<![CDATA[\n";
1731 $cdata_end .= "\n$comment]]>";
1732 } else {
1733 $cdata_start = "\n<!-- Hide script\n";
1734 $cdata_end = $comment;
1735 $cdata_end .= " End script hiding -->\n";
1736 }
1737 my(@satts);
1738 push(@satts,'src'=>$src) if $src;
1739 push(@satts,'language'=>$language) unless defined $type;
1740 push(@satts,'type'=>$type);
29ddc2a4
RGS
1741 $code = $cdata_start . $code . $cdata_end if defined $code;
1742 push(@result,$self->script({@satts},$code || ''));
7d37aa8e 1743 }
424ec8fa 1744 @result;
54310121 1745}
1746END_OF_FUNC
1747
54310121 1748#### Method: end_html
1749# End an HTML document.
3acbd4f5 1750# Trivial method for completeness. Just returns "</body>"
54310121 1751####
1752'end_html' => <<'END_OF_FUNC',
1753sub end_html {
29ddc2a4 1754 return "\n</body>\n</html>";
54310121 1755}
1756END_OF_FUNC
1757
1758
1759################################
1760# METHODS USED IN BUILDING FORMS
1761################################
1762
1763#### Method: isindex
1764# Just prints out the isindex tag.
1765# Parameters:
1766# $action -> optional URL of script to run
1767# Returns:
188ba755 1768# A string containing a <isindex> tag
54310121 1769'isindex' => <<'END_OF_FUNC',
1770sub isindex {
1771 my($self,@p) = self_or_default(@_);
3d1a2ec4 1772 my($action,@other) = rearrange([ACTION],@p);
188ba755 1773 $action = qq/ action="$action"/ if $action;
54310121 1774 my($other) = @other ? " @other" : '';
188ba755 1775 return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>";
54310121 1776}
1777END_OF_FUNC
1778
1779
1780#### Method: startform
1781# Start a form
1782# Parameters:
1783# $method -> optional submission method to use (GET or POST)
1784# $action -> optional URL of script to run
1785# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1786'startform' => <<'END_OF_FUNC',
1787sub startform {
1788 my($self,@p) = self_or_default(@_);
1789
1790 my($method,$action,$enctype,@other) =
3d1a2ec4 1791 rearrange([METHOD,ACTION,ENCTYPE],@p);
54310121 1792
13548fdf
RGS
1793 $method = $self->escapeHTML(lc($method) || 'post');
1794 $enctype = $self->escapeHTML($enctype || &URL_ENCODED);
1795 if (defined $action) {
1796 $action = $self->escapeHTML($action);
1797 }
1798 else {
0a9bdad4 1799 $action = $self->escapeHTML($self->request_uri);
03b9648d
JH
1800 }
1801 $action = qq(action="$action");
54310121 1802 my($other) = @other ? " @other" : '';
1803 $self->{'.parametersToAdd'}={};
6b4ac661 1804 return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
54310121 1805}
1806END_OF_FUNC
1807
1808
1809#### Method: start_form
1810# synonym for startform
1811'start_form' => <<'END_OF_FUNC',
1812sub start_form {
29ddc2a4 1813 $XHTML ? &start_multipart_form : &startform;
54310121 1814}
1815END_OF_FUNC
1816
71f3e297
JH
1817'end_multipart_form' => <<'END_OF_FUNC',
1818sub end_multipart_form {
1819 &endform;
1820}
1821END_OF_FUNC
54310121 1822
1823#### Method: start_multipart_form
1824# synonym for startform
1825'start_multipart_form' => <<'END_OF_FUNC',
1826sub start_multipart_form {
1827 my($self,@p) = self_or_default(@_);
0a9bdad4 1828 if (defined($p[0]) && substr($p[0],0,1) eq '-') {
adb86593 1829 return $self->startform(-enctype=>&MULTIPART,@p);
54310121 1830 } else {
1831 my($method,$action,@other) =
3d1a2ec4 1832 rearrange([METHOD,ACTION],@p);
54310121 1833 return $self->startform($method,$action,&MULTIPART,@other);
1834 }
1835}
1836END_OF_FUNC
1837
1838
1839#### Method: endform
1840# End a form
1841'endform' => <<'END_OF_FUNC',
1842sub endform {
0a9bdad4 1843 my($self,@p) = self_or_default(@_);
3d1a2ec4 1844 if ( $NOSTICKY ) {
6b4ac661 1845 return wantarray ? ("</form>") : "\n</form>";
3d1a2ec4 1846 } else {
0a9bdad4
SP
1847 if (my @fields = $self->get_fields) {
1848 return wantarray ? ("<div>",@fields,"</div>","</form>")
1849 : "<div>".(join '',@fields)."</div>\n</form>";
1850 } else {
1851 return "</form>";
1852 }
3d1a2ec4 1853 }
54310121 1854}
1855END_OF_FUNC
1856
1857
424ec8fa
GS
1858'_textfield' => <<'END_OF_FUNC',
1859sub _textfield {
1860 my($self,$tag,@p) = self_or_default(@_);
29ddc2a4
RGS
1861 my($name,$default,$size,$maxlength,$override,$tabindex,@other) =
1862 rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p);
424ec8fa
GS
1863
1864 my $current = $override ? $default :
1865 (defined($self->param($name)) ? $self->param($name) : $default);
1866
a3b3a725 1867 $current = defined($current) ? $self->escapeHTML($current,1) : '';
424ec8fa 1868 $name = defined($name) ? $self->escapeHTML($name) : '';
ba056755
JH
1869 my($s) = defined($size) ? qq/ size="$size"/ : '';
1870 my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
71f3e297
JH
1871 my($other) = @other ? " @other" : '';
1872 # this entered at cristy's request to fix problems with file upload fields
1873 # and WebTV -- not sure it won't break stuff
6b4ac661 1874 my($value) = $current ne '' ? qq(value="$current") : '';
29ddc2a4 1875 $tabindex = $self->element_tab($tabindex);
0a9bdad4 1876 return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />)
b2d0d414 1877 : qq(<input type="$tag" name="$name" $value$s$m$other>);
424ec8fa
GS
1878}
1879END_OF_FUNC
1880
54310121 1881#### Method: textfield
1882# Parameters:
1883# $name -> Name of the text field
1884# $default -> Optional default value of the field if not
1885# already defined.
1886# $size -> Optional width of field in characaters.
1887# $maxlength -> Optional maximum number of characters.
1888# Returns:
188ba755 1889# A string containing a <input type="text"> field
54310121 1890#
1891'textfield' => <<'END_OF_FUNC',
1892sub textfield {
1893 my($self,@p) = self_or_default(@_);
424ec8fa 1894 $self->_textfield('text',@p);
54310121 1895}
1896END_OF_FUNC
1897
1898
1899#### Method: filefield
1900# Parameters:
1901# $name -> Name of the file upload field
1902# $size -> Optional width of field in characaters.
1903# $maxlength -> Optional maximum number of characters.
1904# Returns:
188ba755 1905# A string containing a <input type="file"> field
54310121 1906#
1907'filefield' => <<'END_OF_FUNC',
1908sub filefield {
1909 my($self,@p) = self_or_default(@_);
424ec8fa 1910 $self->_textfield('file',@p);
54310121 1911}
1912END_OF_FUNC
1913
1914
1915#### Method: password
1916# Create a "secret password" entry field
1917# Parameters:
1918# $name -> Name of the field
1919# $default -> Optional default value of the field if not
1920# already defined.
1921# $size -> Optional width of field in characters.
1922# $maxlength -> Optional maximum characters that can be entered.
1923# Returns:
188ba755 1924# A string containing a <input type="password"> field
54310121 1925#
1926'password_field' => <<'END_OF_FUNC',
1927sub password_field {
1928 my ($self,@p) = self_or_default(@_);
424ec8fa 1929 $self->_textfield('password',@p);
54310121 1930}
1931END_OF_FUNC
1932
54310121 1933#### Method: textarea
1934# Parameters:
1935# $name -> Name of the text field
1936# $default -> Optional default value of the field if not
1937# already defined.
1938# $rows -> Optional number of rows in text area
1939# $columns -> Optional number of columns in text area
1940# Returns:
3acbd4f5 1941# A string containing a <textarea></textarea> tag
54310121 1942#
1943'textarea' => <<'END_OF_FUNC',
1944sub textarea {
1945 my($self,@p) = self_or_default(@_);
29ddc2a4
RGS
1946 my($name,$default,$rows,$cols,$override,$tabindex,@other) =
1947 rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p);
54310121 1948
1949 my($current)= $override ? $default :
1950 (defined($self->param($name)) ? $self->param($name) : $default);
1951
1952 $name = defined($name) ? $self->escapeHTML($name) : '';
1953 $current = defined($current) ? $self->escapeHTML($current) : '';
3acbd4f5
JH
1954 my($r) = $rows ? qq/ rows="$rows"/ : '';
1955 my($c) = $cols ? qq/ cols="$cols"/ : '';
54310121 1956 my($other) = @other ? " @other" : '';
29ddc2a4 1957 $tabindex = $self->element_tab($tabindex);
0a9bdad4 1958 return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>};
54310121 1959}
1960END_OF_FUNC
1961
1962
1963#### Method: button
1964# Create a javascript button.
1965# Parameters:
1966# $name -> (optional) Name for the button. (-name)
1967# $value -> (optional) Value of the button when selected (and visible name) (-value)
1968# $onclick -> (optional) Text of the JavaScript to run when the button is
1969# clicked.
1970# Returns:
188ba755 1971# A string containing a <input type="button"> tag
54310121 1972####
1973'button' => <<'END_OF_FUNC',
1974sub button {
1975 my($self,@p) = self_or_default(@_);
1976
29ddc2a4
RGS
1977 my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],
1978 [ONCLICK,SCRIPT],TABINDEX],@p);
54310121 1979
1980 $label=$self->escapeHTML($label);
a3b3a725 1981 $value=$self->escapeHTML($value,1);
54310121 1982 $script=$self->escapeHTML($script);
1983
1984 my($name) = '';
ba056755 1985 $name = qq/ name="$label"/ if $label;
54310121 1986 $value = $value || $label;
1987 my($val) = '';
6b4ac661
JH
1988 $val = qq/ value="$value"/ if $value;
1989 $script = qq/ onclick="$script"/ if $script;
54310121 1990 my($other) = @other ? " @other" : '';
29ddc2a4 1991 $tabindex = $self->element_tab($tabindex);
0a9bdad4 1992 return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />)
b2d0d414 1993 : qq(<input type="button"$name$val$script$other>);
54310121 1994}
1995END_OF_FUNC
1996
1997
1998#### Method: submit
1999# Create a "submit query" button.
2000# Parameters:
2001# $name -> (optional) Name for the button.
2002# $value -> (optional) Value of the button when selected (also doubles as label).
2003# $label -> (optional) Label printed on the button(also doubles as the value).
2004# Returns:
188ba755 2005# A string containing a <input type="submit"> tag
54310121 2006####
2007'submit' => <<'END_OF_FUNC',
2008sub submit {
2009 my($self,@p) = self_or_default(@_);
2010
29ddc2a4 2011 my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p);
54310121 2012
2013 $label=$self->escapeHTML($label);
a3b3a725 2014 $value=$self->escapeHTML($value,1);
54310121 2015
0a9bdad4
SP
2016 my $name = $NOSTICKY ? '' : 'name=".submit" ';
2017 $name = qq/name="$label" / if defined($label);
424ec8fa 2018 $value = defined($value) ? $value : $label;
8f3ccfa2 2019 my $val = '';
0a9bdad4 2020 $val = qq/value="$value" / if defined($value);
29ddc2a4 2021 $tabindex = $self->element_tab($tabindex);
0a9bdad4
SP
2022 my($other) = @other ? "@other " : '';
2023 return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>)
2024 : qq(<input type="submit" $name$val$other>);
54310121 2025}
2026END_OF_FUNC
2027
2028
2029#### Method: reset
2030# Create a "reset" button.
2031# Parameters:
2032# $name -> (optional) Name for the button.
2033# Returns:
188ba755 2034# A string containing a <input type="reset"> tag
54310121 2035####
2036'reset' => <<'END_OF_FUNC',
2037sub reset {
2038 my($self,@p) = self_or_default(@_);
29ddc2a4 2039 my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p);
54310121 2040 $label=$self->escapeHTML($label);
8f3ccfa2
JH
2041 $value=$self->escapeHTML($value,1);
2042 my ($name) = ' name=".reset"';
2043 $name = qq/ name="$label"/ if defined($label);
2044 $value = defined($value) ? $value : $label;
2045 my($val) = '';
2046 $val = qq/ value="$value"/ if defined($value);
54310121 2047 my($other) = @other ? " @other" : '';
29ddc2a4 2048 $tabindex = $self->element_tab($tabindex);
0a9bdad4 2049 return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />)
8f3ccfa2 2050 : qq(<input type="reset"$name$val$other>);
54310121 2051}
2052END_OF_FUNC
2053
2054
2055#### Method: defaults
2056# Create a "defaults" button.
2057# Parameters:
2058# $name -> (optional) Name for the button.
2059# Returns:
188ba755 2060# A string containing a <input type="submit" name=".defaults"> tag
54310121 2061#
2062# Note: this button has a special meaning to the initialization script,
2063# and tells it to ERASE the current query string so that your defaults
2064# are used again!
2065####
2066'defaults' => <<'END_OF_FUNC',
2067sub defaults {
2068 my($self,@p) = self_or_default(@_);
2069
29ddc2a4 2070 my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p);
54310121 2071
a3b3a725 2072 $label=$self->escapeHTML($label,1);
54310121 2073 $label = $label || "Defaults";
6b4ac661 2074 my($value) = qq/ value="$label"/;
54310121 2075 my($other) = @other ? " @other" : '';
29ddc2a4 2076 $tabindex = $self->element_tab($tabindex);
0a9bdad4 2077 return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />)
6b4ac661 2078 : qq/<input type="submit" NAME=".defaults"$value$other>/;
54310121 2079}
2080END_OF_FUNC
2081
2082
424ec8fa
GS
2083#### Method: comment
2084# Create an HTML <!-- comment -->
2085# Parameters: a string
2086'comment' => <<'END_OF_FUNC',
2087sub comment {
2088 my($self,@p) = self_or_CGI(@_);
2089 return "<!-- @p -->";
2090}
2091END_OF_FUNC
2092
54310121 2093#### Method: checkbox
2094# Create a checkbox that is not logically linked to any others.
2095# The field value is "on" when the button is checked.
2096# Parameters:
2097# $name -> Name of the checkbox
2098# $checked -> (optional) turned on by default if true
2099# $value -> (optional) value of the checkbox, 'on' by default
2100# $label -> (optional) a user-readable label printed next to the box.
2101# Otherwise the checkbox name is used.
2102# Returns:
188ba755 2103# A string containing a <input type="checkbox"> field
54310121 2104####
2105'checkbox' => <<'END_OF_FUNC',
2106sub checkbox {
2107 my($self,@p) = self_or_default(@_);
2108
29ddc2a4
RGS
2109 my($name,$checked,$value,$label,$override,$tabindex,@other) =
2110 rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE],TABINDEX],@p);
2111
424ec8fa
GS
2112 $value = defined $value ? $value : 'on';
2113
2114 if (!$override && ($self->{'.fieldnames'}->{$name} ||
2115 defined $self->param($name))) {
3acbd4f5 2116 $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
54310121 2117 } else {
3acbd4f5 2118 $checked = $self->_checked($checked);
54310121 2119 }
2120 my($the_label) = defined $label ? $label : $name;
2121 $name = $self->escapeHTML($name);
a3b3a725 2122 $value = $self->escapeHTML($value,1);
54310121 2123 $the_label = $self->escapeHTML($the_label);
0a9bdad4 2124 my($other) = @other ? "@other " : '';
29ddc2a4 2125 $tabindex = $self->element_tab($tabindex);
54310121 2126 $self->register_parameter($name);
0a9bdad4 2127 return $XHTML ? CGI::label(qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
6b4ac661 2128 : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
54310121 2129}
2130END_OF_FUNC
2131
2132
54310121 2133
54310121 2134# Escape HTML -- used internally
2135'escapeHTML' => <<'END_OF_FUNC',
2136sub escapeHTML {
ac734d8b
JH
2137 # hack to work around earlier hacks
2138 push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
a3b3a725 2139 my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
6b4ac661 2140 return undef unless defined($toencode);
188ba755 2141 return $toencode if ref($self) && !$self->{'escape'};
6b4ac661
JH
2142 $toencode =~ s{&}{&amp;}gso;
2143 $toencode =~ s{<}{&lt;}gso;
2144 $toencode =~ s{>}{&gt;}gso;
13548fdf
RGS
2145 if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
2146 # $quot; was accidentally omitted from the HTML 3.2 DTD -- see
2147 # <http://validator.w3.org/docs/errors.html#bad-entity> /
2148 # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
2149 $toencode =~ s{"}{&#34;}gso;
2150 }
2151 else {
2152 $toencode =~ s{"}{&quot;}gso;
2153 }
a3b3a725
JH
2154 my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' ||
2155 uc $self->{'.charset'} eq 'WINDOWS-1252';
2156 if ($latin) { # bug in some browsers
ba056755 2157 $toencode =~ s{'}{&#39;}gso;
188ba755
JH
2158 $toencode =~ s{\x8b}{&#8249;}gso;
2159 $toencode =~ s{\x9b}{&#8250;}gso;
a3b3a725
JH
2160 if (defined $newlinestoo && $newlinestoo) {
2161 $toencode =~ s{\012}{&#10;}gso;
2162 $toencode =~ s{\015}{&#13;}gso;
2163 }
2164 }
6b4ac661 2165 return $toencode;
54310121 2166}
2167END_OF_FUNC
2168
424ec8fa
GS
2169# unescape HTML -- used internally
2170'unescapeHTML' => <<'END_OF_FUNC',
2171sub unescapeHTML {
efc8e943
NC
2172 # hack to work around earlier hacks
2173 push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
6b4ac661 2174 my ($self,$string) = CGI::self_or_default(@_);
424ec8fa 2175 return undef unless defined($string);
a3b3a725
JH
2176 my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
2177 : 1;
71f3e297
JH
2178 # thanks to Randal Schwartz for the correct solution to this one
2179 $string=~ s[&(.*?);]{
2180 local $_ = $1;
2181 /^amp$/i ? "&" :
2182 /^quot$/i ? '"' :
2183 /^gt$/i ? ">" :
2184 /^lt$/i ? "<" :
6b4ac661
JH
2185 /^#(\d+)$/ && $latin ? chr($1) :
2186 /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
71f3e297
JH
2187 $_
2188 }gex;
424ec8fa
GS
2189 return $string;
2190}
2191END_OF_FUNC
54310121 2192
2193# Internal procedure - don't use
2194'_tableize' => <<'END_OF_FUNC',
2195sub _tableize {
2196 my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
29ddc2a4
RGS
2197 my @rowheaders = $rowheaders ? @$rowheaders : ();
2198 my @colheaders = $colheaders ? @$colheaders : ();
54310121 2199 my($result);
2200
424ec8fa
GS
2201 if (defined($columns)) {
2202 $rows = int(0.99 + @elements/$columns) unless defined($rows);
2203 }
2204 if (defined($rows)) {
2205 $columns = int(0.99 + @elements/$rows) unless defined($columns);
2206 }
29ddc2a4 2207
54310121 2208 # rearrange into a pretty table
6b4ac661 2209 $result = "<table>";
54310121 2210 my($row,$column);
29ddc2a4
RGS
2211 unshift(@colheaders,'') if @colheaders && @rowheaders;
2212 $result .= "<tr>" if @colheaders;
2213 foreach (@colheaders) {
6b4ac661 2214 $result .= "<th>$_</th>";
54310121 2215 }
2216 for ($row=0;$row<$rows;$row++) {
6b4ac661 2217 $result .= "<tr>";
29ddc2a4 2218 $result .= "<th>$rowheaders[$row]</th>" if @rowheaders;
54310121 2219 for ($column=0;$column<$columns;$column++) {
6b4ac661 2220 $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
424ec8fa 2221 if defined($elements[$column*$rows + $row]);
54310121 2222 }
6b4ac661 2223 $result .= "</tr>";
54310121 2224 }
6b4ac661 2225 $result .= "</table>";
54310121 2226 return $result;
2227}
2228END_OF_FUNC
2229
2230
2231#### Method: radio_group
2232# Create a list of logically-linked radio buttons.
2233# Parameters:
2234# $name -> Common name for all the buttons.
2235# $values -> A pointer to a regular array containing the
2236# values for each button in the group.
2237# $default -> (optional) Value of the button to turn on by default. Pass '-'
2238# to turn _nothing_ on.
2239# $linebreak -> (optional) Set to true to place linebreaks
2240# between the buttons.
2241# $labels -> (optional)
2242# A pointer to an associative array of labels to print next to each checkbox
2243# in the form $label{'value'}="Long explanatory label".
2244# Otherwise the provided values are used as the labels.
2245# Returns:
188ba755 2246# An ARRAY containing a series of <input type="radio"> fields
54310121 2247####
2248'radio_group' => <<'END_OF_FUNC',
2249sub radio_group {
2250 my($self,@p) = self_or_default(@_);
29ddc2a4
RGS
2251 $self->_box_group('radio',@p);
2252}
2253END_OF_FUNC
2254
2255#### Method: checkbox_group
2256# Create a list of logically-linked checkboxes.
2257# Parameters:
2258# $name -> Common name for all the check boxes
2259# $values -> A pointer to a regular array containing the
2260# values for each checkbox in the group.
2261# $defaults -> (optional)
2262# 1. If a pointer to a regular array of checkbox values,
2263# then this will be used to decide which
2264# checkboxes to turn on by default.
2265# 2. If a scalar, will be assumed to hold the
2266# value of a single checkbox in the group to turn on.
2267# $linebreak -> (optional) Set to true to place linebreaks
2268# between the buttons.
2269# $labels -> (optional)
2270# A pointer to an associative array of labels to print next to each checkbox
2271# in the form $label{'value'}="Long explanatory label".
2272# Otherwise the provided values are used as the labels.
2273# Returns:
2274# An ARRAY containing a series of <input type="checkbox"> fields
2275####
2276
2277'checkbox_group' => <<'END_OF_FUNC',
2278sub checkbox_group {
2279 my($self,@p) = self_or_default(@_);
2280 $self->_box_group('checkbox',@p);
2281}
2282END_OF_FUNC
54310121 2283
29ddc2a4
RGS
2284'_box_group' => <<'END_OF_FUNC',
2285sub _box_group {
2286 my $self = shift;
2287 my $box_type = shift;
2288
2289 my($name,$values,$defaults,$linebreak,$labels,$attributes,
2290 $rows,$columns,$rowheaders,$colheaders,
2291 $override,$nolabels,$tabindex,@other) =
2292 rearrange([ NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,ATTRIBUTES,
2293 ROWS,[COLUMNS,COLS],ROWHEADERS,COLHEADERS,
2294 [OVERRIDE,FORCE],NOLABELS,TABINDEX
2295 ],@_);
54310121 2296 my($result,$checked);
2297
29ddc2a4 2298
424ec8fa 2299 my(@elements,@values);
424ec8fa 2300 @values = $self->_set_values_and_labels($values,\$labels,$name);
29ddc2a4 2301 my %checked = $self->previous_or_default($name,$defaults,$override);
424ec8fa 2302
71f3e297 2303 # If no check array is specified, check the first by default
29ddc2a4
RGS
2304 $checked{$values[0]}++ if $box_type eq 'radio' && !%checked;
2305
71f3e297
JH
2306 $name=$self->escapeHTML($name);
2307
29ddc2a4 2308 my %tabs = ();
0a9bdad4 2309 if ($TABINDEX && $tabindex) {
29ddc2a4
RGS
2310 if (!ref $tabindex) {
2311 $self->element_tab($tabindex);
2312 } elsif (ref $tabindex eq 'ARRAY') {
2313 %tabs = map {$_=>$self->element_tab} @$tabindex;
2314 } elsif (ref $tabindex eq 'HASH') {
2315 %tabs = %$tabindex;
2316 }
2317 }
2318 %tabs = map {$_=>$self->element_tab} @values unless %tabs;
2319
0a9bdad4 2320 my $other = @other ? "@other " : '';
29ddc2a4 2321 my $radio_checked;
54310121 2322 foreach (@values) {
29ddc2a4
RGS
2323 my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
2324 : $checked{$_});
6b4ac661
JH
2325 my($break);
2326 if ($linebreak) {
ba056755 2327 $break = $XHTML ? "<br />" : "<br>";
6b4ac661
JH
2328 }
2329 else {
ba056755 2330 $break = '';
6b4ac661 2331 }
54310121 2332 my($label)='';
2333 unless (defined($nolabels) && $nolabels) {
2334 $label = $_;
424ec8fa 2335 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
a3b3a725 2336 $label = $self->escapeHTML($label,1);
54310121 2337 }
29ddc2a4 2338 my $attribs = $self->_set_attributes($_, $attributes);
0a9bdad4 2339 my $tab = $tabs{$_};
54310121 2340 $_=$self->escapeHTML($_);
29ddc2a4
RGS
2341 if ($XHTML) {
2342 push @elements,
2343 CGI::label(
0a9bdad4 2344 qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs/>$label)).${break};
29ddc2a4
RGS
2345 } else {
2346 push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs>${label}${break}/);
2347 }
54310121 2348 }
2349 $self->register_parameter($name);
29ddc2a4 2350 return wantarray ? @elements : "@elements"
424ec8fa 2351 unless defined($columns) || defined($rows);
54310121 2352 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
2353}
2354END_OF_FUNC
2355
2356
2357#### Method: popup_menu
2358# Create a popup menu.
2359# Parameters:
2360# $name -> Name for all the menu
2361# $values -> A pointer to a regular array containing the
2362# text of each menu item.
2363# $default -> (optional) Default item to display
2364# $labels -> (optional)
2365# A pointer to an associative array of labels to print next to each checkbox
2366# in the form $label{'value'}="Long explanatory label".
2367# Otherwise the provided values are used as the labels.
2368# Returns:
2369# A string containing the definition of a popup menu.
2370####
2371'popup_menu' => <<'END_OF_FUNC',
2372sub popup_menu {
2373 my($self,@p) = self_or_default(@_);
2374
29ddc2a4 2375 my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) =
188ba755 2376 rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
29ddc2a4 2377 ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
54310121 2378 my($result,$selected);
2379
2380 if (!$override && defined($self->param($name))) {
2381 $selected = $self->param($name);
2382 } else {
2383 $selected = $default;
2384 }
2385 $name=$self->escapeHTML($name);
2386 my($other) = @other ? " @other" : '';
2387
424ec8fa
GS
2388 my(@values);
2389 @values = $self->_set_values_and_labels($values,\$labels,$name);
29ddc2a4 2390 $tabindex = $self->element_tab($tabindex);
0a9bdad4 2391 $result = qq/<select name="$name" $tabindex$other>\n/;
54310121 2392 foreach (@values) {
188ba755
JH
2393 if (/<optgroup/) {
2394 foreach (split(/\n/)) {
2395 my $selectit = $XHTML ? 'selected="selected"' : 'selected';
2396 s/(value="$selected")/$selectit $1/ if defined $selected;
2397 $result .= "$_\n";
2398 }
2399 }
2400 else {
cb3b230c
SP
2401 my $attribs = $self->_set_attributes($_, $attributes);
2402 my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : '';
2403 my($label) = $_;
2404 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2405 my($value) = $self->escapeHTML($_);
2406 $label=$self->escapeHTML($label,1);
2407 $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
188ba755 2408 }
54310121 2409 }
2410
69c89ae7 2411 $result .= "</select>";
54310121 2412 return $result;
2413}
2414END_OF_FUNC
2415
2416
188ba755
JH
2417#### Method: optgroup
2418# Create a optgroup.
2419# Parameters:
2420# $name -> Label for the group
2421# $values -> A pointer to a regular array containing the
2422# values for each option line in the group.
2423# $labels -> (optional)
2424# A pointer to an associative array of labels to print next to each item
2425# in the form $label{'value'}="Long explanatory label".
2426# Otherwise the provided values are used as the labels.
2427# $labeled -> (optional)
2428# A true value indicates the value should be used as the label attribute
2429# in the option elements.
2430# The label attribute specifies the option label presented to the user.
2431# This defaults to the content of the <option> element, but the label
2432# attribute allows authors to more easily use optgroup without sacrificing
2433# compatibility with browsers that do not support option groups.
2434# $novals -> (optional)
2435# A true value indicates to suppress the val attribute in the option elements
2436# Returns:
2437# A string containing the definition of an option group.
2438####
2439'optgroup' => <<'END_OF_FUNC',
2440sub optgroup {
2441 my($self,@p) = self_or_default(@_);
2442 my($name,$values,$attributes,$labeled,$noval,$labels,@other)
2443 = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p);
2444
2445 my($result,@values);
2446 @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
2447 my($other) = @other ? " @other" : '';
2448
2449 $name=$self->escapeHTML($name);
2450 $result = qq/<optgroup label="$name"$other>\n/;
2451 foreach (@values) {
2452 if (/<optgroup/) {
2453 foreach (split(/\n/)) {
2454 my $selectit = $XHTML ? 'selected="selected"' : 'selected';
2455 s/(value="$selected")/$selectit $1/ if defined $selected;
2456 $result .= "$_\n";
2457 }
2458 }
2459 else {
2460 my $attribs = $self->_set_attributes($_, $attributes);
2461 my($label) = $_;
2462 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2463 $label=$self->escapeHTML($label);
2464 my($value)=$self->escapeHTML($_,1);
2465 $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
2466 : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
2467 : $novals ? "<option$attribs>$label</option>\n"
2468 : "<option$attribs value=\"$value\">$label</option>\n";
2469 }
2470 }
2471 $result .= "</optgroup>";
2472 return $result;
2473}
2474END_OF_FUNC
2475
2476
54310121 2477#### Method: scrolling_list
2478# Create a scrolling list.
2479# Parameters:
2480# $name -> name for the list
2481# $values -> A pointer to a regular array containing the
2482# values for each option line in the list.
2483# $defaults -> (optional)
2484# 1. If a pointer to a regular array of options,
2485# then this will be used to decide which
2486# lines to turn on by default.
2487# 2. Otherwise holds the value of the single line to turn on.
2488# $size -> (optional) Size of the list.
2489# $multiple -> (optional) If set, allow multiple selections.
2490# $labels -> (optional)
2491# A pointer to an associative array of labels to print next to each checkbox
2492# in the form $label{'value'}="Long explanatory label".
2493# Otherwise the provided values are used as the labels.
2494# Returns:
2495# A string containing the definition of a scrolling list.
2496####
2497'scrolling_list' => <<'END_OF_FUNC',
2498sub scrolling_list {
2499 my($self,@p) = self_or_default(@_);
29ddc2a4 2500 my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other)
3d1a2ec4 2501 = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
29ddc2a4 2502 SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
54310121 2503
424ec8fa
GS
2504 my($result,@values);
2505 @values = $self->_set_values_and_labels($values,\$labels,$name);
2506
54310121 2507 $size = $size || scalar(@values);
2508
2509 my(%selected) = $self->previous_or_default($name,$defaults,$override);
ac734d8b 2510 my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
6b4ac661 2511 my($has_size) = $size ? qq/ size="$size"/: '';
54310121 2512 my($other) = @other ? " @other" : '';
2513
2514 $name=$self->escapeHTML($name);
29ddc2a4 2515 $tabindex = $self->element_tab($tabindex);
0a9bdad4 2516 $result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/;
54310121 2517 foreach (@values) {
3acbd4f5 2518 my($selectit) = $self->_selected($selected{$_});
54310121 2519 my($label) = $_;
424ec8fa 2520 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
54310121 2521 $label=$self->escapeHTML($label);
a3b3a725 2522 my($value)=$self->escapeHTML($_,1);
188ba755 2523 my $attribs = $self->_set_attributes($_, $attributes);
1f426928 2524 $result .= "<option ${selectit}${attribs}value=\"$value\">$label</option>\n";
54310121 2525 }
69c89ae7 2526 $result .= "</select>";
54310121 2527 $self->register_parameter($name);
2528 return $result;
2529}
2530END_OF_FUNC
2531
2532
2533#### Method: hidden
2534# Parameters:
2535# $name -> Name of the hidden field
2536# @default -> (optional) Initial values of field (may be an array)
2537# or
2538# $default->[initial values of field]
2539# Returns:
188ba755 2540# A string containing a <input type="hidden" name="name" value="value">
54310121 2541####
2542'hidden' => <<'END_OF_FUNC',
2543sub hidden {
2544 my($self,@p) = self_or_default(@_);
2545
2546 # this is the one place where we departed from our standard
2547 # calling scheme, so we have to special-case (darn)
2548 my(@result,@value);
2549 my($name,$default,$override,@other) =
3d1a2ec4 2550 rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
54310121 2551
2552 my $do_override = 0;
3d1a2ec4 2553 if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
54310121 2554 @value = ref($default) ? @{$default} : $default;
2555 $do_override = $override;
2556 } else {
2557 foreach ($default,$override,@other) {
2558 push(@value,$_) if defined($_);
2559 }
2560 }
2561
2562 # use previous values if override is not set
2563 my @prev = $self->param($name);
2564 @value = @prev if !$do_override && @prev;
2565
2566 $name=$self->escapeHTML($name);
2567 foreach (@value) {
a3b3a725 2568 $_ = defined($_) ? $self->escapeHTML($_,1) : '';
13548fdf
RGS
2569 push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
2570 : qq(<input type="hidden" name="$name" value="$_" @other>);
54310121 2571 }
2572 return wantarray ? @result : join('',@result);
2573}
2574END_OF_FUNC
2575
2576
2577#### Method: image_button
2578# Parameters:
2579# $name -> Name of the button
2580# $src -> URL of the image source
2581# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
2582# Returns:
188ba755 2583# A string containing a <input type="image" name="name" src="url" align="alignment">
54310121 2584####
2585'image_button' => <<'END_OF_FUNC',
2586sub image_button {
2587 my($self,@p) = self_or_default(@_);
2588
2589 my($name,$src,$alignment,@other) =
3d1a2ec4 2590 rearrange([NAME,SRC,ALIGN],@p);
54310121 2591
ac734d8b 2592 my($align) = $alignment ? " align=\U\"$alignment\"" : '';
54310121 2593 my($other) = @other ? " @other" : '';
2594 $name=$self->escapeHTML($name);
6b4ac661
JH
2595 return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
2596 : qq/<input type="image" name="$name" src="$src"$align$other>/;
54310121 2597}
2598END_OF_FUNC
2599
2600
2601#### Method: self_url
2602# Returns a URL containing the current script and all its
2603# param/value pairs arranged as a query. You can use this
2604# to create a link that, when selected, will reinvoke the
2605# script with all its state information preserved.
2606####
2607'self_url' => <<'END_OF_FUNC',
2608sub self_url {
424ec8fa
GS
2609 my($self,@p) = self_or_default(@_);
2610 return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
54310121 2611}
2612END_OF_FUNC
2613
2614
2615# This is provided as a synonym to self_url() for people unfortunate
2616# enough to have incorporated it into their programs already!
2617'state' => <<'END_OF_FUNC',
2618sub state {
2619 &self_url;
2620}
2621END_OF_FUNC
2622
2623
2624#### Method: url
2625# Like self_url, but doesn't return the query string part of
2626# the URL.
2627####
2628'url' => <<'END_OF_FUNC',
2629sub url {
424ec8fa 2630 my($self,@p) = self_or_default(@_);
0a9bdad4
SP
2631 my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) =
2632 rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p);
2633 my $url = '';
2371fea9 2634 $full++ if $base || !($relative || $absolute);
0a9bdad4 2635 $rewrite++ unless defined $rewrite;
424ec8fa 2636
0a9bdad4
SP
2637 my $path = $self->path_info;
2638 my $script_name = $self->script_name;
cb3b230c 2639 my $request_uri = unescape($self->request_uri) || '';
0a9bdad4
SP
2640 my $query_str = $self->query_string;
2641
2642 my $rewrite_in_use = $request_uri && $request_uri !~ /^$script_name/;
2643 undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active
2644
2645 my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
edc47407 2646 $uri =~ s/\?.*$//; # remove query string
adb86593 2647 $uri =~ s/\Q$path\E$// if defined $path; # remove path
d45d855d 2648
424ec8fa
GS
2649 if ($full) {
2650 my $protocol = $self->protocol();
2651 $url = "$protocol://";
13548fdf 2652 my $vh = http('x_forwarded_host') || http('host');
424ec8fa
GS
2653 if ($vh) {
2654 $url .= $vh;
2655 } else {
2656 $url .= server_name();
2657 my $port = $self->server_port;
2658 $url .= ":" . $port
2ed511ec 2659 unless (lc($protocol) eq 'http' && $port == 80)
424ec8fa
GS
2660 || (lc($protocol) eq 'https' && $port == 443);
2661 }
03b9648d 2662 return $url if $base;
0a9bdad4 2663 $url .= $uri;
424ec8fa 2664 } elsif ($relative) {
cb3b230c 2665 ($url) = $uri =~ m!([^/]+)$!;
424ec8fa 2666 } elsif ($absolute) {
0a9bdad4 2667 $url = $uri;
424ec8fa 2668 }
03b9648d 2669
0a9bdad4
SP
2670 $url .= $path if $path_info and defined $path;
2671 $url .= "?$query_str" if $query and $query_str ne '';
2371fea9 2672 $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
424ec8fa 2673 return $url;
54310121 2674}
2675
2676END_OF_FUNC
2677
2678#### Method: cookie
2679# Set or read a cookie from the specified name.
2680# Cookie can then be passed to header().
2681# Usual rules apply to the stickiness of -value.
2682# Parameters:
2683# -name -> name for this cookie (optional)
2684# -value -> value of this cookie (scalar, array or hash)
2685# -path -> paths for which this cookie is valid (optional)
2686# -domain -> internet domain in which this cookie is valid (optional)
2687# -secure -> if true, cookie only passed through secure channel (optional)
7d37aa8e 2688# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
54310121 2689####
2690'cookie' => <<'END_OF_FUNC',
54310121 2691sub cookie {
2692 my($self,@p) = self_or_default(@_);
2693 my($name,$value,$path,$domain,$secure,$expires) =
3d1a2ec4 2694 rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
54310121 2695
424ec8fa 2696 require CGI::Cookie;
54310121 2697
2698 # if no value is supplied, then we retrieve the
2699 # value of the cookie, if any. For efficiency, we cache the parsed
424ec8fa
GS
2700 # cookies in our state variables.
2701 unless ( defined($value) ) {
2702 $self->{'.cookies'} = CGI::Cookie->fetch
2703 unless $self->{'.cookies'};
54310121 2704
2705 # If no name is supplied, then retrieve the names of all our cookies.
2706 return () unless $self->{'.cookies'};
424ec8fa
GS
2707 return keys %{$self->{'.cookies'}} unless $name;
2708 return () unless $self->{'.cookies'}->{$name};
2709 return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
54310121 2710 }
54310121 2711
424ec8fa 2712 # If we get here, we're creating a new cookie
ba056755 2713 return undef unless defined($name) && $name ne ''; # this is an error
54310121 2714
424ec8fa
GS
2715 my @param;
2716 push(@param,'-name'=>$name);
2717 push(@param,'-value'=>$value);
2718 push(@param,'-domain'=>$domain) if $domain;
2719 push(@param,'-path'=>$path) if $path;
2720 push(@param,'-expires'=>$expires) if $expires;
2721 push(@param,'-secure'=>$secure) if $secure;
54310121 2722
6b4ac661 2723 return new CGI::Cookie(@param);
54310121 2724}
2725END_OF_FUNC
2726
424ec8fa
GS
2727'parse_keywordlist' => <<'END_OF_FUNC',
2728sub parse_keywordlist {
2729 my($self,$tosplit) = @_;
2730 $tosplit = unescape($tosplit); # unescape the keywords
2731 $tosplit=~tr/+/ /; # pluses to spaces
2732 my(@keywords) = split(/\s+/,$tosplit);
2733 return @keywords;
2734}
2735END_OF_FUNC
2736
2737'param_fetch' => <<'END_OF_FUNC',
2738sub param_fetch {
2739 my($self,@p) = self_or_default(@_);
3d1a2ec4 2740 my($name) = rearrange([NAME],@p);
424ec8fa
GS
2741 unless (exists($self->{$name})) {
2742 $self->add_parameter($name);
2743 $self->{$name} = [];
2744 }
2745
2746 return $self->{$name};
2747}
2748END_OF_FUNC
2749
54310121 2750###############################################
2751# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
2752###############################################
2753
2754#### Method: path_info
2755# Return the extra virtual path information provided
2756# after the URL (if any)
2757####
2758'path_info' => <<'END_OF_FUNC',
2759sub path_info {
424ec8fa
GS
2760 my ($self,$info) = self_or_default(@_);
2761 if (defined($info)) {
2762 $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
2763 $self->{'.path_info'} = $info;
2764 } elsif (! defined($self->{'.path_info'}) ) {
7dc108d1
SP
2765 my (undef,$path_info) = $self->_name_and_path_from_env;
2766 $self->{'.path_info'} = $path_info || '';
424ec8fa
GS
2767 }
2768 return $self->{'.path_info'};
54310121 2769}
2770END_OF_FUNC
2771
7dc108d1
SP
2772# WE USE THIS TO COMPENSATE FOR A BUG IN APACHE 2 PRESENT AT LEAST UP THROUGH 2.0.54
2773'_name_and_path_from_env' => <<'END_OF_FUNC',
2774sub _name_and_path_from_env {
2775 my $self = shift;
2776 my $raw_script_name = $ENV{SCRIPT_NAME} || '';
2777 my $raw_path_info = $ENV{PATH_INFO} || '';
cb3b230c 2778 my $uri = unescape($self->request_uri) || '';
7dc108d1 2779
adb86593
SP
2780 my $protected = quotemeta($raw_path_info);
2781 $raw_script_name =~ s/$protected$//;
0a9bdad4 2782
7dc108d1
SP
2783 my @uri_double_slashes = $uri =~ m^(/{2,}?)^g;
2784 my @path_double_slashes = "$raw_script_name $raw_path_info" =~ m^(/{2,}?)^g;
2785
2786 my $apache_bug = @uri_double_slashes != @path_double_slashes;
2787 return ($raw_script_name,$raw_path_info) unless $apache_bug;
2788
cb3b230c 2789 my $path_info_search = quotemeta($raw_path_info);
7dc108d1
SP
2790 $path_info_search =~ s!/!/+!g;
2791 if ($uri =~ m/^(.+)($path_info_search)/) {
2792 return ($1,$2);
2793 } else {
2794 return ($raw_script_name,$raw_path_info);
2795 }
2796}
2797END_OF_FUNC
2798
54310121 2799
2800#### Method: request_method
2801# Returns 'POST', 'GET', 'PUT' or 'HEAD'
2802####
2803'request_method' => <<'END_OF_FUNC',
2804sub request_method {
2805 return $ENV{'REQUEST_METHOD'};
2806}
2807END_OF_FUNC
2808
3538e1d5
GS
2809#### Method: content_type
2810# Returns the content_type string
2811####
2812'content_type' => <<'END_OF_FUNC',
2813sub content_type {
2814 return $ENV{'CONTENT_TYPE'};
2815}
2816END_OF_FUNC
2817
54310121 2818#### Method: path_translated
2819# Return the physical path information provided
2820# by the URL (if any)
2821####
2822'path_translated' => <<'END_OF_FUNC',
2823sub path_translated {
2824 return $ENV{'PATH_TRANSLATED'};
2825}
2826END_OF_FUNC
2827
2828
7dc108d1
SP
2829#### Method: request_uri
2830# Return the literal request URI
2831####
2832'request_uri' => <<'END_OF_FUNC',
2833sub request_uri {
2834 return $ENV{'REQUEST_URI'};
2835}
2836END_OF_FUNC
2837
2838
54310121 2839#### Method: query_string
2840# Synthesize a query string from our current
2841# parameters
2842####
2843'query_string' => <<'END_OF_FUNC',
2844sub query_string {
2845 my($self) = self_or_default(@_);
2846 my($param,$value,@pairs);
2847 foreach $param ($self->param) {
424ec8fa 2848 my($eparam) = escape($param);
54310121 2849 foreach $value ($self->param($param)) {
424ec8fa 2850 $value = escape($value);
3538e1d5 2851 next unless defined $value;
54310121 2852 push(@pairs,"$eparam=$value");
2853 }
2854 }
d45d855d
JH
2855 foreach (keys %{$self->{'.fieldnames'}}) {
2856 push(@pairs,".cgifields=".escape("$_"));
2857 }
71f3e297 2858 return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
54310121 2859}
2860END_OF_FUNC
2861
2862
2863#### Method: accept
2864# Without parameters, returns an array of the
2865# MIME types the browser accepts.
2866# With a single parameter equal to a MIME
2867# type, will return undef if the browser won't
2868# accept it, 1 if the browser accepts it but
2869# doesn't give a preference, or a floating point
2870# value between 0.0 and 1.0 if the browser
2871# declares a quantitative score for it.
2872# This handles MIME type globs correctly.
2873####
71f3e297
JH
2874'Accept' => <<'END_OF_FUNC',
2875sub Accept {
54310121 2876 my($self,$search) = self_or_CGI(@_);
2877 my(%prefs,$type,$pref,$pat);
2878
2879 my(@accept) = split(',',$self->http('accept'));
2880
2881 foreach (@accept) {
2882 ($pref) = /q=(\d\.\d+|\d+)/;
2883 ($type) = m#(\S+/[^;]+)#;
2884 next unless $type;
2885 $prefs{$type}=$pref || 1;
2886 }
2887
2888 return keys %prefs unless $search;
2889
2890 # if a search type is provided, we may need to
2891 # perform a pattern matching operation.
2892 # The MIME types use a glob mechanism, which
2893 # is easily translated into a perl pattern match
2894
2895 # First return the preference for directly supported
2896 # types:
2897 return $prefs{$search} if $prefs{$search};
2898
2899 # Didn't get it, so try pattern matching.
2900 foreach (keys %prefs) {
2901 next unless /\*/; # not a pattern match
2902 ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2903 $pat =~ s/\*/.*/g; # turn it into a pattern
2904 return $prefs{$_} if $search=~/$pat/;
2905 }
2906}
2907END_OF_FUNC
2908
2909
2910#### Method: user_agent
2911# If called with no parameters, returns the user agent.
2912# If called with one parameter, does a pattern match (case
2913# insensitive) on the user agent.
2914####
2915'user_agent' => <<'END_OF_FUNC',
2916sub user_agent {
2917 my($self,$match)=self_or_CGI(@_);
2918 return $self->http('user_agent') unless $match;
2919 return $self->http('user_agent') =~ /$match/i;
2920}
2921END_OF_FUNC
2922
2923
424ec8fa
GS
2924#### Method: raw_cookie
2925# Returns the magic cookies for the session.
2926# The cookies are not parsed or altered in any way, i.e.
2927# cookies are returned exactly as given in the HTTP
2928# headers. If a cookie name is given, only that cookie's
2929# value is returned, otherwise the entire raw cookie
2930# is returned.
54310121 2931####
2932'raw_cookie' => <<'END_OF_FUNC',
2933sub raw_cookie {
424ec8fa
GS
2934 my($self,$key) = self_or_CGI(@_);
2935
2936 require CGI::Cookie;
2937
2938 if (defined($key)) {
2939 $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
2940 unless $self->{'.raw_cookies'};
2941
2942 return () unless $self->{'.raw_cookies'};
2943 return () unless $self->{'.raw_cookies'}->{$key};
2944 return $self->{'.raw_cookies'}->{$key};
2945 }
54310121 2946 return $self->http('cookie') || $ENV{'COOKIE'} || '';
2947}
2948END_OF_FUNC
2949
2950#### Method: virtual_host
2951# Return the name of the virtual_host, which
2952# is not always the same as the server
2953######
2954'virtual_host' => <<'END_OF_FUNC',
2955sub virtual_host {
13548fdf 2956 my $vh = http('x_forwarded_host') || http('host') || server_name();
424ec8fa
GS
2957 $vh =~ s/:\d+$//; # get rid of port number
2958 return $vh;
54310121 2959}
2960END_OF_FUNC
2961
2962#### Method: remote_host
2963# Return the name of the remote host, or its IP
2964# address if unavailable. If this variable isn't
2965# defined, it returns "localhost" for debugging
2966# purposes.
2967####
2968'remote_host' => <<'END_OF_FUNC',
2969sub remote_host {
2970 return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
2971 || 'localhost';
2972}
2973END_OF_FUNC
2974
2975
2976#### Method: remote_addr
2977# Return the IP addr of the remote host.
2978####
2979'remote_addr' => <<'END_OF_FUNC',
2980sub remote_addr {
2981 return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
2982}
2983END_OF_FUNC
2984
2985
2986#### Method: script_name
2987# Return the partial URL to this script for
2988# self-referencing scripts. Also see
2989# self_url(), which returns a URL with all state information
2990# preserved.
2991####
2992'script_name' => <<'END_OF_FUNC',
2993sub script_name {
7dc108d1
SP
2994 my ($self,@p) = self_or_default(@_);
2995 if (@p) {
2996 $self->{'.script_name'} = shift;
2997 } elsif (!exists $self->{'.script_name'}) {
2998 my ($script_name,$path_info) = $self->_name_and_path_from_env();
2999 $self->{'.script_name'} = $script_name;
3000 }
3001 return $self->{'.script_name'};
54310121 3002}
3003END_OF_FUNC
3004
3005
3006#### Method: referer
3007# Return the HTTP_REFERER: useful for generating
3008# a GO BACK button.
3009####
3010'referer' => <<'END_OF_FUNC',
3011sub referer {
3012 my($self) = self_or_CGI(@_);
3013 return $self->http('referer');
3014}
3015END_OF_FUNC
3016
3017
3018#### Method: server_name
3019# Return the name of the server
3020####
3021'server_name' => <<'END_OF_FUNC',
3022sub server_name {
3023 return $ENV{'SERVER_NAME'} || 'localhost';
3024}
3025END_OF_FUNC
3026
3027#### Method: server_software
3028# Return the name of the server software
3029####
3030'server_software' => <<'END_OF_FUNC',
3031sub server_software {
3032 return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
3033}
3034END_OF_FUNC
3035
2ed511ec
RGS
3036#### Method: virtual_port
3037# Return the server port, taking virtual hosts into account
3038####
3039'virtual_port' => <<'END_OF_FUNC',
3040sub virtual_port {
3041 my($self) = self_or_default(@_);
13548fdf 3042 my $vh = $self->http('x_forwarded_host') || $self->http('host');
0a9bdad4 3043 my $protocol = $self->protocol;
2ed511ec 3044 if ($vh) {
0a9bdad4 3045 return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80);
2ed511ec
RGS
3046 } else {
3047 return $self->server_port();
3048 }
3049}
3050END_OF_FUNC
3051
54310121 3052#### Method: server_port
3053# Return the tcp/ip port the server is running on
3054####
3055'server_port' => <<'END_OF_FUNC',
3056sub server_port {
3057 return $ENV{'SERVER_PORT'} || 80; # for debugging
3058}
3059END_OF_FUNC
3060
3061#### Method: server_protocol
3062# Return the protocol (usually HTTP/1.0)
3063####
3064'server_protocol' => <<'END_OF_FUNC',
3065sub server_protocol {
3066 return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
3067}
3068END_OF_FUNC
3069
3070#### Method: http
3071# Return the value of an HTTP variable, or
3072# the list of variables if none provided
3073####
3074'http' => <<'END_OF_FUNC',
3075sub http {
3076 my ($self,$parameter) = self_or_CGI(@_);
3077 return $ENV{$parameter} if $parameter=~/^HTTP/;
3538e1d5 3078 $parameter =~ tr/-/_/;
54310121 3079 return $ENV{"HTTP_\U$parameter\E"} if $parameter;
3080 my(@p);
3081 foreach (keys %ENV) {
3082 push(@p,$_) if /^HTTP/;
3083 }
3084 return @p;
3085}
3086END_OF_FUNC
3087
3088#### Method: https
3089# Return the value of HTTPS
3090####
3091'https' => <<'END_OF_FUNC',
3092sub https {
3093 local($^W)=0;
3094 my ($self,$parameter) = self_or_CGI(@_);
3095 return $ENV{HTTPS} unless $parameter;
3096 return $ENV{$parameter} if $parameter=~/^HTTPS/;
3538e1d5 3097 $parameter =~ tr/-/_/;
54310121 3098 return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
3099 my(@p);
3100 foreach (keys %ENV) {
3101 push(@p,$_) if /^HTTPS/;
3102 }
3103 return @p;
3104}
3105END_OF_FUNC
3106
3107#### Method: protocol
3108# Return the protocol (http or https currently)
3109####
3110'protocol' => <<'END_OF_FUNC',
3111sub protocol {
3112 local($^W)=0;
3113 my $self = shift;
424ec8fa 3114 return 'https' if uc($self->https()) eq 'ON';
54310121 3115 return 'https' if $self->server_port == 443;
3116 my $prot = $self->server_protocol;
3117 my($protocol,$version) = split('/',$prot);
3118 return "\L$protocol\E";
3119}
3120END_OF_FUNC
3121
3122#### Method: remote_ident
3123# Return the identity of the remote user
3124# (but only if his host is running identd)
3125####
3126'remote_ident' => <<'END_OF_FUNC',
3127sub remote_ident {
3128 return $ENV{'REMOTE_IDENT'};
3129}
3130END_OF_FUNC
3131
3132
3133#### Method: auth_type
3134# Return the type of use verification/authorization in use, if any.
3135####
3136'auth_type' => <<'END_OF_FUNC',
3137sub auth_type {
3138 return $ENV{'AUTH_TYPE'};
3139}
3140END_OF_FUNC
3141
3142
3143#### Method: remote_user
3144# Return the authorization name used for user
3145# verification.
3146####
3147'remote_user' => <<'END_OF_FUNC',
3148sub remote_user {
3149 return $ENV{'REMOTE_USER'};
3150}
3151END_OF_FUNC
3152
3153
3154#### Method: user_name
3155# Try to return the remote user's name by hook or by
3156# crook
3157####
3158'user_name' => <<'END_OF_FUNC',
3159sub user_name {
3160 my ($self) = self_or_CGI(@_);
3161 return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
3162}
3163END_OF_FUNC
3164
3d1a2ec4
GS
3165#### Method: nosticky
3166# Set or return the NOSTICKY global flag
3167####
3168'nosticky' => <<'END_OF_FUNC',
3169sub nosticky {
3170 my ($self,$param) = self_or_CGI(@_);
3171 $CGI::NOSTICKY = $param if defined($param);
3172 return $CGI::NOSTICKY;
3173}
3174END_OF_FUNC
3175
54310121 3176#### Method: nph
3177# Set or return the NPH global flag
3178####
3179'nph' => <<'END_OF_FUNC',
3180sub nph {
3181 my ($self,$param) = self_or_CGI(@_);
7d37aa8e
LS
3182 $CGI::NPH = $param if defined($param);
3183 return $CGI::NPH;
3184}
3185END_OF_FUNC
3186
3187#### Method: private_tempfiles
3188# Set or return the private_tempfiles global flag
3189####
3190'private_tempfiles' => <<'END_OF_FUNC',
3191sub private_tempfiles {
3192 my ($self,$param) = self_or_CGI(@_);
424ec8fa 3193 $CGI::PRIVATE_TEMPFILES = $param if defined($param);
7d37aa8e 3194 return $CGI::PRIVATE_TEMPFILES;
54310121 3195}
3196END_OF_FUNC
8f3ccfa2
JH
3197#### Method: close_upload_files
3198# Set or return the close_upload_files global flag
3199####
3200'close_upload_files' => <<'END_OF_FUNC',
3201sub close_upload_files {
3202 my ($self,$param) = self_or_CGI(@_);
3203 $CGI::CLOSE_UPLOAD_FILES = $param if defined($param);
3204 return $CGI::CLOSE_UPLOAD_FILES;
3205}
3206END_OF_FUNC
3207
54310121 3208
424ec8fa
GS
3209#### Method: default_dtd
3210# Set or return the default_dtd global
3211####
3212'default_dtd' => <<'END_OF_FUNC',
3213sub default_dtd {
3d1a2ec4
GS
3214 my ($self,$param,$param2) = self_or_CGI(@_);
3215 if (defined $param2 && defined $param) {
3216 $CGI::DEFAULT_DTD = [ $param, $param2 ];
3217 } elsif (defined $param) {
3218 $CGI::DEFAULT_DTD = $param;
3219 }
424ec8fa
GS
3220 return $CGI::DEFAULT_DTD;
3221}
3222END_OF_FUNC
3223
54310121 3224# -------------- really private subroutines -----------------
3225'previous_or_default' => <<'END_OF_FUNC',
3226sub previous_or_default {
3227 my($self,$name,$defaults,$override) = @_;
3228 my(%selected);
3229
3230 if (!$override && ($self->{'.fieldnames'}->{$name} ||
3231 defined($self->param($name)) ) ) {
3232 grep($selected{$_}++,$self->param($name));
3233 } elsif (defined($defaults) && ref($defaults) &&
3234 (ref($defaults) eq 'ARRAY')) {
3235 grep($selected{$_}++,@{$defaults});
3236 } else {
3237 $selected{$defaults}++ if defined($defaults);
3238 }
3239
3240 return %selected;
3241}
3242END_OF_FUNC
3243
3244'register_parameter' => <<'END_OF_FUNC',
3245sub register_parameter {
3246 my($self,$param) = @_;
3247 $self->{'.parametersToAdd'}->{$param}++;
3248}
3249END_OF_FUNC
3250
3251'get_fields' => <<'END_OF_FUNC',
3252sub get_fields {
3253 my($self) = @_;
424ec8fa
GS
3254 return $self->CGI::hidden('-name'=>'.cgifields',
3255 '-values'=>[keys %{$self->{'.parametersToAdd'}}],
3256 '-override'=>1);
54310121 3257}
3258END_OF_FUNC
3259
3260'read_from_cmdline' => <<'END_OF_FUNC',
3261sub read_from_cmdline {
54310121 3262 my($input,@words);
3263 my($query_string);
2ed511ec 3264 my($subpath);
3d1a2ec4 3265 if ($DEBUG && @ARGV) {
424ec8fa 3266 @words = @ARGV;
3d1a2ec4 3267 } elsif ($DEBUG > 1) {
424ec8fa 3268 require "shellwords.pl";
2ed511ec 3269 print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n";
424ec8fa 3270 chomp(@lines = <STDIN>); # remove newlines
54310121 3271 $input = join(" ",@lines);
424ec8fa
GS
3272 @words = &shellwords($input);
3273 }
3274 foreach (@words) {
3275 s/\\=/%3D/g;
3276 s/\\&/%26/g;
54310121 3277 }
3278
54310121 3279 if ("@words"=~/=/) {
3280 $query_string = join('&',@words);
3281 } else {
3282 $query_string = join('+',@words);
3283 }
2ed511ec
RGS
3284 if ($query_string =~ /^(.*?)\?(.*)$/)
3285 {
3286 $query_string = $2;
3287 $subpath = $1;
3288 }
3289 return { 'query_string' => $query_string, 'subpath' => $subpath };
54310121 3290}
3291END_OF_FUNC
3292
3293#####
3294# subroutine: read_multipart
3295#
3296# Read multipart data and store it into our parameters.
3297# An interesting feature is that if any of the parts is a file, we
3298# create a temporary file and open up a filehandle on it so that the
3299# caller can read from it if necessary.
3300#####
3301'read_multipart' => <<'END_OF_FUNC',
3302sub read_multipart {
2ed511ec
RGS
3303 my($self,$boundary,$length) = @_;
3304 my($buffer) = $self->new_MultipartBuffer($boundary,$length);
54310121 3305 return unless $buffer;
3306 my(%header,$body);
424ec8fa 3307 my $filenumber = 0;
54310121 3308 while (!$buffer->eof) {
3309 %header = $buffer->readHeader;
3538e1d5
GS
3310
3311 unless (%header) {
3312 $self->cgi_error("400 Bad request (malformed multipart POST)");
3313 return;
3314 }
54310121 3315
c29edf6c 3316 my($param)= $header{'Content-Disposition'}=~/ name="([^"]*)"/;
188ba755 3317 $param .= $TAINTED;
54310121 3318
424ec8fa 3319 # Bug: Netscape doesn't escape quotation marks in file names!!!
c29edf6c 3320 my($filename) = $header{'Content-Disposition'}=~/ filename="([^"]*)"/;
8f3ccfa2
JH
3321 # Test for Opera's multiple upload feature
3322 my($multipart) = ( defined( $header{'Content-Type'} ) &&
3323 $header{'Content-Type'} =~ /multipart\/mixed/ ) ?
3324 1 : 0;
54310121 3325
3326 # add this parameter to our list
3327 $self->add_parameter($param);
3328
3329 # If no filename specified, then just read the data and assign it
3330 # to our parameter list.
8f3ccfa2 3331 if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
54310121 3332 my($value) = $buffer->readBody;
188ba755 3333 $value .= $TAINTED;
54310121 3334 push(@{$self->{$param}},$value);
3335 next;
3336 }
3337
424ec8fa
GS
3338 my ($tmpfile,$tmp,$filehandle);
3339 UPLOADS: {
3340 # If we get here, then we are dealing with a potentially large
3341 # uploaded form. Save the data to a temporary file, then open
3342 # the file for reading.
54310121 3343
424ec8fa
GS
3344 # skip the file if uploads disabled
3345 if ($DISABLE_UPLOADS) {
3346 while (defined($data = $buffer->read)) { }
3347 last UPLOADS;
3348 }
7d37aa8e 3349
8f3ccfa2
JH
3350 # set the filename to some recognizable value
3351 if ( ( !defined($filename) || $filename eq '' ) && $multipart ) {
3352 $filename = "multipart/mixed";
3353 }
3354
3538e1d5 3355 # choose a relatively unpredictable tmpfile sequence number
29ddc2a4 3356 my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
3538e1d5 3357 for (my $cnt=10;$cnt>0;$cnt--) {
ac734d8b 3358 next unless $tmpfile = new CGITempFile($seqno);
3538e1d5 3359 $tmp = $tmpfile->as_string;
ffd2dff2 3360 last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
3538e1d5
GS
3361 $seqno += int rand(100);
3362 }
69c89ae7 3363 die "CGI open of tmpfile: $!\n" unless defined $filehandle;
2ed511ec
RGS
3364 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
3365 && defined fileno($filehandle);
424ec8fa 3366
8f3ccfa2 3367 # if this is an multipart/mixed attachment, save the header
2ed511ec 3368 # together with the body for later parsing with an external
8f3ccfa2
JH
3369 # MIME parser module
3370 if ( $multipart ) {
3371 foreach ( keys %header ) {
3372 print $filehandle "$_: $header{$_}${CRLF}";
3373 }
3374 print $filehandle "${CRLF}";
3375 }
3376
424ec8fa 3377 my ($data);
71f3e297 3378 local($\) = '';
2ed511ec
RGS
3379 my $totalbytes;
3380 while (defined($data = $buffer->read)) {
3381 if (defined $self->{'.upload_hook'})
3382 {
3383 $totalbytes += length($data);
3384 &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
3385 }
cb3b230c 3386 print $filehandle $data if ($self->{'use_tempfile'});
2ed511ec 3387 }
424ec8fa
GS
3388
3389 # back up to beginning of file
3390 seek($filehandle,0,0);
8f3ccfa2
JH
3391
3392 ## Close the filehandle if requested this allows a multipart MIME
3393 ## upload to contain many files, and we won't die due to too many
3394 ## open file handles. The user can access the files using the hash
3395 ## below.
3396 close $filehandle if $CLOSE_UPLOAD_FILES;
424ec8fa
GS
3397 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
3398
3399 # Save some information about the uploaded file where we can get
3400 # at it later.
0a9bdad4
SP
3401 # Use the typeglob as the key, as this is guaranteed to be
3402 # unique for each filehandle. Don't use the file descriptor as
3403 # this will be re-used for each filehandle if the
3404 # close_upload_files feature is used.
3405 $self->{'.tmpfiles'}->{$$filehandle}= {
2ed511ec 3406 hndl => $filehandle,
424ec8fa
GS
3407 name => $tmpfile,
3408 info => {%header},
3409 };
3410 push(@{$self->{$param}},$filehandle);
3411 }
54310121 3412 }
3413}
3414END_OF_FUNC
3415
3538e1d5
GS
3416'upload' =><<'END_OF_FUNC',
3417sub upload {
3418 my($self,$param_name) = self_or_default(@_);
199d4a26
JH
3419 my @param = grep(ref && fileno($_), $self->param($param_name));
3420 return unless @param;
3421 return wantarray ? @param : $param[0];
3538e1d5
GS
3422}
3423END_OF_FUNC
3424
54310121 3425'tmpFileName' => <<'END_OF_FUNC',
3426sub tmpFileName {
3427 my($self,$filename) = self_or_default(@_);
0a9bdad4
SP
3428 return $self->{'.tmpfiles'}->{$$filename}->{name} ?
3429 $self->{'.tmpfiles'}->{$$filename}->{name}->as_string
7d37aa8e 3430 : '';
54310121 3431}
3432END_OF_FUNC
3433
424ec8fa 3434'uploadInfo' => <<'END_OF_FUNC',
54310121 3435sub uploadInfo {
3436 my($self,$filename) = self_or_default(@_);
0a9bdad4 3437 return $self->{'.tmpfiles'}->{$$filename}->{info};
54310121 3438}
3439END_OF_FUNC
3440
424ec8fa
GS
3441# internal routine, don't use
3442'_set_values_and_labels' => <<'END_OF_FUNC',
3443sub _set_values_and_labels {
3444 my $self = shift;
3445 my ($v,$l,$n) = @_;
3446 $$l = $v if ref($v) eq 'HASH' && !ref($$l);
3447 return $self->param($n) if !defined($v);
3448 return $v if !ref($v);
3449 return ref($v) eq 'HASH' ? keys %$v : @$v;
3450}
3451END_OF_FUNC
3452
188ba755
JH
3453# internal routine, don't use
3454'_set_attributes' => <<'END_OF_FUNC',
3455sub _set_attributes {
3456 my $self = shift;
3457 my($element, $attributes) = @_;
3458 return '' unless defined($attributes->{$element});
3459 $attribs = ' ';
3460 foreach my $attrib (keys %{$attributes->{$element}}) {
13548fdf
RGS
3461 (my $clean_attrib = $attrib) =~ s/^-//;
3462 $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" ";
188ba755
JH
3463 }
3464 $attribs =~ s/ $//;
3465 return $attribs;
3466}
3467END_OF_FUNC
3468
424ec8fa
GS
3469'_compile_all' => <<'END_OF_FUNC',
3470sub _compile_all {
3471 foreach (@_) {
3472 next if defined(&$_);
3473 $AUTOLOAD = "CGI::$_";
3474 _compile();
3475 }
3476}
3477END_OF_FUNC
3478
54310121 3479);
3480END_OF_AUTOLOAD
3481;
3482
424ec8fa
GS
3483#########################################################
3484# Globals and stubs for other packages that we use.
3485#########################################################
3486
3487################### Fh -- lightweight filehandle ###############
3488package Fh;
3489use overload
3490 '""' => \&asString,
3491 'cmp' => \&compare,
3492 'fallback'=>1;
3493
3494$FH='fh00000';
3495
3496*Fh::AUTOLOAD = \&CGI::AUTOLOAD;
3497
29ddc2a4
RGS
3498sub DESTROY {
3499 my $self = shift;
3500 close $self;
3501}
3502
424ec8fa
GS
3503$AUTOLOADED_ROUTINES = ''; # prevent -w error
3504$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3505%SUBS = (
3506'asString' => <<'END_OF_FUNC',
3507sub asString {
3508 my $self = shift;
71f3e297 3509 # get rid of package name
ffd2dff2 3510 (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
ba056755 3511 $i =~ s/%(..)/ chr(hex($1)) /eg;
188ba755 3512 return $i.$CGI::TAINTED;
71f3e297
JH
3513# BEGIN DEAD CODE
3514# This was an extremely clever patch that allowed "use strict refs".
3515# Unfortunately it relied on another bug that caused leaky file descriptors.
3516# The underlying bug has been fixed, so this no longer works. However
3517# "strict refs" still works for some reason.
3518# my $self = shift;
3519# return ${*{$self}{SCALAR}};
3520# END DEAD CODE
424ec8fa
GS
3521}
3522END_OF_FUNC
3523
3524'compare' => <<'END_OF_FUNC',
3525sub compare {
3526 my $self = shift;
3527 my $value = shift;
3528 return "$self" cmp $value;
3529}
3530END_OF_FUNC
3531
3532'new' => <<'END_OF_FUNC',
3533sub new {
3534 my($pack,$name,$file,$delete) = @_;
188ba755 3535 _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
424ec8fa 3536 require Fcntl unless defined &Fcntl::O_RDWR;
ba056755
JH
3537 (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
3538 my $fv = ++$FH . $safename;
6b4ac661 3539 my $ref = \*{"Fh::$fv"};
188ba755
JH
3540 $file =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
3541 my $safe = $1;
3542 sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
3543 unlink($safe) if $delete;
6b4ac661 3544 CORE::delete $Fh::{$fv};
71f3e297 3545 return bless $ref,$pack;
424ec8fa
GS
3546}
3547END_OF_FUNC
3548
424ec8fa
GS
3549);
3550END_OF_AUTOLOAD
3551
3552######################## MultipartBuffer ####################
54310121 3553package MultipartBuffer;
3554
2ed511ec
RGS
3555use constant DEBUG => 0;
3556
54310121 3557# how many bytes to read at a time. We use
71f3e297
JH
3558# a 4K buffer by default.
3559$INITIAL_FILLUNIT = 1024 * 4;
3560$TIMEOUT = 240*60; # 4 hour timeout for big files
3561$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
54310121 3562$CRLF=$CGI::CRLF;
3563
3564#reuse the autoload function
3565*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
3566
424ec8fa
GS
3567# avoid autoloader warnings
3568sub DESTROY {}
3569
54310121 3570###############################################################################
3571################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3572###############################################################################
3573$AUTOLOADED_ROUTINES = ''; # prevent -w error
3574$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3575%SUBS = (
3576
3577'new' => <<'END_OF_FUNC',
3578sub new {
2ed511ec 3579 my($package,$interface,$boundary,$length) = @_;
424ec8fa 3580 $FILLUNIT = $INITIAL_FILLUNIT;
2ed511ec 3581 $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always
29ddc2a4 3582
54310121 3583 # If the user types garbage into the file upload field,
3584 # then Netscape passes NOTHING to the server (not good).
3585 # We may hang on this read in that case. So we implement
3586 # a read timeout. If nothing is ready to read
3587 # by then, we return.
3588
3589 # Netscape seems to be a little bit unreliable
3590 # about providing boundary strings.
3d1a2ec4 3591 my $boundary_read = 0;
54310121 3592 if ($boundary) {
3593
3594 # Under the MIME spec, the boundary consists of the
3595 # characters "--" PLUS the Boundary string
424ec8fa
GS
3596
3597 # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
71f3e297 3598 # the two extra hyphens. We do a special case here on the user-agent!!!!
69c89ae7 3599 $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport');
424ec8fa 3600
54310121 3601 } else { # otherwise we find it ourselves
3602 my($old);
3603 ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
2ed511ec 3604 $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl
54310121 3605 $length -= length($boundary);
3606 chomp($boundary); # remove the CRLF
3607 $/ = $old; # restore old line separator
3d1a2ec4 3608 $boundary_read++;
54310121 3609 }
3610
3611 my $self = {LENGTH=>$length,
29ddc2a4 3612 CHUNKED=>!defined $length,
54310121 3613 BOUNDARY=>$boundary,
54310121 3614 INTERFACE=>$interface,
3615 BUFFER=>'',
3616 };
3617
3618 $FILLUNIT = length($boundary)
3619 if length($boundary) > $FILLUNIT;
3620
424ec8fa
GS
3621 my $retval = bless $self,ref $package || $package;
3622
3623 # Read the preamble and the topmost (boundary) line plus the CRLF.
3d1a2ec4
GS
3624 unless ($boundary_read) {
3625 while ($self->read(0)) { }
3626 }
2ed511ec 3627 die "Malformed multipart POST: data truncated\n" if $self->eof;
424ec8fa
GS
3628
3629 return $retval;
54310121 3630}
3631END_OF_FUNC
3632
3633'readHeader' => <<'END_OF_FUNC',
3634sub readHeader {
3635 my($self) = @_;
3636 my($end);
3637 my($ok) = 0;
47e3cabd 3638 my($bad) = 0;
424ec8fa 3639
2ed511ec 3640 local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC;
424ec8fa 3641
54310121 3642 do {
3643 $self->fillBuffer($FILLUNIT);
3644 $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
3645 $ok++ if $self->{BUFFER} eq '';
47e3cabd 3646 $bad++ if !$ok && $self->{LENGTH} <= 0;
424ec8fa
GS
3647 # this was a bad idea
3648 # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
47e3cabd
LS
3649 } until $ok || $bad;
3650 return () if $bad;
54310121 3651
2ed511ec
RGS
3652 #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines!
3653
54310121 3654 my($header) = substr($self->{BUFFER},0,$end+2);
3655 substr($self->{BUFFER},0,$end+4) = '';
3656 my %return;
424ec8fa 3657
2ed511ec
RGS
3658 if ($CGI::EBCDIC) {
3659 warn "untranslated header=$header\n" if DEBUG;
3660 $header = CGI::Util::ascii2ebcdic($header);
3661 warn "translated header=$header\n" if DEBUG;
3662 }
3663
424ec8fa
GS
3664 # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
3665 # (Folding Long Header Fields), 3.4.3 (Comments)
3666 # and 3.4.5 (Quoted-Strings).
3667
3668 my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
3669 $header=~s/$CRLF\s+/ /og; # merge continuation lines
188ba755 3670
424ec8fa 3671 while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
188ba755 3672 my ($field_name,$field_value) = ($1,$2);
424ec8fa
GS
3673 $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
3674 $return{$field_name}=$field_value;
54310121 3675 }
3676 return %return;
3677}
3678END_OF_FUNC
3679
3680# This reads and returns the body as a single scalar value.
3681'readBody' => <<'END_OF_FUNC',
3682sub readBody {
3683 my($self) = @_;
3684 my($data);
3685 my($returnval)='';
2ed511ec
RGS
3686
3687 #EBCDIC NOTE: want to translate returnval into EBCDIC HERE
3688
54310121 3689 while (defined($data = $self->read)) {
3690 $returnval .= $data;
3691 }
2ed511ec
RGS
3692
3693 if ($CGI::EBCDIC) {
3694 warn "untranslated body=$returnval\n" if DEBUG;
3695 $returnval = CGI::Util::ascii2ebcdic($returnval);
3696 warn "translated body=$returnval\n" if DEBUG;
3697 }
54310121 3698 return $returnval;
3699}
3700END_OF_FUNC
3701
3702# This will read $bytes or until the boundary is hit, whichever happens
3703# first. After the boundary is hit, we return undef. The next read will
3704# skip over the boundary and begin reading again;
3705'read' => <<'END_OF_FUNC',
3706sub read {
3707 my($self,$bytes) = @_;
3708
3709 # default number of bytes to read
2ed511ec 3710 $bytes = $bytes || $FILLUNIT;
54310121 3711
3712 # Fill up our internal buffer in such a way that the boundary
3713 # is never split between reads.
3714 $self->fillBuffer($bytes);
3715
2ed511ec
RGS
3716 my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY};
3717 my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--';
3718
54310121 3719 # Find the boundary in the buffer (it may not be there).
2ed511ec
RGS
3720 my $start = index($self->{BUFFER},$boundary_start);
3721
3722 warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG;
54310121 3723
29ddc2a4
RGS
3724 # protect against malformed multipart POST operations
3725 die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0);
2ed511ec
RGS
3726
3727 #EBCDIC NOTE: want to translate boundary search into ASCII here.
3728
54310121 3729 # If the boundary begins the data, then skip past it
03b9648d 3730 # and return undef.
54310121 3731 if ($start == 0) {
3732
3733 # clear us out completely if we've hit the last boundary.
2ed511ec 3734 if (index($self->{BUFFER},$boundary_end)==0) {
54310121 3735 $self->{BUFFER}='';
3736 $self->{LENGTH}=0;
3737 return undef;
3738 }
3739
3740 # just remove the boundary.