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