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