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