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