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
Continue what #4494 started; introduce uid and gid formats.
[perl5.git] / lib / CGI.pm
CommitLineData
54310121 1package CGI;
424ec8fa 2require 5.004;
54310121 3
4# See the bottom of this file for the POD documentation. Search for the
5# string '=head'.
6
7# You can run this file through either pod2man or pod2html to produce pretty
8# documentation in manual or html file format (these utilities are part of the
9# Perl 5 distribution).
10
424ec8fa 11# Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
54310121 12# It may be used and modified freely, but I do request that this copyright
13# notice remain attached to the file. You may modify this module as you
14# wish, but if you redistribute a modified version, please attach a note
15# listing the modifications you have made.
16
17# The most recent version and complete docs are available at:
71f3e297 18# http://stein.cshl.org/WWW/software/CGI/
54310121 19
f6b3007c
JH		 20$CGI::revision = '$Id: CGI.pm,v 1.18 1999/06/09 14:52:45 lstein Exp $';
21$CGI::VERSION='2.53';
54310121 22
23# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
24# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
25# $TempFile::TMPDIRECTORY = '/usr/tmp';
26
424ec8fa
GS		 27# >>>>> Here are some globals that you might want to adjust <<<<<<
28sub initialize_globals {
29 # Set this to 1 to enable copious autoloader debugging messages
30 $AUTOLOAD_DEBUG = 0;
31
32 # Change this to the preferred DTD to print in start_html()
33 # or use default_dtd('text of DTD to use');
34 $DEFAULT_DTD = '-//IETF//DTD HTML//EN';
35
36 # Set this to 1 to enable NPH scripts
37 # or:
38 # 1) use CGI qw(-nph)
39 # 2) $CGI::nph(1)
40 # 3) print header(-nph=>1)
41 $NPH = 0;
42
43 # Set this to 1 to disable debugging from the
44 # command line
45 $NO_DEBUG = 0;
46
47 # Set this to 1 to make the temporary files created
48 # during file uploads safe from prying eyes
49 # or do...
50 # 1) use CGI qw(:private_tempfiles)
51 # 2) $CGI::private_tempfiles(1);
52 $PRIVATE_TEMPFILES = 0;
53
54 # Set this to a positive value to limit the size of a POSTing
55 # to a certain number of bytes:
56 $POST_MAX = -1;
57
58 # Change this to 1 to disable uploads entirely:
59 $DISABLE_UPLOADS = 0;
60
f6b3007c
JH		 61 # Automatically determined -- don't change
62 $EBCDIC = 0;
63
71f3e297
JH		 64 # Change this to 1 to suppress redundant HTTP headers
65 $HEADERS_ONCE = 0;
66
67 # separate the name=value pairs by semicolons rather than ampersands
68 $USE_PARAM_SEMICOLONS = 0;
69
424ec8fa
GS		 70 # Other globals that you shouldn't worry about.
71 undef $Q;
72 $BEEN_THERE = 0;
73 undef @QUERY_PARAM;
74 undef %EXPORT;
75
76 # prevent complaints by mod_perl
77 1;
78}
79
54310121 80# ------------------ START OF THE LIBRARY ------------
81
424ec8fa
GS		 82# make mod_perlhappy
83initialize_globals();
84
54310121 85# FIGURE OUT THE OS WE'RE RUNNING UNDER
86# Some systems support the $^O variable. If not
87# available then require() the Config library
88unless ($OS) {
89 unless ($OS = $^O) {
90 require Config;
91 $OS = $Config::Config{'osname'};
92 }
93}
94if ($OS=~/Win/i) {
f6b3007c 95 $OS = 'WINDOWS';
54310121 96} elsif ($OS=~/vms/i) {
f6b3007c
JH		 97 $OS = 'VMS';
98} elsif ($OS=~/dos/i) {
99 $OS = 'DOS';
424ec8fa 100} elsif ($OS=~/^MacOS$/i) {
54310121 101 $OS = 'MACINTOSH';
102} elsif ($OS=~/os2/i) {
103 $OS = 'OS2';
104} else {
105 $OS = 'UNIX';
106}
107
108# Some OS logic. Binary mode enabled on DOS, NT and VMS
f6b3007c 109$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/;
54310121 110
111# This is the default class for the CGI object to use when all else fails.
112$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
424ec8fa 113
54310121 114# This is where to look for autoloaded routines.
115$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
116
117# The path separator is a slash, backslash or semicolon, depending
118# on the paltform.
119$SL = {
f6b3007c 120 UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
54310121 121 }->{$OS};
122
424ec8fa 123# This no longer seems to be necessary
54310121 124# Turn on NPH scripts by default when running under IIS server!
424ec8fa
GS		 125# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
126$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
54310121 127
128# Turn on special checking for Doug MacEachern's modperl
71f3e297
JH		 129if (exists $ENV{'GATEWAY_INTERFACE'}
130 &&
f6b3007c 131 ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
424ec8fa 132{
54310121 133 $| = 1;
424ec8fa
GS		 134 require Apache;
135}
136# Turn on special checking for ActiveState's PerlEx
137$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
138
139# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
140# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
141# and sometimes CR). The most popular VMS web server
142# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
143# use ASCII, so \015\012 means something different. I find this all
144# really annoying.
145$EBCDIC = "\t" ne "\011";
146if ($OS eq 'VMS') {
f6b3007c 147 $CRLF = "\n";
424ec8fa 148} elsif ($EBCDIC) {
f6b3007c 149 $CRLF= "\r\n";
424ec8fa 150} else {
f6b3007c
JH		 151 $CRLF = "\015\012";
152}
153
154if ($EBCDIC) {
155@A2E = (
156 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
157 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
158 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
159240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
160124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
161215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
162121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
163151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7,
164 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27,
165 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255,
166 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
167144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
168100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
169172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
170 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
171140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
172 );
54310121 173}
174
54310121 175if ($needs_binmode) {
176 $CGI::DefaultClass->binmode(main::STDOUT);
177 $CGI::DefaultClass->binmode(main::STDIN);
178 $CGI::DefaultClass->binmode(main::STDERR);
179}
180
54310121 181%EXPORT_TAGS = (
424ec8fa
GS		 182 ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
183 tt u i b blockquote pre img a address cite samp dfn html head
184 base body Link nextid title meta kbd start_html end_html
185 input Select option comment/],
71f3e297 186 ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param
424ec8fa
GS		 187 embed basefont style span layer ilayer font frameset frame script small big/],
188 ':netscape'=>[qw/blink fontsize center/],
189 ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
190 submit reset defaults radio_group popup_menu button autoEscape
191 scrolling_list image_button start_form end_form startform endform
71f3e297 192 start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
f6b3007c
JH		 193 ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump
194 raw_cookie request_method query_string Accept user_agent remote_host content_type
424ec8fa
GS		 195 remote_addr referer server_name server_software server_port server_protocol
196 virtual_host remote_ident auth_type http use_named_parameters
197 save_parameters restore_parameters param_fetch
f6b3007c
JH		 198 remote_user user_name header redirect import_names put
199 Delete Delete_all url_param cgi_error/],
424ec8fa 200 ':ssl' => [qw/https/],
71f3e297 201 ':imagemap' => [qw/Area Map/],
f6b3007c 202 ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
424ec8fa
GS		 203 ':html' => [qw/:html2 :html3 :netscape/],
204 ':standard' => [qw/:html2 :html3 :form :cgi/],
205 ':push' => [qw/multipart_init multipart_start multipart_end/],
206 ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/]
207 );
54310121 208
209# to import symbols into caller
210sub import {
211 my $self = shift;
424ec8fa
GS		 212
213# This causes modules to clash.
214# undef %EXPORT_OK;
215# undef %EXPORT;
216
217 $self->_setup_symbols(@_);
54310121 218 my ($callpack, $callfile, $callline) = caller;
424ec8fa 219
54310121 220 # To allow overriding, search through the packages
221 # Till we find one in which the correct subroutine is defined.
222 my @packages = ($self,@{"$self\:\:ISA"});
223 foreach $sym (keys %EXPORT) {
224 my $pck;
225 my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
226 foreach $pck (@packages) {
227 if (defined(&{"$pck\:\:$sym"})) {
228 $def = $pck;
229 last;
230 }
231 }
232 *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
233 }
234}
235
424ec8fa
GS		 236sub compile {
237 my $pack = shift;
238 $pack->_setup_symbols('-compile',@_);
239}
240
54310121 241sub expand_tags {
242 my($tag) = @_;
71f3e297 243 return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
54310121 244 my(@r);
245 return ($tag) unless $EXPORT_TAGS{$tag};
246 foreach (@{$EXPORT_TAGS{$tag}}) {
247 push(@r,&expand_tags($_));
248 }
249 return @r;
250}
251
252#### Method: new
253# The new routine. This will check the current environment
254# for an existing query string, and initialize itself, if so.
255####
256sub new {
257 my($class,$initializer) = @_;
258 my $self = {};
259 bless $self,ref $class || $class || $DefaultClass;
424ec8fa
GS		 260 if ($MOD_PERL) {
261 Apache->request->register_cleanup(\&CGI::_reset_globals);
262 undef $NPH;
263 }
264 $self->_reset_globals if $PERLEX;
54310121 265 $self->init($initializer);
266 return $self;
267}
268
269# We provide a DESTROY method so that the autoloader
270# doesn't bother trying to find it.
271sub DESTROY { }
272
273#### Method: param
274# Returns the value(s)of a named parameter.
275# If invoked in a list context, returns the
276# entire list. Otherwise returns the first
277# member of the list.
278# If name is not provided, return a list of all
279# the known parameters names available.
280# If more than one argument is provided, the
281# second and subsequent arguments are used to
282# set the value of the parameter.
283####
284sub param {
285 my($self,@p) = self_or_default(@_);
286 return $self->all_parameters unless @p;
287 my($name,$value,@other);
288
289 # For compatibility between old calling style and use_named_parameters() style,
290 # we have to special case for a single parameter present.
291 if (@p > 1) {
292 ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
293 my(@values);
294
295 if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
296 @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
297 } else {
298 foreach ($value,@other) {
299 push(@values,$_) if defined($_);
300 }
301 }
302 # If values is provided, then we set it.
303 if (@values) {
304 $self->add_parameter($name);
305 $self->{$name}=[@values];
306 }
307 } else {
308 $name = $p[0];
309 }
310
71f3e297 311 return unless defined($name) && $self->{$name};
54310121 312 return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
313}
314
54310121 315sub self_or_default {
424ec8fa 316 return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
54310121 317 unless (defined($_[0]) &&
424ec8fa
GS		 318 (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
319 ) {
54310121 320 $Q = $CGI::DefaultClass->new unless defined($Q);
321 unshift(@_,$Q);
322 }
323 return @_;
324}
325
54310121 326sub self_or_CGI {
327 local $^W=0; # prevent a warning
328 if (defined($_[0]) &&
329 (substr(ref($_[0]),0,3) eq 'CGI'
424ec8fa 330 || UNIVERSAL::isa($_[0],'CGI'))) {
54310121 331 return @_;
332 } else {
333 return ($DefaultClass,@_);
334 }
335}
336
54310121 337########################################
338# THESE METHODS ARE MORE OR LESS PRIVATE
339# GO TO THE __DATA__ SECTION TO SEE MORE
340# PUBLIC METHODS
341########################################
342
343# Initialize the query object from the environment.
344# If a parameter list is found, this object will be set
345# to an associative array in which parameter names are keys
346# and the values are stored as lists
347# If a keyword list is found, this method creates a bogus
348# parameter list with the single parameter 'keywords'.
349
350sub init {
351 my($self,$initializer) = @_;
424ec8fa 352 my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
71f3e297 353 local($/) = "\n";
54310121 354
355 # if we get called more than once, we want to initialize
356 # ourselves from the original query (which may be gone
357 # if it was read from STDIN originally.)
2c2d71f5 358 if (@QUERY_PARAM && !defined($initializer)) {
54310121 359 foreach (@QUERY_PARAM) {
360 $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
361 }
362 return;
363 }
364
365 $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
424ec8fa 366 $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
f6b3007c 367
424ec8fa 368 $fh = to_filehandle($initializer) if $initializer;
54310121 369
54310121 370 METHOD: {
54310121 371
f6b3007c
JH		 372 # avoid unreasonably large postings
373 if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
374 $self->cgi_error("413 Request entity too large");
375 last METHOD;
376 }
377
424ec8fa
GS		 378 # Process multipart postings, but only if the initializer is
379 # not defined.
380 if ($meth eq 'POST'
381 && defined($ENV{'CONTENT_TYPE'})
382 && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
383 && !defined($initializer)
384 ) {
71f3e297 385 my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
424ec8fa
GS		 386 $self->read_multipart($boundary,$content_length);
387 last METHOD;
388 }
389
390 # If initializer is defined, then read parameters
391 # from it.
392 if (defined($initializer)) {
393 if (UNIVERSAL::isa($initializer,'CGI')) {
394 $query_string = $initializer->query_string;
395 last METHOD;
396 }
54310121 397 if (ref($initializer) && ref($initializer) eq 'HASH') {
398 foreach (keys %$initializer) {
399 $self->param('-name'=>$_,'-value'=>$initializer->{$_});
400 }
401 last METHOD;
402 }
403
424ec8fa
GS		 404 if (defined($fh) && ($fh ne '')) {
405 while (<$fh>) {
54310121 406 chomp;
407 last if /^=/;
408 push(@lines,$_);
409 }
410 # massage back into standard format
411 if ("@lines" =~ /=/) {
412 $query_string=join("&",@lines);
413 } else {
414 $query_string=join("+",@lines);
415 }
416 last METHOD;
417 }
424ec8fa
GS		 418
419 # last chance -- treat it as a string
420 $initializer = $$initializer if ref($initializer) eq 'SCALAR';
54310121 421 $query_string = $initializer;
424ec8fa 422
54310121 423 last METHOD;
424 }
54310121 425
424ec8fa
GS		 426 # If method is GET or HEAD, fetch the query from
427 # the environment.
428 if ($meth=~/^(GET|HEAD)$/) {
f6b3007c
JH		 429 if ($MOD_PERL) {
430 $query_string = Apache->request->args;
431 } else {
432 $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
433 }
424ec8fa
GS		 434 last METHOD;
435 }
54310121 436
424ec8fa
GS		 437 if ($meth eq 'POST') {
438 $self->read_from_client(\*STDIN,\$query_string,$content_length,0)
439 if $content_length > 0;
54310121 440 # Some people want to have their cake and eat it too!
441 # Uncomment this line to have the contents of the query string
442 # APPENDED to the POST data.
424ec8fa 443 # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
54310121 444 last METHOD;
445 }
424ec8fa
GS		 446
447 # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
54310121 448 # Check the command line and then the standard input for data.
449 # We use the shellwords package in order to behave the way that
450 # UN*X programmers expect.
424ec8fa 451 $query_string = read_from_cmdline() unless $NO_DEBUG;
54310121 452 }
424ec8fa 453
54310121 454 # We now have the query string in hand. We do slightly
455 # different things for keyword lists and parameter lists.
424ec8fa 456 if ($query_string ne '') {
54310121 457 if ($query_string =~ /=/) {
458 $self->parse_params($query_string);
459 } else {
460 $self->add_parameter('keywords');
461 $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
462 }
463 }
464
465 # Special case. Erase everything if there is a field named
466 # .defaults.
467 if ($self->param('.defaults')) {
468 undef %{$self};
469 }
470
471 # Associative array containing our defined fieldnames
472 $self->{'.fieldnames'} = {};
473 foreach ($self->param('.cgifields')) {
474 $self->{'.fieldnames'}->{$_}++;
475 }
476
477 # Clear out our default submission button flag if present
478 $self->delete('.submit');
479 $self->delete('.cgifields');
480 $self->save_request unless $initializer;
54310121 481}
482
54310121 483# FUNCTIONS TO OVERRIDE:
54310121 484# Turn a string into a filehandle
485sub to_filehandle {
424ec8fa
GS		 486 my $thingy = shift;
487 return undef unless $thingy;
488 return $thingy if UNIVERSAL::isa($thingy,'GLOB');
489 return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
490 if (!ref($thingy)) {
491 my $caller = 1;
492 while (my $package = caller($caller++)) {
493 my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
494 return $tmp if defined(fileno($tmp));
495 }
54310121 496 }
424ec8fa 497 return undef;
54310121 498}
499
500# send output to the browser
501sub put {
502 my($self,@p) = self_or_default(@_);
503 $self->print(@p);
504}
505
506# print to standard output (for overriding in mod_perl)
507sub print {
508 shift;
509 CORE::print(@_);
510}
511
f6b3007c
JH		 512# get/set last cgi_error
513sub cgi_error {
514 my ($self,$err) = self_or_default(@_);
515 $self->{'.cgi_error'} = $err if defined $err;
516 return $self->{'.cgi_error'};
517}
518
54310121 519# unescape URL-encoded data
520sub unescape {
f6b3007c
JH		 521 shift() if ref($_[0]) || $_[0] eq $DefaultClass;
522 my $todecode = shift;
523 return undef unless defined($todecode);
524 $todecode =~ tr/+/ /; # pluses become spaces
525 if ($EBCDIC) {
526 $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",$A2E[hex($1)])/ge;
527 } else {
528 $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
529 }
530 return $todecode;
54310121 531}
532
533# URL-encode data
534sub escape {
424ec8fa
GS		 535 shift() if ref($_[0]) || $_[0] eq $DefaultClass;
536 my $toencode = shift;
537 return undef unless defined($toencode);
f6b3007c
JH		 538 $toencode=~s/ /+/g;
539 $toencode=~s/([^a-zA-Z0-9_.+-])/uc sprintf("%%%02x",ord($1))/eg;
54310121 540 return $toencode;
541}
542
543sub save_request {
544 my($self) = @_;
545 # We're going to play with the package globals now so that if we get called
546 # again, we initialize ourselves in exactly the same way. This allows
547 # us to have several of these objects.
548 @QUERY_PARAM = $self->param; # save list of parameters
549 foreach (@QUERY_PARAM) {
550 $QUERY_PARAM{$_}=$self->{$_};
551 }
552}
553
54310121 554sub parse_params {
555 my($self,$tosplit) = @_;
71f3e297 556 my(@pairs) = split(/[&;]/,$tosplit);
54310121 557 my($param,$value);
558 foreach (@pairs) {
424ec8fa
GS		 559 ($param,$value) = split('=',$_,2);
560 $param = unescape($param);
561 $value = unescape($value);
54310121 562 $self->add_parameter($param);
563 push (@{$self->{$param}},$value);
564 }
565}
566
567sub add_parameter {
568 my($self,$param)=@_;
569 push (@{$self->{'.parameters'}},$param)
570 unless defined($self->{$param});
571}
572
573sub all_parameters {
574 my $self = shift;
575 return () unless defined($self) && $self->{'.parameters'};
576 return () unless @{$self->{'.parameters'}};
577 return @{$self->{'.parameters'}};
578}
579
424ec8fa
GS		 580# put a filehandle into binary mode (DOS)
581sub binmode {
582 CORE::binmode($_[1]);
583}
584
585sub _make_tag_func {
71f3e297 586 my ($self,$tagname) = @_;
f6b3007c 587 my $func = qq(
424ec8fa 588 sub $tagname {
424ec8fa 589 shift if \$_[0] &&
f6b3007c 590# (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) ||
424ec8fa
GS		 591 (ref(\$_[0]) &&
592 (substr(ref(\$_[0]),0,3) eq 'CGI' ||
593 UNIVERSAL::isa(\$_[0],'CGI')));
594
595 my(\$attr) = '';
596 if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') {
597 my(\@attr) = make_attributes( '',shift() );
598 \$attr = " \@attr" if \@attr;
599 }
f6b3007c 600 );
71f3e297
JH		 601 if ($tagname=~/start_(\w+)/i) {
602 $func .= qq! return "<\U$1\E\$attr>";} !;
603 } elsif ($tagname=~/end_(\w+)/i) {
604 $func .= qq! return "<\U/$1\E>"; } !;
605 } else {
606 $func .= qq#
424ec8fa
GS		 607 my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U</$tagname>\E");
608 return \$tag unless \@_;
609 my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
610 return "\@result";
71f3e297
JH		 611 }#;
612 }
613return $func;
54310121 614}
615
616sub AUTOLOAD {
617 print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
424ec8fa
GS		 618 my $func = &_compile;
619 goto &$func;
54310121 620}
621
622# PRIVATE SUBROUTINE
623# Smart rearrangement of parameters to allow named parameter
624# calling. We do the rearangement if:
625# 1. The first parameter begins with a -
626# 2. The use_named_parameters() method returns true
627sub rearrange {
628 my($self,$order,@param) = @_;
629 return () unless @param;
54310121 630
424ec8fa
GS		 631 if (ref($param[0]) eq 'HASH') {
632 @param = %{$param[0]};
633 } else {
634 return @param
635 unless (defined($param[0]) && substr($param[0],0,1) eq '-')
636 || $self->use_named_parameters;
54310121 637 }
424ec8fa
GS		 638
639 # map parameters into positional indices
640 my ($i,%pos);
641 $i = 0;
642 foreach (@$order) {
643 foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; }
644 $i++;
645 }
646
647 my (@result,%leftover);
648 $#result = $#$order; # preextend
649 while (@param) {
650 my $key = uc(shift(@param));
651 $key =~ s/^\-//;
652 if (exists $pos{$key}) {
653 $result[$pos{$key}] = shift(@param);
54310121 654 } else {
424ec8fa
GS		 655 $leftover{$key} = shift(@param);
656 }
657 }
658
659 push (@result,$self->make_attributes(\%leftover)) if %leftover;
660 @result;
661}
662
663sub _compile {
664 my($func) = $AUTOLOAD;
665 my($pack,$func_name);
666 {
667 local($1,$2); # this fixes an obscure variable suicide problem.
668 $func=~/(.+)::([^:]+)$/;
669 ($pack,$func_name) = ($1,$2);
670 $pack=~s/::SUPER$//; # fix another obscure problem
671 $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
672 unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
673
674 my($sub) = \%{"$pack\:\:SUBS"};
675 unless (%$sub) {
676 my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
677 eval "package $pack; $$auto";
678 die $@ if $@;
679 $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
680 }
681 my($code) = $sub->{$func_name};
682
683 $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
684 if (!$code) {
71f3e297 685 (my $base = $func_name) =~ s/^(start_|end_)//i;
424ec8fa
GS		 686 if ($EXPORT{':any'} ||
687 $EXPORT{'-any'} ||
71f3e297 688 $EXPORT{$base} ||
424ec8fa 689 (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
71f3e297
JH		 690 && $EXPORT_OK{$base}) {
691 $code = $CGI::DefaultClass->_make_tag_func($func_name);
424ec8fa
GS		 692 }
693 }
694 die "Undefined subroutine $AUTOLOAD\n" unless $code;
695 eval "package $pack; $code";
696 if ($@) {
697 $@ =~ s/ at .*\n//;
698 die $@;
699 }
700 }
f6b3007c 701 CORE::delete($sub->{$func_name}); #free storage
424ec8fa
GS		 702 return "$pack\:\:$func_name";
703}
704
705sub _reset_globals { initialize_globals(); }
706
707sub _setup_symbols {
708 my $self = shift;
709 my $compile = 0;
710 foreach (@_) {
71f3e297
JH		 711 $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
712 $NPH++, next if /^[:-]nph$/;
713 $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/;
714 $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
715 $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
716 $EXPORT{$_}++, next if /^[:-]any$/;
717 $compile++, next if /^[:-]compile$/;
424ec8fa 718
71f3e297 719 # This is probably extremely evil code -- to be deleted some day.
424ec8fa
GS		 720 if (/^[-]autoload$/) {
721 my($pkg) = caller(1);
722 *{"${pkg}::AUTOLOAD"} = sub {
723 my($routine) = $AUTOLOAD;
724 $routine =~ s/^.*::/CGI::/;
725 &$routine;
726 };
727 next;
728 }
729
730 foreach (&expand_tags($_)) {
731 tr/a-zA-Z0-9_//cd; # don't allow weird function names
732 $EXPORT{$_}++;
54310121 733 }
54310121 734 }
424ec8fa 735 _compile_all(keys %EXPORT) if $compile;
54310121 736}
737
738###############################################################################
739################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
740###############################################################################
741$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
742$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
743
744%SUBS = (
745
746'URL_ENCODED'=> <<'END_OF_FUNC',
747sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
748END_OF_FUNC
749
750'MULTIPART' => <<'END_OF_FUNC',
751sub MULTIPART { 'multipart/form-data'; }
752END_OF_FUNC
753
424ec8fa
GS		 754'SERVER_PUSH' => <<'END_OF_FUNC',
755sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; }
756END_OF_FUNC
757
758'use_named_parameters' => <<'END_OF_FUNC',
759#### Method: use_named_parameters
760# Force CGI.pm to use named parameter-style method calls
761# rather than positional parameters. The same effect
762# will happen automatically if the first parameter
763# begins with a -.
764sub use_named_parameters {
765 my($self,$use_named) = self_or_default(@_);
766 return $self->{'.named'} unless defined ($use_named);
767
768 # stupidity to avoid annoying warnings
769 return $self->{'.named'}=$use_named;
770}
771END_OF_FUNC
772
773'new_MultipartBuffer' => <<'END_OF_FUNC',
774# Create a new multipart buffer
775sub new_MultipartBuffer {
776 my($self,$boundary,$length,$filehandle) = @_;
777 return MultipartBuffer->new($self,$boundary,$length,$filehandle);
778}
779END_OF_FUNC
780
781'read_from_client' => <<'END_OF_FUNC',
782# Read data from a file handle
783sub read_from_client {
784 my($self, $fh, $buff, $len, $offset) = @_;
785 local $^W=0; # prevent a warning
786 return undef unless defined($fh);
787 return read($fh, $$buff, $len, $offset);
788}
789END_OF_FUNC
790
791'delete' => <<'END_OF_FUNC',
792#### Method: delete
793# Deletes the named parameter entirely.
794####
795sub delete {
796 my($self,$name) = self_or_default(@_);
f6b3007c
JH		 797 CORE::delete $self->{$name};
798 CORE::delete $self->{'.fieldnames'}->{$name};
424ec8fa
GS		 799 @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
800 return wantarray ? () : undef;
801}
802END_OF_FUNC
803
804#### Method: import_names
805# Import all parameters into the given namespace.
806# Assumes namespace 'Q' if not specified
807####
808'import_names' => <<'END_OF_FUNC',
809sub import_names {
810 my($self,$namespace,$delete) = self_or_default(@_);
811 $namespace = 'Q' unless defined($namespace);
812 die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
f6b3007c 813 if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
424ec8fa
GS		 814 # can anyone find an easier way to do this?
815 foreach (keys %{"${namespace}::"}) {
816 local *symbol = "${namespace}::${_}";
817 undef $symbol;
818 undef @symbol;
819 undef %symbol;
54310121 820 }
424ec8fa
GS		 821 }
822 my($param,@value,$var);
823 foreach $param ($self->param) {
824 # protect against silly names
825 ($var = $param)=~tr/a-zA-Z0-9_/_/c;
826 $var =~ s/^(?=\d)/_/;
827 local *symbol = "${namespace}::$var";
828 @value = $self->param($param);
829 @symbol = @value;
830 $symbol = $value[0];
54310121 831 }
832}
833END_OF_FUNC
834
835#### Method: keywords
836# Keywords acts a bit differently. Calling it in a list context
837# returns the list of keywords.
838# Calling it in a scalar context gives you the size of the list.
839####
840'keywords' => <<'END_OF_FUNC',
841sub keywords {
842 my($self,@values) = self_or_default(@_);
843 # If values is provided, then we set it.
2c2d71f5 844 $self->{'keywords'}=[@values] if @values;
424ec8fa 845 my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
54310121 846 @result;
847}
848END_OF_FUNC
849
850# These are some tie() interfaces for compatibility
851# with Steve Brenner's cgi-lib.pl routines
f6b3007c
JH		 852'Vars' => <<'END_OF_FUNC',
853sub Vars {
854 my %in;
855 tie(%in,CGI);
856 return %in if wantarray;
857 return \%in;
858}
859END_OF_FUNC
860
861# These are some tie() interfaces for compatibility
862# with Steve Brenner's cgi-lib.pl routines
54310121 863'ReadParse' => <<'END_OF_FUNC',
864sub ReadParse {
865 local(*in);
866 if (@_) {
867 *in = $_[0];
868 } else {
869 my $pkg = caller();
870 *in=*{"${pkg}::in"};
871 }
872 tie(%in,CGI);
424ec8fa 873 return scalar(keys %in);
54310121 874}
875END_OF_FUNC
876
877'PrintHeader' => <<'END_OF_FUNC',
878sub PrintHeader {
879 my($self) = self_or_default(@_);
880 return $self->header();
881}
882END_OF_FUNC
883
884'HtmlTop' => <<'END_OF_FUNC',
885sub HtmlTop {
886 my($self,@p) = self_or_default(@_);
887 return $self->start_html(@p);
888}
889END_OF_FUNC
890
891'HtmlBot' => <<'END_OF_FUNC',
892sub HtmlBot {
893 my($self,@p) = self_or_default(@_);
894 return $self->end_html(@p);
895}
896END_OF_FUNC
897
898'SplitParam' => <<'END_OF_FUNC',
899sub SplitParam {
900 my ($param) = @_;
901 my (@params) = split ("\0", $param);
902 return (wantarray ? @params : $params[0]);
903}
904END_OF_FUNC
905
906'MethGet' => <<'END_OF_FUNC',
907sub MethGet {
908 return request_method() eq 'GET';
909}
910END_OF_FUNC
911
912'MethPost' => <<'END_OF_FUNC',
913sub MethPost {
914 return request_method() eq 'POST';
915}
916END_OF_FUNC
917
918'TIEHASH' => <<'END_OF_FUNC',
919sub TIEHASH {
424ec8fa 920 return $Q || new CGI;
54310121 921}
922END_OF_FUNC
923
924'STORE' => <<'END_OF_FUNC',
925sub STORE {
926 $_[0]->param($_[1],split("\0",$_[2]));
927}
928END_OF_FUNC
929
930'FETCH' => <<'END_OF_FUNC',
931sub FETCH {
932 return $_[0] if $_[1] eq 'CGI';
933 return undef unless defined $_[0]->param($_[1]);
934 return join("\0",$_[0]->param($_[1]));
935}
936END_OF_FUNC
937
938'FIRSTKEY' => <<'END_OF_FUNC',
939sub FIRSTKEY {
940 $_[0]->{'.iterator'}=0;
941 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
942}
943END_OF_FUNC
944
945'NEXTKEY' => <<'END_OF_FUNC',
946sub NEXTKEY {
947 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
948}
949END_OF_FUNC
950
951'EXISTS' => <<'END_OF_FUNC',
952sub EXISTS {
953 exists $_[0]->{$_[1]};
954}
955END_OF_FUNC
956
957'DELETE' => <<'END_OF_FUNC',
958sub DELETE {
959 $_[0]->delete($_[1]);
960}
961END_OF_FUNC
962
963'CLEAR' => <<'END_OF_FUNC',
964sub CLEAR {
965 %{$_[0]}=();
966}
967####
968END_OF_FUNC
969
970####
971# Append a new value to an existing query
972####
973'append' => <<'EOF',
974sub append {
975 my($self,@p) = @_;
976 my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
977 my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
978 if (@values) {
979 $self->add_parameter($name);
980 push(@{$self->{$name}},@values);
981 }
982 return $self->param($name);
983}
984EOF
985
986#### Method: delete_all
987# Delete all parameters
988####
989'delete_all' => <<'EOF',
990sub delete_all {
991 my($self) = self_or_default(@_);
992 undef %{$self};
993}
994EOF
995
424ec8fa
GS		 996'Delete' => <<'EOF',
997sub Delete {
998 my($self,@p) = self_or_default(@_);
999 $self->delete(@p);
1000}
1001EOF
1002
1003'Delete_all' => <<'EOF',
1004sub Delete_all {
1005 my($self,@p) = self_or_default(@_);
1006 $self->delete_all(@p);
1007}
1008EOF
1009
54310121 1010#### Method: autoescape
1011# If you want to turn off the autoescaping features,
1012# call this method with undef as the argument
1013'autoEscape' => <<'END_OF_FUNC',
1014sub autoEscape {
1015 my($self,$escape) = self_or_default(@_);
1016 $self->{'dontescape'}=!$escape;
1017}
1018END_OF_FUNC
1019
1020
1021#### Method: version
1022# Return the current version
1023####
1024'version' => <<'END_OF_FUNC',
1025sub version {
1026 return $VERSION;
1027}
1028END_OF_FUNC
1029
1030'make_attributes' => <<'END_OF_FUNC',
1031sub make_attributes {
1032 my($self,$attr) = @_;
1033 return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
1034 my(@att);
1035 foreach (keys %{$attr}) {
1036 my($key) = $_;
1037 $key=~s/^\-//; # get rid of initial - if present
424ec8fa
GS		 1038 $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
1039 push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/);
54310121 1040 }
1041 return @att;
1042}
1043END_OF_FUNC
1044
424ec8fa
GS		 1045#### Method: url_param
1046# Return a parameter in the QUERY_STRING, regardless of
1047# whether this was a POST or a GET
1048####
1049'url_param' => <<'END_OF_FUNC',
1050sub url_param {
1051 my ($self,@p) = self_or_default(@_);
1052 my $name = shift(@p);
1053 return undef unless exists($ENV{QUERY_STRING});
1054 unless (exists($self->{'.url_param'})) {
1055 $self->{'.url_param'}={}; # empty hash
1056 if ($ENV{QUERY_STRING} =~ /=/) {
71f3e297 1057 my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
424ec8fa
GS		 1058 my($param,$value);
1059 foreach (@pairs) {
1060 ($param,$value) = split('=',$_,2);
1061 $param = unescape($param);
1062 $value = unescape($value);
1063 push(@{$self->{'.url_param'}->{$param}},$value);
1064 }
1065 } else {
1066 $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
1067 }
1068 }
1069 return keys %{$self->{'.url_param'}} unless defined($name);
1070 return () unless $self->{'.url_param'}->{$name};
1071 return wantarray ? @{$self->{'.url_param'}->{$name}}
1072 : $self->{'.url_param'}->{$name}->[0];
1073}
1074END_OF_FUNC
1075
54310121 1076#### Method: dump
1077# Returns a string in which all the known parameter/value
1078# pairs are represented as nested lists, mainly for the purposes
1079# of debugging.
1080####
1081'dump' => <<'END_OF_FUNC',
1082sub dump {
1083 my($self) = self_or_default(@_);
1084 my($param,$value,@result);
1085 return '<UL></UL>' unless $self->param;
1086 push(@result,"<UL>");
1087 foreach $param ($self->param) {
1088 my($name)=$self->escapeHTML($param);
1089 push(@result,"<LI><STRONG>$param</STRONG>");
1090 push(@result,"<UL>");
1091 foreach $value ($self->param($param)) {
1092 $value = $self->escapeHTML($value);
f6b3007c 1093 $value =~ s/\n/<BR>\n/g;
54310121 1094 push(@result,"<LI>$value");
1095 }
1096 push(@result,"</UL>");
1097 }
1098 push(@result,"</UL>\n");
1099 return join("\n",@result);
1100}
1101END_OF_FUNC
1102
424ec8fa
GS		 1103#### Method as_string
1104#
1105# synonym for "dump"
1106####
1107'as_string' => <<'END_OF_FUNC',
1108sub as_string {
1109 &dump(@_);
1110}
1111END_OF_FUNC
1112
1113#### Method: save
1114# Write values out to a filehandle in such a way that they can
1115# be reinitialized by the filehandle form of the new() method
54310121 1116####
1117'save' => <<'END_OF_FUNC',
1118sub save {
1119 my($self,$filehandle) = self_or_default(@_);
54310121 1120 $filehandle = to_filehandle($filehandle);
424ec8fa
GS		 1121 my($param);
1122 local($,) = ''; # set print field separator back to a sane value
71f3e297 1123 local($\) = ''; # set output line separator to a sane value
54310121 1124 foreach $param ($self->param) {
424ec8fa 1125 my($escaped_param) = escape($param);
54310121 1126 my($value);
1127 foreach $value ($self->param($param)) {
f6b3007c 1128 print $filehandle "$escaped_param=",escape("$value"),"\n";
54310121 1129 }
1130 }
1131 print $filehandle "=\n"; # end of record
1132}
1133END_OF_FUNC
1134
1135
424ec8fa
GS		 1136#### Method: save_parameters
1137# An alias for save() that is a better name for exportation.
1138# Only intended to be used with the function (non-OO) interface.
1139####
1140'save_parameters' => <<'END_OF_FUNC',
1141sub save_parameters {
1142 my $fh = shift;
1143 return save(to_filehandle($fh));
1144}
1145END_OF_FUNC
1146
1147#### Method: restore_parameters
1148# A way to restore CGI parameters from an initializer.
1149# Only intended to be used with the function (non-OO) interface.
1150####
1151'restore_parameters' => <<'END_OF_FUNC',
1152sub restore_parameters {
1153 $Q = $CGI::DefaultClass->new(@_);
1154}
1155END_OF_FUNC
1156
1157#### Method: multipart_init
1158# Return a Content-Type: style header for server-push
1159# This has to be NPH, and it is advisable to set $| = 1
1160#
1161# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1162# contribution
1163####
1164'multipart_init' => <<'END_OF_FUNC',
1165sub multipart_init {
1166 my($self,@p) = self_or_default(@_);
1167 my($boundary,@other) = $self->rearrange([BOUNDARY],@p);
1168 $boundary = $boundary || '------- =_aaaaaaaaaa0';
1169 $self->{'separator'} = "\n--$boundary\n";
1170 $type = SERVER_PUSH($boundary);
1171 return $self->header(
1172 -nph => 1,
1173 -type => $type,
1174 (map { split "=", $_, 2 } @other),
1175 ) . $self->multipart_end;
1176}
1177END_OF_FUNC
1178
1179
1180#### Method: multipart_start
1181# Return a Content-Type: style header for server-push, start of section
1182#
1183# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1184# contribution
1185####
1186'multipart_start' => <<'END_OF_FUNC',
1187sub multipart_start {
1188 my($self,@p) = self_or_default(@_);
1189 my($type,@other) = $self->rearrange([TYPE],@p);
1190 $type = $type || 'text/html';
1191 return $self->header(
1192 -type => $type,
1193 (map { split "=", $_, 2 } @other),
1194 );
1195}
1196END_OF_FUNC
1197
1198
1199#### Method: multipart_end
1200# Return a Content-Type: style header for server-push, end of section
1201#
1202# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1203# contribution
1204####
1205'multipart_end' => <<'END_OF_FUNC',
1206sub multipart_end {
1207 my($self,@p) = self_or_default(@_);
1208 return $self->{'separator'};
1209}
1210END_OF_FUNC
1211
1212
54310121 1213#### Method: header
1214# Return a Content-Type: style header
1215#
1216####
1217'header' => <<'END_OF_FUNC',
1218sub header {
1219 my($self,@p) = self_or_default(@_);
1220 my(@header);
1221
71f3e297
JH		 1222 return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
1223
54310121 1224 my($type,$status,$cookie,$target,$expires,$nph,@other) =
71f3e297
JH		 1225 $self->rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
1226 STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
54310121 1227
424ec8fa 1228 $nph ||= $NPH;
54310121 1229 # rearrange() was designed for the HTML portion, so we
1230 # need to fix it up a little.
1231 foreach (@other) {
71f3e297 1232 next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
424ec8fa 1233 ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e;
54310121 1234 }
1235
71f3e297 1236 $type ||= 'text/html' unless defined($type);
54310121 1237
424ec8fa
GS		 1238 # Maybe future compatibility. Maybe not.
1239 my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
1240 push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
1241
54310121 1242 push(@header,"Status: $status") if $status;
424ec8fa 1243 push(@header,"Window-Target: $target") if $target;
54310121 1244 # push all the cookies -- there may be several
1245 if ($cookie) {
424ec8fa 1246 my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
54310121 1247 foreach (@cookie) {
71f3e297
JH		 1248 my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
1249 push(@header,"Set-Cookie: $cs") if $cs ne '';
54310121 1250 }
1251 }
1252 # if the user indicates an expiration time, then we need
1253 # both an Expires and a Date header (so that the browser is
1254 # uses OUR clock)
424ec8fa 1255 push(@header,"Expires: " . expires($expires,'http'))
7d37aa8e 1256 if $expires;
424ec8fa 1257 push(@header,"Date: " . expires(0,'http')) if $expires || $cookie;
54310121 1258 push(@header,"Pragma: no-cache") if $self->cache();
1259 push(@header,@other);
71f3e297 1260 push(@header,"Content-Type: $type") if $type ne '';
54310121 1261
424ec8fa
GS		 1262 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1263 if ($MOD_PERL and not $nph) {
1264 my $r = Apache->request;
1265 $r->send_cgi_header($header);
1266 return '';
1267 }
1268 return $header;
54310121 1269}
1270END_OF_FUNC
1271
1272
1273#### Method: cache
1274# Control whether header() will produce the no-cache
1275# Pragma directive.
1276####
1277'cache' => <<'END_OF_FUNC',
1278sub cache {
1279 my($self,$new_value) = self_or_default(@_);
1280 $new_value = '' unless $new_value;
1281 if ($new_value ne '') {
1282 $self->{'cache'} = $new_value;
1283 }
1284 return $self->{'cache'};
1285}
1286END_OF_FUNC
1287
1288
1289#### Method: redirect
1290# Return a Location: style header
1291#
1292####
1293'redirect' => <<'END_OF_FUNC',
1294sub redirect {
1295 my($self,@p) = self_or_default(@_);
424ec8fa 1296 my($url,$target,$cookie,$nph,@other) = $self->rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p);
54310121 1297 $url = $url || $self->self_url;
1298 my(@o);
424ec8fa
GS		 1299 foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
1300 unshift(@o,
1301 '-Status'=>'302 Moved',
54310121 1302 '-Location'=>$url,
424ec8fa
GS		 1303 '-nph'=>$nph);
1304 unshift(@o,'-Target'=>$target) if $target;
1305 unshift(@o,'-Cookie'=>$cookie) if $cookie;
71f3e297 1306 unshift(@o,'-Type'=>'');
54310121 1307 return $self->header(@o);
1308}
1309END_OF_FUNC
1310
1311
1312#### Method: start_html
1313# Canned HTML header
1314#
1315# Parameters:
1316# $title -> (optional) The title for this HTML document (-title)
1317# $author -> (optional) e-mail address of the author (-author)
1318# $base -> (optional) if set to true, will enter the BASE address of this document
1319# for resolving relative references (-base)
1320# $xbase -> (optional) alternative base at some remote location (-xbase)
1321# $target -> (optional) target window to load all links into (-target)
1322# $script -> (option) Javascript code (-script)
47e3cabd 1323# $no_script -> (option) Javascript <noscript> tag (-noscript)
54310121 1324# $meta -> (optional) Meta information tags
7d37aa8e
LS		 1325# $head -> (optional) any other elements you'd like to incorporate into the <HEAD> tag
1326# (a scalar or array ref)
1327# $style -> (optional) reference to an external style sheet
54310121 1328# @other -> (optional) any other named parameters you'd like to incorporate into
1329# the <BODY> tag.
1330####
1331'start_html' => <<'END_OF_FUNC',
1332sub start_html {
1333 my($self,@p) = &self_or_default(@_);
424ec8fa
GS		 1334 my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,@other) =
1335 $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD],@p);
54310121 1336
1337 # strangely enough, the title needs to be escaped as HTML
1338 # while the author needs to be escaped as a URL
1339 $title = $self->escapeHTML($title || 'Untitled Document');
424ec8fa 1340 $author = $self->escape($author);
54310121 1341 my(@result);
424ec8fa
GS		 1342 $dtd = $DEFAULT_DTD unless $dtd && $dtd =~ m|^-//|;
1343 push(@result,qq(<!DOCTYPE HTML PUBLIC "$dtd">)) if $dtd;
54310121 1344 push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
424ec8fa 1345 push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if defined $author;
54310121 1346
1347 if ($base || $xbase || $target) {
424ec8fa 1348 my $href = $xbase || $self->url('-path'=>1);
54310121 1349 my $t = $target ? qq/ TARGET="$target"/ : '';
1350 push(@result,qq/<BASE HREF="$href"$t>/);
1351 }
1352
1353 if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
1354 foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
1355 }
7d37aa8e
LS		 1356
1357 push(@result,ref($head) ? @$head : $head) if $head;
1358
424ec8fa
GS		 1359 # handle the infrequently-used -style and -script parameters
1360 push(@result,$self->_style($style)) if defined $style;
1361 push(@result,$self->_script($script)) if defined $script;
1362
1363 # handle -noscript parameter
1364 push(@result,<<END) if $noscript;
1365<NOSCRIPT>
1366$noscript
1367</NOSCRIPT>
1368END
1369 ;
1370 my($other) = @other ? " @other" : '';
1371 push(@result,"</HEAD><BODY$other>");
1372 return join("\n",@result);
1373}
1374END_OF_FUNC
1375
1376### Method: _style
1377# internal method for generating a CSS style section
1378####
1379'_style' => <<'END_OF_FUNC',
1380sub _style {
1381 my ($self,$style) = @_;
1382 my (@result);
1383 my $type = 'text/css';
1384 if (ref($style)) {
1385 my($src,$code,$stype,@other) =
1386 $self->rearrange([SRC,CODE,TYPE],
1387 '-foo'=>'bar', # a trick to allow the '-' to be omitted
1388 ref($style) eq 'ARRAY' ? @$style : %$style);
1389 $type = $stype if $stype;
f6b3007c 1390 push(@result,qq/<LINK REL="stylesheet" TYPE="$type" HREF="$src">/) if $src;
424ec8fa
GS		 1391 push(@result,style({'type'=>$type},"<!--\n$code\n-->")) if $code;
1392 } else {
1393 push(@result,style({'type'=>$type},"<!--\n$style\n-->"));
7d37aa8e 1394 }
424ec8fa
GS		 1395 @result;
1396}
1397END_OF_FUNC
1398
7d37aa8e 1399
424ec8fa
GS		 1400'_script' => <<'END_OF_FUNC',
1401sub _script {
1402 my ($self,$script) = @_;
1403 my (@result);
1404 my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
1405 foreach $script (@scripts) {
7d37aa8e
LS		 1406 my($src,$code,$language);
1407 if (ref($script)) { # script is a hash
1408 ($src,$code,$language) =
1409 $self->rearrange([SRC,CODE,LANGUAGE],
1410 '-foo'=>'bar', # a trick to allow the '-' to be omitted
f6b3007c 1411 ref($script) eq 'ARRAY' ? @$script : %$script);
424ec8fa 1412
7d37aa8e
LS		 1413 } else {
1414 ($src,$code,$language) = ('',$script,'JavaScript');
1415 }
1416 my(@satts);
1417 push(@satts,'src'=>$src) if $src;
1418 push(@satts,'language'=>$language || 'JavaScript');
1419 $code = "<!-- Hide script\n$code\n// End script hiding -->"
1420 if $code && $language=~/javascript/i;
1421 $code = "<!-- Hide script\n$code\n\# End script hiding -->"
1422 if $code && $language=~/perl/i;
f6b3007c 1423 push(@result,script({@satts},$code || ''));
7d37aa8e 1424 }
424ec8fa 1425 @result;
54310121 1426}
1427END_OF_FUNC
1428
54310121 1429#### Method: end_html
1430# End an HTML document.
1431# Trivial method for completeness. Just returns "</BODY>"
1432####
1433'end_html' => <<'END_OF_FUNC',
1434sub end_html {
1435 return "</BODY></HTML>";
1436}
1437END_OF_FUNC
1438
1439
1440################################
1441# METHODS USED IN BUILDING FORMS
1442################################
1443
1444#### Method: isindex
1445# Just prints out the isindex tag.
1446# Parameters:
1447# $action -> optional URL of script to run
1448# Returns:
1449# A string containing a <ISINDEX> tag
1450'isindex' => <<'END_OF_FUNC',
1451sub isindex {
1452 my($self,@p) = self_or_default(@_);
1453 my($action,@other) = $self->rearrange([ACTION],@p);
1454 $action = qq/ACTION="$action"/ if $action;
1455 my($other) = @other ? " @other" : '';
1456 return "<ISINDEX $action$other>";
1457}
1458END_OF_FUNC
1459
1460
1461#### Method: startform
1462# Start a form
1463# Parameters:
1464# $method -> optional submission method to use (GET or POST)
1465# $action -> optional URL of script to run
1466# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1467'startform' => <<'END_OF_FUNC',
1468sub startform {
1469 my($self,@p) = self_or_default(@_);
1470
1471 my($method,$action,$enctype,@other) =
1472 $self->rearrange([METHOD,ACTION,ENCTYPE],@p);
1473
1474 $method = $method || 'POST';
1475 $enctype = $enctype || &URL_ENCODED;
1476 $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
1477 'ACTION="'.$self->script_name.'"' : '';
1478 my($other) = @other ? " @other" : '';
1479 $self->{'.parametersToAdd'}={};
1480 return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
1481}
1482END_OF_FUNC
1483
1484
1485#### Method: start_form
1486# synonym for startform
1487'start_form' => <<'END_OF_FUNC',
1488sub start_form {
1489 &startform;
1490}
1491END_OF_FUNC
1492
71f3e297
JH		 1493'end_multipart_form' => <<'END_OF_FUNC',
1494sub end_multipart_form {
1495 &endform;
1496}
1497END_OF_FUNC
54310121 1498
1499#### Method: start_multipart_form
1500# synonym for startform
1501'start_multipart_form' => <<'END_OF_FUNC',
1502sub start_multipart_form {
1503 my($self,@p) = self_or_default(@_);
1504 if ($self->use_named_parameters ||
1505 (defined($param[0]) && substr($param[0],0,1) eq '-')) {
1506 my(%p) = @p;
1507 $p{'-enctype'}=&MULTIPART;
1508 return $self->startform(%p);
1509 } else {
1510 my($method,$action,@other) =
1511 $self->rearrange([METHOD,ACTION],@p);
1512 return $self->startform($method,$action,&MULTIPART,@other);
1513 }
1514}
1515END_OF_FUNC
1516
1517
1518#### Method: endform
1519# End a form
1520'endform' => <<'END_OF_FUNC',
1521sub endform {
1522 my($self,@p) = self_or_default(@_);
1523 return ($self->get_fields,"</FORM>");
1524}
1525END_OF_FUNC
1526
1527
1528#### Method: end_form
1529# synonym for endform
1530'end_form' => <<'END_OF_FUNC',
1531sub end_form {
1532 &endform;
1533}
1534END_OF_FUNC
1535
1536
424ec8fa
GS		 1537'_textfield' => <<'END_OF_FUNC',
1538sub _textfield {
1539 my($self,$tag,@p) = self_or_default(@_);
1540 my($name,$default,$size,$maxlength,$override,@other) =
1541 $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1542
1543 my $current = $override ? $default :
1544 (defined($self->param($name)) ? $self->param($name) : $default);
1545
1546 $current = defined($current) ? $self->escapeHTML($current) : '';
1547 $name = defined($name) ? $self->escapeHTML($name) : '';
1548 my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1549 my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
71f3e297
JH		 1550 my($other) = @other ? " @other" : '';
1551 # this entered at cristy's request to fix problems with file upload fields
1552 # and WebTV -- not sure it won't break stuff
1553 my($value) = $current ne '' ? qq(VALUE="$current") : '';
1554 return qq/<INPUT TYPE="$tag" NAME="$name" $value$s$m$other>/;
424ec8fa
GS		 1555}
1556END_OF_FUNC
1557
54310121 1558#### Method: textfield
1559# Parameters:
1560# $name -> Name of the text field
1561# $default -> Optional default value of the field if not
1562# already defined.
1563# $size -> Optional width of field in characaters.
1564# $maxlength -> Optional maximum number of characters.
1565# Returns:
1566# A string containing a <INPUT TYPE="text"> field
1567#
1568'textfield' => <<'END_OF_FUNC',
1569sub textfield {
1570 my($self,@p) = self_or_default(@_);
424ec8fa 1571 $self->_textfield('text',@p);
54310121 1572}
1573END_OF_FUNC
1574
1575
1576#### Method: filefield
1577# Parameters:
1578# $name -> Name of the file upload field
1579# $size -> Optional width of field in characaters.
1580# $maxlength -> Optional maximum number of characters.
1581# Returns:
1582# A string containing a <INPUT TYPE="text"> field
1583#
1584'filefield' => <<'END_OF_FUNC',
1585sub filefield {
1586 my($self,@p) = self_or_default(@_);
424ec8fa 1587 $self->_textfield('file',@p);
54310121 1588}
1589END_OF_FUNC
1590
1591
1592#### Method: password
1593# Create a "secret password" entry field
1594# Parameters:
1595# $name -> Name of the field
1596# $default -> Optional default value of the field if not
1597# already defined.
1598# $size -> Optional width of field in characters.
1599# $maxlength -> Optional maximum characters that can be entered.
1600# Returns:
1601# A string containing a <INPUT TYPE="password"> field
1602#
1603'password_field' => <<'END_OF_FUNC',
1604sub password_field {
1605 my ($self,@p) = self_or_default(@_);
424ec8fa 1606 $self->_textfield('password',@p);
54310121 1607}
1608END_OF_FUNC
1609
54310121 1610#### Method: textarea
1611# Parameters:
1612# $name -> Name of the text field
1613# $default -> Optional default value of the field if not
1614# already defined.
1615# $rows -> Optional number of rows in text area
1616# $columns -> Optional number of columns in text area
1617# Returns:
1618# A string containing a <TEXTAREA></TEXTAREA> tag
1619#
1620'textarea' => <<'END_OF_FUNC',
1621sub textarea {
1622 my($self,@p) = self_or_default(@_);
1623
1624 my($name,$default,$rows,$cols,$override,@other) =
1625 $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
1626
1627 my($current)= $override ? $default :
1628 (defined($self->param($name)) ? $self->param($name) : $default);
1629
1630 $name = defined($name) ? $self->escapeHTML($name) : '';
1631 $current = defined($current) ? $self->escapeHTML($current) : '';
1632 my($r) = $rows ? " ROWS=$rows" : '';
1633 my($c) = $cols ? " COLS=$cols" : '';
1634 my($other) = @other ? " @other" : '';
1635 return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
1636}
1637END_OF_FUNC
1638
1639
1640#### Method: button
1641# Create a javascript button.
1642# Parameters:
1643# $name -> (optional) Name for the button. (-name)
1644# $value -> (optional) Value of the button when selected (and visible name) (-value)
1645# $onclick -> (optional) Text of the JavaScript to run when the button is
1646# clicked.
1647# Returns:
1648# A string containing a <INPUT TYPE="button"> tag
1649####
1650'button' => <<'END_OF_FUNC',
1651sub button {
1652 my($self,@p) = self_or_default(@_);
1653
1654 my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
1655 [ONCLICK,SCRIPT]],@p);
1656
1657 $label=$self->escapeHTML($label);
1658 $value=$self->escapeHTML($value);
1659 $script=$self->escapeHTML($script);
1660
1661 my($name) = '';
1662 $name = qq/ NAME="$label"/ if $label;
1663 $value = $value || $label;
1664 my($val) = '';
1665 $val = qq/ VALUE="$value"/ if $value;
1666 $script = qq/ ONCLICK="$script"/ if $script;
1667 my($other) = @other ? " @other" : '';
1668 return qq/<INPUT TYPE="button"$name$val$script$other>/;
1669}
1670END_OF_FUNC
1671
1672
1673#### Method: submit
1674# Create a "submit query" button.
1675# Parameters:
1676# $name -> (optional) Name for the button.
1677# $value -> (optional) Value of the button when selected (also doubles as label).
1678# $label -> (optional) Label printed on the button(also doubles as the value).
1679# Returns:
1680# A string containing a <INPUT TYPE="submit"> tag
1681####
1682'submit' => <<'END_OF_FUNC',
1683sub submit {
1684 my($self,@p) = self_or_default(@_);
1685
1686 my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p);
1687
1688 $label=$self->escapeHTML($label);
1689 $value=$self->escapeHTML($value);
1690
1691 my($name) = ' NAME=".submit"';
424ec8fa
GS		 1692 $name = qq/ NAME="$label"/ if defined($label);
1693 $value = defined($value) ? $value : $label;
54310121 1694 my($val) = '';
1695 $val = qq/ VALUE="$value"/ if defined($value);
1696 my($other) = @other ? " @other" : '';
1697 return qq/<INPUT TYPE="submit"$name$val$other>/;
1698}
1699END_OF_FUNC
1700
1701
1702#### Method: reset
1703# Create a "reset" button.
1704# Parameters:
1705# $name -> (optional) Name for the button.
1706# Returns:
1707# A string containing a <INPUT TYPE="reset"> tag
1708####
1709'reset' => <<'END_OF_FUNC',
1710sub reset {
1711 my($self,@p) = self_or_default(@_);
1712 my($label,@other) = $self->rearrange([NAME],@p);
1713 $label=$self->escapeHTML($label);
1714 my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
1715 my($other) = @other ? " @other" : '';
1716 return qq/<INPUT TYPE="reset"$value$other>/;
1717}
1718END_OF_FUNC
1719
1720
1721#### Method: defaults
1722# Create a "defaults" button.
1723# Parameters:
1724# $name -> (optional) Name for the button.
1725# Returns:
1726# A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
1727#
1728# Note: this button has a special meaning to the initialization script,
1729# and tells it to ERASE the current query string so that your defaults
1730# are used again!
1731####
1732'defaults' => <<'END_OF_FUNC',
1733sub defaults {
1734 my($self,@p) = self_or_default(@_);
1735
1736 my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
1737
1738 $label=$self->escapeHTML($label);
1739 $label = $label || "Defaults";
1740 my($value) = qq/ VALUE="$label"/;
1741 my($other) = @other ? " @other" : '';
1742 return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
1743}
1744END_OF_FUNC
1745
1746
424ec8fa
GS		 1747#### Method: comment
1748# Create an HTML <!-- comment -->
1749# Parameters: a string
1750'comment' => <<'END_OF_FUNC',
1751sub comment {
1752 my($self,@p) = self_or_CGI(@_);
1753 return "<!-- @p -->";
1754}
1755END_OF_FUNC
1756
54310121 1757#### Method: checkbox
1758# Create a checkbox that is not logically linked to any others.
1759# The field value is "on" when the button is checked.
1760# Parameters:
1761# $name -> Name of the checkbox
1762# $checked -> (optional) turned on by default if true
1763# $value -> (optional) value of the checkbox, 'on' by default
1764# $label -> (optional) a user-readable label printed next to the box.
1765# Otherwise the checkbox name is used.
1766# Returns:
1767# A string containing a <INPUT TYPE="checkbox"> field
1768####
1769'checkbox' => <<'END_OF_FUNC',
1770sub checkbox {
1771 my($self,@p) = self_or_default(@_);
1772
1773 my($name,$checked,$value,$label,$override,@other) =
1774 $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
1775
424ec8fa
GS		 1776 $value = defined $value ? $value : 'on';
1777
1778 if (!$override && ($self->{'.fieldnames'}->{$name} ||
1779 defined $self->param($name))) {
1780 $checked = grep($_ eq $value,$self->param($name)) ? ' CHECKED' : '';
54310121 1781 } else {
1782 $checked = $checked ? ' CHECKED' : '';
54310121 1783 }
1784 my($the_label) = defined $label ? $label : $name;
1785 $name = $self->escapeHTML($name);
1786 $value = $self->escapeHTML($value);
1787 $the_label = $self->escapeHTML($the_label);
1788 my($other) = @other ? " @other" : '';
1789 $self->register_parameter($name);
f6b3007c 1790 return qq{<INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label};
54310121 1791}
1792END_OF_FUNC
1793
1794
1795#### Method: checkbox_group
1796# Create a list of logically-linked checkboxes.
1797# Parameters:
1798# $name -> Common name for all the check boxes
1799# $values -> A pointer to a regular array containing the
1800# values for each checkbox in the group.
1801# $defaults -> (optional)
1802# 1. If a pointer to a regular array of checkbox values,
1803# then this will be used to decide which
1804# checkboxes to turn on by default.
1805# 2. If a scalar, will be assumed to hold the
1806# value of a single checkbox in the group to turn on.
1807# $linebreak -> (optional) Set to true to place linebreaks
1808# between the buttons.
1809# $labels -> (optional)
1810# A pointer to an associative array of labels to print next to each checkbox
1811# in the form $label{'value'}="Long explanatory label".
1812# Otherwise the provided values are used as the labels.
1813# Returns:
1814# An ARRAY containing a series of <INPUT TYPE="checkbox"> fields
1815####
1816'checkbox_group' => <<'END_OF_FUNC',
1817sub checkbox_group {
1818 my($self,@p) = self_or_default(@_);
1819
1820 my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
1821 $rowheaders,$colheaders,$override,$nolabels,@other) =
1822 $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1823 LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
1824 ROWHEADERS,COLHEADERS,
1825 [OVERRIDE,FORCE],NOLABELS],@p);
1826
1827 my($checked,$break,$result,$label);
1828
1829 my(%checked) = $self->previous_or_default($name,$defaults,$override);
1830
1831 $break = $linebreak ? "<BR>" : '';
1832 $name=$self->escapeHTML($name);
1833
1834 # Create the elements
424ec8fa
GS		 1835 my(@elements,@values);
1836
1837 @values = $self->_set_values_and_labels($values,\$labels,$name);
1838
54310121 1839 my($other) = @other ? " @other" : '';
1840 foreach (@values) {
1841 $checked = $checked{$_} ? ' CHECKED' : '';
1842 $label = '';
1843 unless (defined($nolabels) && $nolabels) {
1844 $label = $_;
424ec8fa 1845 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
54310121 1846 $label = $self->escapeHTML($label);
1847 }
1848 $_ = $self->escapeHTML($_);
424ec8fa 1849 push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label}${break}/);
54310121 1850 }
1851 $self->register_parameter($name);
424ec8fa
GS		 1852 return wantarray ? @elements : join(' ',@elements)
1853 unless defined($columns) || defined($rows);
54310121 1854 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1855}
1856END_OF_FUNC
1857
54310121 1858# Escape HTML -- used internally
1859'escapeHTML' => <<'END_OF_FUNC',
1860sub escapeHTML {
f6b3007c 1861 my ($self,$toencode) = self_or_default(@_);
54310121 1862 return undef unless defined($toencode);
424ec8fa
GS		 1863 return $toencode if ref($self) && $self->{'dontescape'};
1864
54310121 1865 $toencode=~s/&/&amp;/g;
1866 $toencode=~s/\"/&quot;/g;
1867 $toencode=~s/>/&gt;/g;
1868 $toencode=~s/</&lt;/g;
1869 return $toencode;
1870}
1871END_OF_FUNC
1872
424ec8fa
GS		 1873# unescape HTML -- used internally
1874'unescapeHTML' => <<'END_OF_FUNC',
1875sub unescapeHTML {
1876 my $string = ref($_[0]) ? $_[1] : $_[0];
1877 return undef unless defined($string);
71f3e297
JH		 1878 # thanks to Randal Schwartz for the correct solution to this one
1879 $string=~ s[&(.*?);]{
1880 local $_ = $1;
1881 /^amp$/i ? "&" :
1882 /^quot$/i ? '"' :
1883 /^gt$/i ? ">" :
1884 /^lt$/i ? "<" :
1885 /^#(\d+)$/ ? chr($1) :
1886 /^#x([0-9a-f]+)$/i ? chr(hex($1)) :
1887 $_
1888 }gex;
424ec8fa
GS		 1889 return $string;
1890}
1891END_OF_FUNC
54310121 1892
1893# Internal procedure - don't use
1894'_tableize' => <<'END_OF_FUNC',
1895sub _tableize {
1896 my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
1897 my($result);
1898
424ec8fa
GS		 1899 if (defined($columns)) {
1900 $rows = int(0.99 + @elements/$columns) unless defined($rows);
1901 }
1902 if (defined($rows)) {
1903 $columns = int(0.99 + @elements/$rows) unless defined($columns);
1904 }
1905
54310121 1906 # rearrange into a pretty table
1907 $result = "<TABLE>";
1908 my($row,$column);
2c2d71f5
JH		 1909 unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
1910 $result .= "<TR>" if @$colheaders;
54310121 1911 foreach (@{$colheaders}) {
1912 $result .= "<TH>$_</TH>";
1913 }
1914 for ($row=0;$row<$rows;$row++) {
1915 $result .= "<TR>";
2c2d71f5 1916 $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
54310121 1917 for ($column=0;$column<$columns;$column++) {
424ec8fa
GS		 1918 $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>"
1919 if defined($elements[$column*$rows + $row]);
54310121 1920 }
1921 $result .= "</TR>";
1922 }
1923 $result .= "</TABLE>";
1924 return $result;
1925}
1926END_OF_FUNC
1927
1928
1929#### Method: radio_group
1930# Create a list of logically-linked radio buttons.
1931# Parameters:
1932# $name -> Common name for all the buttons.
1933# $values -> A pointer to a regular array containing the
1934# values for each button in the group.
1935# $default -> (optional) Value of the button to turn on by default. Pass '-'
1936# to turn _nothing_ on.
1937# $linebreak -> (optional) Set to true to place linebreaks
1938# between the buttons.
1939# $labels -> (optional)
1940# A pointer to an associative array of labels to print next to each checkbox
1941# in the form $label{'value'}="Long explanatory label".
1942# Otherwise the provided values are used as the labels.
1943# Returns:
1944# An ARRAY containing a series of <INPUT TYPE="radio"> fields
1945####
1946'radio_group' => <<'END_OF_FUNC',
1947sub radio_group {
1948 my($self,@p) = self_or_default(@_);
1949
1950 my($name,$values,$default,$linebreak,$labels,
1951 $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
1952 $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
1953 ROWS,[COLUMNS,COLS],
1954 ROWHEADERS,COLHEADERS,
1955 [OVERRIDE,FORCE],NOLABELS],@p);
1956 my($result,$checked);
1957
1958 if (!$override && defined($self->param($name))) {
1959 $checked = $self->param($name);
1960 } else {
1961 $checked = $default;
1962 }
424ec8fa 1963 my(@elements,@values);
424ec8fa
GS		 1964 @values = $self->_set_values_and_labels($values,\$labels,$name);
1965
71f3e297
JH		 1966 # If no check array is specified, check the first by default
1967 $checked = $values[0] unless defined($checked) && $checked ne '';
1968 $name=$self->escapeHTML($name);
1969
54310121 1970 my($other) = @other ? " @other" : '';
1971 foreach (@values) {
1972 my($checkit) = $checked eq $_ ? ' CHECKED' : '';
1973 my($break) = $linebreak ? '<BR>' : '';
1974 my($label)='';
1975 unless (defined($nolabels) && $nolabels) {
1976 $label = $_;
424ec8fa 1977 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
54310121 1978 $label = $self->escapeHTML($label);
1979 }
1980 $_=$self->escapeHTML($_);
424ec8fa 1981 push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label}${break}/);
54310121 1982 }
1983 $self->register_parameter($name);
424ec8fa
GS		 1984 return wantarray ? @elements : join(' ',@elements)
1985 unless defined($columns) || defined($rows);
54310121 1986 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1987}
1988END_OF_FUNC
1989
1990
1991#### Method: popup_menu
1992# Create a popup menu.
1993# Parameters:
1994# $name -> Name for all the menu
1995# $values -> A pointer to a regular array containing the
1996# text of each menu item.
1997# $default -> (optional) Default item to display
1998# $labels -> (optional)
1999# A pointer to an associative array of labels to print next to each checkbox
2000# in the form $label{'value'}="Long explanatory label".
2001# Otherwise the provided values are used as the labels.
2002# Returns:
2003# A string containing the definition of a popup menu.
2004####
2005'popup_menu' => <<'END_OF_FUNC',
2006sub popup_menu {
2007 my($self,@p) = self_or_default(@_);
2008
2009 my($name,$values,$default,$labels,$override,@other) =
2010 $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
2011 my($result,$selected);
2012
2013 if (!$override && defined($self->param($name))) {
2014 $selected = $self->param($name);
2015 } else {
2016 $selected = $default;
2017 }
2018 $name=$self->escapeHTML($name);
2019 my($other) = @other ? " @other" : '';
2020
424ec8fa
GS		 2021 my(@values);
2022 @values = $self->_set_values_and_labels($values,\$labels,$name);
2023
54310121 2024 $result = qq/<SELECT NAME="$name"$other>\n/;
2025 foreach (@values) {
2026 my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
2027 my($label) = $_;
424ec8fa 2028 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
54310121 2029 my($value) = $self->escapeHTML($_);
2030 $label=$self->escapeHTML($label);
2031 $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
2032 }
2033
2034 $result .= "</SELECT>\n";
2035 return $result;
2036}
2037END_OF_FUNC
2038
2039
2040#### Method: scrolling_list
2041# Create a scrolling list.
2042# Parameters:
2043# $name -> name for the list
2044# $values -> A pointer to a regular array containing the
2045# values for each option line in the list.
2046# $defaults -> (optional)
2047# 1. If a pointer to a regular array of options,
2048# then this will be used to decide which
2049# lines to turn on by default.
2050# 2. Otherwise holds the value of the single line to turn on.
2051# $size -> (optional) Size of the list.
2052# $multiple -> (optional) If set, allow multiple selections.
2053# $labels -> (optional)
2054# A pointer to an associative array of labels to print next to each checkbox
2055# in the form $label{'value'}="Long explanatory label".
2056# Otherwise the provided values are used as the labels.
2057# Returns:
2058# A string containing the definition of a scrolling list.
2059####
2060'scrolling_list' => <<'END_OF_FUNC',
2061sub scrolling_list {
2062 my($self,@p) = self_or_default(@_);
2063 my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
2064 = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
2065 SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
2066
424ec8fa
GS		 2067 my($result,@values);
2068 @values = $self->_set_values_and_labels($values,\$labels,$name);
2069
54310121 2070 $size = $size || scalar(@values);
2071
2072 my(%selected) = $self->previous_or_default($name,$defaults,$override);
2073 my($is_multiple) = $multiple ? ' MULTIPLE' : '';
2074 my($has_size) = $size ? " SIZE=$size" : '';
2075 my($other) = @other ? " @other" : '';
2076
2077 $name=$self->escapeHTML($name);
2078 $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
2079 foreach (@values) {
2080 my($selectit) = $selected{$_} ? 'SELECTED' : '';
2081 my($label) = $_;
424ec8fa 2082 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
54310121 2083 $label=$self->escapeHTML($label);
2084 my($value)=$self->escapeHTML($_);
2085 $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
2086 }
2087 $result .= "</SELECT>\n";
2088 $self->register_parameter($name);
2089 return $result;
2090}
2091END_OF_FUNC
2092
2093
2094#### Method: hidden
2095# Parameters:
2096# $name -> Name of the hidden field
2097# @default -> (optional) Initial values of field (may be an array)
2098# or
2099# $default->[initial values of field]
2100# Returns:
2101# A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
2102####
2103'hidden' => <<'END_OF_FUNC',
2104sub hidden {
2105 my($self,@p) = self_or_default(@_);
2106
2107 # this is the one place where we departed from our standard
2108 # calling scheme, so we have to special-case (darn)
2109 my(@result,@value);
2110 my($name,$default,$override,@other) =
2111 $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
2112
2113 my $do_override = 0;
424ec8fa 2114 if ( ref($p[0]) || substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
54310121 2115 @value = ref($default) ? @{$default} : $default;
2116 $do_override = $override;
2117 } else {
2118 foreach ($default,$override,@other) {
2119 push(@value,$_) if defined($_);
2120 }
2121 }
2122
2123 # use previous values if override is not set
2124 my @prev = $self->param($name);
2125 @value = @prev if !$do_override && @prev;
2126
2127 $name=$self->escapeHTML($name);
2128 foreach (@value) {
2129 $_=$self->escapeHTML($_);
2130 push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
2131 }
2132 return wantarray ? @result : join('',@result);
2133}
2134END_OF_FUNC
2135
2136
2137#### Method: image_button
2138# Parameters:
2139# $name -> Name of the button
2140# $src -> URL of the image source
2141# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
2142# Returns:
2143# A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment">
2144####
2145'image_button' => <<'END_OF_FUNC',
2146sub image_button {
2147 my($self,@p) = self_or_default(@_);
2148
2149 my($name,$src,$alignment,@other) =
2150 $self->rearrange([NAME,SRC,ALIGN],@p);
2151
2152 my($align) = $alignment ? " ALIGN=\U$alignment" : '';
2153 my($other) = @other ? " @other" : '';
2154 $name=$self->escapeHTML($name);
2155 return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/;
2156}
2157END_OF_FUNC
2158
2159
2160#### Method: self_url
2161# Returns a URL containing the current script and all its
2162# param/value pairs arranged as a query. You can use this
2163# to create a link that, when selected, will reinvoke the
2164# script with all its state information preserved.
2165####
2166'self_url' => <<'END_OF_FUNC',
2167sub self_url {
424ec8fa
GS		 2168 my($self,@p) = self_or_default(@_);
2169 return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
54310121 2170}
2171END_OF_FUNC
2172
2173
2174# This is provided as a synonym to self_url() for people unfortunate
2175# enough to have incorporated it into their programs already!
2176'state' => <<'END_OF_FUNC',
2177sub state {
2178 &self_url;
2179}
2180END_OF_FUNC
2181
2182
2183#### Method: url
2184# Like self_url, but doesn't return the query string part of
2185# the URL.
2186####
2187'url' => <<'END_OF_FUNC',
2188sub url {
424ec8fa
GS		 2189 my($self,@p) = self_or_default(@_);
2190 my ($relative,$absolute,$full,$path_info,$query) =
2191 $self->rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING']],@p);
2192 my $url;
2193 $full++ if !($relative || $absolute);
2194
f6b3007c
JH		 2195 my $path = $self->path_info;
2196 my $script_name;
2197 if (exists($ENV{REQUEST_URI})) {
2198 my $index;
2199 $script_name = $ENV{REQUEST_URI};
2200 # strip query string
2201 substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0;
2202 # and path
2203 substr($script_name,$index) = '' if $path and ($index = rindex($script_name,$path)) >= 0;
2204 } else {
2205 $script_name = $self->script_name;
2206 }
2207
424ec8fa
GS		 2208 if ($full) {
2209 my $protocol = $self->protocol();
2210 $url = "$protocol://";
2211 my $vh = http('host');
2212 if ($vh) {
2213 $url .= $vh;
2214 } else {
2215 $url .= server_name();
2216 my $port = $self->server_port;
2217 $url .= ":" . $port
2218 unless (lc($protocol) eq 'http' && $port == 80)
2219 || (lc($protocol) eq 'https' && $port == 443);
2220 }
f6b3007c 2221 $url .= $script_name;
424ec8fa 2222 } elsif ($relative) {
f6b3007c 2223 ($url) = $script_name =~ m!([^/]+)$!;
424ec8fa 2224 } elsif ($absolute) {
f6b3007c 2225 $url = $script_name;
424ec8fa 2226 }
f6b3007c 2227 $url .= $path if $path_info and defined $path;
424ec8fa
GS		 2228 $url .= "?" . $self->query_string if $query and $self->query_string;
2229 return $url;
54310121 2230}
2231
2232END_OF_FUNC
2233
2234#### Method: cookie
2235# Set or read a cookie from the specified name.
2236# Cookie can then be passed to header().
2237# Usual rules apply to the stickiness of -value.
2238# Parameters:
2239# -name -> name for this cookie (optional)
2240# -value -> value of this cookie (scalar, array or hash)
2241# -path -> paths for which this cookie is valid (optional)
2242# -domain -> internet domain in which this cookie is valid (optional)
2243# -secure -> if true, cookie only passed through secure channel (optional)
7d37aa8e 2244# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
54310121 2245####
2246'cookie' => <<'END_OF_FUNC',
54310121 2247sub cookie {
2248 my($self,@p) = self_or_default(@_);
2249 my($name,$value,$path,$domain,$secure,$expires) =
2250 $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
2251
424ec8fa 2252 require CGI::Cookie;
54310121 2253
2254 # if no value is supplied, then we retrieve the
2255 # value of the cookie, if any. For efficiency, we cache the parsed
424ec8fa
GS		 2256 # cookies in our state variables.
2257 unless ( defined($value) ) {
2258 $self->{'.cookies'} = CGI::Cookie->fetch
2259 unless $self->{'.cookies'};
54310121 2260
2261 # If no name is supplied, then retrieve the names of all our cookies.
2262 return () unless $self->{'.cookies'};
424ec8fa
GS		 2263 return keys %{$self->{'.cookies'}} unless $name;
2264 return () unless $self->{'.cookies'}->{$name};
2265 return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
54310121 2266 }
54310121 2267
424ec8fa
GS		 2268 # If we get here, we're creating a new cookie
2269 return undef unless $name; # this is an error
54310121 2270
424ec8fa
GS		 2271 my @param;
2272 push(@param,'-name'=>$name);
2273 push(@param,'-value'=>$value);
2274 push(@param,'-domain'=>$domain) if $domain;
2275 push(@param,'-path'=>$path) if $path;
2276 push(@param,'-expires'=>$expires) if $expires;
2277 push(@param,'-secure'=>$secure) if $secure;
54310121 2278
424ec8fa 2279 return new CGI::Cookie(@param);
54310121 2280}
2281END_OF_FUNC
2282
7d37aa8e
LS		 2283# This internal routine creates an expires time exactly some number of
2284# hours from the current time. It incorporates modifications from
424ec8fa 2285# Mark Fisher.
7d37aa8e
LS		 2286'expire_calc' => <<'END_OF_FUNC',
2287sub expire_calc {
54310121 2288 my($time) = @_;
54310121 2289 my(%mult) = ('s'=>1,
7d37aa8e
LS		 2290 'm'=>60,
2291 'h'=>60*60,
2292 'd'=>60*60*24,
2293 'M'=>60*60*24*30,
2294 'y'=>60*60*24*365);
54310121 2295 # format for time can be in any of the forms...
2296 # "now" -- expire immediately
2297 # "+180s" -- in 180 seconds
2298 # "+2m" -- in 2 minutes
2299 # "+12h" -- in 12 hours
2300 # "+1d" -- in 1 day
2301 # "+3M" -- in 3 months
2302 # "+2y" -- in 2 years
2303 # "-3m" -- 3 minutes ago(!)
2304 # If you don't supply one of these forms, we assume you are
2305 # specifying the date yourself
2306 my($offset);
424ec8fa 2307 if (!$time || (lc($time) eq 'now')) {
7d37aa8e 2308 $offset = 0;
f6b3007c
JH		 2309 } elsif ($time=~/^\d+/) {
2310 return $time;
424ec8fa 2311 } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
7d37aa8e 2312 $offset = ($mult{$2} || 1)*$1;
54310121 2313 } else {
7d37aa8e 2314 return $time;
54310121 2315 }
7d37aa8e 2316 return (time+$offset);
54310121 2317}
2318END_OF_FUNC
2319
7d37aa8e
LS		 2320# This internal routine creates date strings suitable for use in
2321# cookies and HTTP headers. (They differ, unfortunately.)
f6b3007c 2322# Thanks to Mark Fisher for this.
424ec8fa
GS		 2323'expires' => <<'END_OF_FUNC',
2324sub expires {
7d37aa8e 2325 my($time,$format) = @_;
424ec8fa
GS		 2326 $format ||= 'http';
2327
7d37aa8e
LS		 2328 my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
2329 my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
2330
2331 # pass through preformatted dates for the sake of expire_calc()
424ec8fa
GS		 2332 $time = expire_calc($time);
2333 return $time unless $time =~ /^\d+$/;
7d37aa8e
LS		 2334
2335 # make HTTP/cookie date string from GMT'ed time
2336 # (cookies use '-' as date separator, HTTP uses ' ')
2337 my($sc) = ' ';
2338 $sc = '-' if $format eq "cookie";
2339 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
2340 $year += 1900;
2341 return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
2342 $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
2343}
2344END_OF_FUNC
54310121 2345
424ec8fa
GS		 2346'parse_keywordlist' => <<'END_OF_FUNC',
2347sub parse_keywordlist {
2348 my($self,$tosplit) = @_;
2349 $tosplit = unescape($tosplit); # unescape the keywords
2350 $tosplit=~tr/+/ /; # pluses to spaces
2351 my(@keywords) = split(/\s+/,$tosplit);
2352 return @keywords;
2353}
2354END_OF_FUNC
2355
2356'param_fetch' => <<'END_OF_FUNC',
2357sub param_fetch {
2358 my($self,@p) = self_or_default(@_);
2359 my($name) = $self->rearrange([NAME],@p);
2360 unless (exists($self->{$name})) {
2361 $self->add_parameter($name);
2362 $self->{$name} = [];
2363 }
2364
2365 return $self->{$name};
2366}
2367END_OF_FUNC
2368
54310121 2369###############################################
2370# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
2371###############################################
2372
2373#### Method: path_info
2374# Return the extra virtual path information provided
2375# after the URL (if any)
2376####
2377'path_info' => <<'END_OF_FUNC',
2378sub path_info {
424ec8fa
GS		 2379 my ($self,$info) = self_or_default(@_);
2380 if (defined($info)) {
2381 $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
2382 $self->{'.path_info'} = $info;
2383 } elsif (! defined($self->{'.path_info'}) ) {
2384 $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ?
2385 $ENV{'PATH_INFO'} : '';
2386
2387 # hack to fix broken path info in IIS
2388 $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
2389
2390 }
2391 return $self->{'.path_info'};
54310121 2392}
2393END_OF_FUNC
2394
2395
2396#### Method: request_method
2397# Returns 'POST', 'GET', 'PUT' or 'HEAD'
2398####
2399'request_method' => <<'END_OF_FUNC',
2400sub request_method {
2401 return $ENV{'REQUEST_METHOD'};
2402}
2403END_OF_FUNC
2404
f6b3007c
JH		 2405#### Method: content_type
2406# Returns the content_type string
2407####
2408'content_type' => <<'END_OF_FUNC',
2409sub content_type {
2410 return $ENV{'CONTENT_TYPE'};
2411}
2412END_OF_FUNC
2413
54310121 2414#### Method: path_translated
2415# Return the physical path information provided
2416# by the URL (if any)
2417####
2418'path_translated' => <<'END_OF_FUNC',
2419sub path_translated {
2420 return $ENV{'PATH_TRANSLATED'};
2421}
2422END_OF_FUNC
2423
2424
2425#### Method: query_string
2426# Synthesize a query string from our current
2427# parameters
2428####
2429'query_string' => <<'END_OF_FUNC',
2430sub query_string {
2431 my($self) = self_or_default(@_);
2432 my($param,$value,@pairs);
2433 foreach $param ($self->param) {
424ec8fa 2434 my($eparam) = escape($param);
54310121 2435 foreach $value ($self->param($param)) {
424ec8fa 2436 $value = escape($value);
f6b3007c 2437 next unless defined $value;
54310121 2438 push(@pairs,"$eparam=$value");
2439 }
2440 }
71f3e297 2441 return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
54310121 2442}
2443END_OF_FUNC
2444
2445
2446#### Method: accept
2447# Without parameters, returns an array of the
2448# MIME types the browser accepts.
2449# With a single parameter equal to a MIME
2450# type, will return undef if the browser won't
2451# accept it, 1 if the browser accepts it but
2452# doesn't give a preference, or a floating point
2453# value between 0.0 and 1.0 if the browser
2454# declares a quantitative score for it.
2455# This handles MIME type globs correctly.
2456####
71f3e297
JH		 2457'Accept' => <<'END_OF_FUNC',
2458sub Accept {
54310121 2459 my($self,$search) = self_or_CGI(@_);
2460 my(%prefs,$type,$pref,$pat);
2461
2462 my(@accept) = split(',',$self->http('accept'));
2463
2464 foreach (@accept) {
2465 ($pref) = /q=(\d\.\d+|\d+)/;
2466 ($type) = m#(\S+/[^;]+)#;
2467 next unless $type;
2468 $prefs{$type}=$pref || 1;
2469 }
2470
2471 return keys %prefs unless $search;
2472
2473 # if a search type is provided, we may need to
2474 # perform a pattern matching operation.
2475 # The MIME types use a glob mechanism, which
2476 # is easily translated into a perl pattern match
2477
2478 # First return the preference for directly supported
2479 # types:
2480 return $prefs{$search} if $prefs{$search};
2481
2482 # Didn't get it, so try pattern matching.
2483 foreach (keys %prefs) {
2484 next unless /\*/; # not a pattern match
2485 ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2486 $pat =~ s/\*/.*/g; # turn it into a pattern
2487 return $prefs{$_} if $search=~/$pat/;
2488 }
2489}
2490END_OF_FUNC
2491
2492
2493#### Method: user_agent
2494# If called with no parameters, returns the user agent.
2495# If called with one parameter, does a pattern match (case
2496# insensitive) on the user agent.
2497####
2498'user_agent' => <<'END_OF_FUNC',
2499sub user_agent {
2500 my($self,$match)=self_or_CGI(@_);
2501 return $self->http('user_agent') unless $match;
2502 return $self->http('user_agent') =~ /$match/i;
2503}
2504END_OF_FUNC
2505
2506
424ec8fa
GS		 2507#### Method: raw_cookie
2508# Returns the magic cookies for the session.
2509# The cookies are not parsed or altered in any way, i.e.
2510# cookies are returned exactly as given in the HTTP
2511# headers. If a cookie name is given, only that cookie's
2512# value is returned, otherwise the entire raw cookie
2513# is returned.
54310121 2514####
2515'raw_cookie' => <<'END_OF_FUNC',
2516sub raw_cookie {
424ec8fa
GS		 2517 my($self,$key) = self_or_CGI(@_);
2518
2519 require CGI::Cookie;
2520
2521 if (defined($key)) {
2522 $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
2523 unless $self->{'.raw_cookies'};
2524
2525 return () unless $self->{'.raw_cookies'};
2526 return () unless $self->{'.raw_cookies'}->{$key};
2527 return $self->{'.raw_cookies'}->{$key};
2528 }
54310121 2529 return $self->http('cookie') || $ENV{'COOKIE'} || '';
2530}
2531END_OF_FUNC
2532
2533#### Method: virtual_host
2534# Return the name of the virtual_host, which
2535# is not always the same as the server
2536######
2537'virtual_host' => <<'END_OF_FUNC',
2538sub virtual_host {
424ec8fa
GS		 2539 my $vh = http('host') || server_name();
2540 $vh =~ s/:\d+$//; # get rid of port number
2541 return $vh;
54310121 2542}
2543END_OF_FUNC
2544
2545#### Method: remote_host
2546# Return the name of the remote host, or its IP
2547# address if unavailable. If this variable isn't
2548# defined, it returns "localhost" for debugging
2549# purposes.
2550####
2551'remote_host' => <<'END_OF_FUNC',
2552sub remote_host {
2553 return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
2554 || 'localhost';
2555}
2556END_OF_FUNC
2557
2558
2559#### Method: remote_addr
2560# Return the IP addr of the remote host.
2561####
2562'remote_addr' => <<'END_OF_FUNC',
2563sub remote_addr {
2564 return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
2565}
2566END_OF_FUNC
2567
2568
2569#### Method: script_name
2570# Return the partial URL to this script for
2571# self-referencing scripts. Also see
2572# self_url(), which returns a URL with all state information
2573# preserved.
2574####
2575'script_name' => <<'END_OF_FUNC',
2576sub script_name {
424ec8fa 2577 return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'});
54310121 2578 # These are for debugging
2579 return "/$0" unless $0=~/^\//;
2580 return $0;
2581}
2582END_OF_FUNC
2583
2584
2585#### Method: referer
2586# Return the HTTP_REFERER: useful for generating
2587# a GO BACK button.
2588####
2589'referer' => <<'END_OF_FUNC',
2590sub referer {
2591 my($self) = self_or_CGI(@_);
2592 return $self->http('referer');
2593}
2594END_OF_FUNC
2595
2596
2597#### Method: server_name
2598# Return the name of the server
2599####
2600'server_name' => <<'END_OF_FUNC',
2601sub server_name {
2602 return $ENV{'SERVER_NAME'} || 'localhost';
2603}
2604END_OF_FUNC
2605
2606#### Method: server_software
2607# Return the name of the server software
2608####
2609'server_software' => <<'END_OF_FUNC',
2610sub server_software {
2611 return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
2612}
2613END_OF_FUNC
2614
2615#### Method: server_port
2616# Return the tcp/ip port the server is running on
2617####
2618'server_port' => <<'END_OF_FUNC',
2619sub server_port {
2620 return $ENV{'SERVER_PORT'} || 80; # for debugging
2621}
2622END_OF_FUNC
2623
2624#### Method: server_protocol
2625# Return the protocol (usually HTTP/1.0)
2626####
2627'server_protocol' => <<'END_OF_FUNC',
2628sub server_protocol {
2629 return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
2630}
2631END_OF_FUNC
2632
2633#### Method: http
2634# Return the value of an HTTP variable, or
2635# the list of variables if none provided
2636####
2637'http' => <<'END_OF_FUNC',
2638sub http {
2639 my ($self,$parameter) = self_or_CGI(@_);
2640 return $ENV{$parameter} if $parameter=~/^HTTP/;
f6b3007c 2641 $parameter =~ tr/-/_/;
54310121 2642 return $ENV{"HTTP_\U$parameter\E"} if $parameter;
2643 my(@p);
2644 foreach (keys %ENV) {
2645 push(@p,$_) if /^HTTP/;
2646 }
2647 return @p;
2648}
2649END_OF_FUNC
2650
2651#### Method: https
2652# Return the value of HTTPS
2653####
2654'https' => <<'END_OF_FUNC',
2655sub https {
2656 local($^W)=0;
2657 my ($self,$parameter) = self_or_CGI(@_);
2658 return $ENV{HTTPS} unless $parameter;
2659 return $ENV{$parameter} if $parameter=~/^HTTPS/;
f6b3007c 2660 $parameter =~ tr/-/_/;
54310121 2661 return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
2662 my(@p);
2663 foreach (keys %ENV) {
2664 push(@p,$_) if /^HTTPS/;
2665 }
2666 return @p;
2667}
2668END_OF_FUNC
2669
2670#### Method: protocol
2671# Return the protocol (http or https currently)
2672####
2673'protocol' => <<'END_OF_FUNC',
2674sub protocol {
2675 local($^W)=0;
2676 my $self = shift;
424ec8fa 2677 return 'https' if uc($self->https()) eq 'ON';
54310121 2678 return 'https' if $self->server_port == 443;
2679 my $prot = $self->server_protocol;
2680 my($protocol,$version) = split('/',$prot);
2681 return "\L$protocol\E";
2682}
2683END_OF_FUNC
2684
2685#### Method: remote_ident
2686# Return the identity of the remote user
2687# (but only if his host is running identd)
2688####
2689'remote_ident' => <<'END_OF_FUNC',
2690sub remote_ident {
2691 return $ENV{'REMOTE_IDENT'};
2692}
2693END_OF_FUNC
2694
2695
2696#### Method: auth_type
2697# Return the type of use verification/authorization in use, if any.
2698####
2699'auth_type' => <<'END_OF_FUNC',
2700sub auth_type {
2701 return $ENV{'AUTH_TYPE'};
2702}
2703END_OF_FUNC
2704
2705
2706#### Method: remote_user
2707# Return the authorization name used for user
2708# verification.
2709####
2710'remote_user' => <<'END_OF_FUNC',
2711sub remote_user {
2712 return $ENV{'REMOTE_USER'};
2713}
2714END_OF_FUNC
2715
2716
2717#### Method: user_name
2718# Try to return the remote user's name by hook or by
2719# crook
2720####
2721'user_name' => <<'END_OF_FUNC',
2722sub user_name {
2723 my ($self) = self_or_CGI(@_);
2724 return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
2725}
2726END_OF_FUNC
2727
2728#### Method: nph
2729# Set or return the NPH global flag
2730####
2731'nph' => <<'END_OF_FUNC',
2732sub nph {
2733 my ($self,$param) = self_or_CGI(@_);
7d37aa8e
LS		 2734 $CGI::NPH = $param if defined($param);
2735 return $CGI::NPH;
2736}
2737END_OF_FUNC
2738
2739#### Method: private_tempfiles
2740# Set or return the private_tempfiles global flag
2741####
2742'private_tempfiles' => <<'END_OF_FUNC',
2743sub private_tempfiles {
2744 my ($self,$param) = self_or_CGI(@_);
424ec8fa 2745 $CGI::PRIVATE_TEMPFILES = $param if defined($param);
7d37aa8e 2746 return $CGI::PRIVATE_TEMPFILES;
54310121 2747}
2748END_OF_FUNC
2749
424ec8fa
GS		 2750#### Method: default_dtd
2751# Set or return the default_dtd global
2752####
2753'default_dtd' => <<'END_OF_FUNC',
2754sub default_dtd {
2755 my ($self,$param) = self_or_CGI(@_);
2756 $CGI::DEFAULT_DTD = $param if defined($param);
2757 return $CGI::DEFAULT_DTD;
2758}
2759END_OF_FUNC
2760
54310121 2761# -------------- really private subroutines -----------------
2762'previous_or_default' => <<'END_OF_FUNC',
2763sub previous_or_default {
2764 my($self,$name,$defaults,$override) = @_;
2765 my(%selected);
2766
2767 if (!$override && ($self->{'.fieldnames'}->{$name} ||
2768 defined($self->param($name)) ) ) {
2769 grep($selected{$_}++,$self->param($name));
2770 } elsif (defined($defaults) && ref($defaults) &&
2771 (ref($defaults) eq 'ARRAY')) {
2772 grep($selected{$_}++,@{$defaults});
2773 } else {
2774 $selected{$defaults}++ if defined($defaults);
2775 }
2776
2777 return %selected;
2778}
2779END_OF_FUNC
2780
2781'register_parameter' => <<'END_OF_FUNC',
2782sub register_parameter {
2783 my($self,$param) = @_;
2784 $self->{'.parametersToAdd'}->{$param}++;
2785}
2786END_OF_FUNC
2787
2788'get_fields' => <<'END_OF_FUNC',
2789sub get_fields {
2790 my($self) = @_;
424ec8fa
GS		 2791 return $self->CGI::hidden('-name'=>'.cgifields',
2792 '-values'=>[keys %{$self->{'.parametersToAdd'}}],
2793 '-override'=>1);
54310121 2794}
2795END_OF_FUNC
2796
2797'read_from_cmdline' => <<'END_OF_FUNC',
2798sub read_from_cmdline {
54310121 2799 my($input,@words);
2800 my($query_string);
2801 if (@ARGV) {
424ec8fa 2802 @words = @ARGV;
54310121 2803 } else {
424ec8fa 2804 require "shellwords.pl";
54310121 2805 print STDERR "(offline mode: enter name=value pairs on standard input)\n";
424ec8fa 2806 chomp(@lines = <STDIN>); # remove newlines
54310121 2807 $input = join(" ",@lines);
424ec8fa
GS		 2808 @words = &shellwords($input);
2809 }
2810 foreach (@words) {
2811 s/\\=/%3D/g;
2812 s/\\&/%26/g;
54310121 2813 }
2814
54310121 2815 if ("@words"=~/=/) {
2816 $query_string = join('&',@words);
2817 } else {
2818 $query_string = join('+',@words);
2819 }
2820 return $query_string;
2821}
2822END_OF_FUNC
2823
2824#####
2825# subroutine: read_multipart
2826#
2827# Read multipart data and store it into our parameters.
2828# An interesting feature is that if any of the parts is a file, we
2829# create a temporary file and open up a filehandle on it so that the
2830# caller can read from it if necessary.
2831#####
2832'read_multipart' => <<'END_OF_FUNC',
2833sub read_multipart {
424ec8fa
GS		 2834 my($self,$boundary,$length,$filehandle) = @_;
2835 my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle);
54310121 2836 return unless $buffer;
2837 my(%header,$body);
424ec8fa 2838 my $filenumber = 0;
54310121 2839 while (!$buffer->eof) {
2840 %header = $buffer->readHeader;
f6b3007c
JH		 2841
2842 unless (%header) {
2843 $self->cgi_error("400 Bad request (malformed multipart POST)");
2844 return;
2845 }
54310121 2846
424ec8fa 2847 my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
54310121 2848
424ec8fa
GS		 2849 # Bug: Netscape doesn't escape quotation marks in file names!!!
2850 my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/;
54310121 2851
2852 # add this parameter to our list
2853 $self->add_parameter($param);
2854
2855 # If no filename specified, then just read the data and assign it
2856 # to our parameter list.
2857 unless ($filename) {
2858 my($value) = $buffer->readBody;
2859 push(@{$self->{$param}},$value);
2860 next;
2861 }
2862
424ec8fa
GS		 2863 my ($tmpfile,$tmp,$filehandle);
2864 UPLOADS: {
2865 # If we get here, then we are dealing with a potentially large
2866 # uploaded form. Save the data to a temporary file, then open
2867 # the file for reading.
54310121 2868
424ec8fa
GS		 2869 # skip the file if uploads disabled
2870 if ($DISABLE_UPLOADS) {
2871 while (defined($data = $buffer->read)) { }
2872 last UPLOADS;
2873 }
7d37aa8e 2874
f6b3007c
JH		 2875 # choose a relatively unpredictable tmpfile sequence number
2876 my $seqno = unpack("%16C*",join('',localtime,values %ENV));
2877 for (my $cnt=10;$cnt>0;$cnt--) {
2878 next unless $tmpfile = new TempFile($seqno);
2879 $tmp = $tmpfile->as_string;
2880 last if $filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES);
2881 $seqno += int rand(100);
2882 }
2883 die "CGI open of tmpfile: $!\n" unless $filehandle;
424ec8fa 2884 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
424ec8fa
GS		 2885
2886 my ($data);
71f3e297 2887 local($\) = '';
424ec8fa
GS		 2888 while (defined($data = $buffer->read)) {
2889 print $filehandle $data;
2890 }
2891
2892 # back up to beginning of file
2893 seek($filehandle,0,0);
2894 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2895
2896 # Save some information about the uploaded file where we can get
2897 # at it later.
2898 $self->{'.tmpfiles'}->{$filename}= {
2899 name => $tmpfile,
2900 info => {%header},
2901 };
2902 push(@{$self->{$param}},$filehandle);
2903 }
54310121 2904 }
2905}
2906END_OF_FUNC
2907
f6b3007c
JH		 2908'upload' =><<'END_OF_FUNC',
2909sub upload {
2910 my($self,$param_name) = self_or_default(@_);
2911 my $param = $self->param($param_name);
2912 return unless $param;
2913 return unless ref($param) && fileno($param);
2914 return $param;
2915}
2916END_OF_FUNC
2917
54310121 2918'tmpFileName' => <<'END_OF_FUNC',
2919sub tmpFileName {
2920 my($self,$filename) = self_or_default(@_);
7d37aa8e
LS		 2921 return $self->{'.tmpfiles'}->{$filename}->{name} ?
2922 $self->{'.tmpfiles'}->{$filename}->{name}->as_string
2923 : '';
54310121 2924}
2925END_OF_FUNC
2926
424ec8fa 2927'uploadInfo' => <<'END_OF_FUNC',
54310121 2928sub uploadInfo {
2929 my($self,$filename) = self_or_default(@_);
2930 return $self->{'.tmpfiles'}->{$filename}->{info};
2931}
2932END_OF_FUNC
2933
424ec8fa
GS		 2934# internal routine, don't use
2935'_set_values_and_labels' => <<'END_OF_FUNC',
2936sub _set_values_and_labels {
2937 my $self = shift;
2938 my ($v,$l,$n) = @_;
2939 $$l = $v if ref($v) eq 'HASH' && !ref($$l);
2940 return $self->param($n) if !defined($v);
2941 return $v if !ref($v);
2942 return ref($v) eq 'HASH' ? keys %$v : @$v;
2943}
2944END_OF_FUNC
2945
2946'_compile_all' => <<'END_OF_FUNC',
2947sub _compile_all {
2948 foreach (@_) {
2949 next if defined(&$_);
2950 $AUTOLOAD = "CGI::$_";
2951 _compile();
2952 }
2953}
2954END_OF_FUNC
2955
54310121 2956);
2957END_OF_AUTOLOAD
2958;
2959
424ec8fa
GS		 2960#########################################################
2961# Globals and stubs for other packages that we use.
2962#########################################################
2963
2964################### Fh -- lightweight filehandle ###############
2965package Fh;
2966use overload
2967 '""' => \&asString,
2968 'cmp' => \&compare,
2969 'fallback'=>1;
2970
2971$FH='fh00000';
2972
2973*Fh::AUTOLOAD = \&CGI::AUTOLOAD;
2974
2975$AUTOLOADED_ROUTINES = ''; # prevent -w error
2976$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
2977%SUBS = (
2978'asString' => <<'END_OF_FUNC',
2979sub asString {
2980 my $self = shift;
71f3e297
JH		 2981 # get rid of package name
2982 (my $i = $$self) =~ s/^\*(\w+::)+//;
424ec8fa
GS		 2983 $i =~ s/\\(.)/$1/g;
2984 return $i;
71f3e297
JH		 2985# BEGIN DEAD CODE
2986# This was an extremely clever patch that allowed "use strict refs".
2987# Unfortunately it relied on another bug that caused leaky file descriptors.
2988# The underlying bug has been fixed, so this no longer works. However
2989# "strict refs" still works for some reason.
2990# my $self = shift;
2991# return ${*{$self}{SCALAR}};
2992# END DEAD CODE
424ec8fa
GS		 2993}
2994END_OF_FUNC
2995
2996'compare' => <<'END_OF_FUNC',
2997sub compare {
2998 my $self = shift;
2999 my $value = shift;
3000 return "$self" cmp $value;
3001}
3002END_OF_FUNC
3003
3004'new' => <<'END_OF_FUNC',
3005sub new {
3006 my($pack,$name,$file,$delete) = @_;
3007 require Fcntl unless defined &Fcntl::O_RDWR;
3008 ++$FH;
71f3e297 3009 my $ref = \*{'Fh::' . quotemeta($name)};
f6b3007c 3010 sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
424ec8fa 3011 unlink($file) if $delete;
f6b3007c 3012 CORE::delete $Fh::{$FH};
71f3e297 3013 return bless $ref,$pack;
424ec8fa
GS		 3014}
3015END_OF_FUNC
3016
3017'DESTROY' => <<'END_OF_FUNC',
3018sub DESTROY {
3019 my $self = shift;
3020 close $self;
3021}
3022END_OF_FUNC
3023
3024);
3025END_OF_AUTOLOAD
3026
3027######################## MultipartBuffer ####################
54310121 3028package MultipartBuffer;
3029
3030# how many bytes to read at a time. We use
71f3e297
JH		 3031# a 4K buffer by default.
3032$INITIAL_FILLUNIT = 1024 * 4;
3033$TIMEOUT = 240*60; # 4 hour timeout for big files
3034$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
54310121 3035$CRLF=$CGI::CRLF;
3036
3037#reuse the autoload function
3038*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
3039
424ec8fa
GS		 3040# avoid autoloader warnings
3041sub DESTROY {}
3042
54310121 3043###############################################################################
3044################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3045###############################################################################
3046$AUTOLOADED_ROUTINES = ''; # prevent -w error
3047$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3048%SUBS = (
3049
3050'new' => <<'END_OF_FUNC',
3051sub new {
3052 my($package,$interface,$boundary,$length,$filehandle) = @_;
424ec8fa 3053 $FILLUNIT = $INITIAL_FILLUNIT;
54310121 3054 my $IN;
3055 if ($filehandle) {
3056 my($package) = caller;
3057 # force into caller's package if necessary
3058 $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
3059 }
3060 $IN = "main::STDIN" unless $IN;
3061
3062 $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
3063
3064 # If the user types garbage into the file upload field,
3065 # then Netscape passes NOTHING to the server (not good).
3066 # We may hang on this read in that case. So we implement
3067 # a read timeout. If nothing is ready to read
3068 # by then, we return.
3069
3070 # Netscape seems to be a little bit unreliable
3071 # about providing boundary strings.
3072 if ($boundary) {
3073
3074 # Under the MIME spec, the boundary consists of the
3075 # characters "--" PLUS the Boundary string
424ec8fa
GS		 3076
3077 # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
71f3e297 3078 # the two extra hyphens. We do a special case here on the user-agent!!!!
f6b3007c 3079 $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac');
424ec8fa 3080
54310121 3081 } else { # otherwise we find it ourselves
3082 my($old);
3083 ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
3084 $boundary = <$IN>; # BUG: This won't work correctly under mod_perl
3085 $length -= length($boundary);
3086 chomp($boundary); # remove the CRLF
3087 $/ = $old; # restore old line separator
3088 }
3089
3090 my $self = {LENGTH=>$length,
3091 BOUNDARY=>$boundary,
3092 IN=>$IN,
3093 INTERFACE=>$interface,
3094 BUFFER=>'',
3095 };
3096
3097 $FILLUNIT = length($boundary)
3098 if length($boundary) > $FILLUNIT;
3099
424ec8fa
GS		 3100 my $retval = bless $self,ref $package || $package;
3101
3102 # Read the preamble and the topmost (boundary) line plus the CRLF.
3103 while ($self->read(0)) { }
3104 die "Malformed multipart POST\n" if $self->eof;
3105
3106 return $retval;
54310121 3107}
3108END_OF_FUNC
3109
3110'readHeader' => <<'END_OF_FUNC',
3111sub readHeader {
3112 my($self) = @_;
3113 my($end);
3114 my($ok) = 0;
47e3cabd 3115 my($bad) = 0;
424ec8fa
GS		 3116
3117 if ($CGI::OS eq 'VMS') { # tssk, tssk: inconsistency alert!
3118 local($CRLF) = "\015\012";
3119 }
3120
54310121 3121 do {
3122 $self->fillBuffer($FILLUNIT);
3123 $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
3124 $ok++ if $self->{BUFFER} eq '';
47e3cabd 3125 $bad++ if !$ok && $self->{LENGTH} <= 0;
424ec8fa
GS		 3126 # this was a bad idea
3127 # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
47e3cabd
LS		 3128 } until $ok || $bad;
3129 return () if $bad;
54310121 3130
3131 my($header) = substr($self->{BUFFER},0,$end+2);
3132 substr($self->{BUFFER},0,$end+4) = '';
3133 my %return;
424ec8fa
GS		 3134
3135
3136 # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
3137 # (Folding Long Header Fields), 3.4.3 (Comments)
3138 # and 3.4.5 (Quoted-Strings).
3139
3140 my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
3141 $header=~s/$CRLF\s+/ /og; # merge continuation lines
3142 while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
3143 my ($field_name,$field_value) = ($1,$2); # avoid taintedness
3144 $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
3145 $return{$field_name}=$field_value;
54310121 3146 }
3147 return %return;
3148}
3149END_OF_FUNC
3150
3151# This reads and returns the body as a single scalar value.
3152'readBody' => <<'END_OF_FUNC',
3153sub readBody {
3154 my($self) = @_;
3155 my($data);
3156 my($returnval)='';
3157 while (defined($data = $self->read)) {
3158 $returnval .= $data;
3159 }
3160 return $returnval;
3161}
3162END_OF_FUNC
3163
3164# This will read $bytes or until the boundary is hit, whichever happens
3165# first. After the boundary is hit, we return undef. The next read will
3166# skip over the boundary and begin reading again;
3167'read' => <<'END_OF_FUNC',
3168sub read {
3169 my($self,$bytes) = @_;
3170
3171 # default number of bytes to read
3172 $bytes = $bytes || $FILLUNIT;
3173
3174 # Fill up our internal buffer in such a way that the boundary
3175 # is never split between reads.
3176 $self->fillBuffer($bytes);
3177
3178 # Find the boundary in the buffer (it may not be there).
3179 my $start = index($self->{BUFFER},$self->{BOUNDARY});
47e3cabd
LS		 3180 # protect against malformed multipart POST operations
3181 die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
54310121 3182
3183 # If the boundary begins the data, then skip past it
3184 # and return undef. The +2 here is a fiendish plot to
3185 # remove the CR/LF pair at the end of the boundary.
3186 if ($start == 0) {
3187
3188 # clear us out completely if we've hit the last boundary.
3189 if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
3190 $self->{BUFFER}='';
3191 $self->{LENGTH}=0;
3192 return undef;
3193 }
3194
3195 # just remove the boundary.
3196 substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
3197 return undef;
3198 }
3199
3200 my $bytesToReturn;
3201 if ($start > 0) { # read up to the boundary
3202 $bytesToReturn = $start > $bytes ? $bytes : $start;
3203 } else { # read the requested number of bytes
3204 # leave enough bytes in the buffer to allow us to read
3205 # the boundary. Thanks to Kevin Hendrick for finding
3206 # this one.
3207 $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
3208 }
3209
3210 my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
3211 substr($self->{BUFFER},0,$bytesToReturn)='';
3212
3213 # If we hit the boundary, remove the CRLF from the end.
3214 return ($start > 0) ? substr($returnval,0,-2) : $returnval;
3215}
3216END_OF_FUNC
3217
3218
3219# This fills up our internal buffer in such a way that the
3220# boundary is never split between reads
3221'fillBuffer' => <<'END_OF_FUNC',
3222sub fillBuffer {
3223 my($self,$bytes) = @_;
3224 return unless $self->{LENGTH};
3225
3226 my($boundaryLength) = length($self->{BOUNDARY});
3227 my($bufferLength) = length($self->{BUFFER});
3228 my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
3229 $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
3230
3231 # Try to read some data. We may hang here if the browser is screwed up.
3232 my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN},
3233 \$self->{BUFFER},
3234 $bytesToRead,
3235 $bufferLength);
71f3e297 3236 $self->{BUFFER} = '' unless defined $self->{BUFFER};
54310121 3237
47e3cabd 3238 # An apparent bug in the Apache server causes the read()
54310121 3239 # to return zero bytes repeatedly without blocking if the
3240 # remote user aborts during a file transfer. I don't know how
3241 # they manage this, but the workaround is to abort if we get
3242 # more than SPIN_LOOP_MAX consecutive zero reads.
3243 if ($bytesRead == 0) {
3244 die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
3245 if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
3246 } else {
3247 $self->{ZERO_LOOP_COUNTER}=0;
3248 }
3249
3250 $self->{LENGTH} -= $bytesRead;
3251}
3252END_OF_FUNC
3253
3254
3255# Return true when we've finished reading
3256'eof' => <<'END_OF_FUNC'
3257sub eof {
3258 my($self) = @_;
3259 return 1 if (length($self->{BUFFER}) == 0)
3260 && ($self->{LENGTH} <= 0);
3261 undef;
3262}
3263END_OF_FUNC
3264
3265);
3266END_OF_AUTOLOAD
3267
3268####################################################################################
3269################################## TEMPORARY FILES #################################
3270####################################################################################
3271package TempFile;
3272
3273$SL = $CGI::SL;
424ec8fa
GS		 3274$MAC = $CGI::OS eq 'MACINTOSH';
3275my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
54310121 3276unless ($TMPDIRECTORY) {
424ec8fa 3277 @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
f6b3007c
JH		 3278 "C:${SL}temp","${SL}tmp","${SL}temp",
3279 "${vol}${SL}Temporary Items",
424ec8fa 3280 "${SL}WWW_ROOT");
f6b3007c
JH		 3281 unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'};
3282
3283 #
3284 # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
3285 # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
3286 # : can generate a 'getpwuid() not implemented' exception, even though
3287 # : it's never called. Found under DOS/Win with the DJGPP perl port.
3288 # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
3289 unshift(@TEMP,(eval {(getpwuid($<))[7]}).'/tmp') if $CGI::OS eq 'UNIX';
3290
54310121 3291 foreach (@TEMP) {
3292 do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
3293 }
3294}
3295
424ec8fa 3296$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
424ec8fa 3297$MAXTRIES = 5000;
54310121 3298
3299# cute feature, but overload implementation broke it
3300# %OVERLOAD = ('""'=>'as_string');
3301*TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
3302
3303###############################################################################
3304################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3305###############################################################################
3306$AUTOLOADED_ROUTINES = ''; # prevent -w error
3307$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3308%SUBS = (
3309
3310'new' => <<'END_OF_FUNC',
3311sub new {
f6b3007c
JH		 3312 my($package,$sequence) = @_;
3313 my $filename;
3314 for (my $i = 0; $i < $MAXTRIES; $i++) {
3315 last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
424ec8fa 3316 }
f6b3007c
JH		 3317 # untaint the darn thing
3318 return unless $filename =~ m!^([a-zA-Z0-9_ '":/\\]+)$!;
3319 $filename = $1;
3320 return bless \$filename;
54310121 3321}
3322END_OF_FUNC
3323
3324'DESTROY' => <<'END_OF_FUNC',
3325sub DESTROY {
3326 my($self) = @_;
3327 unlink $$self; # get rid of the file
3328}
3329END_OF_FUNC
3330
3331'as_string' => <<'END_OF_FUNC'
3332sub as_string {
3333 my($self) = @_;
3334 return $$self;
3335}
3336END_OF_FUNC
3337
3338);
3339END_OF_AUTOLOAD
3340
3341package CGI;
3342
3343# We get a whole bunch of warnings about "possibly uninitialized variables"
3344# when running with the -w switch. Touch them all once to get rid of the
3345# warnings. This is ugly and I hate it.
3346if ($^W) {
3347 $CGI::CGI = '';
3348 $CGI::CGI=<<EOF;
3349 $CGI::VERSION;
3350 $MultipartBuffer::SPIN_LOOP_MAX;
3351 $MultipartBuffer::CRLF;
3352 $MultipartBuffer::TIMEOUT;
424ec8fa 3353 $MultipartBuffer::INITIAL_FILLUNIT;
54310121 3354EOF
3355 ;
3356}
3357
424ec8fa 33581;
54310121 3359
3360__END__
3361
3362=head1 NAME
3363
3364CGI - Simple Common Gateway Interface Class
3365
dc848c6f 3366=head1 SYNOPSIS
3367
424ec8fa
GS		 3368 # CGI script that creates a fill-out form
3369 # and echoes back its values.
3370
3371 use CGI qw/:standard/;
3372 print header,
3373 start_html('A Simple Example'),
3374 h1('A Simple Example'),
3375 start_form,
3376 "What's your name? ",textfield('name'),p,
3377 "What's the combination?", p,
3378 checkbox_group(-name=>'words',
3379 -values=>['eenie','meenie','minie','moe'],
3380 -defaults=>['eenie','minie']), p,
3381 "What's your favorite color? ",
3382 popup_menu(-name=>'color',
3383 -values=>['red','green','blue','chartreuse']),p,
3384 submit,
3385 end_form,
3386 hr;
3387
3388 if (param()) {
3389 print "Your name is",em(param('name')),p,
3390 "The keywords are: ",em(join(", ",param('words'))),p,
3391 "Your favorite color is ",em(param('color')),
3392 hr;
3393 }
dc848c6f 3394
54310121 3395=head1 ABSTRACT
3396
424ec8fa
GS		 3397This perl library uses perl5 objects to make it easy to create Web
3398fill-out forms and parse their contents. This package defines CGI
3399objects, entities that contain the values of the current query string
3400and other state variables. Using a CGI object's methods, you can
3401examine keywords and parameters passed to your script, and create
3402forms whose initial values are taken from the current query (thereby
3403preserving state information). The module provides shortcut functions
3404that produce boilerplate HTML, reducing typing and coding errors. It
3405also provides functionality for some of the more advanced features of
3406CGI scripting, including support for file uploads, cookies, cascading
3407style sheets, server push, and frames.
3408
3409CGI.pm also provides a simple function-oriented programming style for
3410those who don't need its object-oriented features.
54310121 3411
3412The current version of CGI.pm is available at
3413
3414 http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
3415 ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
3416
424ec8fa 3417=head1 DESCRIPTION
47e3cabd 3418
424ec8fa
GS		 3419=head2 PROGRAMMING STYLE
3420
3421There are two styles of programming with CGI.pm, an object-oriented
3422style and a function-oriented style. In the object-oriented style you
3423create one or more CGI objects and then use object methods to create
3424the various elements of the page. Each CGI object starts out with the
3425list of named parameters that were passed to your CGI script by the
3426server. You can modify the objects, save them to a file or database
3427and recreate them. Because each object corresponds to the "state" of
3428the CGI script, and because each object's parameter list is
3429independent of the others, this allows you to save the state of the
3430script and restore it later.
3431
f610777f 3432For example, using the object oriented style, here is how you create
424ec8fa
GS		 3433a simple "Hello World" HTML page:
3434
f6b3007c 3435 #!/usr/local/bin/perl -w
424ec8fa
GS		 3436 use CGI; # load CGI routines
3437 $q = new CGI; # create new CGI object
3438 print $q->header, # create the HTTP header
3439 $q->start_html('hello world'), # start the HTML
3440 $q->h1('hello world'), # level 1 header
3441 $q->end_html; # end the HTML
3442
3443In the function-oriented style, there is one default CGI object that
3444you rarely deal with directly. Instead you just call functions to
3445retrieve CGI parameters, create HTML tags, manage cookies, and so
3446on. This provides you with a cleaner programming interface, but
3447limits you to using one CGI object at a time. The following example
3448prints the same page, but uses the function-oriented interface.
3449The main differences are that we now need to import a set of functions
3450into our name space (usually the "standard" functions), and we don't
3451need to create the CGI object.
3452
71f3e297 3453 #!/usr/local/bin/perl
424ec8fa
GS		 3454 use CGI qw/:standard/; # load standard CGI routines
3455 print header, # create the HTTP header
3456 start_html('hello world'), # start the HTML
3457 h1('hello world'), # level 1 header
3458 end_html; # end the HTML
3459
3460The examples in this document mainly use the object-oriented style.
3461See HOW TO IMPORT FUNCTIONS for important information on
3462function-oriented programming in CGI.pm
3463
3464=head2 CALLING CGI.PM ROUTINES
3465
3466Most CGI.pm routines accept several arguments, sometimes as many as 20
3467optional ones! To simplify this interface, all routines use a named
3468argument calling style that looks like this:
3469
3470 print $q->header(-type=>'image/gif',-expires=>'+3d');
3471
3472Each argument name is preceded by a dash. Neither case nor order
3473matters in the argument list. -type, -Type, and -TYPE are all
3474acceptable. In fact, only the first argument needs to begin with a
3475dash. If a dash is present in the first argument, CGI.pm assumes
3476dashes for the subsequent ones.
3477
f610777f 3478You don't have to use the hyphen at all if you don't want to. After
424ec8fa
GS		 3479creating a CGI object, call the B<use_named_parameters()> method with
3480a nonzero value. This will tell CGI.pm that you intend to use named
3481parameters exclusively:
54310121 3482
424ec8fa
GS		 3483 $query = new CGI;
3484 $query->use_named_parameters(1);
3485 $field = $query->radio_group('name'=>'OS',
3486 'values'=>['Unix','Windows','Macintosh'],
3487 'default'=>'Unix');
54310121 3488
424ec8fa
GS		 3489Several routines are commonly called with just one argument. In the
3490case of these routines you can provide the single argument without an
3491argument name. header() happens to be one of these routines. In this
3492case, the single argument is the document type.
3493
3494 print $q->header('text/html');
3495
3496Other such routines are documented below.
3497
3498Sometimes named arguments expect a scalar, sometimes a reference to an
3499array, and sometimes a reference to a hash. Often, you can pass any
3500type of argument and the routine will do whatever is most appropriate.
3501For example, the param() routine is used to set a CGI parameter to a
3502single or a multi-valued value. The two cases are shown below:
3503
3504 $q->param(-name=>'veggie',-value=>'tomato');
3505 $q->param(-name=>'veggie',-value=>'[tomato','tomahto','potato','potahto']);
3506
3507A large number of routines in CGI.pm actually aren't specifically
3508defined in the module, but are generated automatically as needed.
3509These are the "HTML shortcuts," routines that generate HTML tags for
3510use in dynamically-generated pages. HTML tags have both attributes
3511(the attribute="value" pairs within the tag itself) and contents (the
3512part between the opening and closing pairs.) To distinguish between
3513attributes and contents, CGI.pm uses the convention of passing HTML
3514attributes as a hash reference as the first argument, and the
3515contents, if any, as any subsequent arguments. It works out like
3516this:
3517
3518 Code Generated HTML
3519 ---- --------------
3520 h1() <H1>
3521 h1('some','contents'); <H1>some contents</H1>
3522 h1({-align=>left}); <H1 ALIGN="LEFT">
3523 h1({-align=>left},'contents'); <H1 ALIGN="LEFT">contents</H1>
3524
3525HTML tags are described in more detail later.
3526
3527Many newcomers to CGI.pm are puzzled by the difference between the
3528calling conventions for the HTML shortcuts, which require curly braces
3529around the HTML tag attributes, and the calling conventions for other
3530routines, which manage to generate attributes without the curly
3531brackets. Don't be confused. As a convenience the curly braces are
3532optional in all but the HTML shortcuts. If you like, you can use
3533curly braces when calling any routine that takes named arguments. For
3534example:
3535
3536 print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
3537
3538If you use the B<-w> switch, you will be warned that some CGI.pm argument
3539names conflict with built-in Perl functions. The most frequent of
3540these is the -values argument, used to create multi-valued menus,
3541radio button clusters and the like. To get around this warning, you
3542have several choices:
54310121 3543
424ec8fa 3544=over 4
54310121 3545
424ec8fa
GS		 3546=item 1. Use another name for the argument, if one is available. For
3547example, -value is an alias for -values.
54310121 3548
424ec8fa 3549=item 2. Change the capitalization, e.g. -Values
54310121 3550
424ec8fa 3551=item 3. Put quotes around the argument name, e.g. '-values'
54310121 3552
424ec8fa 3553=back
54310121 3554
424ec8fa
GS		 3555Many routines will do something useful with a named argument that it
3556doesn't recognize. For example, you can produce non-standard HTTP
3557header fields by providing them as named arguments:
54310121 3558
424ec8fa
GS		 3559 print $q->header(-type => 'text/html',
3560 -cost => 'Three smackers',
3561 -annoyance_level => 'high',
3562 -complaints_to => 'bit bucket');
54310121 3563
424ec8fa
GS		 3564This will produce the following nonstandard HTTP header:
3565
3566 HTTP/1.0 200 OK
3567 Cost: Three smackers
3568 Annoyance-level: high
3569 Complaints-to: bit bucket
3570 Content-type: text/html
3571
3572Notice the way that underscores are translated automatically into
3573hyphens. HTML-generating routines perform a different type of
3574translation.
3575
3576This feature allows you to keep up with the rapidly changing HTTP and
3577HTML "standards".
54310121 3578
424ec8fa 3579=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
54310121 3580
3581 $query = new CGI;
3582
3583This will parse the input (from both POST and GET methods) and store
3584it into a perl5 object called $query.
3585
3586=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
3587
3588 $query = new CGI(INPUTFILE);
3589
424ec8fa
GS		 3590If you provide a file handle to the new() method, it will read
3591parameters from the file (or STDIN, or whatever). The file can be in
3592any of the forms describing below under debugging (i.e. a series of
3593newline delimited TAG=VALUE pairs will work). Conveniently, this type
3594of file is created by the save() method (see below). Multiple records
3595can be saved and restored.
54310121 3596
3597Perl purists will be pleased to know that this syntax accepts
3598references to file handles, or even references to filehandle globs,
3599which is the "official" way to pass a filehandle:
3600
3601 $query = new CGI(\*STDIN);
3602
424ec8fa
GS		 3603You can also initialize the CGI object with a FileHandle or IO::File
3604object.
3605
3606If you are using the function-oriented interface and want to
3607initialize CGI state from a file handle, the way to do this is with
3608B<restore_parameters()>. This will (re)initialize the
3609default CGI object from the indicated file handle.
3610
3611 open (IN,"test.in") || die;
3612 restore_parameters(IN);
3613 close IN;
3614
54310121 3615You can also initialize the query object from an associative array
3616reference:
3617
3618 $query = new CGI( {'dinosaur'=>'barney',
3619 'song'=>'I love you',
3620 'friends'=>[qw/Jessica George Nancy/]}
3621 );
3622
3623or from a properly formatted, URL-escaped query string:
3624
3625 $query = new CGI('dinosaur=barney&color=purple');
3626
424ec8fa
GS		 3627or from a previously existing CGI object (currently this clones the
3628parameter list, but none of the other object-specific fields, such as
3629autoescaping):
3630
3631 $old_query = new CGI;
3632 $new_query = new CGI($old_query);
3633
54310121 3634To create an empty query, initialize it from an empty string or hash:
3635
424ec8fa
GS		 3636 $empty_query = new CGI("");
3637
3638 -or-
3639
3640 $empty_query = new CGI({});
54310121 3641
3642=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
3643
3644 @keywords = $query->keywords
3645
3646If the script was invoked as the result of an <ISINDEX> search, the
3647parsed keywords can be obtained as an array using the keywords() method.
3648
3649=head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
3650
3651 @names = $query->param
3652
3653If the script was invoked with a parameter list
3654(e.g. "name1=value1&name2=value2&name3=value3"), the param()
3655method will return the parameter names as a list. If the
3656script was invoked as an <ISINDEX> script, there will be a
3657single parameter named 'keywords'.
3658
3659NOTE: As of version 1.5, the array of parameter names returned will
3660be in the same order as they were submitted by the browser.
3661Usually this order is the same as the order in which the
3662parameters are defined in the form (however, this isn't part
3663of the spec, and so isn't guaranteed).
3664
3665=head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
3666
3667 @values = $query->param('foo');
3668
3669 -or-
3670
3671 $value = $query->param('foo');
3672
3673Pass the param() method a single argument to fetch the value of the
3674named parameter. If the parameter is multivalued (e.g. from multiple
3675selections in a scrolling list), you can ask to receive an array. Otherwise
3676the method will return a single value.
3677
3678=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
3679
3680 $query->param('foo','an','array','of','values');
3681
3682This sets the value for the named parameter 'foo' to an array of
3683values. This is one way to change the value of a field AFTER
3684the script has been invoked once before. (Another way is with
3685the -override parameter accepted by all methods that generate
3686form elements.)
3687
3688param() also recognizes a named parameter style of calling described
3689in more detail later:
3690
3691 $query->param(-name=>'foo',-values=>['an','array','of','values']);
3692
3693 -or-
3694
3695 $query->param(-name=>'foo',-value=>'the value');
3696
3697=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
3698
424ec8fa 3699 $query->append(-name=>'foo',-values=>['yet','more','values']);
54310121 3700
3701This adds a value or list of values to the named parameter. The
3702values are appended to the end of the parameter if it already exists.
3703Otherwise the parameter is created. Note that this method only
3704recognizes the named argument calling syntax.
3705
3706=head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
3707
3708 $query->import_names('R');
3709
3710This creates a series of variables in the 'R' namespace. For example,
3711$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
3712If no namespace is given, this method will assume 'Q'.
3713WARNING: don't import anything into 'main'; this is a major security
3714risk!!!!
3715
3716In older versions, this method was called B<import()>. As of version 2.20,
3717this name has been removed completely to avoid conflict with the built-in
3718Perl module B<import> operator.
3719
3720=head2 DELETING A PARAMETER COMPLETELY:
3721
3722 $query->delete('foo');
3723
3724This completely clears a parameter. It sometimes useful for
3725resetting parameters that you don't want passed down between
3726script invocations.
3727
424ec8fa
GS		 3728If you are using the function call interface, use "Delete()" instead
3729to avoid conflicts with Perl's built-in delete operator.
3730
54310121 3731=head2 DELETING ALL PARAMETERS:
3732
424ec8fa 3733 $query->delete_all();
54310121 3734
3735This clears the CGI object completely. It might be useful to ensure
3736that all the defaults are taken when you create a fill-out form.
3737
424ec8fa
GS		 3738Use Delete_all() instead if you are using the function call interface.
3739
3740=head2 DIRECT ACCESS TO THE PARAMETER LIST:
3741
3742 $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
3743 unshift @{$q->param_fetch(-name=>'address')},'George Munster';
3744
3745If you need access to the parameter list in a way that isn't covered
3746by the methods above, you can obtain a direct reference to it by
3747calling the B<param_fetch()> method with the name of the . This
3748will return an array reference to the named parameters, which you then
3749can manipulate in any way you like.
3750
3751You can also use a named argument style using the B<-name> argument.
3752
f6b3007c
JH		 3753=head2 FETCHING THE PARAMETER LIST AS A HASH:
3754
3755 $params = $q->Vars;
3756 print $params->{'address'};
3757 @foo = split("\0",$params->{'foo'});
3758 %params = $q->Vars;
3759
3760 use CGI ':cgi-lib';
3761 $params = Vars;
3762
3763Many people want to fetch the entire parameter list as a hash in which
3764the keys are the names of the CGI parameters, and the values are the
3765parameters' values. The Vars() method does this. Called in a scalar
3766context, it returns the parameter list as a tied hash reference.
3767Changing a key changes the value of the parameter in the underlying
3768CGI parameter list. Called in an array context, it returns the
3769parameter list as an ordinary hash. This allows you to read the
3770contents of the parameter list, but not to change it.
3771
3772When using this, the thing you must watch out for are multivalued CGI
3773parameters. Because a hash cannot distinguish between scalar and
3774array context, multivalued parameters will be returned as a packed
3775string, separated by the "\0" (null) character. You must split this
3776packed string in order to get at the individual values. This is the
3777convention introduced long ago by Steve Brenner in his cgi-lib.pl
3778module for Perl version 4.
3779
3780If you wish to use Vars() as a function, import the I<:cgi-lib> set of
3781function calls (also see the section on CGI-LIB compatibility).
3782
424ec8fa 3783=head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
54310121 3784
3785 $query->save(FILEHANDLE)
3786
3787This will write the current state of the form to the provided
3788filehandle. You can read it back in by providing a filehandle
3789to the new() method. Note that the filehandle can be a file, a pipe,
3790or whatever!
3791
3792The format of the saved file is:
3793
3794 NAME1=VALUE1
3795 NAME1=VALUE1'
3796 NAME2=VALUE2
3797 NAME3=VALUE3
3798 =
3799
3800Both name and value are URL escaped. Multi-valued CGI parameters are
3801represented as repeated names. A session record is delimited by a
3802single = symbol. You can write out multiple records and read them
3803back in with several calls to B<new>. You can do this across several
3804sessions by opening the file in append mode, allowing you to create
3805primitive guest books, or to keep a history of users' queries. Here's
3806a short example of creating multiple session records:
3807
3808 use CGI;
3809
3810 open (OUT,">>test.out") || die;
3811 $records = 5;
3812 foreach (0..$records) {
3813 my $q = new CGI;
3814 $q->param(-name=>'counter',-value=>$_);
3815 $q->save(OUT);
3816 }
3817 close OUT;
3818
3819 # reopen for reading
3820 open (IN,"test.out") || die;
3821 while (!eof(IN)) {
3822 my $q = new CGI(IN);
3823 print $q->param('counter'),"\n";
3824 }
3825
3826The file format used for save/restore is identical to that used by the
3827Whitehead Genome Center's data exchange format "Boulderio", and can be
3828manipulated and even databased using Boulderio utilities. See
3829
f6b3007c 3830 http://stein.cshl.org/boulder/
54310121 3831
3832for further details.
3833
424ec8fa
GS		 3834If you wish to use this method from the function-oriented (non-OO)
3835interface, the exported name for this method is B<save_parameters()>.
54310121 3836
f6b3007c
JH		 3837=head2 RETRIEVING CGI ERRORS
3838
3839Errors can occur while processing user input, particularly when
3840processing uploaded files. When these errors occur, CGI will stop
3841processing and return an empty parameter list. You can test for
3842the existence and nature of errors using the I<cgi_error()> function.
3843The error messages are formatted as HTTP status codes. You can either
3844incorporate the error text into an HTML page, or use it as the value
3845of the HTTP status:
3846
3847 my $error = $q->cgi_error;
3848 if ($error) {
3849 print $q->header(-status=>$error),
3850 $q->start_html('Problems'),
3851 $q->h2('Request not processed'),
3852 $q->strong($error);
3853 exit 0;
3854 }
3855
3856When using the function-oriented interface (see the next section),
3857errors may only occur the first time you call I<param()>. Be ready
3858for this!
3859
424ec8fa 3860=head2 USING THE FUNCTION-ORIENTED INTERFACE
54310121 3861
424ec8fa
GS		 3862To use the function-oriented interface, you must specify which CGI.pm
3863routines or sets of routines to import into your script's namespace.
3864There is a small overhead associated with this importation, but it
3865isn't much.
54310121 3866
424ec8fa 3867 use CGI <list of methods>;
54310121 3868
424ec8fa
GS		 3869The listed methods will be imported into the current package; you can
3870call them directly without creating a CGI object first. This example
3871shows how to import the B<param()> and B<header()>
3872methods, and then use them directly:
54310121 3873
424ec8fa
GS		 3874 use CGI 'param','header';
3875 print header('text/plain');
3876 $zipcode = param('zipcode');
54310121 3877
424ec8fa 3878More frequently, you'll import common sets of functions by referring
f610777f 3879to the groups by name. All function sets are preceded with a ":"
424ec8fa 3880character as in ":html3" (for tags defined in the HTML 3 standard).
54310121 3881
424ec8fa 3882Here is a list of the function sets you can import:
54310121 3883
424ec8fa 3884=over 4
54310121 3885
424ec8fa 3886=item B<:cgi>
54310121 3887
424ec8fa
GS		 3888Import all CGI-handling methods, such as B<param()>, B<path_info()>
3889and the like.
54310121 3890
424ec8fa 3891=item B<:form>
54310121 3892
424ec8fa 3893Import all fill-out form generating methods, such as B<textfield()>.
54310121 3894
424ec8fa 3895=item B<:html2>
54310121 3896
424ec8fa 3897Import all methods that generate HTML 2.0 standard elements.
54310121 3898
424ec8fa 3899=item B<:html3>
54310121 3900
424ec8fa
GS		 3901Import all methods that generate HTML 3.0 proposed elements (such as
3902<table>, <super> and <sub>).
54310121 3903
424ec8fa 3904=item B<:netscape>
54310121 3905
424ec8fa 3906Import all methods that generate Netscape-specific HTML extensions.
54310121 3907
424ec8fa 3908=item B<:html>
54310121 3909
424ec8fa
GS		 3910Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
3911'netscape')...
54310121 3912
424ec8fa 3913=item B<:standard>
54310121 3914
424ec8fa 3915Import "standard" features, 'html2', 'html3', 'form' and 'cgi'.
54310121 3916
424ec8fa 3917=item B<:all>
54310121 3918
424ec8fa 3919Import all the available methods. For the full list, see the CGI.pm
f6b3007c 3920code, where the variable %EXPORT_TAGS is defined.
424ec8fa
GS		 3921
3922=back
3923
3924If you import a function name that is not part of CGI.pm, the module
3925will treat it as a new HTML tag and generate the appropriate
3926subroutine. You can then use it like any other HTML tag. This is to
3927provide for the rapidly-evolving HTML "standard." For example, say
3928Microsoft comes out with a new tag called <GRADIENT> (which causes the
3929user's desktop to be flooded with a rotating gradient fill until his
3930machine reboots). You don't need to wait for a new version of CGI.pm
d23a249d 3931to start using it immediately:
424ec8fa
GS		 3932
3933 use CGI qw/:standard :html3 gradient/;
3934 print gradient({-start=>'red',-end=>'blue'});
3935
3936Note that in the interests of execution speed CGI.pm does B<not> use
3937the standard L<Exporter> syntax for specifying load symbols. This may
3938change in the future.
3939
3940If you import any of the state-maintaining CGI or form-generating
3941methods, a default CGI object will be created and initialized
3942automatically the first time you use any of the methods that require
3943one to be present. This includes B<param()>, B<textfield()>,
3944B<submit()> and the like. (If you need direct access to the CGI
3945object, you can find it in the global variable B<$CGI::Q>). By
3946importing CGI.pm methods, you can create visually elegant scripts:
3947
3948 use CGI qw/:standard/;
3949 print
3950 header,
3951 start_html('Simple Script'),
3952 h1('Simple Script'),
3953 start_form,
3954 "What's your name? ",textfield('name'),p,
3955 "What's the combination?",
3956 checkbox_group(-name=>'words',
3957 -values=>['eenie','meenie','minie','moe'],
3958 -defaults=>['eenie','moe']),p,
3959 "What's your favorite color?",
3960 popup_menu(-name=>'color',
3961 -values=>['red','green','blue','chartreuse']),p,
3962 submit,
3963 end_form,
3964 hr,"\n";
3965
3966 if (param) {
3967 print
3968 "Your name is ",em(param('name')),p,
3969 "The keywords are: ",em(join(", ",param('words'))),p,
3970 "Your favorite color is ",em(param('color')),".\n";
3971 }
3972 print end_html;
3973
3974=head2 PRAGMAS
3975
3976In addition to the function sets, there are a number of pragmas that
3977you can import. Pragmas, which are always preceded by a hyphen,
3978change the way that CGI.pm functions in various ways. Pragmas,
3979function sets, and individual functions can all be imported in the
3980same use() line. For example, the following use statement imports the
3981standard set of functions and disables debugging mode (pragma
3982-no_debug):
3983
3984 use CGI qw/:standard -no_debug/;
3985
3986The current list of pragmas is as follows:
3987
3988=over 4
3989
3990=item -any
3991
3992When you I<use CGI -any>, then any method that the query object
3993doesn't recognize will be interpreted as a new HTML tag. This allows
3994you to support the next I<ad hoc> Netscape or Microsoft HTML
3995extension. This lets you go wild with new and unsupported tags:
3996
3997 use CGI qw(-any);
3998 $q=new CGI;
3999 print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
4000
4001Since using <cite>any</cite> causes any mistyped method name
4002to be interpreted as an HTML tag, use it with care or not at
4003all.
54310121 4004
424ec8fa 4005=item -compile
54310121 4006
424ec8fa
GS		 4007This causes the indicated autoloaded methods to be compiled up front,
4008rather than deferred to later. This is useful for scripts that run
4009for an extended period of time under FastCGI or mod_perl, and for
4010those destined to be crunched by Malcom Beattie's Perl compiler. Use
f610777f 4011it in conjunction with the methods or method families you plan to use.
424ec8fa
GS		 4012
4013 use CGI qw(-compile :standard :html3);
4014
4015or even
4016
4017 use CGI qw(-compile :all);
4018
4019Note that using the -compile pragma in this way will always have
4020the effect of importing the compiled functions into the current
4021namespace. If you want to compile without importing use the
4022compile() method instead (see below).
4023
4024=item -nph
4025
4026This makes CGI.pm produce a header appropriate for an NPH (no
4027parsed header) script. You may need to do other things as well
4028to tell the server that the script is NPH. See the discussion
4029of NPH scripts below.
4030
71f3e297
JH		 4031=item -newstyle_urls
4032
4033Separate the name=value pairs in CGI parameter query strings with
4034semicolons rather than ampersands. For example:
4035
4036 ?name=fred;age=24;favorite_color=3
4037
4038Semicolon-delimited query strings are always accepted, but will not be
4039emitted by self_url() and query_string() unless the -newstyle_urls
4040pragma is specified.
4041
424ec8fa
GS		 4042=item -autoload
4043
4044This overrides the autoloader so that any function in your program
4045that is not recognized is referred to CGI.pm for possible evaluation.
4046This allows you to use all the CGI.pm functions without adding them to
4047your symbol table, which is of concern for mod_perl users who are
4048worried about memory consumption. I<Warning:> when
4049I<-autoload> is in effect, you cannot use "poetry mode"
4050(functions without the parenthesis). Use I<hr()> rather
4051than I<hr>, or add something like I<use subs qw/hr p header/>
4052to the top of your script.
4053
4054=item -no_debug
4055
4056This turns off the command-line processing features. If you want to
4057run a CGI.pm script from the command line to produce HTML, and you
4058don't want it pausing to request CGI parameters from standard input or
4059the command line, then use this pragma:
4060
4061 use CGI qw(-no_debug :standard);
4062
4063If you'd like to process the command-line parameters but not standard
4064input, this should work:
4065
4066 use CGI qw(-no_debug :standard);
4067 restore_parameters(join('&',@ARGV));
4068
4069See the section on debugging for more details.
4070
4071=item -private_tempfiles
4072
f6b3007c
JH		 4073CGI.pm can process uploaded file. Ordinarily it spools the uploaded
4074file to a temporary directory, then deletes the file when done.
4075However, this opens the risk of eavesdropping as described in the file
4076upload section. Another CGI script author could peek at this data
4077during the upload, even if it is confidential information. On Unix
4078systems, the -private_tempfiles pragma will cause the temporary file
4079to be unlinked as soon as it is opened and before any data is written
4080into it, reducing, but not eliminating the risk of eavesdropping
4081(there is still a potential race condition). To make life harder for
4082the attacker, the program chooses tempfile names by calculating a 32
4083bit checksum of the incoming HTTP headers.
4084
4085To ensure that the temporary file cannot be read by other CGI scripts,
4086use suEXEC or a CGI wrapper program to run your script. The temporary
4087file is created with mode 0600 (neither world nor group readable).
4088
4089The temporary directory is selected using the following algorithm:
4090
4091 1. if the current user (e.g. "nobody") has a directory named
4092 "tmp" in its home directory, use that (Unix systems only).
4093
4094 2. if the environment variable TMPDIR exists, use the location
4095 indicated.
4096
4097 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp,
4098 /tmp, /temp, ::Temporary Items, and \WWW_ROOT.
4099
4100Each of these locations is checked that it is a directory and is
4101writable. If not, the algorithm tries the next choice.
71f3e297
JH		 4102
4103=back
4104
4105=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS
4106
4107Many of the methods generate HTML tags. As described below, tag
4108functions automatically generate both the opening and closing tags.
4109For example:
4110
4111 print h1('Level 1 Header');
4112
4113produces
4114
4115 <H1>Level 1 Header</H1>
4116
4117There will be some times when you want to produce the start and end
4118tags yourself. In this case, you can use the form start_I<tag_name>
4119and end_I<tag_name>, as in:
4120
4121 print start_h1,'Level 1 Header',end_h1;
4122
4123With a few exceptions (described below), start_I<tag_name> and
4124end_I<tag_name> functions are not generated automatically when you
4125I<use CGI>. However, you can specify the tags you want to generate
4126I<start/end> functions for by putting an asterisk in front of their
4127name, or, alternatively, requesting either "start_I<tag_name>" or
4128"end_I<tag_name>" in the import list.
4129
4130Example:
4131
4132 use CGI qw/:standard *table start_ul/;
4133
4134In this example, the following functions are generated in addition to
4135the standard ones:
4136
4137=over 4
4138
4139=item 1. start_table() (generates a <TABLE> tag)
4140
4141=item 2. end_table() (generates a </TABLE> tag)
4142
4143=item 3. start_ul() (generates a <UL> tag)
4144
4145=item 4. end_ul() (generates a </UL> tag)
4146
424ec8fa
GS		 4147=back
4148
4149=head1 GENERATING DYNAMIC DOCUMENTS
4150
4151Most of CGI.pm's functions deal with creating documents on the fly.
4152Generally you will produce the HTTP header first, followed by the
4153document itself. CGI.pm provides functions for generating HTTP
4154headers of various types as well as for generating HTML. For creating
4155GIF images, see the GD.pm module.
4156
4157Each of these functions produces a fragment of HTML or HTTP which you
4158can print out directly so that it displays in the browser window,
4159append to a string, or save to a file for later use.
4160
4161=head2 CREATING A STANDARD HTTP HEADER:
4162
4163Normally the first thing you will do in any CGI script is print out an
4164HTTP header. This tells the browser what type of document to expect,
4165and gives other optional information, such as the language, expiration
4166date, and whether to cache the document. The header can also be
4167manipulated for special purposes, such as server push and pay per view
4168pages.
54310121 4169
4170 print $query->header;
4171
4172 -or-
4173
4174 print $query->header('image/gif');
4175
4176 -or-
4177
4178 print $query->header('text/html','204 No response');
4179
4180 -or-
4181
4182 print $query->header(-type=>'image/gif',
4183 -nph=>1,
4184 -status=>'402 Payment required',
4185 -expires=>'+3d',
4186 -cookie=>$cookie,
4187 -Cost=>'$2.00');
4188
4189header() returns the Content-type: header. You can provide your own
4190MIME type if you choose, otherwise it defaults to text/html. An
4191optional second parameter specifies the status code and a human-readable
4192message. For example, you can specify 204, "No response" to create a
424ec8fa 4193script that tells the browser to do nothing at all.
54310121 4194
4195The last example shows the named argument style for passing arguments
4196to the CGI methods using named parameters. Recognized parameters are
424ec8fa 4197B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named
54310121 4198parameters will be stripped of their initial hyphens and turned into
4199header fields, allowing you to specify any HTTP header you desire.
424ec8fa
GS		 4200Internal underscores will be turned into hyphens:
4201
4202 print $query->header(-Content_length=>3002);
54310121 4203
4204Most browsers will not cache the output from CGI scripts. Every time
4205the browser reloads the page, the script is invoked anew. You can
4206change this behavior with the B<-expires> parameter. When you specify
4207an absolute or relative expiration interval with this parameter, some
4208browsers and proxy servers will cache the script's output until the
4209indicated expiration date. The following forms are all valid for the
4210-expires field:
4211
4212 +30s 30 seconds from now
4213 +10m ten minutes from now
4214 +1h one hour from now
4215 -1d yesterday (i.e. "ASAP!")
4216 now immediately
4217 +3M in three months
4218 +10y in ten years time
424ec8fa 4219 Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date
54310121 4220
4221The B<-cookie> parameter generates a header that tells the browser to provide
4222a "magic cookie" during all subsequent transactions with your script.
4223Netscape cookies have a special format that includes interesting attributes
4224such as expiration time. Use the cookie() method to create and retrieve
4225session cookies.
4226
4227The B<-nph> parameter, if set to a true value, will issue the correct
4228headers to work with a NPH (no-parse-header) script. This is important
4229to use with certain servers, such as Microsoft Internet Explorer, which
4230expect all their scripts to be NPH.
4231
424ec8fa 4232=head2 GENERATING A REDIRECTION HEADER
54310121 4233
4234 print $query->redirect('http://somewhere.else/in/movie/land');
4235
424ec8fa
GS		 4236Sometimes you don't want to produce a document yourself, but simply
4237redirect the browser elsewhere, perhaps choosing a URL based on the
4238time of day or the identity of the user.
4239
4240The redirect() function redirects the browser to a different URL. If
4241you use redirection like this, you should B<not> print out a header as
4242well. As of version 2.0, we produce both the unofficial Location:
4243header and the official URI: header. This should satisfy most servers
4244and browsers.
54310121 4245
4246One hint I can offer is that relative links may not work correctly
7a2e2cd6 4247when you generate a redirection to another document on your site.
54310121 4248This is due to a well-intentioned optimization that some servers use.
4249The solution to this is to use the full URL (including the http: part)
4250of the document you are redirecting to.
4251
424ec8fa 4252You can also use named arguments:
54310121 4253
4254 print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
4255 -nph=>1);
4256
4257The B<-nph> parameter, if set to a true value, will issue the correct
4258headers to work with a NPH (no-parse-header) script. This is important
4259to use with certain servers, such as Microsoft Internet Explorer, which
4260expect all their scripts to be NPH.
4261
424ec8fa 4262=head2 CREATING THE HTML DOCUMENT HEADER
54310121 4263
4264 print $query->start_html(-title=>'Secrets of the Pyramids',
4265 -author=>'fred@capricorn.org',
4266 -base=>'true',
4267 -target=>'_blank',
4268 -meta=>{'keywords'=>'pharaoh secret mummy',
4269 'copyright'=>'copyright 1996 King Tut'},
7d37aa8e 4270 -style=>{'src'=>'/styles/style1.css'},
54310121 4271 -BGCOLOR=>'blue');
4272
424ec8fa
GS		 4273After creating the HTTP header, most CGI scripts will start writing
4274out an HTML document. The start_html() routine creates the top of the
4275page, along with a lot of optional information that controls the
4276page's appearance and behavior.
54310121 4277
424ec8fa
GS		 4278This method returns a canned HTML header and the opening <BODY> tag.
4279All parameters are optional. In the named parameter form, recognized
4280parameters are -title, -author, -base, -xbase and -target (see below
4281for the explanation). Any additional parameters you provide, such as
4282the Netscape unofficial BGCOLOR attribute, are added to the <BODY>
4283tag. Additional parameters must be proceeded by a hyphen.
54310121 4284
4285The argument B<-xbase> allows you to provide an HREF for the <BASE> tag
4286different from the current location, as in
4287
4288 -xbase=>"http://home.mcom.com/"
4289
4290All relative links will be interpreted relative to this tag.
4291
4292The argument B<-target> allows you to provide a default target frame
4293for all the links and fill-out forms on the page. See the Netscape
4294documentation on frames for details of how to manipulate this.
4295
4296 -target=>"answer_window"
4297
4298All relative links will be interpreted relative to this tag.
4299You add arbitrary meta information to the header with the B<-meta>
4300argument. This argument expects a reference to an associative array
4301containing name/value pairs of meta information. These will be turned
4302into a series of header <META> tags that look something like this:
4303
424ec8fa
GS		 4304 <META NAME="keywords" CONTENT="pharaoh secret mummy">
4305 <META NAME="description" CONTENT="copyright 1996 King Tut">
4306
4307There is no support for the HTTP-EQUIV type of <META> tag. This is
4308because you can modify the HTTP header directly with the B<header()>
4309method. For example, if you want to send the Refresh: header, do it
4310in the header() method:
4311
4312 print $q->header(-Refresh=>'10; URL=http://www.capricorn.com');
4313
4314The B<-style> tag is used to incorporate cascading stylesheets into
4315your code. See the section on CASCADING STYLESHEETS for more information.
4316
4317You can place other arbitrary HTML elements to the <HEAD> section with the
4318B<-head> tag. For example, to place the rarely-used <LINK> element in the
4319head section, use this:
4320
f6b3007c
JH		 4321 print start_html(-head=>Link({-rel=>'next',
4322 -href=>'http://www.capricorn.com/s2.html'}));
424ec8fa
GS		 4323
4324To incorporate multiple HTML elements into the <HEAD> section, just pass an
4325array reference:
4326
f6b3007c
JH		 4327 print start_html(-head=>[
4328 Link({-rel=>'next',
4329 -href=>'http://www.capricorn.com/s2.html'}),
4330 Link({-rel=>'previous',
4331 -href=>'http://www.capricorn.com/s1.html'})
424ec8fa
GS		 4332 ]
4333 );
4334
4335JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
4336B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
4337to add Netscape JavaScript calls to your pages. B<-script> should
4338point to a block of text containing JavaScript function definitions.
4339This block will be placed within a <SCRIPT> block inside the HTML (not
4340HTTP) header. The block is placed in the header in order to give your
4341page a fighting chance of having all its JavaScript functions in place
4342even if the user presses the stop button before the page has loaded
4343completely. CGI.pm attempts to format the script in such a way that
4344JavaScript-naive browsers will not choke on the code: unfortunately
4345there are some browsers, such as Chimera for Unix, that get confused
4346by it nevertheless.
4347
4348The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
4349code to execute when the page is respectively opened and closed by the
4350browser. Usually these parameters are calls to functions defined in the
4351B<-script> field:
4352
4353 $query = new CGI;
4354 print $query->header;
4355 $JSCRIPT=<<END;
4356 // Ask a silly question
4357 function riddle_me_this() {
4358 var r = prompt("What walks on four legs in the morning, " +
4359 "two legs in the afternoon, " +
4360 "and three legs in the evening?");
4361 response(r);
4362 }
4363 // Get a silly answer
4364 function response(answer) {
4365 if (answer == "man")
4366 alert("Right you are!");
4367 else
4368 alert("Wrong! Guess again.");
4369 }
4370 END
4371 print $query->start_html(-title=>'The Riddle of the Sphinx',
4372 -script=>$JSCRIPT);
4373
4374Use the B<-noScript> parameter to pass some HTML text that will be displayed on
4375browsers that do not have JavaScript (or browsers where JavaScript is turned
4376off).
4377
4378Netscape 3.0 recognizes several attributes of the <SCRIPT> tag,
4379including LANGUAGE and SRC. The latter is particularly interesting,
4380as it allows you to keep the JavaScript code in a file or CGI script
4381rather than cluttering up each page with the source. To use these
4382attributes pass a HASH reference in the B<-script> parameter containing
4383one or more of -language, -src, or -code:
4384
4385 print $q->start_html(-title=>'The Riddle of the Sphinx',
4386 -script=>{-language=>'JAVASCRIPT',
4387 -src=>'/javascript/sphinx.js'}
4388 );
4389
4390 print $q->(-title=>'The Riddle of the Sphinx',
f6b3007c
JH		 4391 -script=>{-language=>'PERLSCRIPT',
4392 -code=>'print "hello world!\n;"'}
424ec8fa
GS		 4393 );
4394
4395
4396A final feature allows you to incorporate multiple <SCRIPT> sections into the
4397header. Just pass the list of script sections as an array reference.
4398this allows you to specify different source files for different dialects
4399of JavaScript. Example:
4400
f6b3007c
JH		 4401 print $q->start_html(-title=>'The Riddle of the Sphinx',
4402 -script=>[
4403 { -language => 'JavaScript1.0',
4404 -src => '/javascript/utilities10.js'
424ec8fa 4405 },
f6b3007c
JH		 4406 { -language => 'JavaScript1.1',
4407 -src => '/javascript/utilities11.js'
424ec8fa 4408 },
f6b3007c
JH		 4409 { -language => 'JavaScript1.2',
4410 -src => '/javascript/utilities12.js'
424ec8fa 4411 },
f6b3007c
JH		 4412 { -language => 'JavaScript28.2',
4413 -src => '/javascript/utilities219.js'
424ec8fa
GS		 4414 }
4415 ]
4416 );
4417 </pre>
4418
4419If this looks a bit extreme, take my advice and stick with straight CGI scripting.
4420
4421See
4422
4423 http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
4424
4425for more information about JavaScript.
4426
4427The old-style positional parameters are as follows:
4428
4429=over 4
4430
4431=item B<Parameters:>
4432
4433=item 1.
4434
4435The title
4436
4437=item 2.
4438
4439The author's e-mail address (will create a <LINK REV="MADE"> tag if present
4440
4441=item 3.
4442
4443A 'true' flag if you want to include a <BASE> tag in the header. This
4444helps resolve relative addresses to absolute ones when the document is moved,
4445but makes the document hierarchy non-portable. Use with care!
4446
4447=item 4, 5, 6...
4448
4449Any other parameters you want to include in the <BODY> tag. This is a good
4450place to put Netscape extensions, such as colors and wallpaper patterns.
4451
4452=back
4453
4454=head2 ENDING THE HTML DOCUMENT:
4455
4456 print $query->end_html
4457
4458This ends an HTML document by printing the </BODY></HTML> tags.
4459
4460=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
4461
4462 $myself = $query->self_url;
4463 print "<A HREF=$myself>I'm talking to myself.</A>";
4464
4465self_url() will return a URL, that, when selected, will reinvoke
4466this script with all its state information intact. This is most
4467useful when you want to jump around within the document using
4468internal anchors but you don't want to disrupt the current contents
4469of the form(s). Something like this will do the trick.
4470
4471 $myself = $query->self_url;
4472 print "<A HREF=$myself#table1>See table 1</A>";
4473 print "<A HREF=$myself#table2>See table 2</A>";
4474 print "<A HREF=$myself#yourself>See for yourself</A>";
4475
4476If you want more control over what's returned, using the B<url()>
4477method instead.
4478
4479You can also retrieve the unprocessed query string with query_string():
4480
4481 $the_string = $query->query_string;
4482
4483=head2 OBTAINING THE SCRIPT'S URL
4484
4485 $full_url = $query->url();
4486 $full_url = $query->url(-full=>1); #alternative syntax
4487 $relative_url = $query->url(-relative=>1);
4488 $absolute_url = $query->url(-absolute=>1);
4489 $url_with_path = $query->url(-path_info=>1);
4490 $url_with_path_and_query = $query->url(-path_info=>1,-query=>1);
4491
4492B<url()> returns the script's URL in a variety of formats. Called
4493without any arguments, it returns the full form of the URL, including
4494host name and port number
4495
4496 http://your.host.com/path/to/script.cgi
4497
4498You can modify this format with the following named arguments:
4499
4500=over 4
4501
4502=item B<-absolute>
4503
4504If true, produce an absolute URL, e.g.
4505
4506 /path/to/script.cgi
4507
4508=item B<-relative>
4509
4510Produce a relative URL. This is useful if you want to reinvoke your
4511script with different parameters. For example:
4512
4513 script.cgi
4514
4515=item B<-full>
4516
4517Produce the full URL, exactly as if called without any arguments.
4518This overrides the -relative and -absolute arguments.
4519
4520=item B<-path> (B<-path_info>)
4521
4522Append the additional path information to the URL. This can be
4523combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info>
4524is provided as a synonym.
4525
4526=item B<-query> (B<-query_string>)
4527
4528Append the query string to the URL. This can be combined with
4529B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
4530as a synonym.
4531
4532=back
4533
71f3e297
JH		 4534=head2 MIXING POST AND URL PARAMETERS
4535
4536 $color = $query-&gt;url_param('color');
4537
4538It is possible for a script to receive CGI parameters in the URL as
4539well as in the fill-out form by creating a form that POSTs to a URL
4540containing a query string (a "?" mark followed by arguments). The
4541B<param()> method will always return the contents of the POSTed
4542fill-out form, ignoring the URL's query string. To retrieve URL
4543parameters, call the B<url_param()> method. Use it in the same way as
4544B<param()>. The main difference is that it allows you to read the
4545parameters, but not set them.
4546
4547
4548Under no circumstances will the contents of the URL query string
4549interfere with similarly-named CGI parameters in POSTed forms. If you
4550try to mix a URL query string with a form submitted with the GET
4551method, the results will not be what you expect.
4552
424ec8fa
GS		 4553=head1 CREATING STANDARD HTML ELEMENTS:
4554
4555CGI.pm defines general HTML shortcut methods for most, if not all of
4556the HTML 3 and HTML 4 tags. HTML shortcuts are named after a single
4557HTML element and return a fragment of HTML text that you can then
4558print or manipulate as you like. Each shortcut returns a fragment of
4559HTML code that you can append to a string, save to a file, or, most
4560commonly, print out so that it displays in the browser window.
4561
4562This example shows how to use the HTML methods:
4563
4564 $q = new CGI;
4565 print $q->blockquote(
4566 "Many years ago on the island of",
4567 $q->a({href=>"http://crete.org/"},"Crete"),
f6b3007c 4568 "there lived a Minotaur named",
424ec8fa
GS		 4569 $q->strong("Fred."),
4570 ),
4571 $q->hr;
4572
4573This results in the following HTML code (extra newlines have been
4574added for readability):
4575
4576 <blockquote>
4577 Many years ago on the island of
4578 <a HREF="http://crete.org/">Crete</a> there lived
4579 a minotaur named <strong>Fred.</strong>
4580 </blockquote>
4581 <hr>
4582
4583If you find the syntax for calling the HTML shortcuts awkward, you can
4584import them into your namespace and dispense with the object syntax
4585completely (see the next section for more details):
4586
4587 use CGI ':standard';
4588 print blockquote(
4589 "Many years ago on the island of",
4590 a({href=>"http://crete.org/"},"Crete"),
4591 "there lived a minotaur named",
4592 strong("Fred."),
4593 ),
4594 hr;
54310121 4595
424ec8fa 4596=head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
7d37aa8e 4597
424ec8fa
GS		 4598The HTML methods will accept zero, one or multiple arguments. If you
4599provide no arguments, you get a single tag:
7d37aa8e 4600
424ec8fa 4601 print hr; # <HR>
7d37aa8e 4602
424ec8fa
GS		 4603If you provide one or more string arguments, they are concatenated
4604together with spaces and placed between opening and closing tags:
7d37aa8e 4605
424ec8fa 4606 print h1("Chapter","1"); # <H1>Chapter 1</H1>"
7d37aa8e 4607
424ec8fa
GS		 4608If the first argument is an associative array reference, then the keys
4609and values of the associative array become the HTML tag's attributes:
7d37aa8e 4610
424ec8fa
GS		 4611 print a({-href=>'fred.html',-target=>'_new'},
4612 "Open a new frame");
7d37aa8e 4613
424ec8fa
GS		 4614 <A HREF="fred.html",TARGET="_new">Open a new frame</A>
4615
4616You may dispense with the dashes in front of the attribute names if
4617you prefer:
54310121 4618
424ec8fa 4619 print img {src=>'fred.gif',align=>'LEFT'};
54310121 4620
424ec8fa 4621 <IMG ALIGN="LEFT" SRC="fred.gif">
54310121 4622
424ec8fa
GS		 4623Sometimes an HTML tag attribute has no argument. For example, ordered
4624lists can be marked as COMPACT. The syntax for this is an argument that
4625that points to an undef string:
54310121 4626
424ec8fa 4627 print ol({compact=>undef},li('one'),li('two'),li('three'));
47e3cabd 4628
424ec8fa
GS		 4629Prior to CGI.pm version 2.41, providing an empty ('') string as an
4630attribute argument was the same as providing undef. However, this has
f610777f 4631changed in order to accommodate those who want to create tags of the form
424ec8fa
GS		 4632<IMG ALT="">. The difference is shown in these two pieces of code:
4633
4634 CODE RESULT
4635 img({alt=>undef}) <IMG ALT>
4636 img({alt=>''}) <IMT ALT="">
7d37aa8e 4637
424ec8fa 4638=head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
7d37aa8e 4639
424ec8fa
GS		 4640One of the cool features of the HTML shortcuts is that they are
4641distributive. If you give them an argument consisting of a
4642B<reference> to a list, the tag will be distributed across each
4643element of the list. For example, here's one way to make an ordered
4644list:
7d37aa8e 4645
424ec8fa
GS		 4646 print ul(
4647 li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']);
4648 );
7d37aa8e 4649
424ec8fa 4650This example will result in HTML output that looks like this:
54310121 4651
424ec8fa
GS		 4652 <UL>
4653 <LI TYPE="disc">Sneezy</LI>
4654 <LI TYPE="disc">Doc</LI>
4655 <LI TYPE="disc">Sleepy</LI>
4656 <LI TYPE="disc">Happy</LI>
4657 </UL>
54310121 4658
424ec8fa 4659This is extremely useful for creating tables. For example:
54310121 4660
424ec8fa
GS		 4661 print table({-border=>undef},
4662 caption('When Should You Eat Your Vegetables?'),
4663 Tr({-align=>CENTER,-valign=>TOP},
4664 [
4665 th(['Vegetable', 'Breakfast','Lunch','Dinner']),
4666 td(['Tomatoes' , 'no', 'yes', 'yes']),
4667 td(['Broccoli' , 'no', 'no', 'yes']),
4668 td(['Onions' , 'yes','yes', 'yes'])
4669 ]
4670 )
4671 );
54310121 4672
424ec8fa 4673=head2 HTML SHORTCUTS AND LIST INTERPOLATION
54310121 4674
424ec8fa 4675Consider this bit of code:
54310121 4676
424ec8fa 4677 print blockquote(em('Hi'),'mom!'));
54310121 4678
424ec8fa 4679It will ordinarily return the string that you probably expect, namely:
54310121 4680
424ec8fa 4681 <BLOCKQUOTE><EM>Hi</EM> mom!</BLOCKQUOTE>
54310121 4682
424ec8fa
GS		 4683Note the space between the element "Hi" and the element "mom!".
4684CGI.pm puts the extra space there using array interpolation, which is
4685controlled by the magic $" variable. Sometimes this extra space is
4686not what you want, for example, when you are trying to align a series
4687of images. In this case, you can simply change the value of $" to an
4688empty string.
54310121 4689
424ec8fa
GS		 4690 {
4691 local($") = '';
4692 print blockquote(em('Hi'),'mom!'));
4693 }
54310121 4694
424ec8fa
GS		 4695I suggest you put the code in a block as shown here. Otherwise the
4696change to $" will affect all subsequent code until you explicitly
4697reset it.
54310121 4698
424ec8fa 4699=head2 NON-STANDARD HTML SHORTCUTS
54310121 4700
424ec8fa
GS		 4701A few HTML tags don't follow the standard pattern for various
4702reasons.
54310121 4703
424ec8fa
GS		 4704B<comment()> generates an HTML comment (<!-- comment -->). Call it
4705like
54310121 4706
424ec8fa 4707 print comment('here is my comment');
54310121 4708
424ec8fa
GS		 4709Because of conflicts with built-in Perl functions, the following functions
4710begin with initial caps:
54310121 4711
424ec8fa
GS		 4712 Select
4713 Tr
4714 Link
4715 Delete
71f3e297
JH		 4716 Accept
4717 Sub
54310121 4718
424ec8fa
GS		 4719In addition, start_html(), end_html(), start_form(), end_form(),
4720start_multipart_form() and all the fill-out form tags are special.
4721See their respective sections.
4722
71f3e297
JH		 4723=head2 PRETTY-PRINTING HTML
4724
4725By default, all the HTML produced by these functions comes out as one
4726long line without carriage returns or indentation. This is yuck, but
4727it does reduce the size of the documents by 10-20%. To get
4728pretty-printed output, please use L<CGI::Pretty>, a subclass
4729contributed by Brian Paulsen.
4730
424ec8fa 4731=head1 CREATING FILL-OUT FORMS:
54310121 4732
4733I<General note> The various form-creating methods all return strings
4734to the caller, containing the tag or tags that will create the requested
4735form element. You are responsible for actually printing out these strings.
4736It's set up this way so that you can place formatting tags
4737around the form elements.
4738
4739I<Another note> The default values that you specify for the forms are only
4740used the B<first> time the script is invoked (when there is no query
4741string). On subsequent invocations of the script (when there is a query
4742string), the former values are used even if they are blank.
4743
4744If you want to change the value of a field from its previous value, you have two
4745choices:
4746
4747(1) call the param() method to set it.
4748
4749(2) use the -override (alias -force) parameter (a new feature in version 2.15).
4750This forces the default value to be used, regardless of the previous value:
4751
4752 print $query->textfield(-name=>'field_name',
4753 -default=>'starting value',
4754 -override=>1,
4755 -size=>50,
4756 -maxlength=>80);
4757
4758I<Yet another note> By default, the text and labels of form elements are
4759escaped according to HTML rules. This means that you can safely use
4760"<CLICK ME>" as the label for a button. However, it also interferes with
4761your ability to incorporate special HTML character sequences, such as &Aacute;,
4762into your fields. If you wish to turn off automatic escaping, call the
4763autoEscape() method with a false value immediately after creating the CGI object:
4764
4765 $query = new CGI;
4766 $query->autoEscape(undef);
4767
4768
4769=head2 CREATING AN ISINDEX TAG
4770
4771 print $query->isindex(-action=>$action);
4772
4773 -or-
4774
4775 print $query->isindex($action);
4776
4777Prints out an <ISINDEX> tag. Not very exciting. The parameter
4778-action specifies the URL of the script to process the query. The
4779default is to process the query with the current script.
4780
4781=head2 STARTING AND ENDING A FORM
4782
4783 print $query->startform(-method=>$method,
4784 -action=>$action,
71f3e297 4785 -enctype=>$encoding);
54310121 4786 <... various form stuff ...>
4787 print $query->endform;
4788
4789 -or-
4790
4791 print $query->startform($method,$action,$encoding);
4792 <... various form stuff ...>
4793 print $query->endform;
4794
4795startform() will return a <FORM> tag with the optional method,
4796action and form encoding that you specify. The defaults are:
4797
4798 method: POST
4799 action: this script
71f3e297 4800 enctype: application/x-www-form-urlencoded
54310121 4801
4802endform() returns the closing </FORM> tag.
4803
71f3e297 4804Startform()'s enctype argument tells the browser how to package the various
54310121 4805fields of the form before sending the form to the server. Two
4806values are possible:
4807
4808=over 4
4809
4810=item B<application/x-www-form-urlencoded>
4811
4812This is the older type of encoding used by all browsers prior to
4813Netscape 2.0. It is compatible with many CGI scripts and is
4814suitable for short fields containing text data. For your
4815convenience, CGI.pm stores the name of this encoding
4816type in B<$CGI::URL_ENCODED>.
4817
4818=item B<multipart/form-data>
4819
4820This is the newer type of encoding introduced by Netscape 2.0.
4821It is suitable for forms that contain very large fields or that
4822are intended for transferring binary data. Most importantly,
4823it enables the "file upload" feature of Netscape 2.0 forms. For
4824your convenience, CGI.pm stores the name of this encoding type
424ec8fa 4825in B<&CGI::MULTIPART>
54310121 4826
4827Forms that use this type of encoding are not easily interpreted
4828by CGI scripts unless they use CGI.pm or another library designed
4829to handle them.
4830
4831=back
4832
4833For compatibility, the startform() method uses the older form of
4834encoding by default. If you want to use the newer form of encoding
4835by default, you can call B<start_multipart_form()> instead of
4836B<startform()>.
4837
4838JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
4839for use with JavaScript. The -name parameter gives the
4840form a name so that it can be identified and manipulated by
4841JavaScript functions. -onSubmit should point to a JavaScript
4842function that will be executed just before the form is submitted to your
4843server. You can use this opportunity to check the contents of the form
4844for consistency and completeness. If you find something wrong, you
4845can put up an alert box or maybe fix things up yourself. You can
4846abort the submission by returning false from this function.
4847
4848Usually the bulk of JavaScript functions are defined in a <SCRIPT>
4849block in the HTML header and -onSubmit points to one of these function
4850call. See start_html() for details.
4851
4852=head2 CREATING A TEXT FIELD
4853
4854 print $query->textfield(-name=>'field_name',
4855 -default=>'starting value',
4856 -size=>50,
4857 -maxlength=>80);
4858 -or-
4859
4860 print $query->textfield('field_name','starting value',50,80);
4861
4862textfield() will return a text input field.
4863
4864=over 4
4865
4866=item B<Parameters>
4867
4868=item 1.
4869
4870The first parameter is the required name for the field (-name).
4871
4872=item 2.
4873
4874The optional second parameter is the default starting value for the field
4875contents (-default).
4876
4877=item 3.
4878
4879The optional third parameter is the size of the field in
4880 characters (-size).
4881
4882=item 4.
4883
4884The optional fourth parameter is the maximum number of characters the
4885 field will accept (-maxlength).
4886
4887=back
4888
4889As with all these methods, the field will be initialized with its
4890previous contents from earlier invocations of the script.
4891When the form is processed, the value of the text field can be
4892retrieved with:
4893
4894 $value = $query->param('foo');
4895
4896If you want to reset it from its initial value after the script has been
4897called once, you can do so like this:
4898
4899 $query->param('foo',"I'm taking over this value!");
4900
4901NEW AS OF VERSION 2.15: If you don't want the field to take on its previous
4902value, you can force its current value by using the -override (alias -force)
4903parameter:
4904
4905 print $query->textfield(-name=>'field_name',
4906 -default=>'starting value',
4907 -override=>1,
4908 -size=>50,
4909 -maxlength=>80);
4910
424ec8fa
GS		 4911JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>,
4912B<-onBlur>, B<-onMouseOver>, B<-onMouseOut> and B<-onSelect>
4913parameters to register JavaScript event handlers. The onChange
4914handler will be called whenever the user changes the contents of the
4915text field. You can do text validation if you like. onFocus and
4916onBlur are called respectively when the insertion point moves into and
4917out of the text field. onSelect is called when the user changes the
4918portion of the text that is selected.
54310121 4919
4920=head2 CREATING A BIG TEXT FIELD
4921
4922 print $query->textarea(-name=>'foo',
4923 -default=>'starting value',
4924 -rows=>10,
4925 -columns=>50);
4926
4927 -or
4928
4929 print $query->textarea('foo','starting value',10,50);
4930
4931textarea() is just like textfield, but it allows you to specify
4932rows and columns for a multiline text entry box. You can provide
4933a starting value for the field, which can be long and contain
4934multiple lines.
4935
424ec8fa
GS		 4936JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> ,
4937B<-onMouseOver>, B<-onMouseOut>, and B<-onSelect> parameters are
4938recognized. See textfield().
54310121 4939
4940=head2 CREATING A PASSWORD FIELD
4941
4942 print $query->password_field(-name=>'secret',
4943 -value=>'starting value',
4944 -size=>50,
4945 -maxlength=>80);
4946 -or-
4947
4948 print $query->password_field('secret','starting value',50,80);
4949
4950password_field() is identical to textfield(), except that its contents
4951will be starred out on the web page.
4952
424ec8fa
GS		 4953JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
4954B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
4955recognized. See textfield().
54310121 4956
4957=head2 CREATING A FILE UPLOAD FIELD
4958
4959 print $query->filefield(-name=>'uploaded_file',
4960 -default=>'starting value',
4961 -size=>50,
4962 -maxlength=>80);
4963 -or-
4964
4965 print $query->filefield('uploaded_file','starting value',50,80);
4966
4967filefield() will return a file upload field for Netscape 2.0 browsers.
4968In order to take full advantage of this I<you must use the new
4969multipart encoding scheme> for the form. You can do this either
4970by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>,
4971or by calling the new method B<start_multipart_form()> instead of
4972vanilla B<startform()>.
4973
4974=over 4
4975
4976=item B<Parameters>
4977
4978=item 1.
4979
4980The first parameter is the required name for the field (-name).
4981
4982=item 2.
4983
4984The optional second parameter is the starting value for the field contents
4985to be used as the default file name (-default).
4986
71f3e297
JH		 4987For security reasons, browsers don't pay any attention to this field,
4988and so the starting value will always be blank. Worse, the field
4989loses its "sticky" behavior and forgets its previous contents. The
4990starting value field is called for in the HTML specification, however,
4991and possibly some browser will eventually provide support for it.
54310121 4992
4993=item 3.
4994
4995The optional third parameter is the size of the field in
4996characters (-size).
4997
4998=item 4.
4999
5000The optional fourth parameter is the maximum number of characters the
5001field will accept (-maxlength).
5002
5003=back
5004
5005When the form is processed, you can retrieve the entered filename
f6b3007c 5006by calling param():
54310121 5007
5008 $filename = $query->param('uploaded_file');
5009
f6b3007c
JH		 5010Different browsers will return slightly different things for the
5011name. Some browsers return the filename only. Others return the full
5012path to the file, using the path conventions of the user's machine.
5013Regardless, the name returned is always the name of the file on the
5014I<user's> machine, and is unrelated to the name of the temporary file
5015that CGI.pm creates during upload spooling (see below).
54310121 5016
5017The filename returned is also a file handle. You can read the contents
5018of the file using standard Perl file reading calls:
5019
5020 # Read a text file and print it out
5021 while (<$filename>) {
5022 print;
5023 }
5024
5025 # Copy a binary file to somewhere safe
5026 open (OUTFILE,">>/usr/local/web/users/feedback");
5027 while ($bytesread=read($filename,$buffer,1024)) {
5028 print OUTFILE $buffer;
5029 }
5030
f6b3007c
JH		 5031However, there are problems with the dual nature of the upload fields.
5032If you C<use strict>, then Perl will complain when you try to use a
5033string as a filehandle. You can get around this by placing the file
5034reading code in a block containing the C<no strict> pragma. More
5035seriously, it is possible for the remote user to type garbage into the
5036upload field, in which case what you get from param() is not a
5037filehandle at all, but a string.
5038
5039To be safe, use the I<upload()> function (new in version 2.47). When
5040called with the name of an upload field, I<upload()> returns a
5041filehandle, or undef if the parameter is not a valid filehandle.
5042
5043 $fh = $query->upload('uploaded_file');
5044 while (<$fh>) {
5045 print;
5046 }
5047
5048This is the recommended idiom.
5049
54310121 5050When a file is uploaded the browser usually sends along some
5051information along with it in the format of headers. The information
5052usually includes the MIME content type. Future browsers may send
5053other information as well (such as modification date and size). To
5054retrieve this information, call uploadInfo(). It returns a reference to
5055an associative array containing all the document headers.
5056
5057 $filename = $query->param('uploaded_file');
5058 $type = $query->uploadInfo($filename)->{'Content-Type'};
5059 unless ($type eq 'text/html') {
5060 die "HTML FILES ONLY!";
5061 }
5062
5063If you are using a machine that recognizes "text" and "binary" data
5064modes, be sure to understand when and how to use them (see the Camel book).
f6b3007c
JH		 5065Otherwise you may find that binary files are corrupted during file
5066uploads.
5067
5068There are occasionally problems involving parsing the uploaded file.
5069This usually happens when the user presses "Stop" before the upload is
5070finished. In this case, CGI.pm will return undef for the name of the
5071uploaded file and set I<cgi_error()> to the string "400 Bad request
5072(malformed multipart POST)". This error message is designed so that
5073you can incorporate it into a status code to be sent to the browser.
5074Example:
5075
5076 $file = $query->upload('uploaded_file');
5077 if (!$file && $query->cgi_error) {
5078 print $query->header(-status->$query->cgi_error);
5079 exit 0;
5080 }
5081
5082You are free to create a custom HTML page to complain about the error,
5083if you wish.
54310121 5084
424ec8fa
GS		 5085JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
5086B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
5087recognized. See textfield() for details.
54310121 5088
5089=head2 CREATING A POPUP MENU
5090
5091 print $query->popup_menu('menu_name',
5092 ['eenie','meenie','minie'],
5093 'meenie');
5094
5095 -or-
5096
5097 %labels = ('eenie'=>'your first choice',
5098 'meenie'=>'your second choice',
5099 'minie'=>'your third choice');
5100 print $query->popup_menu('menu_name',
5101 ['eenie','meenie','minie'],
5102 'meenie',\%labels);
5103
5104 -or (named parameter style)-
5105
5106 print $query->popup_menu(-name=>'menu_name',
5107 -values=>['eenie','meenie','minie'],
5108 -default=>'meenie',
5109 -labels=>\%labels);
5110
5111popup_menu() creates a menu.
5112
5113=over 4
5114
5115=item 1.
5116
5117The required first argument is the menu's name (-name).
5118
5119=item 2.
5120
5121The required second argument (-values) is an array B<reference>
5122containing the list of menu items in the menu. You can pass the
5123method an anonymous array, as shown in the example, or a reference to
5124a named array, such as "\@foo".
5125
5126=item 3.
5127
5128The optional third parameter (-default) is the name of the default
5129menu choice. If not specified, the first item will be the default.
5130The values of the previous choice will be maintained across queries.
5131
5132=item 4.
5133
5134The optional fourth parameter (-labels) is provided for people who
5135want to use different values for the user-visible label inside the
5136popup menu nd the value returned to your script. It's a pointer to an
5137associative array relating menu values to user-visible labels. If you
5138leave this parameter blank, the menu values will be displayed by
5139default. (You can also leave a label undefined if you want to).
5140
5141=back
5142
5143When the form is processed, the selected value of the popup menu can
5144be retrieved using:
5145
5146 $popup_menu_value = $query->param('menu_name');
5147
5148JAVASCRIPTING: popup_menu() recognizes the following event handlers:
424ec8fa
GS		 5149B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>, and
5150B<-onBlur>. See the textfield() section for details on when these
5151handlers are called.
54310121 5152
5153=head2 CREATING A SCROLLING LIST
5154
5155 print $query->scrolling_list('list_name',
5156 ['eenie','meenie','minie','moe'],
5157 ['eenie','moe'],5,'true');
5158 -or-
5159
5160 print $query->scrolling_list('list_name',
5161 ['eenie','meenie','minie','moe'],
5162 ['eenie','moe'],5,'true',
5163 \%labels);
5164
5165 -or-
5166
5167 print $query->scrolling_list(-name=>'list_name',
5168 -values=>['eenie','meenie','minie','moe'],
5169 -default=>['eenie','moe'],
5170 -size=>5,
5171 -multiple=>'true',
5172 -labels=>\%labels);
5173
5174scrolling_list() creates a scrolling list.
5175
5176=over 4
5177
5178=item B<Parameters:>
5179
5180=item 1.
5181
5182The first and second arguments are the list name (-name) and values
5183(-values). As in the popup menu, the second argument should be an
5184array reference.
5185
5186=item 2.
5187
5188The optional third argument (-default) can be either a reference to a
5189list containing the values to be selected by default, or can be a
5190single value to select. If this argument is missing or undefined,
5191then nothing is selected when the list first appears. In the named
5192parameter version, you can use the synonym "-defaults" for this
5193parameter.
5194
5195=item 3.
5196
5197The optional fourth argument is the size of the list (-size).
5198
5199=item 4.
5200
5201The optional fifth argument can be set to true to allow multiple
5202simultaneous selections (-multiple). Otherwise only one selection
5203will be allowed at a time.
5204
5205=item 5.
5206
5207The optional sixth argument is a pointer to an associative array
5208containing long user-visible labels for the list items (-labels).
5209If not provided, the values will be displayed.
5210
5211When this form is processed, all selected list items will be returned as
5212a list under the parameter name 'list_name'. The values of the
5213selected items can be retrieved with:
5214
5215 @selected = $query->param('list_name');
5216
5217=back
5218
424ec8fa
GS		 5219JAVASCRIPTING: scrolling_list() recognizes the following event
5220handlers: B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>
5221and B<-onBlur>. See textfield() for the description of when these
5222handlers are called.
54310121 5223
5224=head2 CREATING A GROUP OF RELATED CHECKBOXES
5225
5226 print $query->checkbox_group(-name=>'group_name',
5227 -values=>['eenie','meenie','minie','moe'],
5228 -default=>['eenie','moe'],
5229 -linebreak=>'true',
5230 -labels=>\%labels);
5231
5232 print $query->checkbox_group('group_name',
5233 ['eenie','meenie','minie','moe'],
5234 ['eenie','moe'],'true',\%labels);
5235
5236 HTML3-COMPATIBLE BROWSERS ONLY:
5237
5238 print $query->checkbox_group(-name=>'group_name',
5239 -values=>['eenie','meenie','minie','moe'],
5240 -rows=2,-columns=>2);
5241
5242
5243checkbox_group() creates a list of checkboxes that are related
5244by the same name.
5245
5246=over 4
5247
5248=item B<Parameters:>
5249
5250=item 1.
5251
5252The first and second arguments are the checkbox name and values,
5253respectively (-name and -values). As in the popup menu, the second
5254argument should be an array reference. These values are used for the
5255user-readable labels printed next to the checkboxes as well as for the
5256values passed to your script in the query string.
5257
5258=item 2.
5259
5260The optional third argument (-default) can be either a reference to a
5261list containing the values to be checked by default, or can be a
5262single value to checked. If this argument is missing or undefined,
5263then nothing is selected when the list first appears.
5264
5265=item 3.
5266
5267The optional fourth argument (-linebreak) can be set to true to place
5268line breaks between the checkboxes so that they appear as a vertical
5269list. Otherwise, they will be strung together on a horizontal line.
5270
5271=item 4.
5272
5273The optional fifth argument is a pointer to an associative array
7a2e2cd6 5274relating the checkbox values to the user-visible labels that will
54310121 5275be printed next to them (-labels). If not provided, the values will
5276be used as the default.
5277
5278=item 5.
5279
424ec8fa
GS		 5280B<HTML3-compatible browsers> (such as Netscape) can take advantage of
5281the optional parameters B<-rows>, and B<-columns>. These parameters
5282cause checkbox_group() to return an HTML3 compatible table containing
5283the checkbox group formatted with the specified number of rows and
5284columns. You can provide just the -columns parameter if you wish;
5285checkbox_group will calculate the correct number of rows for you.
54310121 5286
5287To include row and column headings in the returned table, you
424ec8fa 5288can use the B<-rowheaders> and B<-colheaders> parameters. Both
54310121 5289of these accept a pointer to an array of headings to use.
5290The headings are just decorative. They don't reorganize the
5291interpretation of the checkboxes -- they're still a single named
5292unit.
5293
5294=back
5295
5296When the form is processed, all checked boxes will be returned as
5297a list under the parameter name 'group_name'. The values of the
5298"on" checkboxes can be retrieved with:
5299
5300 @turned_on = $query->param('group_name');
5301
5302The value returned by checkbox_group() is actually an array of button
5303elements. You can capture them and use them within tables, lists,
5304or in other creative ways:
5305
5306 @h = $query->checkbox_group(-name=>'group_name',-values=>\@values);
5307 &use_in_creative_way(@h);
5308
5309JAVASCRIPTING: checkbox_group() recognizes the B<-onClick>
5310parameter. This specifies a JavaScript code fragment or
5311function call to be executed every time the user clicks on
5312any of the buttons in the group. You can retrieve the identity
5313of the particular button clicked on using the "this" variable.
5314
5315=head2 CREATING A STANDALONE CHECKBOX
5316
5317 print $query->checkbox(-name=>'checkbox_name',
5318 -checked=>'checked',
5319 -value=>'ON',
5320 -label=>'CLICK ME');
5321
5322 -or-
5323
5324 print $query->checkbox('checkbox_name','checked','ON','CLICK ME');
5325
5326checkbox() is used to create an isolated checkbox that isn't logically
5327related to any others.
5328
5329=over 4
5330
5331=item B<Parameters:>
5332
5333=item 1.
5334
5335The first parameter is the required name for the checkbox (-name). It
5336will also be used for the user-readable label printed next to the
5337checkbox.
5338
5339=item 2.
5340
5341The optional second parameter (-checked) specifies that the checkbox
5342is turned on by default. Synonyms are -selected and -on.
5343
5344=item 3.
5345
5346The optional third parameter (-value) specifies the value of the
5347checkbox when it is checked. If not provided, the word "on" is
5348assumed.
5349
5350=item 4.
5351
5352The optional fourth parameter (-label) is the user-readable label to
5353be attached to the checkbox. If not provided, the checkbox name is
5354used.
5355
5356=back
5357
5358The value of the checkbox can be retrieved using:
5359
5360 $turned_on = $query->param('checkbox_name');
5361
5362JAVASCRIPTING: checkbox() recognizes the B<-onClick>
5363parameter. See checkbox_group() for further details.
5364
5365=head2 CREATING A RADIO BUTTON GROUP
5366
5367 print $query->radio_group(-name=>'group_name',
5368 -values=>['eenie','meenie','minie'],
5369 -default=>'meenie',
5370 -linebreak=>'true',
5371 -labels=>\%labels);
5372
5373 -or-
5374
5375 print $query->radio_group('group_name',['eenie','meenie','minie'],
5376 'meenie','true',\%labels);
5377
5378
5379 HTML3-COMPATIBLE BROWSERS ONLY:
5380
5381 print $query->radio_group(-name=>'group_name',
5382 -values=>['eenie','meenie','minie','moe'],
5383 -rows=2,-columns=>2);
5384
5385radio_group() creates a set of logically-related radio buttons
5386(turning one member of the group on turns the others off)
5387
5388=over 4
5389
5390=item B<Parameters:>
5391
5392=item 1.
5393
5394The first argument is the name of the group and is required (-name).
5395
5396=item 2.
5397
5398The second argument (-values) is the list of values for the radio
5399buttons. The values and the labels that appear on the page are
5400identical. Pass an array I<reference> in the second argument, either
5401using an anonymous array, as shown, or by referencing a named array as
5402in "\@foo".
5403
5404=item 3.
5405
5406The optional third parameter (-default) is the name of the default
5407button to turn on. If not specified, the first item will be the
5408default. You can provide a nonexistent button name, such as "-" to
5409start up with no buttons selected.
5410
5411=item 4.
5412
5413The optional fourth parameter (-linebreak) can be set to 'true' to put
5414line breaks between the buttons, creating a vertical list.
5415
5416=item 5.
5417
5418The optional fifth parameter (-labels) is a pointer to an associative
5419array relating the radio button values to user-visible labels to be
5420used in the display. If not provided, the values themselves are
5421displayed.
5422
5423=item 6.
5424
5425B<HTML3-compatible browsers> (such as Netscape) can take advantage
5426of the optional
5427parameters B<-rows>, and B<-columns>. These parameters cause
5428radio_group() to return an HTML3 compatible table containing
5429the radio group formatted with the specified number of rows
5430and columns. You can provide just the -columns parameter if you
5431wish; radio_group will calculate the correct number of rows
5432for you.
5433
5434To include row and column headings in the returned table, you
5435can use the B<-rowheader> and B<-colheader> parameters. Both
5436of these accept a pointer to an array of headings to use.
5437The headings are just decorative. They don't reorganize the
f610777f 5438interpretation of the radio buttons -- they're still a single named
54310121 5439unit.
5440
5441=back
5442
5443When the form is processed, the selected radio button can
5444be retrieved using:
5445
5446 $which_radio_button = $query->param('group_name');
5447
5448The value returned by radio_group() is actually an array of button
5449elements. You can capture them and use them within tables, lists,
5450or in other creative ways:
5451
5452 @h = $query->radio_group(-name=>'group_name',-values=>\@values);
5453 &use_in_creative_way(@h);
5454
5455=head2 CREATING A SUBMIT BUTTON
5456
5457 print $query->submit(-name=>'button_name',
5458 -value=>'value');
5459
5460 -or-
5461
5462 print $query->submit('button_name','value');
5463
5464submit() will create the query submission button. Every form
5465should have one of these.
5466
5467=over 4
5468
5469=item B<Parameters:>
5470
5471=item 1.
5472
5473The first argument (-name) is optional. You can give the button a
5474name if you have several submission buttons in your form and you want
5475to distinguish between them. The name will also be used as the
5476user-visible label. Be aware that a few older browsers don't deal with this correctly and
5477B<never> send back a value from a button.
5478
5479=item 2.
5480
5481The second argument (-value) is also optional. This gives the button
5482a value that will be passed to your script in the query string.
5483
5484=back
5485
5486You can figure out which button was pressed by using different
5487values for each one:
5488
5489 $which_one = $query->param('button_name');
5490
5491JAVASCRIPTING: radio_group() recognizes the B<-onClick>
5492parameter. See checkbox_group() for further details.
5493
5494=head2 CREATING A RESET BUTTON
5495
5496 print $query->reset
5497
5498reset() creates the "reset" button. Note that it restores the
5499form to its value from the last time the script was called,
5500NOT necessarily to the defaults.
5501
71f3e297
JH		 5502Note that this conflicts with the Perl reset() built-in. Use
5503CORE::reset() to get the original reset function.
5504
54310121 5505=head2 CREATING A DEFAULT BUTTON
5506
5507 print $query->defaults('button_label')
5508
5509defaults() creates a button that, when invoked, will cause the
5510form to be completely reset to its defaults, wiping out all the
5511changes the user ever made.
5512
5513=head2 CREATING A HIDDEN FIELD
5514
5515 print $query->hidden(-name=>'hidden_name',
5516 -default=>['value1','value2'...]);
5517
5518 -or-
5519
5520 print $query->hidden('hidden_name','value1','value2'...);
5521
5522hidden() produces a text field that can't be seen by the user. It
5523is useful for passing state variable information from one invocation
5524of the script to the next.
5525
5526=over 4
5527
5528=item B<Parameters:>
5529
5530=item 1.
5531
5532The first argument is required and specifies the name of this
5533field (-name).
5534
5535=item 2.
5536
5537The second argument is also required and specifies its value
5538(-default). In the named parameter style of calling, you can provide
5539a single value here or a reference to a whole list
5540
5541=back
5542
5543Fetch the value of a hidden field this way:
5544
5545 $hidden_value = $query->param('hidden_name');
5546
5547Note, that just like all the other form elements, the value of a
5548hidden field is "sticky". If you want to replace a hidden field with
5549some other values after the script has been called once you'll have to
5550do it manually:
5551
5552 $query->param('hidden_name','new','values','here');
5553
5554=head2 CREATING A CLICKABLE IMAGE BUTTON
5555
5556 print $query->image_button(-name=>'button_name',
5557 -src=>'/source/URL',
5558 -align=>'MIDDLE');
5559
5560 -or-
5561
5562 print $query->image_button('button_name','/source/URL','MIDDLE');
5563
5564image_button() produces a clickable image. When it's clicked on the
5565position of the click is returned to your script as "button_name.x"
5566and "button_name.y", where "button_name" is the name you've assigned
5567to it.
5568
5569JAVASCRIPTING: image_button() recognizes the B<-onClick>
5570parameter. See checkbox_group() for further details.
5571
5572=over 4
5573
5574=item B<Parameters:>
5575
5576=item 1.
5577
5578The first argument (-name) is required and specifies the name of this
5579field.
5580
5581=item 2.
5582
5583The second argument (-src) is also required and specifies the URL
5584
5585=item 3.
5586The third option (-align, optional) is an alignment type, and may be
5587TOP, BOTTOM or MIDDLE
5588
5589=back
5590
5591Fetch the value of the button this way:
5592 $x = $query->param('button_name.x');
5593 $y = $query->param('button_name.y');
5594
5595=head2 CREATING A JAVASCRIPT ACTION BUTTON
5596
5597 print $query->button(-name=>'button_name',
5598 -value=>'user visible label',
5599 -onClick=>"do_something()");
5600
5601 -or-
5602
5603 print $query->button('button_name',"do_something()");
5604
5605button() produces a button that is compatible with Netscape 2.0's
5606JavaScript. When it's pressed the fragment of JavaScript code
5607pointed to by the B<-onClick> parameter will be executed. On
5608non-Netscape browsers this form element will probably not even
5609display.
5610
71f3e297 5611=head1 HTTP COOKIES
54310121 5612
71f3e297
JH		 5613Netscape browsers versions 1.1 and higher, and all versions of
5614Internet Explorer, support a so-called "cookie" designed to help
5615maintain state within a browser session. CGI.pm has several methods
5616that support cookies.
54310121 5617
5618A cookie is a name=value pair much like the named parameters in a CGI
5619query string. CGI scripts create one or more cookies and send
5620them to the browser in the HTTP header. The browser maintains a list
5621of cookies that belong to a particular Web server, and returns them
5622to the CGI script during subsequent interactions.
5623
5624In addition to the required name=value pair, each cookie has several
5625optional attributes:
5626
5627=over 4
5628
5629=item 1. an expiration time
5630
5631This is a time/date string (in a special GMT format) that indicates
5632when a cookie expires. The cookie will be saved and returned to your
5633script until this expiration date is reached if the user exits
71f3e297
JH		 5634the browser and restarts it. If an expiration date isn't specified, the cookie
5635will remain active until the user quits the browser.
54310121 5636
5637=item 2. a domain
5638
5639This is a partial or complete domain name for which the cookie is
5640valid. The browser will return the cookie to any host that matches
5641the partial domain name. For example, if you specify a domain name
71f3e297 5642of ".capricorn.com", then the browser will return the cookie to
54310121 5643Web servers running on any of the machines "www.capricorn.com",
5644"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
5645must contain at least two periods to prevent attempts to match
5646on top level domains like ".edu". If no domain is specified, then
5647the browser will only return the cookie to servers on the host the
5648cookie originated from.
5649
5650=item 3. a path
5651
5652If you provide a cookie path attribute, the browser will check it
5653against your script's URL before returning the cookie. For example,
5654if you specify the path "/cgi-bin", then the cookie will be returned
5655to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
5656and "/cgi-bin/customer_service/complain.pl", but not to the script
5657"/cgi-private/site_admin.pl". By default, path is set to "/", which
5658causes the cookie to be sent to any CGI script on your site.
5659
5660=item 4. a "secure" flag
5661
5662If the "secure" attribute is set, the cookie will only be sent to your
5663script if the CGI request is occurring on a secure channel, such as SSL.
5664
5665=back
5666
71f3e297 5667The interface to HTTP cookies is the B<cookie()> method:
54310121 5668
5669 $cookie = $query->cookie(-name=>'sessionID',
5670 -value=>'xyzzy',
5671 -expires=>'+1h',
5672 -path=>'/cgi-bin/database',
5673 -domain=>'.capricorn.org',
5674 -secure=>1);
5675 print $query->header(-cookie=>$cookie);
5676
5677B<cookie()> creates a new cookie. Its parameters include:
5678
5679=over 4
5680
5681=item B<-name>
5682
5683The name of the cookie (required). This can be any string at all.
71f3e297 5684Although browsers limit their cookie names to non-whitespace
54310121 5685alphanumeric characters, CGI.pm removes this restriction by escaping
5686and unescaping cookies behind the scenes.
5687
5688=item B<-value>
5689
5690The value of the cookie. This can be any scalar value,
5691array reference, or even associative array reference. For example,
5692you can store an entire associative array into a cookie this way:
5693
5694 $cookie=$query->cookie(-name=>'family information',
5695 -value=>\%childrens_ages);
5696
5697=item B<-path>
5698
5699The optional partial path for which this cookie will be valid, as described
5700above.
5701
5702=item B<-domain>
5703
5704The optional partial domain for which this cookie will be valid, as described
5705above.
5706
5707=item B<-expires>
5708
5709The optional expiration date for this cookie. The format is as described
5710in the section on the B<header()> method:
5711
5712 "+1h" one hour from now
5713
5714=item B<-secure>
5715
5716If set to true, this cookie will only be used within a secure
5717SSL session.
5718
5719=back
5720
5721The cookie created by cookie() must be incorporated into the HTTP
5722header within the string returned by the header() method:
5723
5724 print $query->header(-cookie=>$my_cookie);
5725
5726To create multiple cookies, give header() an array reference:
5727
5728 $cookie1 = $query->cookie(-name=>'riddle_name',
5729 -value=>"The Sphynx's Question");
5730 $cookie2 = $query->cookie(-name=>'answers',
5731 -value=>\%answers);
5732 print $query->header(-cookie=>[$cookie1,$cookie2]);
5733
5734To retrieve a cookie, request it by name by calling cookie()
5735method without the B<-value> parameter:
5736
5737 use CGI;
5738 $query = new CGI;
5739 %answers = $query->cookie(-name=>'answers');
5740 # $query->cookie('answers') will work too!
5741
5742The cookie and CGI namespaces are separate. If you have a parameter
5743named 'answers' and a cookie named 'answers', the values retrieved by
5744param() and cookie() are independent of each other. However, it's
5745simple to turn a CGI parameter into a cookie, and vice-versa:
5746
5747 # turn a CGI parameter into a cookie
5748 $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]);
5749 # vice-versa
5750 $q->param(-name=>'answers',-value=>[$q->cookie('answers')]);
5751
5752See the B<cookie.cgi> example script for some ideas on how to use
5753cookies effectively.
5754
71f3e297 5755=head1 WORKING WITH FRAMES
54310121 5756
71f3e297
JH		 5757It's possible for CGI.pm scripts to write into several browser panels
5758and windows using the HTML 4 frame mechanism. There are three
5759techniques for defining new frames programmatically:
54310121 5760
5761=over 4
5762
5763=item 1. Create a <Frameset> document
5764
5765After writing out the HTTP header, instead of creating a standard
5766HTML document using the start_html() call, create a <FRAMESET>
5767document that defines the frames on the page. Specify your script(s)
5768(with appropriate parameters) as the SRC for each of the frames.
5769
5770There is no specific support for creating <FRAMESET> sections
5771in CGI.pm, but the HTML is very simple to write. See the frame
5772documentation in Netscape's home pages for details
5773
5774 http://home.netscape.com/assist/net_sites/frames.html
5775
5776=item 2. Specify the destination for the document in the HTTP header
5777
5778You may provide a B<-target> parameter to the header() method:
5779
5780 print $q->header(-target=>'ResultsWindow');
5781
71f3e297
JH		 5782This will tell the browser to load the output of your script into the
5783frame named "ResultsWindow". If a frame of that name doesn't already
5784exist, the browser will pop up a new window and load your script's
5785document into that. There are a number of magic names that you can
5786use for targets. See the frame documents on Netscape's home pages for
5787details.
54310121 5788
5789=item 3. Specify the destination for the document in the <FORM> tag
5790
5791You can specify the frame to load in the FORM tag itself. With
5792CGI.pm it looks like this:
5793
5794 print $q->startform(-target=>'ResultsWindow');
5795
5796When your script is reinvoked by the form, its output will be loaded
5797into the frame named "ResultsWindow". If one doesn't already exist
5798a new window will be created.
5799
5800=back
5801
5802The script "frameset.cgi" in the examples directory shows one way to
5803create pages in which the fill-out form and the response live in
5804side-by-side frames.
5805
7d37aa8e
LS		 5806=head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
5807
5808CGI.pm has limited support for HTML3's cascading style sheets (css).
5809To incorporate a stylesheet into your document, pass the
5810start_html() method a B<-style> parameter. The value of this
5811parameter may be a scalar, in which case it is incorporated directly
5812into a <STYLE> section, or it may be a hash reference. In the latter
5813case you should provide the hash with one or more of B<-src> or
5814B<-code>. B<-src> points to a URL where an externally-defined
5815stylesheet can be found. B<-code> points to a scalar value to be
5816incorporated into a <STYLE> section. Style definitions in B<-code>
5817override similarly-named ones in B<-src>, hence the name "cascading."
5818
424ec8fa
GS		 5819You may also specify the type of the stylesheet by adding the optional
5820B<-type> parameter to the hash pointed to by B<-style>. If not
5821specified, the style defaults to 'text/css'.
5822
7d37aa8e
LS		 5823To refer to a style within the body of your document, add the
5824B<-class> parameter to any HTML element:
5825
5826 print h1({-class=>'Fancy'},'Welcome to the Party');
5827
5828Or define styles on the fly with the B<-style> parameter:
5829
5830 print h1({-style=>'Color: red;'},'Welcome to Hell');
5831
5832You may also use the new B<span()> element to apply a style to a
5833section of text:
5834
5835 print span({-style=>'Color: red;'},
5836 h1('Welcome to Hell'),
5837 "Where did that handbasket get to?"
5838 );
5839
5840Note that you must import the ":html3" definitions to have the
5841B<span()> method available. Here's a quick and dirty example of using
5842CSS's. See the CSS specification at
5843http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
5844
5845 use CGI qw/:standard :html3/;
5846
5847 #here's a stylesheet incorporated directly into the page
5848 $newStyle=<<END;
5849 <!--
5850 P.Tip {
5851 margin-right: 50pt;
5852 margin-left: 50pt;
5853 color: red;
5854 }
5855 P.Alert {
5856 font-size: 30pt;
5857 font-family: sans-serif;
5858 color: red;
5859 }
5860 -->
5861 END
5862 print header();
5863 print start_html( -title=>'CGI with Style',
5864 -style=>{-src=>'http://www.capricorn.com/style/st1.css',
5865 -code=>$newStyle}
5866 );
5867 print h1('CGI with Style'),
5868 p({-class=>'Tip'},
5869 "Better read the cascading style sheet spec before playing with this!"),
5870 span({-style=>'color: magenta'},
5871 "Look Mom, no hands!",
5872 p(),
5873 "Whooo wee!"
5874 );
5875 print end_html;
5876
54310121 5877=head1 DEBUGGING
5878
5879If you are running the script
5880from the command line or in the perl debugger, you can pass the script
5881a list of keywords or parameter=value pairs on the command line or
5882from standard input (you don't have to worry about tricking your
5883script into reading from environment variables).
5884You can pass keywords like this:
5885
5886 your_script.pl keyword1 keyword2 keyword3
5887
5888or this:
5889
5890 your_script.pl keyword1+keyword2+keyword3
5891
5892or this:
5893
5894 your_script.pl name1=value1 name2=value2
5895
5896or this:
5897
5898 your_script.pl name1=value1&name2=value2
5899
5900or even as newline-delimited parameters on standard input.
5901
5902When debugging, you can use quotes and backslashes to escape
5903characters in the familiar shell manner, letting you place
5904spaces and other funny characters in your parameter=value
5905pairs:
5906
5907 your_script.pl "name1='I am a long value'" "name2=two\ words"
5908
5909=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
5910
5911The dump() method produces a string consisting of all the query's
5912name/value pairs formatted nicely as a nested list. This is useful
5913for debugging purposes:
5914
5915 print $query->dump
5916
5917
5918Produces something that looks like:
5919
5920 <UL>
5921 <LI>name1
5922 <UL>
5923 <LI>value1
5924 <LI>value2
5925 </UL>
5926 <LI>name2
5927 <UL>
5928 <LI>value1
5929 </UL>
5930 </UL>
5931
71f3e297
JH		 5932As a shortcut, you can interpolate the entire CGI object into a string
5933and it will be replaced with the a nice HTML dump shown above:
54310121 5934
5935 $query=new CGI;
5936 print "<H2>Current Values</H2> $query\n";
5937
5938=head1 FETCHING ENVIRONMENT VARIABLES
5939
5940Some of the more useful environment variables can be fetched
5941through this interface. The methods are as follows:
5942
5943=over 4
5944
71f3e297
JH		 5945=item B<Accept()>
5946
5947Return a list of MIME types that the remote browser accepts. If you
5948give this method a single argument corresponding to a MIME type, as in
5949$query->Accept('text/html'), it will return a floating point value
5950corresponding to the browser's preference for this type from 0.0
5951(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept
5952list are handled correctly.
54310121 5953
71f3e297
JH		 5954Note that the capitalization changed between version 2.43 and 2.44 in
5955order to avoid conflict with Perl's accept() function.
54310121 5956
5957=item B<raw_cookie()>
5958
424ec8fa 5959Returns the HTTP_COOKIE variable, an HTTP extension implemented by
71f3e297
JH		 5960Netscape browsers version 1.1 and higher, and all versions of Internet
5961Explorer. Cookies have a special format, and this method call just
5962returns the raw form (?cookie dough). See cookie() for ways of
5963setting and retrieving cooked cookies.
424ec8fa
GS		 5964
5965Called with no parameters, raw_cookie() returns the packed cookie
5966structure. You can separate it into individual cookies by splitting
5967on the character sequence "; ". Called with the name of a cookie,
5968retrieves the B<unescaped> form of the cookie. You can use the
5969regular cookie() method to get the names, or use the raw_fetch()
5970method from the CGI::Cookie module.
54310121 5971
5972=item B<user_agent()>
5973
5974Returns the HTTP_USER_AGENT variable. If you give
5975this method a single argument, it will attempt to
5976pattern match on it, allowing you to do something
5977like $query->user_agent(netscape);
5978
5979=item B<path_info()>
5980
5981Returns additional path information from the script URL.
5982E.G. fetching /cgi-bin/your_script/additional/stuff will
5983result in $query->path_info() returning
5984"additional/stuff".
5985
5986NOTE: The Microsoft Internet Information Server
5987is broken with respect to additional path information. If
5988you use the Perl DLL library, the IIS server will attempt to
5989execute the additional path information as a Perl script.
5990If you use the ordinary file associations mapping, the
5991path information will be present in the environment,
5992but incorrect. The best thing to do is to avoid using additional
5993path information in CGI scripts destined for use with IIS.
5994
5995=item B<path_translated()>
5996
5997As per path_info() but returns the additional
5998path information translated into a physical path, e.g.
5999"/usr/local/etc/httpd/htdocs/additional/stuff".
6000
6001The Microsoft IIS is broken with respect to the translated
6002path as well.
6003
6004=item B<remote_host()>
6005
6006Returns either the remote host name or IP address.
6007if the former is unavailable.
6008
6009=item B<script_name()>
6010Return the script name as a partial URL, for self-refering
6011scripts.
6012
6013=item B<referer()>
6014
6015Return the URL of the page the browser was viewing
6016prior to fetching your script. Not available for all
6017browsers.
6018
6019=item B<auth_type ()>
6020
6021Return the authorization/verification method in use for this
6022script, if any.
6023
6024=item B<server_name ()>
6025
6026Returns the name of the server, usually the machine's host
6027name.
6028
6029=item B<virtual_host ()>
6030
6031When using virtual hosts, returns the name of the host that
6032the browser attempted to contact
6033
6034=item B<server_software ()>
6035
6036Returns the server software and version number.
6037
6038=item B<remote_user ()>
6039
6040Return the authorization/verification name used for user
6041verification, if this script is protected.
6042
6043=item B<user_name ()>
6044
71f3e297
JH		 6045Attempt to obtain the remote user's name, using a variety of different
6046techniques. This only works with older browsers such as Mosaic.
6047Newer browsers do not report the user name for privacy reasons!
54310121 6048
6049=item B<request_method()>
6050
6051Returns the method used to access your script, usually
6052one of 'POST', 'GET' or 'HEAD'.
6053
f6b3007c
JH		 6054=item B<content_type()>
6055
6056Returns the content_type of data submitted in a POST, generally
6057multipart/form-data or application/x-www-form-urlencoded
6058
6059=item B<http()>
6060
6061Called with no arguments returns the list of HTTP environment
6062variables, including such things as HTTP_USER_AGENT,
6063HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the
6064like-named HTTP header fields in the request. Called with the name of
6065an HTTP header field, returns its value. Capitalization and the use
6066of hyphens versus underscores are not significant.
6067
6068For example, all three of these examples are equivalent:
6069
6070 $requested_language = $q->http('Accept-language');
6071 $requested_language = $q->http('Accept_language');
6072 $requested_language = $q->http('HTTP_ACCEPT_LANGUAGE');
6073
6074=item B<https()>
6075
6076The same as I<http()>, but operates on the HTTPS environment variables
6077present when the SSL protocol is in effect. Can be used to determine
6078whether SSL is turned on.
6079
54310121 6080=back
6081
424ec8fa 6082=head1 USING NPH SCRIPTS
54310121 6083
424ec8fa
GS		 6084NPH, or "no-parsed-header", scripts bypass the server completely by
6085sending the complete HTTP header directly to the browser. This has
6086slight performance benefits, but is of most use for taking advantage
6087of HTTP extensions that are not directly supported by your server,
6088such as server push and PICS headers.
54310121 6089
424ec8fa
GS		 6090Servers use a variety of conventions for designating CGI scripts as
6091NPH. Many Unix servers look at the beginning of the script's name for
6092the prefix "nph-". The Macintosh WebSTAR server and Microsoft's
6093Internet Information Server, in contrast, try to decide whether a
6094program is an NPH script by examining the first line of script output.
54310121 6095
54310121 6096
424ec8fa
GS		 6097CGI.pm supports NPH scripts with a special NPH mode. When in this
6098mode, CGI.pm will output the necessary extra header information when
6099the header() and redirect() methods are
6100called.
54310121 6101
424ec8fa
GS		 6102The Microsoft Internet Information Server requires NPH mode. As of version
61032.30, CGI.pm will automatically detect when the script is running under IIS
6104and put itself into this mode. You do not need to do this manually, although
6105it won't hurt anything if you do.
54310121 6106
424ec8fa 6107There are a number of ways to put CGI.pm into NPH mode:
54310121 6108
424ec8fa 6109=over 4
54310121 6110
424ec8fa 6111=item In the B<use> statement
54310121 6112
424ec8fa
GS		 6113Simply add the "-nph" pragmato the list of symbols to be imported into
6114your script:
54310121 6115
424ec8fa 6116 use CGI qw(:standard -nph)
54310121 6117
424ec8fa 6118=item By calling the B<nph()> method:
54310121 6119
424ec8fa 6120Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
54310121 6121
424ec8fa 6122 CGI->nph(1)
54310121 6123
424ec8fa 6124=item By using B<-nph> parameters in the B<header()> and B<redirect()> statements:
54310121 6125
424ec8fa 6126 print $q->header(-nph=>1);
54310121 6127
424ec8fa 6128=back
54310121 6129
424ec8fa
GS		 6130=head1 Server Push
6131
6132CGI.pm provides three simple functions for producing multipart
6133documents of the type needed to implement server push. These
6134functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To
6135import these into your namespace, you must import the ":push" set.
6136You are also advised to put the script into NPH mode and to set $| to
61371 to avoid buffering problems.
6138
6139Here is a simple script that demonstrates server push:
6140
6141 #!/usr/local/bin/perl
6142 use CGI qw/:push -nph/;
6143 $| = 1;
6144 print multipart_init(-boundary=>'----------------here we go!');
6145 while (1) {
6146 print multipart_start(-type=>'text/plain'),
6147 "The current time is ",scalar(localtime),"\n",
6148 multipart_end;
6149 sleep 1;
6150 }
54310121 6151
424ec8fa
GS		 6152This script initializes server push by calling B<multipart_init()>.
6153It then enters an infinite loop in which it begins a new multipart
6154section by calling B<multipart_start()>, prints the current local time,
6155and ends a multipart section with B<multipart_end()>. It then sleeps
6156a second, and begins again.
54310121 6157
424ec8fa 6158=over 4
54310121 6159
424ec8fa
GS		 6160=item multipart_init()
6161
6162 multipart_init(-boundary=>$boundary);
54310121 6163
424ec8fa
GS		 6164Initialize the multipart system. The -boundary argument specifies
6165what MIME boundary string to use to separate parts of the document.
6166If not provided, CGI.pm chooses a reasonable boundary for you.
54310121 6167
424ec8fa 6168=item multipart_start()
54310121 6169
424ec8fa 6170 multipart_start(-type=>$type)
54310121 6171
424ec8fa
GS		 6172Start a new part of the multipart document using the specified MIME
6173type. If not specified, text/html is assumed.
54310121 6174
424ec8fa 6175=item multipart_end()
54310121 6176
424ec8fa 6177 multipart_end()
54310121 6178
424ec8fa
GS		 6179End a part. You must remember to call multipart_end() once for each
6180multipart_start().
54310121 6181
424ec8fa 6182=back
54310121 6183
424ec8fa
GS		 6184Users interested in server push applications should also have a look
6185at the CGI::Push module.
54310121 6186
424ec8fa 6187=head1 Avoiding Denial of Service Attacks
54310121 6188
424ec8fa
GS		 6189A potential problem with CGI.pm is that, by default, it attempts to
6190process form POSTings no matter how large they are. A wily hacker
6191could attack your site by sending a CGI script a huge POST of many
6192megabytes. CGI.pm will attempt to read the entire POST into a
6193variable, growing hugely in size until it runs out of memory. While
6194the script attempts to allocate the memory the system may slow down
6195dramatically. This is a form of denial of service attack.
54310121 6196
424ec8fa
GS		 6197Another possible attack is for the remote user to force CGI.pm to
6198accept a huge file upload. CGI.pm will accept the upload and store it
6199in a temporary directory even if your script doesn't expect to receive
6200an uploaded file. CGI.pm will delete the file automatically when it
6201terminates, but in the meantime the remote user may have filled up the
6202server's disk space, causing problems for other programs.
54310121 6203
424ec8fa
GS		 6204The best way to avoid denial of service attacks is to limit the amount
6205of memory, CPU time and disk space that CGI scripts can use. Some Web
6206servers come with built-in facilities to accomplish this. In other
6207cases, you can use the shell I<limit> or I<ulimit>
6208commands to put ceilings on CGI resource usage.
54310121 6209
54310121 6210
424ec8fa
GS		 6211CGI.pm also has some simple built-in protections against denial of
6212service attacks, but you must activate them before you can use them.
6213These take the form of two global variables in the CGI name space:
54310121 6214
424ec8fa 6215=over 4
54310121 6216
424ec8fa 6217=item B<$CGI::POST_MAX>
54310121 6218
424ec8fa
GS		 6219If set to a non-negative integer, this variable puts a ceiling
6220on the size of POSTings, in bytes. If CGI.pm detects a POST
6221that is greater than the ceiling, it will immediately exit with an error
6222message. This value will affect both ordinary POSTs and
6223multipart POSTs, meaning that it limits the maximum size of file
6224uploads as well. You should set this to a reasonably high
6225value, such as 1 megabyte.
54310121 6226
424ec8fa 6227=item B<$CGI::DISABLE_UPLOADS>
54310121 6228
424ec8fa
GS		 6229If set to a non-zero value, this will disable file uploads
6230completely. Other fill-out form values will work as usual.
54310121 6231
6232=back
6233
424ec8fa 6234You can use these variables in either of two ways.
54310121 6235
424ec8fa 6236=over 4
54310121 6237
424ec8fa 6238=item B<1. On a script-by-script basis>
54310121 6239
424ec8fa 6240Set the variable at the top of the script, right after the "use" statement:
54310121 6241
424ec8fa
GS		 6242 use CGI qw/:standard/;
6243 use CGI::Carp 'fatalsToBrowser';
6244 $CGI::POST_MAX=1024 * 100; # max 100K posts
6245 $CGI::DISABLE_UPLOADS = 1; # no uploads
54310121 6246
424ec8fa 6247=item B<2. Globally for all scripts>
54310121 6248
424ec8fa
GS		 6249Open up CGI.pm, find the definitions for $POST_MAX and
6250$DISABLE_UPLOADS, and set them to the desired values. You'll
6251find them towards the top of the file in a subroutine named
6252initialize_globals().
54310121 6253
424ec8fa 6254=back
54310121 6255
f6b3007c
JH		 6256An attempt to send a POST larger than $POST_MAX bytes will cause
6257I<param()> to return an empty CGI parameter list. You can test for
6258this event by checking I<cgi_error()>, either after you create the CGI
6259object or, if you are using the function-oriented interface, call
6260<param()> for the first time. If the POST was intercepted, then
6261cgi_error() will return the message "413 POST too large".
6262
6263This error message is actually defined by the HTTP protocol, and is
6264designed to be returned to the browser as the CGI script's status
6265 code. For example:
6266
6267 $uploaded_file = param('upload');
6268 if (!$uploaded_file && cgi_error()) {
6269 print header(-status=>cgi_error());
6270 exit 0;
6271 }
6272
6273However it isn't clear that any browser currently knows what to do
6274with this status code. It might be better just to create an
6275HTML page that warns the user of the problem.
54310121 6276
424ec8fa 6277=head1 COMPATIBILITY WITH CGI-LIB.PL
54310121 6278
f6b3007c
JH		 6279To make it easier to port existing programs that use cgi-lib.pl the
6280compatibility routine "ReadParse" is provided. Porting is simple:
54310121 6281
424ec8fa
GS		 6282OLD VERSION
6283 require "cgi-lib.pl";
6284 &ReadParse;
6285 print "The value of the antique is $in{antique}.\n";
54310121 6286
424ec8fa
GS		 6287NEW VERSION
6288 use CGI;
6289 CGI::ReadParse
6290 print "The value of the antique is $in{antique}.\n";
54310121 6291
424ec8fa
GS		 6292CGI.pm's ReadParse() routine creates a tied variable named %in,
6293which can be accessed to obtain the query variables. Like
6294ReadParse, you can also provide your own variable. Infrequently
6295used features of ReadParse, such as the creation of @in and $in
6296variables, are not supported.
54310121 6297
424ec8fa
GS		 6298Once you use ReadParse, you can retrieve the query object itself
6299this way:
54310121 6300
424ec8fa
GS		 6301 $q = $in{CGI};
6302 print $q->textfield(-name=>'wow',
6303 -value=>'does this really work?');
54310121 6304
424ec8fa
GS		 6305This allows you to start using the more interesting features
6306of CGI.pm without rewriting your old scripts from scratch.
54310121 6307
6308=head1 AUTHOR INFORMATION
6309
71f3e297
JH		 6310Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
6311
6312This library is free software; you can redistribute it and/or modify
6313it under the same terms as Perl itself.
54310121 6314
71f3e297
JH		 6315Address bug reports and comments to: lstein@cshl.org. When sending
6316bug reports, please provide the version of CGI.pm, the version of
6317Perl, the name and version of your Web server, and the name and
6318version of the operating system you are using. If the problem is even
6319remotely browser dependent, please provide information about the
6320affected browers as well.
54310121 6321
6322=head1 CREDITS
6323
6324Thanks very much to:
6325
6326=over 4
6327
6328=item Matt Heffron (heffron@falstaff.css.beckman.com)
6329
6330=item James Taylor (james.taylor@srs.gov)
6331
6332=item Scott Anguish <sanguish@digifix.com>
6333
6334=item Mike Jewell (mlj3u@virginia.edu)
6335
6336=item Timothy Shimmin (tes@kbs.citri.edu.au)
6337
6338=item Joergen Haegg (jh@axis.se)
6339
71f3e297 6340=item Laurent Delfosse (delfosse@delfosse.com)
54310121 6341
6342=item Richard Resnick (applepi1@aol.com)
6343
6344=item Craig Bishop (csb@barwonwater.vic.gov.au)
6345
6346=item Tony Curtis (tc@vcpc.univie.ac.at)
6347
6348=item Tim Bunce (Tim.Bunce@ig.co.uk)
6349
6350=item Tom Christiansen (tchrist@convex.com)
6351
6352=item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
6353
6354=item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
6355
6356=item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
6357
6358=item Stephen Dahmen (joyfire@inxpress.net)
6359
6360=item Ed Jordan (ed@fidalgo.net)
6361
6362=item David Alan Pisoni (david@cnation.com)
6363
424ec8fa
GS		 6364=item Doug MacEachern (dougm@opengroup.org)
6365
6366=item Robin Houston (robin@oneworld.org)
6367
54310121 6368=item ...and many many more...
6369
6370for suggestions and bug fixes.
6371
6372=back
6373
6374=head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
6375
6376
6377 #!/usr/local/bin/perl
6378
6379 use CGI;
6380
6381 $query = new CGI;
6382
6383 print $query->header;
6384 print $query->start_html("Example CGI.pm Form");
6385 print "<H1> Example CGI.pm Form</H1>\n";
6386 &print_prompt($query);
6387 &do_work($query);
6388 &print_tail;
6389 print $query->end_html;
6390
6391 sub print_prompt {
6392 my($query) = @_;
6393
6394 print $query->startform;
6395 print "<EM>What's your name?</EM><BR>";
6396 print $query->textfield('name');
6397 print $query->checkbox('Not my real name');
6398
6399 print "<P><EM>Where can you find English Sparrows?</EM><BR>";
6400 print $query->checkbox_group(
6401 -name=>'Sparrow locations',
6402 -values=>[England,France,Spain,Asia,Hoboken],
6403 -linebreak=>'yes',
6404 -defaults=>[England,Asia]);
6405
6406 print "<P><EM>How far can they fly?</EM><BR>",
6407 $query->radio_group(
6408 -name=>'how far',
6409 -values=>['10 ft','1 mile','10 miles','real far'],
6410 -default=>'1 mile');
6411
6412 print "<P><EM>What's your favorite color?</EM> ";
6413 print $query->popup_menu(-name=>'Color',
6414 -values=>['black','brown','red','yellow'],
6415 -default=>'red');
6416
6417 print $query->hidden('Reference','Monty Python and the Holy Grail');
6418
6419 print "<P><EM>What have you got there?</EM><BR>";
6420 print $query->scrolling_list(
6421 -name=>'possessions',
6422 -values=>['A Coconut','A Grail','An Icon',
6423 'A Sword','A Ticket'],
6424 -size=>5,
6425 -multiple=>'true');
6426
6427 print "<P><EM>Any parting comments?</EM><BR>";
6428 print $query->textarea(-name=>'Comments',
6429 -rows=>10,
6430 -columns=>50);
6431
71f3e297 6432 print "<P>",$query->Reset;
54310121 6433 print $query->submit('Action','Shout');
6434 print $query->submit('Action','Scream');
6435 print $query->endform;
6436 print "<HR>\n";
6437 }
6438
6439 sub do_work {
6440 my($query) = @_;
6441 my(@values,$key);
6442
6443 print "<H2>Here are the current settings in this form</H2>";
6444
6445 foreach $key ($query->param) {
6446 print "<STRONG>$key</STRONG> -> ";
6447 @values = $query->param($key);
6448 print join(", ",@values),"<BR>\n";
6449 }
6450 }
6451
6452 sub print_tail {
6453 print <<END;
6454 <HR>
6455 <ADDRESS>Lincoln D. Stein</ADDRESS><BR>
6456 <A HREF="/">Home Page</A>
6457 END
6458 }
6459
6460=head1 BUGS
6461
6462This module has grown large and monolithic. Furthermore it's doing many
6463things, such as handling URLs, parsing CGI input, writing HTML, etc., that
6464are also done in the LWP modules. It should be discarded in favor of
6465the CGI::* modules, but somehow I continue to work on it.
6466
6467Note that the code is truly contorted in order to avoid spurious
6468warnings when programs are run with the B<-w> switch.
6469
6470=head1 SEE ALSO
6471
6472L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>,
71f3e297
JH		 6473L<CGI::Base>, L<CGI::Form>, L<CGI::Push>, L<CGI::Fast>,
6474L<CGI::Pretty>
54310121 6475
6476=cut
6477
Unnamed repository; edit this file 'description' to name the repository.