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