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