4 # See the bottom of this file for the POD documentation. Search for the
7 # You can run this file through either pod2man or pod2html to produce pretty
8 # documentation in manual or html file format (these utilities are part of the
9 # Perl 5 distribution).
11 # Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
12 # It may be used and modified freely, but I do request that this copyright
13 # notice remain attached to the file. You may modify this module as you
14 # wish, but if you redistribute a modified version, please attach a note
15 # listing the modifications you have made.
17 # The most recent version and complete docs are available at:
18 # http://stein.cshl.org/WWW/software/CGI/
20 $CGI::revision = '$Id: CGI.pm,v 1.19 1999/08/31 17:04:37 lstein Exp $';
23 # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
24 # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
25 # $TempFile::TMPDIRECTORY = '/usr/tmp';
27 # >>>>> Here are some globals that you might want to adjust <<<<<<
28 sub initialize_globals {
29 # Set this to 1 to enable copious autoloader debugging messages
32 # Change this to the preferred DTD to print in start_html()
33 # or use default_dtd('text of DTD to use');
34 $DEFAULT_DTD = '-//IETF//DTD HTML//EN';
36 # Set this to 1 to enable NPH scripts
40 # 3) print header(-nph=>1)
43 # Set this to 1 to disable debugging from the
47 # Set this to 1 to make the temporary files created
48 # during file uploads safe from prying eyes
50 # 1) use CGI qw(:private_tempfiles)
51 # 2) $CGI::private_tempfiles(1);
52 $PRIVATE_TEMPFILES = 0;
54 # Set this to a positive value to limit the size of a POSTing
55 # to a certain number of bytes:
58 # Change this to 1 to disable uploads entirely:
61 # Automatically determined -- don't change
64 # Change this to 1 to suppress redundant HTTP headers
67 # separate the name=value pairs by semicolons rather than ampersands
68 $USE_PARAM_SEMICOLONS = 0;
70 # Other globals that you shouldn't worry about.
76 # prevent complaints by mod_perl
80 # ------------------ START OF THE LIBRARY ------------
85 # FIGURE OUT THE OS WE'RE RUNNING UNDER
86 # Some systems support the $^O variable. If not
87 # available then require() the Config library
91 $OS = $Config::Config{'osname'};
96 } elsif ($OS=~/vms/i) {
98 } elsif ($OS=~/bsdos/i) {
100 } elsif ($OS=~/dos/i) {
102 } elsif ($OS=~/^MacOS$/i) {
104 } elsif ($OS=~/os2/i) {
110 # Some OS logic. Binary mode enabled on DOS, NT and VMS
111 $needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/;
113 # This is the default class for the CGI object to use when all else fails.
114 $DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
116 # This is where to look for autoloaded routines.
117 $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
119 # The path separator is a slash, backslash or semicolon, depending
122 UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
125 # This no longer seems to be necessary
126 # Turn on NPH scripts by default when running under IIS server!
127 # $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
128 $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
130 # Turn on special checking for Doug MacEachern's modperl
131 if (exists $ENV{'GATEWAY_INTERFACE'}
133 ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
138 # Turn on special checking for ActiveState's PerlEx
139 $PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
141 # Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
142 # of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
143 # and sometimes CR). The most popular VMS web server
144 # doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
145 # use ASCII, so \015\012 means something different. I find this all
147 $EBCDIC = "\t" ne "\011";
158 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
159 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
160 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
161 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
162 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
163 215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
164 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
165 151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7,
166 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27,
167 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255,
168 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
169 144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
170 100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
171 172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
172 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
173 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
177 if ($needs_binmode) {
178 $CGI::DefaultClass->binmode(main::STDOUT);
179 $CGI::DefaultClass->binmode(main::STDIN);
180 $CGI::DefaultClass->binmode(main::STDERR);
184 ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
185 tt u i b blockquote pre img a address cite samp dfn html head
186 base body Link nextid title meta kbd start_html end_html
187 input Select option comment/],
188 ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param
189 embed basefont style span layer ilayer font frameset frame script small big/],
190 ':netscape'=>[qw/blink fontsize center/],
191 ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
192 submit reset defaults radio_group popup_menu button autoEscape
193 scrolling_list image_button start_form end_form startform endform
194 start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
195 ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump
196 raw_cookie request_method query_string Accept user_agent remote_host content_type
197 remote_addr referer server_name server_software server_port server_protocol
198 virtual_host remote_ident auth_type http use_named_parameters
199 save_parameters restore_parameters param_fetch
200 remote_user user_name header redirect import_names put
201 Delete Delete_all url_param cgi_error/],
202 ':ssl' => [qw/https/],
203 ':imagemap' => [qw/Area Map/],
204 ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
205 ':html' => [qw/:html2 :html3 :netscape/],
206 ':standard' => [qw/:html2 :html3 :form :cgi/],
207 ':push' => [qw/multipart_init multipart_start multipart_end/],
208 ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/]
211 # to import symbols into caller
215 # This causes modules to clash.
219 $self->_setup_symbols(@_);
220 my ($callpack, $callfile, $callline) = caller;
222 # To allow overriding, search through the packages
223 # Till we find one in which the correct subroutine is defined.
224 my @packages = ($self,@{"$self\:\:ISA"});
225 foreach $sym (keys %EXPORT) {
227 my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
228 foreach $pck (@packages) {
229 if (defined(&{"$pck\:\:$sym"})) {
234 *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
240 $pack->_setup_symbols('-compile',@_);
245 return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
247 return ($tag) unless $EXPORT_TAGS{$tag};
248 foreach (@{$EXPORT_TAGS{$tag}}) {
249 push(@r,&expand_tags($_));
255 # The new routine. This will check the current environment
256 # for an existing query string, and initialize itself, if so.
259 my($class,$initializer) = @_;
261 bless $self,ref $class || $class || $DefaultClass;
263 Apache->request->register_cleanup(\&CGI::_reset_globals);
266 $self->_reset_globals if $PERLEX;
267 $self->init($initializer);
271 # We provide a DESTROY method so that the autoloader
272 # doesn't bother trying to find it.
276 # Returns the value(s)of a named parameter.
277 # If invoked in a list context, returns the
278 # entire list. Otherwise returns the first
279 # member of the list.
280 # If name is not provided, return a list of all
281 # the known parameters names available.
282 # If more than one argument is provided, the
283 # second and subsequent arguments are used to
284 # set the value of the parameter.
287 my($self,@p) = self_or_default(@_);
288 return $self->all_parameters unless @p;
289 my($name,$value,@other);
291 # For compatibility between old calling style and use_named_parameters() style,
292 # we have to special case for a single parameter present.
294 ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
297 if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
298 @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
300 foreach ($value,@other) {
301 push(@values,$_) if defined($_);
304 # If values is provided, then we set it.
306 $self->add_parameter($name);
307 $self->{$name}=[@values];
313 return unless defined($name) && $self->{$name};
314 return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
317 sub self_or_default {
318 return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
319 unless (defined($_[0]) &&
320 (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
322 $Q = $CGI::DefaultClass->new unless defined($Q);
329 local $^W=0; # prevent a warning
330 if (defined($_[0]) &&
331 (substr(ref($_[0]),0,3) eq 'CGI'
332 || UNIVERSAL::isa($_[0],'CGI'))) {
335 return ($DefaultClass,@_);
339 ########################################
340 # THESE METHODS ARE MORE OR LESS PRIVATE
341 # GO TO THE __DATA__ SECTION TO SEE MORE
343 ########################################
345 # Initialize the query object from the environment.
346 # If a parameter list is found, this object will be set
347 # to an associative array in which parameter names are keys
348 # and the values are stored as lists
349 # If a keyword list is found, this method creates a bogus
350 # parameter list with the single parameter 'keywords'.
353 my($self,$initializer) = @_;
354 my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
357 # if we get called more than once, we want to initialize
358 # ourselves from the original query (which may be gone
359 # if it was read from STDIN originally.)
360 if (@QUERY_PARAM && !defined($initializer)) {
361 foreach (@QUERY_PARAM) {
362 $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
367 $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
368 $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
370 $fh = to_filehandle($initializer) if $initializer;
374 # avoid unreasonably large postings
375 if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
376 $self->cgi_error("413 Request entity too large");
380 # Process multipart postings, but only if the initializer is
383 && defined($ENV{'CONTENT_TYPE'})
384 && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
385 && !defined($initializer)
387 my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
388 $self->read_multipart($boundary,$content_length);
392 # If initializer is defined, then read parameters
394 if (defined($initializer)) {
395 if (UNIVERSAL::isa($initializer,'CGI')) {
396 $query_string = $initializer->query_string;
399 if (ref($initializer) && ref($initializer) eq 'HASH') {
400 foreach (keys %$initializer) {
401 $self->param('-name'=>$_,'-value'=>$initializer->{$_});
406 if (defined($fh) && ($fh ne '')) {
412 # massage back into standard format
413 if ("@lines" =~ /=/) {
414 $query_string=join("&",@lines);
416 $query_string=join("+",@lines);
421 # last chance -- treat it as a string
422 $initializer = $$initializer if ref($initializer) eq 'SCALAR';
423 $query_string = $initializer;
428 # If method is GET or HEAD, fetch the query from
430 if ($meth=~/^(GET|HEAD)$/) {
432 $query_string = Apache->request->args;
434 $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
439 if ($meth eq 'POST') {
440 $self->read_from_client(\*STDIN,\$query_string,$content_length,0)
441 if $content_length > 0;
442 # Some people want to have their cake and eat it too!
443 # Uncomment this line to have the contents of the query string
444 # APPENDED to the POST data.
445 # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
449 # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
450 # Check the command line and then the standard input for data.
451 # We use the shellwords package in order to behave the way that
452 # UN*X programmers expect.
453 $query_string = read_from_cmdline() unless $NO_DEBUG;
456 # We now have the query string in hand. We do slightly
457 # different things for keyword lists and parameter lists.
458 if (defined $query_string && $query_string) {
459 if ($query_string =~ /=/) {
460 $self->parse_params($query_string);
462 $self->add_parameter('keywords');
463 $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
467 # Special case. Erase everything if there is a field named
469 if ($self->param('.defaults')) {
473 # Associative array containing our defined fieldnames
474 $self->{'.fieldnames'} = {};
475 foreach ($self->param('.cgifields')) {
476 $self->{'.fieldnames'}->{$_}++;
479 # Clear out our default submission button flag if present
480 $self->delete('.submit');
481 $self->delete('.cgifields');
482 $self->save_request unless $initializer;
485 # FUNCTIONS TO OVERRIDE:
486 # Turn a string into a filehandle
489 return undef unless $thingy;
490 return $thingy if UNIVERSAL::isa($thingy,'GLOB');
491 return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
494 while (my $package = caller($caller++)) {
495 my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
496 return $tmp if defined(fileno($tmp));
502 # send output to the browser
504 my($self,@p) = self_or_default(@_);
508 # print to standard output (for overriding in mod_perl)
514 # get/set last cgi_error
516 my ($self,$err) = self_or_default(@_);
517 $self->{'.cgi_error'} = $err if defined $err;
518 return $self->{'.cgi_error'};
521 # unescape URL-encoded data
523 shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass);
524 my $todecode = shift;
525 return undef unless defined($todecode);
526 $todecode =~ tr/+/ /; # pluses become spaces
528 $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",$A2E[hex($1)])/ge;
530 $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
537 shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass);
538 my $toencode = shift;
539 return undef unless defined($toencode);
540 $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
546 # We're going to play with the package globals now so that if we get called
547 # again, we initialize ourselves in exactly the same way. This allows
548 # us to have several of these objects.
549 @QUERY_PARAM = $self->param; # save list of parameters
550 foreach (@QUERY_PARAM) {
551 $QUERY_PARAM{$_}=$self->{$_};
556 my($self,$tosplit) = @_;
557 my(@pairs) = split(/[&;]/,$tosplit);
560 ($param,$value) = split('=',$_,2);
561 $param = unescape($param);
562 $value = unescape($value);
563 $self->add_parameter($param);
564 push (@{$self->{$param}},$value);
570 push (@{$self->{'.parameters'}},$param)
571 unless defined($self->{$param});
576 return () unless defined($self) && $self->{'.parameters'};
577 return () unless @{$self->{'.parameters'}};
578 return @{$self->{'.parameters'}};
581 # put a filehandle into binary mode (DOS)
583 CORE::binmode($_[1]);
587 my ($self,$tagname) = @_;
591 # (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) ||
593 (substr(ref(\$_[0]),0,3) eq 'CGI' ||
594 UNIVERSAL::isa(\$_[0],'CGI')));
597 if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') {
598 my(\@attr) = make_attributes( '',shift() );
599 \$attr = " \@attr" if \@attr;
602 if ($tagname=~/start_(\w+)/i) {
603 $func .= qq! return "<\U$1\E\$attr>";} !;
604 } elsif ($tagname=~/end_(\w+)/i) {
605 $func .= qq! return "<\U/$1\E>"; } !;
608 my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U</$tagname>\E");
609 return \$tag unless \@_;
610 my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
618 print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
619 my $func = &_compile;
624 # Smart rearrangement of parameters to allow named parameter
625 # calling. We do the rearangement if:
626 # 1. The first parameter begins with a -
627 # 2. The use_named_parameters() method returns true
629 my($self,$order,@param) = @_;
630 return () unless @param;
632 if (ref($param[0]) eq 'HASH') {
633 @param = %{$param[0]};
636 unless (defined($param[0]) && substr($param[0],0,1) eq '-')
637 || $self->use_named_parameters;
640 # map parameters into positional indices
644 foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; }
648 my (@result,%leftover);
649 $#result = $#$order; # preextend
651 my $key = uc(shift(@param));
653 if (exists $pos{$key}) {
654 $result[$pos{$key}] = shift(@param);
656 $leftover{$key} = shift(@param);
660 push (@result,$self->make_attributes(\%leftover)) if %leftover;
665 my($func) = $AUTOLOAD;
666 my($pack,$func_name);
668 local($1,$2); # this fixes an obscure variable suicide problem.
669 $func=~/(.+)::([^:]+)$/;
670 ($pack,$func_name) = ($1,$2);
671 $pack=~s/::SUPER$//; # fix another obscure problem
672 $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
673 unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
675 my($sub) = \%{"$pack\:\:SUBS"};
677 my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
678 eval "package $pack; $$auto";
680 $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
682 my($code) = $sub->{$func_name};
684 $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
686 (my $base = $func_name) =~ s/^(start_|end_)//i;
687 if ($EXPORT{':any'} ||
690 (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
691 && $EXPORT_OK{$base}) {
692 $code = $CGI::DefaultClass->_make_tag_func($func_name);
695 die "Undefined subroutine $AUTOLOAD\n" unless $code;
696 eval "package $pack; $code";
702 CORE::delete($sub->{$func_name}); #free storage
703 return "$pack\:\:$func_name";
706 sub _reset_globals { initialize_globals(); }
712 $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
713 $NPH++, next if /^[:-]nph$/;
714 $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/;
715 $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
716 $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
717 $EXPORT{$_}++, next if /^[:-]any$/;
718 $compile++, next if /^[:-]compile$/;
720 # This is probably extremely evil code -- to be deleted some day.
721 if (/^[-]autoload$/) {
722 my($pkg) = caller(1);
723 *{"${pkg}::AUTOLOAD"} = sub {
724 my($routine) = $AUTOLOAD;
725 $routine =~ s/^.*::/CGI::/;
731 foreach (&expand_tags($_)) {
732 tr/a-zA-Z0-9_//cd; # don't allow weird function names
736 _compile_all(keys %EXPORT) if $compile;
739 ###############################################################################
740 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
741 ###############################################################################
742 $AUTOLOADED_ROUTINES = ''; # get rid of -w warning
743 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
747 'URL_ENCODED'=> <<'END_OF_FUNC',
748 sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
751 'MULTIPART' => <<'END_OF_FUNC',
752 sub MULTIPART { 'multipart/form-data'; }
755 'SERVER_PUSH' => <<'END_OF_FUNC',
756 sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; }
759 'use_named_parameters' => <<'END_OF_FUNC',
760 #### Method: use_named_parameters
761 # Force CGI.pm to use named parameter-style method calls
762 # rather than positional parameters. The same effect
763 # will happen automatically if the first parameter
765 sub use_named_parameters {
766 my($self,$use_named) = self_or_default(@_);
767 return $self->{'.named'} unless defined ($use_named);
769 # stupidity to avoid annoying warnings
770 return $self->{'.named'}=$use_named;
774 'new_MultipartBuffer' => <<'END_OF_FUNC',
775 # Create a new multipart buffer
776 sub new_MultipartBuffer {
777 my($self,$boundary,$length,$filehandle) = @_;
778 return MultipartBuffer->new($self,$boundary,$length,$filehandle);
782 'read_from_client' => <<'END_OF_FUNC',
783 # Read data from a file handle
784 sub read_from_client {
785 my($self, $fh, $buff, $len, $offset) = @_;
786 local $^W=0; # prevent a warning
787 return undef unless defined($fh);
788 return read($fh, $$buff, $len, $offset);
792 'delete' => <<'END_OF_FUNC',
794 # Deletes the named parameter entirely.
797 my($self,$name) = self_or_default(@_);
798 CORE::delete $self->{$name};
799 CORE::delete $self->{'.fieldnames'}->{$name};
800 @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
801 return wantarray ? () : undef;
805 #### Method: import_names
806 # Import all parameters into the given namespace.
807 # Assumes namespace 'Q' if not specified
809 'import_names' => <<'END_OF_FUNC',
811 my($self,$namespace,$delete) = self_or_default(@_);
812 $namespace = 'Q' unless defined($namespace);
813 die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
814 if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
815 # can anyone find an easier way to do this?
816 foreach (keys %{"${namespace}::"}) {
817 local *symbol = "${namespace}::${_}";
823 my($param,@value,$var);
824 foreach $param ($self->param) {
825 # protect against silly names
826 ($var = $param)=~tr/a-zA-Z0-9_/_/c;
827 $var =~ s/^(?=\d)/_/;
828 local *symbol = "${namespace}::$var";
829 @value = $self->param($param);
836 #### Method: keywords
837 # Keywords acts a bit differently. Calling it in a list context
838 # returns the list of keywords.
839 # Calling it in a scalar context gives you the size of the list.
841 'keywords' => <<'END_OF_FUNC',
843 my($self,@values) = self_or_default(@_);
844 # If values is provided, then we set it.
845 $self->{'keywords'}=[@values] if @values;
846 my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
851 # These are some tie() interfaces for compatibility
852 # with Steve Brenner's cgi-lib.pl routines
853 'Vars' => <<'END_OF_FUNC',
858 return %in if wantarray;
863 # These are some tie() interfaces for compatibility
864 # with Steve Brenner's cgi-lib.pl routines
865 'ReadParse' => <<'END_OF_FUNC',
875 return scalar(keys %in);
879 'PrintHeader' => <<'END_OF_FUNC',
881 my($self) = self_or_default(@_);
882 return $self->header();
886 'HtmlTop' => <<'END_OF_FUNC',
888 my($self,@p) = self_or_default(@_);
889 return $self->start_html(@p);
893 'HtmlBot' => <<'END_OF_FUNC',
895 my($self,@p) = self_or_default(@_);
896 return $self->end_html(@p);
900 'SplitParam' => <<'END_OF_FUNC',
903 my (@params) = split ("\0", $param);
904 return (wantarray ? @params : $params[0]);
908 'MethGet' => <<'END_OF_FUNC',
910 return request_method() eq 'GET';
914 'MethPost' => <<'END_OF_FUNC',
916 return request_method() eq 'POST';
920 'TIEHASH' => <<'END_OF_FUNC',
922 return $_[1] if defined $_[1];
923 return $Q || new shift;
927 'STORE' => <<'END_OF_FUNC',
929 $_[0]->param($_[1],split("\0",$_[2]));
933 'FETCH' => <<'END_OF_FUNC',
935 return $_[0] if $_[1] eq 'CGI';
936 return undef unless defined $_[0]->param($_[1]);
937 return join("\0",$_[0]->param($_[1]));
941 'FIRSTKEY' => <<'END_OF_FUNC',
943 $_[0]->{'.iterator'}=0;
944 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
948 'NEXTKEY' => <<'END_OF_FUNC',
950 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
954 'EXISTS' => <<'END_OF_FUNC',
956 exists $_[0]->{$_[1]};
960 'DELETE' => <<'END_OF_FUNC',
962 $_[0]->delete($_[1]);
966 'CLEAR' => <<'END_OF_FUNC',
974 # Append a new value to an existing query
979 my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
980 my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
982 $self->add_parameter($name);
983 push(@{$self->{$name}},@values);
985 return $self->param($name);
989 #### Method: delete_all
990 # Delete all parameters
992 'delete_all' => <<'EOF',
994 my($self) = self_or_default(@_);
1001 my($self,@p) = self_or_default(@_);
1006 'Delete_all' => <<'EOF',
1008 my($self,@p) = self_or_default(@_);
1009 $self->delete_all(@p);
1013 #### Method: autoescape
1014 # If you want to turn off the autoescaping features,
1015 # call this method with undef as the argument
1016 'autoEscape' => <<'END_OF_FUNC',
1018 my($self,$escape) = self_or_default(@_);
1019 $self->{'dontescape'}=!$escape;
1024 #### Method: version
1025 # Return the current version
1027 'version' => <<'END_OF_FUNC',
1033 'make_attributes' => <<'END_OF_FUNC',
1034 sub make_attributes {
1035 my($self,$attr) = @_;
1036 return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
1038 foreach (keys %{$attr}) {
1040 $key=~s/^\-//; # get rid of initial - if present
1041 $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
1042 push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/);
1048 #### Method: url_param
1049 # Return a parameter in the QUERY_STRING, regardless of
1050 # whether this was a POST or a GET
1052 'url_param' => <<'END_OF_FUNC',
1054 my ($self,@p) = self_or_default(@_);
1055 my $name = shift(@p);
1056 return undef unless exists($ENV{QUERY_STRING});
1057 unless (exists($self->{'.url_param'})) {
1058 $self->{'.url_param'}={}; # empty hash
1059 if ($ENV{QUERY_STRING} =~ /=/) {
1060 my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
1063 ($param,$value) = split('=',$_,2);
1064 $param = unescape($param);
1065 $value = unescape($value);
1066 push(@{$self->{'.url_param'}->{$param}},$value);
1069 $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
1072 return keys %{$self->{'.url_param'}} unless defined($name);
1073 return () unless $self->{'.url_param'}->{$name};
1074 return wantarray ? @{$self->{'.url_param'}->{$name}}
1075 : $self->{'.url_param'}->{$name}->[0];
1080 # Returns a string in which all the known parameter/value
1081 # pairs are represented as nested lists, mainly for the purposes
1084 'dump' => <<'END_OF_FUNC',
1086 my($self) = self_or_default(@_);
1087 my($param,$value,@result);
1088 return '<UL></UL>' unless $self->param;
1089 push(@result,"<UL>");
1090 foreach $param ($self->param) {
1091 my($name)=$self->escapeHTML($param);
1092 push(@result,"<LI><STRONG>$param</STRONG>");
1093 push(@result,"<UL>");
1094 foreach $value ($self->param($param)) {
1095 $value = $self->escapeHTML($value);
1096 $value =~ s/\n/<BR>\n/g;
1097 push(@result,"<LI>$value");
1099 push(@result,"</UL>");
1101 push(@result,"</UL>\n");
1102 return join("\n",@result);
1106 #### Method as_string
1108 # synonym for "dump"
1110 'as_string' => <<'END_OF_FUNC',
1117 # Write values out to a filehandle in such a way that they can
1118 # be reinitialized by the filehandle form of the new() method
1120 'save' => <<'END_OF_FUNC',
1122 my($self,$filehandle) = self_or_default(@_);
1123 $filehandle = to_filehandle($filehandle);
1125 local($,) = ''; # set print field separator back to a sane value
1126 local($\) = ''; # set output line separator to a sane value
1127 foreach $param ($self->param) {
1128 my($escaped_param) = escape($param);
1130 foreach $value ($self->param($param)) {
1131 print $filehandle "$escaped_param=",escape("$value"),"\n";
1134 print $filehandle "=\n"; # end of record
1139 #### Method: save_parameters
1140 # An alias for save() that is a better name for exportation.
1141 # Only intended to be used with the function (non-OO) interface.
1143 'save_parameters' => <<'END_OF_FUNC',
1144 sub save_parameters {
1146 return save(to_filehandle($fh));
1150 #### Method: restore_parameters
1151 # A way to restore CGI parameters from an initializer.
1152 # Only intended to be used with the function (non-OO) interface.
1154 'restore_parameters' => <<'END_OF_FUNC',
1155 sub restore_parameters {
1156 $Q = $CGI::DefaultClass->new(@_);
1160 #### Method: multipart_init
1161 # Return a Content-Type: style header for server-push
1162 # This has to be NPH, and it is advisable to set $| = 1
1164 # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1167 'multipart_init' => <<'END_OF_FUNC',
1168 sub multipart_init {
1169 my($self,@p) = self_or_default(@_);
1170 my($boundary,@other) = $self->rearrange([BOUNDARY],@p);
1171 $boundary = $boundary || '------- =_aaaaaaaaaa0';
1172 $self->{'separator'} = "\n--$boundary\n";
1173 $type = SERVER_PUSH($boundary);
1174 return $self->header(
1177 (map { split "=", $_, 2 } @other),
1178 ) . $self->multipart_end;
1183 #### Method: multipart_start
1184 # Return a Content-Type: style header for server-push, start of section
1186 # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1189 'multipart_start' => <<'END_OF_FUNC',
1190 sub multipart_start {
1191 my($self,@p) = self_or_default(@_);
1192 my($type,@other) = $self->rearrange([TYPE],@p);
1193 $type = $type || 'text/html';
1194 return $self->header(
1196 (map { split "=", $_, 2 } @other),
1202 #### Method: multipart_end
1203 # Return a Content-Type: style header for server-push, end of section
1205 # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1208 'multipart_end' => <<'END_OF_FUNC',
1210 my($self,@p) = self_or_default(@_);
1211 return $self->{'separator'};
1217 # Return a Content-Type: style header
1220 'header' => <<'END_OF_FUNC',
1222 my($self,@p) = self_or_default(@_);
1225 return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
1227 my($type,$status,$cookie,$target,$expires,$nph,@other) =
1228 $self->rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
1229 STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
1232 # rearrange() was designed for the HTML portion, so we
1233 # need to fix it up a little.
1235 next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
1236 ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e;
1239 $type ||= 'text/html' unless defined($type);
1241 # Maybe future compatibility. Maybe not.
1242 my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
1243 push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
1245 push(@header,"Status: $status") if $status;
1246 push(@header,"Window-Target: $target") if $target;
1247 # push all the cookies -- there may be several
1249 my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
1251 my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
1252 push(@header,"Set-Cookie: $cs") if $cs ne '';
1255 # if the user indicates an expiration time, then we need
1256 # both an Expires and a Date header (so that the browser is
1258 push(@header,"Expires: " . expires($expires,'http'))
1260 push(@header,"Date: " . expires(0,'http')) if $expires || $cookie;
1261 push(@header,"Pragma: no-cache") if $self->cache();
1262 push(@header,@other);
1263 push(@header,"Content-Type: $type") if $type ne '';
1265 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1266 if ($MOD_PERL and not $nph) {
1267 my $r = Apache->request;
1268 $r->send_cgi_header($header);
1277 # Control whether header() will produce the no-cache
1280 'cache' => <<'END_OF_FUNC',
1282 my($self,$new_value) = self_or_default(@_);
1283 $new_value = '' unless $new_value;
1284 if ($new_value ne '') {
1285 $self->{'cache'} = $new_value;
1287 return $self->{'cache'};
1292 #### Method: redirect
1293 # Return a Location: style header
1296 'redirect' => <<'END_OF_FUNC',
1298 my($self,@p) = self_or_default(@_);
1299 my($url,$target,$cookie,$nph,@other) = $self->rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p);
1300 $url = $url || $self->self_url;
1302 foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
1304 '-Status'=>'302 Moved',
1307 unshift(@o,'-Target'=>$target) if $target;
1308 unshift(@o,'-Cookie'=>$cookie) if $cookie;
1309 unshift(@o,'-Type'=>'');
1310 return $self->header(@o);
1315 #### Method: start_html
1316 # Canned HTML header
1319 # $title -> (optional) The title for this HTML document (-title)
1320 # $author -> (optional) e-mail address of the author (-author)
1321 # $base -> (optional) if set to true, will enter the BASE address of this document
1322 # for resolving relative references (-base)
1323 # $xbase -> (optional) alternative base at some remote location (-xbase)
1324 # $target -> (optional) target window to load all links into (-target)
1325 # $script -> (option) Javascript code (-script)
1326 # $no_script -> (option) Javascript <noscript> tag (-noscript)
1327 # $meta -> (optional) Meta information tags
1328 # $head -> (optional) any other elements you'd like to incorporate into the <HEAD> tag
1329 # (a scalar or array ref)
1330 # $style -> (optional) reference to an external style sheet
1331 # @other -> (optional) any other named parameters you'd like to incorporate into
1334 'start_html' => <<'END_OF_FUNC',
1336 my($self,@p) = &self_or_default(@_);
1337 my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,@other) =
1338 $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD],@p);
1340 # strangely enough, the title needs to be escaped as HTML
1341 # while the author needs to be escaped as a URL
1342 $title = $self->escapeHTML($title || 'Untitled Document');
1343 $author = $self->escape($author);
1345 $dtd = $DEFAULT_DTD unless $dtd && $dtd =~ m|^-//|;
1346 push(@result,qq(<!DOCTYPE HTML PUBLIC "$dtd">)) if $dtd;
1347 push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
1348 push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if defined $author;
1350 if ($base || $xbase || $target) {
1351 my $href = $xbase || $self->url('-path'=>1);
1352 my $t = $target ? qq/ TARGET="$target"/ : '';
1353 push(@result,qq/<BASE HREF="$href"$t>/);
1356 if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
1357 foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
1360 push(@result,ref($head) ? @$head : $head) if $head;
1362 # handle the infrequently-used -style and -script parameters
1363 push(@result,$self->_style($style)) if defined $style;
1364 push(@result,$self->_script($script)) if defined $script;
1366 # handle -noscript parameter
1367 push(@result,<<END) if $noscript;
1373 my($other) = @other ? " @other" : '';
1374 push(@result,"</HEAD><BODY$other>");
1375 return join("\n",@result);
1380 # internal method for generating a CSS style section
1382 '_style' => <<'END_OF_FUNC',
1384 my ($self,$style) = @_;
1386 my $type = 'text/css';
1388 my($src,$code,$stype,@other) =
1389 $self->rearrange([SRC,CODE,TYPE],
1390 '-foo'=>'bar', # a trick to allow the '-' to be omitted
1391 ref($style) eq 'ARRAY' ? @$style : %$style);
1392 $type = $stype if $stype;
1393 push(@result,qq/<LINK REL="stylesheet" TYPE="$type" HREF="$src">/) if $src;
1394 push(@result,style({'type'=>$type},"<!--\n$code\n-->")) if $code;
1396 push(@result,style({'type'=>$type},"<!--\n$style\n-->"));
1403 '_script' => <<'END_OF_FUNC',
1405 my ($self,$script) = @_;
1407 my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
1408 foreach $script (@scripts) {
1409 my($src,$code,$language);
1410 if (ref($script)) { # script is a hash
1411 ($src,$code,$language) =
1412 $self->rearrange([SRC,CODE,LANGUAGE],
1413 '-foo'=>'bar', # a trick to allow the '-' to be omitted
1414 ref($script) eq 'ARRAY' ? @$script : %$script);
1417 ($src,$code,$language) = ('',$script,'JavaScript');
1420 push(@satts,'src'=>$src) if $src;
1421 push(@satts,'language'=>$language || 'JavaScript');
1422 $code = "<!-- Hide script\n$code\n// End script hiding -->"
1423 if $code && $language=~/javascript/i;
1424 $code = "<!-- Hide script\n$code\n\# End script hiding -->"
1425 if $code && $language=~/perl/i;
1426 push(@result,script({@satts},$code || ''));
1432 #### Method: end_html
1433 # End an HTML document.
1434 # Trivial method for completeness. Just returns "</BODY>"
1436 'end_html' => <<'END_OF_FUNC',
1438 return "</BODY></HTML>";
1443 ################################
1444 # METHODS USED IN BUILDING FORMS
1445 ################################
1447 #### Method: isindex
1448 # Just prints out the isindex tag.
1450 # $action -> optional URL of script to run
1452 # A string containing a <ISINDEX> tag
1453 'isindex' => <<'END_OF_FUNC',
1455 my($self,@p) = self_or_default(@_);
1456 my($action,@other) = $self->rearrange([ACTION],@p);
1457 $action = qq/ACTION="$action"/ if $action;
1458 my($other) = @other ? " @other" : '';
1459 return "<ISINDEX $action$other>";
1464 #### Method: startform
1467 # $method -> optional submission method to use (GET or POST)
1468 # $action -> optional URL of script to run
1469 # $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1470 'startform' => <<'END_OF_FUNC',
1472 my($self,@p) = self_or_default(@_);
1474 my($method,$action,$enctype,@other) =
1475 $self->rearrange([METHOD,ACTION,ENCTYPE],@p);
1477 $method = $method || 'POST';
1478 $enctype = $enctype || &URL_ENCODED;
1479 $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
1480 'ACTION="'.$self->script_name.'"' : '';
1481 my($other) = @other ? " @other" : '';
1482 $self->{'.parametersToAdd'}={};
1483 return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
1488 #### Method: start_form
1489 # synonym for startform
1490 'start_form' => <<'END_OF_FUNC',
1496 'end_multipart_form' => <<'END_OF_FUNC',
1497 sub end_multipart_form {
1502 #### Method: start_multipart_form
1503 # synonym for startform
1504 'start_multipart_form' => <<'END_OF_FUNC',
1505 sub start_multipart_form {
1506 my($self,@p) = self_or_default(@_);
1507 if ($self->use_named_parameters ||
1508 (defined($param[0]) && substr($param[0],0,1) eq '-')) {
1510 $p{'-enctype'}=&MULTIPART;
1511 return $self->startform(%p);
1513 my($method,$action,@other) =
1514 $self->rearrange([METHOD,ACTION],@p);
1515 return $self->startform($method,$action,&MULTIPART,@other);
1521 #### Method: endform
1523 'endform' => <<'END_OF_FUNC',
1525 my($self,@p) = self_or_default(@_);
1526 return wantarray ? ($self->get_fields,"</FORM>") :
1527 $self->get_fields ."\n</FORM>";
1532 #### Method: end_form
1533 # synonym for endform
1534 'end_form' => <<'END_OF_FUNC',
1541 '_textfield' => <<'END_OF_FUNC',
1543 my($self,$tag,@p) = self_or_default(@_);
1544 my($name,$default,$size,$maxlength,$override,@other) =
1545 $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1547 my $current = $override ? $default :
1548 (defined($self->param($name)) ? $self->param($name) : $default);
1550 $current = defined($current) ? $self->escapeHTML($current) : '';
1551 $name = defined($name) ? $self->escapeHTML($name) : '';
1552 my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1553 my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
1554 my($other) = @other ? " @other" : '';
1555 # this entered at cristy's request to fix problems with file upload fields
1556 # and WebTV -- not sure it won't break stuff
1557 my($value) = $current ne '' ? qq(VALUE="$current") : '';
1558 return qq/<INPUT TYPE="$tag" NAME="$name" $value$s$m$other>/;
1562 #### Method: textfield
1564 # $name -> Name of the text field
1565 # $default -> Optional default value of the field if not
1567 # $size -> Optional width of field in characaters.
1568 # $maxlength -> Optional maximum number of characters.
1570 # A string containing a <INPUT TYPE="text"> field
1572 'textfield' => <<'END_OF_FUNC',
1574 my($self,@p) = self_or_default(@_);
1575 $self->_textfield('text',@p);
1580 #### Method: filefield
1582 # $name -> Name of the file upload field
1583 # $size -> Optional width of field in characaters.
1584 # $maxlength -> Optional maximum number of characters.
1586 # A string containing a <INPUT TYPE="text"> field
1588 'filefield' => <<'END_OF_FUNC',
1590 my($self,@p) = self_or_default(@_);
1591 $self->_textfield('file',@p);
1596 #### Method: password
1597 # Create a "secret password" entry field
1599 # $name -> Name of the field
1600 # $default -> Optional default value of the field if not
1602 # $size -> Optional width of field in characters.
1603 # $maxlength -> Optional maximum characters that can be entered.
1605 # A string containing a <INPUT TYPE="password"> field
1607 'password_field' => <<'END_OF_FUNC',
1608 sub password_field {
1609 my ($self,@p) = self_or_default(@_);
1610 $self->_textfield('password',@p);
1614 #### Method: textarea
1616 # $name -> Name of the text field
1617 # $default -> Optional default value of the field if not
1619 # $rows -> Optional number of rows in text area
1620 # $columns -> Optional number of columns in text area
1622 # A string containing a <TEXTAREA></TEXTAREA> tag
1624 'textarea' => <<'END_OF_FUNC',
1626 my($self,@p) = self_or_default(@_);
1628 my($name,$default,$rows,$cols,$override,@other) =
1629 $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
1631 my($current)= $override ? $default :
1632 (defined($self->param($name)) ? $self->param($name) : $default);
1634 $name = defined($name) ? $self->escapeHTML($name) : '';
1635 $current = defined($current) ? $self->escapeHTML($current) : '';
1636 my($r) = $rows ? " ROWS=$rows" : '';
1637 my($c) = $cols ? " COLS=$cols" : '';
1638 my($other) = @other ? " @other" : '';
1639 return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
1645 # Create a javascript button.
1647 # $name -> (optional) Name for the button. (-name)
1648 # $value -> (optional) Value of the button when selected (and visible name) (-value)
1649 # $onclick -> (optional) Text of the JavaScript to run when the button is
1652 # A string containing a <INPUT TYPE="button"> tag
1654 'button' => <<'END_OF_FUNC',
1656 my($self,@p) = self_or_default(@_);
1658 my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
1659 [ONCLICK,SCRIPT]],@p);
1661 $label=$self->escapeHTML($label);
1662 $value=$self->escapeHTML($value);
1663 $script=$self->escapeHTML($script);
1666 $name = qq/ NAME="$label"/ if $label;
1667 $value = $value || $label;
1669 $val = qq/ VALUE="$value"/ if $value;
1670 $script = qq/ ONCLICK="$script"/ if $script;
1671 my($other) = @other ? " @other" : '';
1672 return qq/<INPUT TYPE="button"$name$val$script$other>/;
1678 # Create a "submit query" button.
1680 # $name -> (optional) Name for the button.
1681 # $value -> (optional) Value of the button when selected (also doubles as label).
1682 # $label -> (optional) Label printed on the button(also doubles as the value).
1684 # A string containing a <INPUT TYPE="submit"> tag
1686 'submit' => <<'END_OF_FUNC',
1688 my($self,@p) = self_or_default(@_);
1690 my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p);
1692 $label=$self->escapeHTML($label);
1693 $value=$self->escapeHTML($value);
1695 my($name) = ' NAME=".submit"';
1696 $name = qq/ NAME="$label"/ if defined($label);
1697 $value = defined($value) ? $value : $label;
1699 $val = qq/ VALUE="$value"/ if defined($value);
1700 my($other) = @other ? " @other" : '';
1701 return qq/<INPUT TYPE="submit"$name$val$other>/;
1707 # Create a "reset" button.
1709 # $name -> (optional) Name for the button.
1711 # A string containing a <INPUT TYPE="reset"> tag
1713 'reset' => <<'END_OF_FUNC',
1715 my($self,@p) = self_or_default(@_);
1716 my($label,@other) = $self->rearrange([NAME],@p);
1717 $label=$self->escapeHTML($label);
1718 my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
1719 my($other) = @other ? " @other" : '';
1720 return qq/<INPUT TYPE="reset"$value$other>/;
1725 #### Method: defaults
1726 # Create a "defaults" button.
1728 # $name -> (optional) Name for the button.
1730 # A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
1732 # Note: this button has a special meaning to the initialization script,
1733 # and tells it to ERASE the current query string so that your defaults
1736 'defaults' => <<'END_OF_FUNC',
1738 my($self,@p) = self_or_default(@_);
1740 my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
1742 $label=$self->escapeHTML($label);
1743 $label = $label || "Defaults";
1744 my($value) = qq/ VALUE="$label"/;
1745 my($other) = @other ? " @other" : '';
1746 return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
1751 #### Method: comment
1752 # Create an HTML <!-- comment -->
1753 # Parameters: a string
1754 'comment' => <<'END_OF_FUNC',
1756 my($self,@p) = self_or_CGI(@_);
1757 return "<!-- @p -->";
1761 #### Method: checkbox
1762 # Create a checkbox that is not logically linked to any others.
1763 # The field value is "on" when the button is checked.
1765 # $name -> Name of the checkbox
1766 # $checked -> (optional) turned on by default if true
1767 # $value -> (optional) value of the checkbox, 'on' by default
1768 # $label -> (optional) a user-readable label printed next to the box.
1769 # Otherwise the checkbox name is used.
1771 # A string containing a <INPUT TYPE="checkbox"> field
1773 'checkbox' => <<'END_OF_FUNC',
1775 my($self,@p) = self_or_default(@_);
1777 my($name,$checked,$value,$label,$override,@other) =
1778 $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
1780 $value = defined $value ? $value : 'on';
1782 if (!$override && ($self->{'.fieldnames'}->{$name} ||
1783 defined $self->param($name))) {
1784 $checked = grep($_ eq $value,$self->param($name)) ? ' CHECKED' : '';
1786 $checked = $checked ? ' CHECKED' : '';
1788 my($the_label) = defined $label ? $label : $name;
1789 $name = $self->escapeHTML($name);
1790 $value = $self->escapeHTML($value);
1791 $the_label = $self->escapeHTML($the_label);
1792 my($other) = @other ? " @other" : '';
1793 $self->register_parameter($name);
1794 return qq{<INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label};
1799 #### Method: checkbox_group
1800 # Create a list of logically-linked checkboxes.
1802 # $name -> Common name for all the check boxes
1803 # $values -> A pointer to a regular array containing the
1804 # values for each checkbox in the group.
1805 # $defaults -> (optional)
1806 # 1. If a pointer to a regular array of checkbox values,
1807 # then this will be used to decide which
1808 # checkboxes to turn on by default.
1809 # 2. If a scalar, will be assumed to hold the
1810 # value of a single checkbox in the group to turn on.
1811 # $linebreak -> (optional) Set to true to place linebreaks
1812 # between the buttons.
1813 # $labels -> (optional)
1814 # A pointer to an associative array of labels to print next to each checkbox
1815 # in the form $label{'value'}="Long explanatory label".
1816 # Otherwise the provided values are used as the labels.
1818 # An ARRAY containing a series of <INPUT TYPE="checkbox"> fields
1820 'checkbox_group' => <<'END_OF_FUNC',
1821 sub checkbox_group {
1822 my($self,@p) = self_or_default(@_);
1824 my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
1825 $rowheaders,$colheaders,$override,$nolabels,@other) =
1826 $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1827 LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
1828 ROWHEADERS,COLHEADERS,
1829 [OVERRIDE,FORCE],NOLABELS],@p);
1831 my($checked,$break,$result,$label);
1833 my(%checked) = $self->previous_or_default($name,$defaults,$override);
1835 $break = $linebreak ? "<BR>" : '';
1836 $name=$self->escapeHTML($name);
1838 # Create the elements
1839 my(@elements,@values);
1841 @values = $self->_set_values_and_labels($values,\$labels,$name);
1843 my($other) = @other ? " @other" : '';
1845 $checked = $checked{$_} ? ' CHECKED' : '';
1847 unless (defined($nolabels) && $nolabels) {
1849 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1850 $label = $self->escapeHTML($label);
1852 $_ = $self->escapeHTML($_);
1853 push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label}${break}/);
1855 $self->register_parameter($name);
1856 return wantarray ? @elements : join(' ',@elements)
1857 unless defined($columns) || defined($rows);
1858 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1862 # Escape HTML -- used internally
1863 'escapeHTML' => <<'END_OF_FUNC',
1865 my ($self,$toencode) = self_or_default(@_);
1866 return undef unless defined($toencode);
1867 return $toencode if ref($self) && $self->{'dontescape'};
1869 $toencode=~s/&/&/g;
1870 $toencode=~s/\"/"/g;
1871 $toencode=~s/>/>/g;
1872 $toencode=~s/</</g;
1877 # unescape HTML -- used internally
1878 'unescapeHTML' => <<'END_OF_FUNC',
1880 my $string = ref($_[0]) ? $_[1] : $_[0];
1881 return undef unless defined($string);
1882 # thanks to Randal Schwartz for the correct solution to this one
1883 $string=~ s[&(.*?);]{
1889 /^#(\d+)$/ ? chr($1) :
1890 /^#x([0-9a-f]+)$/i ? chr(hex($1)) :
1897 # Internal procedure - don't use
1898 '_tableize' => <<'END_OF_FUNC',
1900 my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
1903 if (defined($columns)) {
1904 $rows = int(0.99 + @elements/$columns) unless defined($rows);
1906 if (defined($rows)) {
1907 $columns = int(0.99 + @elements/$rows) unless defined($columns);
1910 # rearrange into a pretty table
1911 $result = "<TABLE>";
1913 unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
1914 $result .= "<TR>" if @$colheaders;
1915 foreach (@{$colheaders}) {
1916 $result .= "<TH>$_</TH>";
1918 for ($row=0;$row<$rows;$row++) {
1920 $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
1921 for ($column=0;$column<$columns;$column++) {
1922 $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>"
1923 if defined($elements[$column*$rows + $row]);
1927 $result .= "</TABLE>";
1933 #### Method: radio_group
1934 # Create a list of logically-linked radio buttons.
1936 # $name -> Common name for all the buttons.
1937 # $values -> A pointer to a regular array containing the
1938 # values for each button in the group.
1939 # $default -> (optional) Value of the button to turn on by default. Pass '-'
1940 # to turn _nothing_ on.
1941 # $linebreak -> (optional) Set to true to place linebreaks
1942 # between the buttons.
1943 # $labels -> (optional)
1944 # A pointer to an associative array of labels to print next to each checkbox
1945 # in the form $label{'value'}="Long explanatory label".
1946 # Otherwise the provided values are used as the labels.
1948 # An ARRAY containing a series of <INPUT TYPE="radio"> fields
1950 'radio_group' => <<'END_OF_FUNC',
1952 my($self,@p) = self_or_default(@_);
1954 my($name,$values,$default,$linebreak,$labels,
1955 $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
1956 $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
1957 ROWS,[COLUMNS,COLS],
1958 ROWHEADERS,COLHEADERS,
1959 [OVERRIDE,FORCE],NOLABELS],@p);
1960 my($result,$checked);
1962 if (!$override && defined($self->param($name))) {
1963 $checked = $self->param($name);
1965 $checked = $default;
1967 my(@elements,@values);
1968 @values = $self->_set_values_and_labels($values,\$labels,$name);
1970 # If no check array is specified, check the first by default
1971 $checked = $values[0] unless defined($checked) && $checked ne '';
1972 $name=$self->escapeHTML($name);
1974 my($other) = @other ? " @other" : '';
1976 my($checkit) = $checked eq $_ ? ' CHECKED' : '';
1977 my($break) = $linebreak ? '<BR>' : '';
1979 unless (defined($nolabels) && $nolabels) {
1981 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1982 $label = $self->escapeHTML($label);
1984 $_=$self->escapeHTML($_);
1985 push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label}${break}/);
1987 $self->register_parameter($name);
1988 return wantarray ? @elements : join(' ',@elements)
1989 unless defined($columns) || defined($rows);
1990 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1995 #### Method: popup_menu
1996 # Create a popup menu.
1998 # $name -> Name for all the menu
1999 # $values -> A pointer to a regular array containing the
2000 # text of each menu item.
2001 # $default -> (optional) Default item to display
2002 # $labels -> (optional)
2003 # A pointer to an associative array of labels to print next to each checkbox
2004 # in the form $label{'value'}="Long explanatory label".
2005 # Otherwise the provided values are used as the labels.
2007 # A string containing the definition of a popup menu.
2009 'popup_menu' => <<'END_OF_FUNC',
2011 my($self,@p) = self_or_default(@_);
2013 my($name,$values,$default,$labels,$override,@other) =
2014 $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
2015 my($result,$selected);
2017 if (!$override && defined($self->param($name))) {
2018 $selected = $self->param($name);
2020 $selected = $default;
2022 $name=$self->escapeHTML($name);
2023 my($other) = @other ? " @other" : '';
2026 @values = $self->_set_values_and_labels($values,\$labels,$name);
2028 $result = qq/<SELECT NAME="$name"$other>\n/;
2030 my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
2032 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2033 my($value) = $self->escapeHTML($_);
2034 $label=$self->escapeHTML($label);
2035 $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
2038 $result .= "</SELECT>\n";
2044 #### Method: scrolling_list
2045 # Create a scrolling list.
2047 # $name -> name for the list
2048 # $values -> A pointer to a regular array containing the
2049 # values for each option line in the list.
2050 # $defaults -> (optional)
2051 # 1. If a pointer to a regular array of options,
2052 # then this will be used to decide which
2053 # lines to turn on by default.
2054 # 2. Otherwise holds the value of the single line to turn on.
2055 # $size -> (optional) Size of the list.
2056 # $multiple -> (optional) If set, allow multiple selections.
2057 # $labels -> (optional)
2058 # A pointer to an associative array of labels to print next to each checkbox
2059 # in the form $label{'value'}="Long explanatory label".
2060 # Otherwise the provided values are used as the labels.
2062 # A string containing the definition of a scrolling list.
2064 'scrolling_list' => <<'END_OF_FUNC',
2065 sub scrolling_list {
2066 my($self,@p) = self_or_default(@_);
2067 my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
2068 = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
2069 SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
2071 my($result,@values);
2072 @values = $self->_set_values_and_labels($values,\$labels,$name);
2074 $size = $size || scalar(@values);
2076 my(%selected) = $self->previous_or_default($name,$defaults,$override);
2077 my($is_multiple) = $multiple ? ' MULTIPLE' : '';
2078 my($has_size) = $size ? " SIZE=$size" : '';
2079 my($other) = @other ? " @other" : '';
2081 $name=$self->escapeHTML($name);
2082 $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
2084 my($selectit) = $selected{$_} ? 'SELECTED' : '';
2086 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2087 $label=$self->escapeHTML($label);
2088 my($value)=$self->escapeHTML($_);
2089 $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
2091 $result .= "</SELECT>\n";
2092 $self->register_parameter($name);
2100 # $name -> Name of the hidden field
2101 # @default -> (optional) Initial values of field (may be an array)
2103 # $default->[initial values of field]
2105 # A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
2107 'hidden' => <<'END_OF_FUNC',
2109 my($self,@p) = self_or_default(@_);
2111 # this is the one place where we departed from our standard
2112 # calling scheme, so we have to special-case (darn)
2114 my($name,$default,$override,@other) =
2115 $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
2117 my $do_override = 0;
2118 if ( ref($p[0]) || substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
2119 @value = ref($default) ? @{$default} : $default;
2120 $do_override = $override;
2122 foreach ($default,$override,@other) {
2123 push(@value,$_) if defined($_);
2127 # use previous values if override is not set
2128 my @prev = $self->param($name);
2129 @value = @prev if !$do_override && @prev;
2131 $name=$self->escapeHTML($name);
2133 $_ = defined($_) ? $self->escapeHTML($_) : '';
2134 push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
2136 return wantarray ? @result : join('',@result);
2141 #### Method: image_button
2143 # $name -> Name of the button
2144 # $src -> URL of the image source
2145 # $align -> Alignment style (TOP, BOTTOM or MIDDLE)
2147 # A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment">
2149 'image_button' => <<'END_OF_FUNC',
2151 my($self,@p) = self_or_default(@_);
2153 my($name,$src,$alignment,@other) =
2154 $self->rearrange([NAME,SRC,ALIGN],@p);
2156 my($align) = $alignment ? " ALIGN=\U$alignment" : '';
2157 my($other) = @other ? " @other" : '';
2158 $name=$self->escapeHTML($name);
2159 return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/;
2164 #### Method: self_url
2165 # Returns a URL containing the current script and all its
2166 # param/value pairs arranged as a query. You can use this
2167 # to create a link that, when selected, will reinvoke the
2168 # script with all its state information preserved.
2170 'self_url' => <<'END_OF_FUNC',
2172 my($self,@p) = self_or_default(@_);
2173 return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
2178 # This is provided as a synonym to self_url() for people unfortunate
2179 # enough to have incorporated it into their programs already!
2180 'state' => <<'END_OF_FUNC',
2188 # Like self_url, but doesn't return the query string part of
2191 'url' => <<'END_OF_FUNC',
2193 my($self,@p) = self_or_default(@_);
2194 my ($relative,$absolute,$full,$path_info,$query) =
2195 $self->rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING']],@p);
2197 $full++ if !($relative || $absolute);
2199 my $path = $self->path_info;
2201 if (exists($ENV{REQUEST_URI})) {
2203 $script_name = $ENV{REQUEST_URI};
2204 # strip query string
2205 substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0;
2207 substr($script_name,$index) = '' if exists($ENV{PATH_INFO})
2208 and ($index = rindex($script_name,$ENV{PATH_INFO})) >= 0;
2210 $script_name = $self->script_name;
2214 my $protocol = $self->protocol();
2215 $url = "$protocol://";
2216 my $vh = http('host');
2220 $url .= server_name();
2221 my $port = $self->server_port;
2223 unless (lc($protocol) eq 'http' && $port == 80)
2224 || (lc($protocol) eq 'https' && $port == 443);
2226 $url .= $script_name;
2227 } elsif ($relative) {
2228 ($url) = $script_name =~ m!([^/]+)$!;
2229 } elsif ($absolute) {
2230 $url = $script_name;
2232 $url .= $path if $path_info and defined $path;
2233 $url .= "?" . $self->query_string if $query and $self->query_string;
2240 # Set or read a cookie from the specified name.
2241 # Cookie can then be passed to header().
2242 # Usual rules apply to the stickiness of -value.
2244 # -name -> name for this cookie (optional)
2245 # -value -> value of this cookie (scalar, array or hash)
2246 # -path -> paths for which this cookie is valid (optional)
2247 # -domain -> internet domain in which this cookie is valid (optional)
2248 # -secure -> if true, cookie only passed through secure channel (optional)
2249 # -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
2251 'cookie' => <<'END_OF_FUNC',
2253 my($self,@p) = self_or_default(@_);
2254 my($name,$value,$path,$domain,$secure,$expires) =
2255 $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
2257 require CGI::Cookie;
2259 # if no value is supplied, then we retrieve the
2260 # value of the cookie, if any. For efficiency, we cache the parsed
2261 # cookies in our state variables.
2262 unless ( defined($value) ) {
2263 $self->{'.cookies'} = CGI::Cookie->fetch
2264 unless $self->{'.cookies'};
2266 # If no name is supplied, then retrieve the names of all our cookies.
2267 return () unless $self->{'.cookies'};
2268 return keys %{$self->{'.cookies'}} unless $name;
2269 return () unless $self->{'.cookies'}->{$name};
2270 return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
2273 # If we get here, we're creating a new cookie
2274 return undef unless $name; # this is an error
2277 push(@param,'-name'=>$name);
2278 push(@param,'-value'=>$value);
2279 push(@param,'-domain'=>$domain) if $domain;
2280 push(@param,'-path'=>$path) if $path;
2281 push(@param,'-expires'=>$expires) if $expires;
2282 push(@param,'-secure'=>$secure) if $secure;
2284 return CGI::Cookie->new(@param);
2288 # This internal routine creates an expires time exactly some number of
2289 # hours from the current time. It incorporates modifications from
2291 'expire_calc' => <<'END_OF_FUNC',
2294 my(%mult) = ('s'=>1,
2300 # format for time can be in any of the forms...
2301 # "now" -- expire immediately
2302 # "+180s" -- in 180 seconds
2303 # "+2m" -- in 2 minutes
2304 # "+12h" -- in 12 hours
2306 # "+3M" -- in 3 months
2307 # "+2y" -- in 2 years
2308 # "-3m" -- 3 minutes ago(!)
2309 # If you don't supply one of these forms, we assume you are
2310 # specifying the date yourself
2312 if (!$time || (lc($time) eq 'now')) {
2314 } elsif ($time=~/^\d+/) {
2316 } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
2317 $offset = ($mult{$2} || 1)*$1;
2321 return (time+$offset);
2325 # This internal routine creates date strings suitable for use in
2326 # cookies and HTTP headers. (They differ, unfortunately.)
2327 # Thanks to Mark Fisher for this.
2328 'expires' => <<'END_OF_FUNC',
2330 my($time,$format) = @_;
2333 my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
2334 my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
2336 # pass through preformatted dates for the sake of expire_calc()
2337 $time = expire_calc($time);
2338 return $time unless $time =~ /^\d+$/;
2340 # make HTTP/cookie date string from GMT'ed time
2341 # (cookies use '-' as date separator, HTTP uses ' ')
2343 $sc = '-' if $format eq "cookie";
2344 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
2346 return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
2347 $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
2351 'parse_keywordlist' => <<'END_OF_FUNC',
2352 sub parse_keywordlist {
2353 my($self,$tosplit) = @_;
2354 $tosplit = unescape($tosplit); # unescape the keywords
2355 $tosplit=~tr/+/ /; # pluses to spaces
2356 my(@keywords) = split(/\s+/,$tosplit);
2361 'param_fetch' => <<'END_OF_FUNC',
2363 my($self,@p) = self_or_default(@_);
2364 my($name) = $self->rearrange([NAME],@p);
2365 unless (exists($self->{$name})) {
2366 $self->add_parameter($name);
2367 $self->{$name} = [];
2370 return $self->{$name};
2374 ###############################################
2375 # OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
2376 ###############################################
2378 #### Method: path_info
2379 # Return the extra virtual path information provided
2380 # after the URL (if any)
2382 'path_info' => <<'END_OF_FUNC',
2384 my ($self,$info) = self_or_default(@_);
2385 if (defined($info)) {
2386 $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
2387 $self->{'.path_info'} = $info;
2388 } elsif (! defined($self->{'.path_info'}) ) {
2389 $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ?
2390 $ENV{'PATH_INFO'} : '';
2392 # hack to fix broken path info in IIS
2393 $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
2396 return $self->{'.path_info'};
2401 #### Method: request_method
2402 # Returns 'POST', 'GET', 'PUT' or 'HEAD'
2404 'request_method' => <<'END_OF_FUNC',
2405 sub request_method {
2406 return $ENV{'REQUEST_METHOD'};
2410 #### Method: content_type
2411 # Returns the content_type string
2413 'content_type' => <<'END_OF_FUNC',
2415 return $ENV{'CONTENT_TYPE'};
2419 #### Method: path_translated
2420 # Return the physical path information provided
2421 # by the URL (if any)
2423 'path_translated' => <<'END_OF_FUNC',
2424 sub path_translated {
2425 return $ENV{'PATH_TRANSLATED'};
2430 #### Method: query_string
2431 # Synthesize a query string from our current
2434 'query_string' => <<'END_OF_FUNC',
2436 my($self) = self_or_default(@_);
2437 my($param,$value,@pairs);
2438 foreach $param ($self->param) {
2439 my($eparam) = escape($param);
2440 foreach $value ($self->param($param)) {
2441 $value = escape($value);
2442 next unless defined $value;
2443 push(@pairs,"$eparam=$value");
2446 return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
2452 # Without parameters, returns an array of the
2453 # MIME types the browser accepts.
2454 # With a single parameter equal to a MIME
2455 # type, will return undef if the browser won't
2456 # accept it, 1 if the browser accepts it but
2457 # doesn't give a preference, or a floating point
2458 # value between 0.0 and 1.0 if the browser
2459 # declares a quantitative score for it.
2460 # This handles MIME type globs correctly.
2462 'Accept' => <<'END_OF_FUNC',
2464 my($self,$search) = self_or_CGI(@_);
2465 my(%prefs,$type,$pref,$pat);
2467 my(@accept) = split(',',$self->http('accept'));
2470 ($pref) = /q=(\d\.\d+|\d+)/;
2471 ($type) = m#(\S+/[^;]+)#;
2473 $prefs{$type}=$pref || 1;
2476 return keys %prefs unless $search;
2478 # if a search type is provided, we may need to
2479 # perform a pattern matching operation.
2480 # The MIME types use a glob mechanism, which
2481 # is easily translated into a perl pattern match
2483 # First return the preference for directly supported
2485 return $prefs{$search} if $prefs{$search};
2487 # Didn't get it, so try pattern matching.
2488 foreach (keys %prefs) {
2489 next unless /\*/; # not a pattern match
2490 ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2491 $pat =~ s/\*/.*/g; # turn it into a pattern
2492 return $prefs{$_} if $search=~/$pat/;
2498 #### Method: user_agent
2499 # If called with no parameters, returns the user agent.
2500 # If called with one parameter, does a pattern match (case
2501 # insensitive) on the user agent.
2503 'user_agent' => <<'END_OF_FUNC',
2505 my($self,$match)=self_or_CGI(@_);
2506 return $self->http('user_agent') unless $match;
2507 return $self->http('user_agent') =~ /$match/i;
2512 #### Method: raw_cookie
2513 # Returns the magic cookies for the session.
2514 # The cookies are not parsed or altered in any way, i.e.
2515 # cookies are returned exactly as given in the HTTP
2516 # headers. If a cookie name is given, only that cookie's
2517 # value is returned, otherwise the entire raw cookie
2520 'raw_cookie' => <<'END_OF_FUNC',
2522 my($self,$key) = self_or_CGI(@_);
2524 require CGI::Cookie;
2526 if (defined($key)) {
2527 $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
2528 unless $self->{'.raw_cookies'};
2530 return () unless $self->{'.raw_cookies'};
2531 return () unless $self->{'.raw_cookies'}->{$key};
2532 return $self->{'.raw_cookies'}->{$key};
2534 return $self->http('cookie') || $ENV{'COOKIE'} || '';
2538 #### Method: virtual_host
2539 # Return the name of the virtual_host, which
2540 # is not always the same as the server
2542 'virtual_host' => <<'END_OF_FUNC',
2544 my $vh = http('host') || server_name();
2545 $vh =~ s/:\d+$//; # get rid of port number
2550 #### Method: remote_host
2551 # Return the name of the remote host, or its IP
2552 # address if unavailable. If this variable isn't
2553 # defined, it returns "localhost" for debugging
2556 'remote_host' => <<'END_OF_FUNC',
2558 return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
2564 #### Method: remote_addr
2565 # Return the IP addr of the remote host.
2567 'remote_addr' => <<'END_OF_FUNC',
2569 return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
2574 #### Method: script_name
2575 # Return the partial URL to this script for
2576 # self-referencing scripts. Also see
2577 # self_url(), which returns a URL with all state information
2580 'script_name' => <<'END_OF_FUNC',
2582 return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'});
2583 # These are for debugging
2584 return "/$0" unless $0=~/^\//;
2590 #### Method: referer
2591 # Return the HTTP_REFERER: useful for generating
2594 'referer' => <<'END_OF_FUNC',
2596 my($self) = self_or_CGI(@_);
2597 return $self->http('referer');
2602 #### Method: server_name
2603 # Return the name of the server
2605 'server_name' => <<'END_OF_FUNC',
2607 return $ENV{'SERVER_NAME'} || 'localhost';
2611 #### Method: server_software
2612 # Return the name of the server software
2614 'server_software' => <<'END_OF_FUNC',
2615 sub server_software {
2616 return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
2620 #### Method: server_port
2621 # Return the tcp/ip port the server is running on
2623 'server_port' => <<'END_OF_FUNC',
2625 return $ENV{'SERVER_PORT'} || 80; # for debugging
2629 #### Method: server_protocol
2630 # Return the protocol (usually HTTP/1.0)
2632 'server_protocol' => <<'END_OF_FUNC',
2633 sub server_protocol {
2634 return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
2639 # Return the value of an HTTP variable, or
2640 # the list of variables if none provided
2642 'http' => <<'END_OF_FUNC',
2644 my ($self,$parameter) = self_or_CGI(@_);
2645 return $ENV{$parameter} if $parameter=~/^HTTP/;
2646 $parameter =~ tr/-/_/;
2647 return $ENV{"HTTP_\U$parameter\E"} if $parameter;
2649 foreach (keys %ENV) {
2650 push(@p,$_) if /^HTTP/;
2657 # Return the value of HTTPS
2659 'https' => <<'END_OF_FUNC',
2662 my ($self,$parameter) = self_or_CGI(@_);
2663 return $ENV{HTTPS} unless $parameter;
2664 return $ENV{$parameter} if $parameter=~/^HTTPS/;
2665 $parameter =~ tr/-/_/;
2666 return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
2668 foreach (keys %ENV) {
2669 push(@p,$_) if /^HTTPS/;
2675 #### Method: protocol
2676 # Return the protocol (http or https currently)
2678 'protocol' => <<'END_OF_FUNC',
2682 return 'https' if uc($self->https()) eq 'ON';
2683 return 'https' if $self->server_port == 443;
2684 my $prot = $self->server_protocol;
2685 my($protocol,$version) = split('/',$prot);
2686 return "\L$protocol\E";
2690 #### Method: remote_ident
2691 # Return the identity of the remote user
2692 # (but only if his host is running identd)
2694 'remote_ident' => <<'END_OF_FUNC',
2696 return $ENV{'REMOTE_IDENT'};
2701 #### Method: auth_type
2702 # Return the type of use verification/authorization in use, if any.
2704 'auth_type' => <<'END_OF_FUNC',
2706 return $ENV{'AUTH_TYPE'};
2711 #### Method: remote_user
2712 # Return the authorization name used for user
2715 'remote_user' => <<'END_OF_FUNC',
2717 return $ENV{'REMOTE_USER'};
2722 #### Method: user_name
2723 # Try to return the remote user's name by hook or by
2726 'user_name' => <<'END_OF_FUNC',
2728 my ($self) = self_or_CGI(@_);
2729 return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
2734 # Set or return the NPH global flag
2736 'nph' => <<'END_OF_FUNC',
2738 my ($self,$param) = self_or_CGI(@_);
2739 $CGI::NPH = $param if defined($param);
2744 #### Method: private_tempfiles
2745 # Set or return the private_tempfiles global flag
2747 'private_tempfiles' => <<'END_OF_FUNC',
2748 sub private_tempfiles {
2749 my ($self,$param) = self_or_CGI(@_);
2750 $CGI::PRIVATE_TEMPFILES = $param if defined($param);
2751 return $CGI::PRIVATE_TEMPFILES;
2755 #### Method: default_dtd
2756 # Set or return the default_dtd global
2758 'default_dtd' => <<'END_OF_FUNC',
2760 my ($self,$param) = self_or_CGI(@_);
2761 $CGI::DEFAULT_DTD = $param if defined($param);
2762 return $CGI::DEFAULT_DTD;
2766 # -------------- really private subroutines -----------------
2767 'previous_or_default' => <<'END_OF_FUNC',
2768 sub previous_or_default {
2769 my($self,$name,$defaults,$override) = @_;
2772 if (!$override && ($self->{'.fieldnames'}->{$name} ||
2773 defined($self->param($name)) ) ) {
2774 grep($selected{$_}++,$self->param($name));
2775 } elsif (defined($defaults) && ref($defaults) &&
2776 (ref($defaults) eq 'ARRAY')) {
2777 grep($selected{$_}++,@{$defaults});
2779 $selected{$defaults}++ if defined($defaults);
2786 'register_parameter' => <<'END_OF_FUNC',
2787 sub register_parameter {
2788 my($self,$param) = @_;
2789 $self->{'.parametersToAdd'}->{$param}++;
2793 'get_fields' => <<'END_OF_FUNC',
2796 return $self->CGI::hidden('-name'=>'.cgifields',
2797 '-values'=>[keys %{$self->{'.parametersToAdd'}}],
2802 'read_from_cmdline' => <<'END_OF_FUNC',
2803 sub read_from_cmdline {
2809 require "shellwords.pl";
2810 print STDERR "(offline mode: enter name=value pairs on standard input)\n";
2811 chomp(@lines = <STDIN>); # remove newlines
2812 $input = join(" ",@lines);
2813 @words = &shellwords($input);
2820 if ("@words"=~/=/) {
2821 $query_string = join('&',@words);
2823 $query_string = join('+',@words);
2825 return $query_string;
2830 # subroutine: read_multipart
2832 # Read multipart data and store it into our parameters.
2833 # An interesting feature is that if any of the parts is a file, we
2834 # create a temporary file and open up a filehandle on it so that the
2835 # caller can read from it if necessary.
2837 'read_multipart' => <<'END_OF_FUNC',
2838 sub read_multipart {
2839 my($self,$boundary,$length,$filehandle) = @_;
2840 my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle);
2841 return unless $buffer;
2844 while (!$buffer->eof) {
2845 %header = $buffer->readHeader;
2848 $self->cgi_error("400 Bad request (malformed multipart POST)");
2852 my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
2854 # Bug: Netscape doesn't escape quotation marks in file names!!!
2855 my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/;
2857 # add this parameter to our list
2858 $self->add_parameter($param);
2860 # If no filename specified, then just read the data and assign it
2861 # to our parameter list.
2862 if ( !defined($filename) || $filename eq '' ) {
2863 my($value) = $buffer->readBody;
2864 push(@{$self->{$param}},$value);
2868 my ($tmpfile,$tmp,$filehandle);
2870 # If we get here, then we are dealing with a potentially large
2871 # uploaded form. Save the data to a temporary file, then open
2872 # the file for reading.
2874 # skip the file if uploads disabled
2875 if ($DISABLE_UPLOADS) {
2876 while (defined($data = $buffer->read)) { }
2880 # choose a relatively unpredictable tmpfile sequence number
2881 my $seqno = unpack("%16C*",join('',localtime,values %ENV));
2882 for (my $cnt=10;$cnt>0;$cnt--) {
2883 next unless $tmpfile = new TempFile($seqno);
2884 $tmp = $tmpfile->as_string;
2885 last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
2886 $seqno += int rand(100);
2888 die "CGI open of tmpfile: $!\n" unless $filehandle;
2889 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2893 while (defined($data = $buffer->read)) {
2894 print $filehandle $data;
2897 # back up to beginning of file
2898 seek($filehandle,0,0);
2899 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2901 # Save some information about the uploaded file where we can get
2903 $self->{'.tmpfiles'}->{fileno($filehandle)}= {
2907 push(@{$self->{$param}},$filehandle);
2913 'upload' =><<'END_OF_FUNC',
2915 my($self,$param_name) = self_or_default(@_);
2916 my $param = $self->param($param_name);
2917 return unless $param;
2918 return unless ref($param) && fileno($param);
2923 'tmpFileName' => <<'END_OF_FUNC',
2925 my($self,$filename) = self_or_default(@_);
2926 return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ?
2927 $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string
2932 'uploadInfo' => <<'END_OF_FUNC',
2934 my($self,$filename) = self_or_default(@_);
2935 return $self->{'.tmpfiles'}->{fileno($filename)}->{info};
2939 # internal routine, don't use
2940 '_set_values_and_labels' => <<'END_OF_FUNC',
2941 sub _set_values_and_labels {
2944 $$l = $v if ref($v) eq 'HASH' && !ref($$l);
2945 return $self->param($n) if !defined($v);
2946 return $v if !ref($v);
2947 return ref($v) eq 'HASH' ? keys %$v : @$v;
2951 '_compile_all' => <<'END_OF_FUNC',
2954 next if defined(&$_);
2955 $AUTOLOAD = "CGI::$_";
2965 #########################################################
2966 # Globals and stubs for other packages that we use.
2967 #########################################################
2969 ################### Fh -- lightweight filehandle ###############
2978 *Fh::AUTOLOAD = \&CGI::AUTOLOAD;
2980 $AUTOLOADED_ROUTINES = ''; # prevent -w error
2981 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
2983 'asString' => <<'END_OF_FUNC',
2986 # get rid of package name
2987 (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
2991 # This was an extremely clever patch that allowed "use strict refs".
2992 # Unfortunately it relied on another bug that caused leaky file descriptors.
2993 # The underlying bug has been fixed, so this no longer works. However
2994 # "strict refs" still works for some reason.
2996 # return ${*{$self}{SCALAR}};
3001 'compare' => <<'END_OF_FUNC',
3005 return "$self" cmp $value;
3009 'new' => <<'END_OF_FUNC',
3011 my($pack,$name,$file,$delete) = @_;
3012 require Fcntl unless defined &Fcntl::O_RDWR;
3013 my $ref = \*{'Fh::' . ++$FH . quotemeta($name)};
3014 sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
3015 unlink($file) if $delete;
3016 CORE::delete $Fh::{$FH};
3017 return bless $ref,$pack;
3021 'DESTROY' => <<'END_OF_FUNC',
3031 ######################## MultipartBuffer ####################
3032 package MultipartBuffer;
3034 # how many bytes to read at a time. We use
3035 # a 4K buffer by default.
3036 $INITIAL_FILLUNIT = 1024 * 4;
3037 $TIMEOUT = 240*60; # 4 hour timeout for big files
3038 $SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
3041 #reuse the autoload function
3042 *MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
3044 # avoid autoloader warnings
3047 ###############################################################################
3048 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3049 ###############################################################################
3050 $AUTOLOADED_ROUTINES = ''; # prevent -w error
3051 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3054 'new' => <<'END_OF_FUNC',
3056 my($package,$interface,$boundary,$length,$filehandle) = @_;
3057 $FILLUNIT = $INITIAL_FILLUNIT;
3060 my($package) = caller;
3061 # force into caller's package if necessary
3062 $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
3064 $IN = "main::STDIN" unless $IN;
3066 $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
3068 # If the user types garbage into the file upload field,
3069 # then Netscape passes NOTHING to the server (not good).
3070 # We may hang on this read in that case. So we implement
3071 # a read timeout. If nothing is ready to read
3072 # by then, we return.
3074 # Netscape seems to be a little bit unreliable
3075 # about providing boundary strings.
3078 # Under the MIME spec, the boundary consists of the
3079 # characters "--" PLUS the Boundary string
3081 # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
3082 # the two extra hyphens. We do a special case here on the user-agent!!!!
3083 $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac');
3085 } else { # otherwise we find it ourselves
3087 ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
3088 $boundary = <$IN>; # BUG: This won't work correctly under mod_perl
3089 $length -= length($boundary);
3090 chomp($boundary); # remove the CRLF
3091 $/ = $old; # restore old line separator
3094 my $self = {LENGTH=>$length,
3095 BOUNDARY=>$boundary,
3097 INTERFACE=>$interface,
3101 $FILLUNIT = length($boundary)
3102 if length($boundary) > $FILLUNIT;
3104 my $retval = bless $self,ref $package || $package;
3106 # Read the preamble and the topmost (boundary) line plus the CRLF.
3107 while ($self->read(0)) { }
3108 die "Malformed multipart POST\n" if $self->eof;
3114 'readHeader' => <<'END_OF_FUNC',
3121 if ($CGI::OS eq 'VMS') { # tssk, tssk: inconsistency alert!
3122 local($CRLF) = "\015\012";
3126 $self->fillBuffer($FILLUNIT);
3127 $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
3128 $ok++ if $self->{BUFFER} eq '';
3129 $bad++ if !$ok && $self->{LENGTH} <= 0;
3130 # this was a bad idea
3131 # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
3132 } until $ok || $bad;
3135 my($header) = substr($self->{BUFFER},0,$end+2);
3136 substr($self->{BUFFER},0,$end+4) = '';
3140 # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
3141 # (Folding Long Header Fields), 3.4.3 (Comments)
3142 # and 3.4.5 (Quoted-Strings).
3144 my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
3145 $header=~s/$CRLF\s+/ /og; # merge continuation lines
3146 while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
3147 my ($field_name,$field_value) = ($1,$2); # avoid taintedness
3148 $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
3149 $return{$field_name}=$field_value;
3155 # This reads and returns the body as a single scalar value.
3156 'readBody' => <<'END_OF_FUNC',
3161 while (defined($data = $self->read)) {
3162 $returnval .= $data;
3168 # This will read $bytes or until the boundary is hit, whichever happens
3169 # first. After the boundary is hit, we return undef. The next read will
3170 # skip over the boundary and begin reading again;
3171 'read' => <<'END_OF_FUNC',
3173 my($self,$bytes) = @_;
3175 # default number of bytes to read
3176 $bytes = $bytes || $FILLUNIT;
3178 # Fill up our internal buffer in such a way that the boundary
3179 # is never split between reads.
3180 $self->fillBuffer($bytes);
3182 # Find the boundary in the buffer (it may not be there).
3183 my $start = index($self->{BUFFER},$self->{BOUNDARY});
3184 # protect against malformed multipart POST operations
3185 die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
3187 # If the boundary begins the data, then skip past it
3188 # and return undef. The +2 here is a fiendish plot to
3189 # remove the CR/LF pair at the end of the boundary.
3192 # clear us out completely if we've hit the last boundary.
3193 if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
3199 # just remove the boundary.
3200 substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
3205 if ($start > 0) { # read up to the boundary
3206 $bytesToReturn = $start > $bytes ? $bytes : $start;
3207 } else { # read the requested number of bytes
3208 # leave enough bytes in the buffer to allow us to read
3209 # the boundary. Thanks to Kevin Hendrick for finding
3211 $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
3214 my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
3215 substr($self->{BUFFER},0,$bytesToReturn)='';
3217 # If we hit the boundary, remove the CRLF from the end.
3218 return ($start > 0) ? substr($returnval,0,-2) : $returnval;
3223 # This fills up our internal buffer in such a way that the
3224 # boundary is never split between reads
3225 'fillBuffer' => <<'END_OF_FUNC',
3227 my($self,$bytes) = @_;
3228 return unless $self->{LENGTH};
3230 my($boundaryLength) = length($self->{BOUNDARY});
3231 my($bufferLength) = length($self->{BUFFER});
3232 my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
3233 $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
3235 # Try to read some data. We may hang here if the browser is screwed up.
3236 my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN},
3240 $self->{BUFFER} = '' unless defined $self->{BUFFER};
3242 # An apparent bug in the Apache server causes the read()
3243 # to return zero bytes repeatedly without blocking if the
3244 # remote user aborts during a file transfer. I don't know how
3245 # they manage this, but the workaround is to abort if we get
3246 # more than SPIN_LOOP_MAX consecutive zero reads.
3247 if ($bytesRead == 0) {
3248 die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
3249 if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
3251 $self->{ZERO_LOOP_COUNTER}=0;
3254 $self->{LENGTH} -= $bytesRead;
3259 # Return true when we've finished reading
3260 'eof' => <<'END_OF_FUNC'
3263 return 1 if (length($self->{BUFFER}) == 0)
3264 && ($self->{LENGTH} <= 0);
3272 ####################################################################################
3273 ################################## TEMPORARY FILES #################################
3274 ####################################################################################
3278 $MAC = $CGI::OS eq 'MACINTOSH';
3279 my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
3280 unless ($TMPDIRECTORY) {
3281 @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
3282 "C:${SL}temp","${SL}tmp","${SL}temp",
3283 "${vol}${SL}Temporary Items","${SL}sys\$scratch",
3285 unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'};
3288 # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
3289 # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
3290 # : can generate a 'getpwuid() not implemented' exception, even though
3291 # : it's never called. Found under DOS/Win with the DJGPP perl port.
3292 # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
3293 unshift(@TEMP,(eval {(getpwuid($<))[7]}).'/tmp') if $CGI::OS eq 'UNIX';
3296 do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
3300 $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
3303 # cute feature, but overload implementation broke it
3304 # %OVERLOAD = ('""'=>'as_string');
3305 *TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
3307 ###############################################################################
3308 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3309 ###############################################################################
3310 $AUTOLOADED_ROUTINES = ''; # prevent -w error
3311 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3314 'new' => <<'END_OF_FUNC',
3316 my($package,$sequence) = @_;
3318 for (my $i = 0; $i < $MAXTRIES; $i++) {
3319 last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
3321 # untaint the darn thing
3322 return unless $filename =~ m!^([a-zA-Z0-9_ '":/\\]+)$!;
3324 return bless \$filename;
3328 'DESTROY' => <<'END_OF_FUNC',
3331 unlink $$self; # get rid of the file
3335 'as_string' => <<'END_OF_FUNC'
3347 # We get a whole bunch of warnings about "possibly uninitialized variables"
3348 # when running with the -w switch. Touch them all once to get rid of the
3349 # warnings. This is ugly and I hate it.
3354 $MultipartBuffer::SPIN_LOOP_MAX;
3355 $MultipartBuffer::CRLF;
3356 $MultipartBuffer::TIMEOUT;
3357 $MultipartBuffer::INITIAL_FILLUNIT;
3368 CGI - Simple Common Gateway Interface Class
3372 # CGI script that creates a fill-out form
3373 # and echoes back its values.
3375 use CGI qw/:standard/;
3377 start_html('A Simple Example'),
3378 h1('A Simple Example'),
3380 "What's your name? ",textfield('name'),p,
3381 "What's the combination?", p,
3382 checkbox_group(-name=>'words',
3383 -values=>['eenie','meenie','minie','moe'],
3384 -defaults=>['eenie','minie']), p,
3385 "What's your favorite color? ",
3386 popup_menu(-name=>'color',
3387 -values=>['red','green','blue','chartreuse']),p,
3393 print "Your name is",em(param('name')),p,
3394 "The keywords are: ",em(join(", ",param('words'))),p,
3395 "Your favorite color is ",em(param('color')),
3401 This perl library uses perl5 objects to make it easy to create Web
3402 fill-out forms and parse their contents. This package defines CGI
3403 objects, entities that contain the values of the current query string
3404 and other state variables. Using a CGI object's methods, you can
3405 examine keywords and parameters passed to your script, and create
3406 forms whose initial values are taken from the current query (thereby
3407 preserving state information). The module provides shortcut functions
3408 that produce boilerplate HTML, reducing typing and coding errors. It
3409 also provides functionality for some of the more advanced features of
3410 CGI scripting, including support for file uploads, cookies, cascading
3411 style sheets, server push, and frames.
3413 CGI.pm also provides a simple function-oriented programming style for
3414 those who don't need its object-oriented features.
3416 The current version of CGI.pm is available at
3418 http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
3419 ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
3423 =head2 PROGRAMMING STYLE
3425 There are two styles of programming with CGI.pm, an object-oriented
3426 style and a function-oriented style. In the object-oriented style you
3427 create one or more CGI objects and then use object methods to create
3428 the various elements of the page. Each CGI object starts out with the
3429 list of named parameters that were passed to your CGI script by the
3430 server. You can modify the objects, save them to a file or database
3431 and recreate them. Because each object corresponds to the "state" of
3432 the CGI script, and because each object's parameter list is
3433 independent of the others, this allows you to save the state of the
3434 script and restore it later.
3436 For example, using the object oriented style, here is how you create
3437 a simple "Hello World" HTML page:
3439 #!/usr/local/bin/perl -w
3440 use CGI; # load CGI routines
3441 $q = new CGI; # create new CGI object
3442 print $q->header, # create the HTTP header
3443 $q->start_html('hello world'), # start the HTML
3444 $q->h1('hello world'), # level 1 header
3445 $q->end_html; # end the HTML
3447 In the function-oriented style, there is one default CGI object that
3448 you rarely deal with directly. Instead you just call functions to
3449 retrieve CGI parameters, create HTML tags, manage cookies, and so
3450 on. This provides you with a cleaner programming interface, but
3451 limits you to using one CGI object at a time. The following example
3452 prints the same page, but uses the function-oriented interface.
3453 The main differences are that we now need to import a set of functions
3454 into our name space (usually the "standard" functions), and we don't
3455 need to create the CGI object.
3457 #!/usr/local/bin/perl
3458 use CGI qw/:standard/; # load standard CGI routines
3459 print header, # create the HTTP header
3460 start_html('hello world'), # start the HTML
3461 h1('hello world'), # level 1 header
3462 end_html; # end the HTML
3464 The examples in this document mainly use the object-oriented style.
3465 See HOW TO IMPORT FUNCTIONS for important information on
3466 function-oriented programming in CGI.pm
3468 =head2 CALLING CGI.PM ROUTINES
3470 Most CGI.pm routines accept several arguments, sometimes as many as 20
3471 optional ones! To simplify this interface, all routines use a named
3472 argument calling style that looks like this:
3474 print $q->header(-type=>'image/gif',-expires=>'+3d');
3476 Each argument name is preceded by a dash. Neither case nor order
3477 matters in the argument list. -type, -Type, and -TYPE are all
3478 acceptable. In fact, only the first argument needs to begin with a
3479 dash. If a dash is present in the first argument, CGI.pm assumes
3480 dashes for the subsequent ones.
3482 You don't have to use the hyphen at all if you don't want to. After
3483 creating a CGI object, call the B<use_named_parameters()> method with
3484 a nonzero value. This will tell CGI.pm that you intend to use named
3485 parameters exclusively:
3488 $query->use_named_parameters(1);
3489 $field = $query->radio_group('name'=>'OS',
3490 'values'=>['Unix','Windows','Macintosh'],
3493 Several routines are commonly called with just one argument. In the
3494 case of these routines you can provide the single argument without an
3495 argument name. header() happens to be one of these routines. In this
3496 case, the single argument is the document type.
3498 print $q->header('text/html');
3500 Other such routines are documented below.
3502 Sometimes named arguments expect a scalar, sometimes a reference to an
3503 array, and sometimes a reference to a hash. Often, you can pass any
3504 type of argument and the routine will do whatever is most appropriate.
3505 For example, the param() routine is used to set a CGI parameter to a
3506 single or a multi-valued value. The two cases are shown below:
3508 $q->param(-name=>'veggie',-value=>'tomato');
3509 $q->param(-name=>'veggie',-value=>'[tomato','tomahto','potato','potahto']);
3511 A large number of routines in CGI.pm actually aren't specifically
3512 defined in the module, but are generated automatically as needed.
3513 These are the "HTML shortcuts," routines that generate HTML tags for
3514 use in dynamically-generated pages. HTML tags have both attributes
3515 (the attribute="value" pairs within the tag itself) and contents (the
3516 part between the opening and closing pairs.) To distinguish between
3517 attributes and contents, CGI.pm uses the convention of passing HTML
3518 attributes as a hash reference as the first argument, and the
3519 contents, if any, as any subsequent arguments. It works out like
3525 h1('some','contents'); <H1>some contents</H1>
3526 h1({-align=>left}); <H1 ALIGN="LEFT">
3527 h1({-align=>left},'contents'); <H1 ALIGN="LEFT">contents</H1>
3529 HTML tags are described in more detail later.
3531 Many newcomers to CGI.pm are puzzled by the difference between the
3532 calling conventions for the HTML shortcuts, which require curly braces
3533 around the HTML tag attributes, and the calling conventions for other
3534 routines, which manage to generate attributes without the curly
3535 brackets. Don't be confused. As a convenience the curly braces are
3536 optional in all but the HTML shortcuts. If you like, you can use
3537 curly braces when calling any routine that takes named arguments. For
3540 print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
3542 If you use the B<-w> switch, you will be warned that some CGI.pm argument
3543 names conflict with built-in Perl functions. The most frequent of
3544 these is the -values argument, used to create multi-valued menus,
3545 radio button clusters and the like. To get around this warning, you
3546 have several choices:
3550 =item 1. Use another name for the argument, if one is available. For
3551 example, -value is an alias for -values.
3553 =item 2. Change the capitalization, e.g. -Values
3555 =item 3. Put quotes around the argument name, e.g. '-values'
3559 Many routines will do something useful with a named argument that it
3560 doesn't recognize. For example, you can produce non-standard HTTP
3561 header fields by providing them as named arguments:
3563 print $q->header(-type => 'text/html',
3564 -cost => 'Three smackers',
3565 -annoyance_level => 'high',
3566 -complaints_to => 'bit bucket');
3568 This will produce the following nonstandard HTTP header:
3571 Cost: Three smackers
3572 Annoyance-level: high
3573 Complaints-to: bit bucket
3574 Content-type: text/html
3576 Notice the way that underscores are translated automatically into
3577 hyphens. HTML-generating routines perform a different type of
3580 This feature allows you to keep up with the rapidly changing HTTP and
3583 =head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
3587 This will parse the input (from both POST and GET methods) and store
3588 it into a perl5 object called $query.
3590 =head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
3592 $query = new CGI(INPUTFILE);
3594 If you provide a file handle to the new() method, it will read
3595 parameters from the file (or STDIN, or whatever). The file can be in
3596 any of the forms describing below under debugging (i.e. a series of
3597 newline delimited TAG=VALUE pairs will work). Conveniently, this type
3598 of file is created by the save() method (see below). Multiple records
3599 can be saved and restored.
3601 Perl purists will be pleased to know that this syntax accepts
3602 references to file handles, or even references to filehandle globs,
3603 which is the "official" way to pass a filehandle:
3605 $query = new CGI(\*STDIN);
3607 You can also initialize the CGI object with a FileHandle or IO::File
3610 If you are using the function-oriented interface and want to
3611 initialize CGI state from a file handle, the way to do this is with
3612 B<restore_parameters()>. This will (re)initialize the
3613 default CGI object from the indicated file handle.
3615 open (IN,"test.in") || die;
3616 restore_parameters(IN);
3619 You can also initialize the query object from an associative array
3622 $query = new CGI( {'dinosaur'=>'barney',
3623 'song'=>'I love you',
3624 'friends'=>[qw/Jessica George Nancy/]}
3627 or from a properly formatted, URL-escaped query string:
3629 $query = new CGI('dinosaur=barney&color=purple');
3631 or from a previously existing CGI object (currently this clones the
3632 parameter list, but none of the other object-specific fields, such as
3635 $old_query = new CGI;
3636 $new_query = new CGI($old_query);
3638 To create an empty query, initialize it from an empty string or hash:
3640 $empty_query = new CGI("");
3644 $empty_query = new CGI({});
3646 =head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
3648 @keywords = $query->keywords
3650 If the script was invoked as the result of an <ISINDEX> search, the
3651 parsed keywords can be obtained as an array using the keywords() method.
3653 =head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
3655 @names = $query->param
3657 If the script was invoked with a parameter list
3658 (e.g. "name1=value1&name2=value2&name3=value3"), the param()
3659 method will return the parameter names as a list. If the
3660 script was invoked as an <ISINDEX> script, there will be a
3661 single parameter named 'keywords'.
3663 NOTE: As of version 1.5, the array of parameter names returned will
3664 be in the same order as they were submitted by the browser.
3665 Usually this order is the same as the order in which the
3666 parameters are defined in the form (however, this isn't part
3667 of the spec, and so isn't guaranteed).
3669 =head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
3671 @values = $query->param('foo');
3675 $value = $query->param('foo');
3677 Pass the param() method a single argument to fetch the value of the
3678 named parameter. If the parameter is multivalued (e.g. from multiple
3679 selections in a scrolling list), you can ask to receive an array. Otherwise
3680 the method will return a single value.
3682 =head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
3684 $query->param('foo','an','array','of','values');
3686 This sets the value for the named parameter 'foo' to an array of
3687 values. This is one way to change the value of a field AFTER
3688 the script has been invoked once before. (Another way is with
3689 the -override parameter accepted by all methods that generate
3692 param() also recognizes a named parameter style of calling described
3693 in more detail later:
3695 $query->param(-name=>'foo',-values=>['an','array','of','values']);
3699 $query->param(-name=>'foo',-value=>'the value');
3701 =head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
3703 $query->append(-name=>'foo',-values=>['yet','more','values']);
3705 This adds a value or list of values to the named parameter. The
3706 values are appended to the end of the parameter if it already exists.
3707 Otherwise the parameter is created. Note that this method only
3708 recognizes the named argument calling syntax.
3710 =head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
3712 $query->import_names('R');
3714 This creates a series of variables in the 'R' namespace. For example,
3715 $R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
3716 If no namespace is given, this method will assume 'Q'.
3717 WARNING: don't import anything into 'main'; this is a major security
3720 In older versions, this method was called B<import()>. As of version 2.20,
3721 this name has been removed completely to avoid conflict with the built-in
3722 Perl module B<import> operator.
3724 =head2 DELETING A PARAMETER COMPLETELY:
3726 $query->delete('foo');
3728 This completely clears a parameter. It sometimes useful for
3729 resetting parameters that you don't want passed down between
3732 If you are using the function call interface, use "Delete()" instead
3733 to avoid conflicts with Perl's built-in delete operator.
3735 =head2 DELETING ALL PARAMETERS:
3737 $query->delete_all();
3739 This clears the CGI object completely. It might be useful to ensure
3740 that all the defaults are taken when you create a fill-out form.
3742 Use Delete_all() instead if you are using the function call interface.
3744 =head2 DIRECT ACCESS TO THE PARAMETER LIST:
3746 $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
3747 unshift @{$q->param_fetch(-name=>'address')},'George Munster';
3749 If you need access to the parameter list in a way that isn't covered
3750 by the methods above, you can obtain a direct reference to it by
3751 calling the B<param_fetch()> method with the name of the . This
3752 will return an array reference to the named parameters, which you then
3753 can manipulate in any way you like.
3755 You can also use a named argument style using the B<-name> argument.
3757 =head2 FETCHING THE PARAMETER LIST AS A HASH:
3760 print $params->{'address'};
3761 @foo = split("\0",$params->{'foo'});
3767 Many people want to fetch the entire parameter list as a hash in which
3768 the keys are the names of the CGI parameters, and the values are the
3769 parameters' values. The Vars() method does this. Called in a scalar
3770 context, it returns the parameter list as a tied hash reference.
3771 Changing a key changes the value of the parameter in the underlying
3772 CGI parameter list. Called in an array context, it returns the
3773 parameter list as an ordinary hash. This allows you to read the
3774 contents of the parameter list, but not to change it.
3776 When using this, the thing you must watch out for are multivalued CGI
3777 parameters. Because a hash cannot distinguish between scalar and
3778 array context, multivalued parameters will be returned as a packed
3779 string, separated by the "\0" (null) character. You must split this
3780 packed string in order to get at the individual values. This is the
3781 convention introduced long ago by Steve Brenner in his cgi-lib.pl
3782 module for Perl version 4.
3784 If you wish to use Vars() as a function, import the I<:cgi-lib> set of
3785 function calls (also see the section on CGI-LIB compatibility).
3787 =head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
3789 $query->save(FILEHANDLE)
3791 This will write the current state of the form to the provided
3792 filehandle. You can read it back in by providing a filehandle
3793 to the new() method. Note that the filehandle can be a file, a pipe,
3796 The format of the saved file is:
3804 Both name and value are URL escaped. Multi-valued CGI parameters are
3805 represented as repeated names. A session record is delimited by a
3806 single = symbol. You can write out multiple records and read them
3807 back in with several calls to B<new>. You can do this across several
3808 sessions by opening the file in append mode, allowing you to create
3809 primitive guest books, or to keep a history of users' queries. Here's
3810 a short example of creating multiple session records:
3814 open (OUT,">>test.out") || die;
3816 foreach (0..$records) {
3818 $q->param(-name=>'counter',-value=>$_);
3823 # reopen for reading
3824 open (IN,"test.out") || die;
3826 my $q = new CGI(IN);
3827 print $q->param('counter'),"\n";
3830 The file format used for save/restore is identical to that used by the
3831 Whitehead Genome Center's data exchange format "Boulderio", and can be
3832 manipulated and even databased using Boulderio utilities. See
3834 http://stein.cshl.org/boulder/
3836 for further details.
3838 If you wish to use this method from the function-oriented (non-OO)
3839 interface, the exported name for this method is B<save_parameters()>.
3841 =head2 RETRIEVING CGI ERRORS
3843 Errors can occur while processing user input, particularly when
3844 processing uploaded files. When these errors occur, CGI will stop
3845 processing and return an empty parameter list. You can test for
3846 the existence and nature of errors using the I<cgi_error()> function.
3847 The error messages are formatted as HTTP status codes. You can either
3848 incorporate the error text into an HTML page, or use it as the value
3851 my $error = $q->cgi_error;
3853 print $q->header(-status=>$error),
3854 $q->start_html('Problems'),
3855 $q->h2('Request not processed'),
3860 When using the function-oriented interface (see the next section),
3861 errors may only occur the first time you call I<param()>. Be ready
3864 =head2 USING THE FUNCTION-ORIENTED INTERFACE
3866 To use the function-oriented interface, you must specify which CGI.pm
3867 routines or sets of routines to import into your script's namespace.
3868 There is a small overhead associated with this importation, but it
3871 use CGI <list of methods>;
3873 The listed methods will be imported into the current package; you can
3874 call them directly without creating a CGI object first. This example
3875 shows how to import the B<param()> and B<header()>
3876 methods, and then use them directly:
3878 use CGI 'param','header';
3879 print header('text/plain');
3880 $zipcode = param('zipcode');
3882 More frequently, you'll import common sets of functions by referring
3883 to the groups by name. All function sets are preceded with a ":"
3884 character as in ":html3" (for tags defined in the HTML 3 standard).
3886 Here is a list of the function sets you can import:
3892 Import all CGI-handling methods, such as B<param()>, B<path_info()>
3897 Import all fill-out form generating methods, such as B<textfield()>.
3901 Import all methods that generate HTML 2.0 standard elements.
3905 Import all methods that generate HTML 3.0 proposed elements (such as
3906 <table>, <super> and <sub>).
3910 Import all methods that generate Netscape-specific HTML extensions.
3914 Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
3919 Import "standard" features, 'html2', 'html3', 'form' and 'cgi'.
3923 Import all the available methods. For the full list, see the CGI.pm
3924 code, where the variable %EXPORT_TAGS is defined.
3928 If you import a function name that is not part of CGI.pm, the module
3929 will treat it as a new HTML tag and generate the appropriate
3930 subroutine. You can then use it like any other HTML tag. This is to
3931 provide for the rapidly-evolving HTML "standard." For example, say
3932 Microsoft comes out with a new tag called <GRADIENT> (which causes the
3933 user's desktop to be flooded with a rotating gradient fill until his
3934 machine reboots). You don't need to wait for a new version of CGI.pm
3935 to start using it immediately:
3937 use CGI qw/:standard :html3 gradient/;
3938 print gradient({-start=>'red',-end=>'blue'});
3940 Note that in the interests of execution speed CGI.pm does B<not> use
3941 the standard L<Exporter> syntax for specifying load symbols. This may
3942 change in the future.
3944 If you import any of the state-maintaining CGI or form-generating
3945 methods, a default CGI object will be created and initialized
3946 automatically the first time you use any of the methods that require
3947 one to be present. This includes B<param()>, B<textfield()>,
3948 B<submit()> and the like. (If you need direct access to the CGI
3949 object, you can find it in the global variable B<$CGI::Q>). By
3950 importing CGI.pm methods, you can create visually elegant scripts:
3952 use CGI qw/:standard/;
3955 start_html('Simple Script'),
3956 h1('Simple Script'),
3958 "What's your name? ",textfield('name'),p,
3959 "What's the combination?",
3960 checkbox_group(-name=>'words',
3961 -values=>['eenie','meenie','minie','moe'],
3962 -defaults=>['eenie','moe']),p,
3963 "What's your favorite color?",
3964 popup_menu(-name=>'color',
3965 -values=>['red','green','blue','chartreuse']),p,
3972 "Your name is ",em(param('name')),p,
3973 "The keywords are: ",em(join(", ",param('words'))),p,
3974 "Your favorite color is ",em(param('color')),".\n";
3980 In addition to the function sets, there are a number of pragmas that
3981 you can import. Pragmas, which are always preceded by a hyphen,
3982 change the way that CGI.pm functions in various ways. Pragmas,
3983 function sets, and individual functions can all be imported in the
3984 same use() line. For example, the following use statement imports the
3985 standard set of functions and disables debugging mode (pragma
3988 use CGI qw/:standard -no_debug/;
3990 The current list of pragmas is as follows:
3996 When you I<use CGI -any>, then any method that the query object
3997 doesn't recognize will be interpreted as a new HTML tag. This allows
3998 you to support the next I<ad hoc> Netscape or Microsoft HTML
3999 extension. This lets you go wild with new and unsupported tags:
4003 print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
4005 Since using <cite>any</cite> causes any mistyped method name
4006 to be interpreted as an HTML tag, use it with care or not at
4011 This causes the indicated autoloaded methods to be compiled up front,
4012 rather than deferred to later. This is useful for scripts that run
4013 for an extended period of time under FastCGI or mod_perl, and for
4014 those destined to be crunched by Malcom Beattie's Perl compiler. Use
4015 it in conjunction with the methods or method families you plan to use.
4017 use CGI qw(-compile :standard :html3);
4021 use CGI qw(-compile :all);
4023 Note that using the -compile pragma in this way will always have
4024 the effect of importing the compiled functions into the current
4025 namespace. If you want to compile without importing use the
4026 compile() method instead (see below).
4030 This makes CGI.pm produce a header appropriate for an NPH (no
4031 parsed header) script. You may need to do other things as well
4032 to tell the server that the script is NPH. See the discussion
4033 of NPH scripts below.
4035 =item -newstyle_urls
4037 Separate the name=value pairs in CGI parameter query strings with
4038 semicolons rather than ampersands. For example:
4040 ?name=fred;age=24;favorite_color=3
4042 Semicolon-delimited query strings are always accepted, but will not be
4043 emitted by self_url() and query_string() unless the -newstyle_urls
4044 pragma is specified.
4048 This overrides the autoloader so that any function in your program
4049 that is not recognized is referred to CGI.pm for possible evaluation.
4050 This allows you to use all the CGI.pm functions without adding them to
4051 your symbol table, which is of concern for mod_perl users who are
4052 worried about memory consumption. I<Warning:> when
4053 I<-autoload> is in effect, you cannot use "poetry mode"
4054 (functions without the parenthesis). Use I<hr()> rather
4055 than I<hr>, or add something like I<use subs qw/hr p header/>
4056 to the top of your script.
4060 This turns off the command-line processing features. If you want to
4061 run a CGI.pm script from the command line to produce HTML, and you
4062 don't want it pausing to request CGI parameters from standard input or
4063 the command line, then use this pragma:
4065 use CGI qw(-no_debug :standard);
4067 If you'd like to process the command-line parameters but not standard
4068 input, this should work:
4070 use CGI qw(-no_debug :standard);
4071 restore_parameters(join('&',@ARGV));
4073 See the section on debugging for more details.
4075 =item -private_tempfiles
4077 CGI.pm can process uploaded file. Ordinarily it spools the uploaded
4078 file to a temporary directory, then deletes the file when done.
4079 However, this opens the risk of eavesdropping as described in the file
4080 upload section. Another CGI script author could peek at this data
4081 during the upload, even if it is confidential information. On Unix
4082 systems, the -private_tempfiles pragma will cause the temporary file
4083 to be unlinked as soon as it is opened and before any data is written
4084 into it, reducing, but not eliminating the risk of eavesdropping
4085 (there is still a potential race condition). To make life harder for
4086 the attacker, the program chooses tempfile names by calculating a 32
4087 bit checksum of the incoming HTTP headers.
4089 To ensure that the temporary file cannot be read by other CGI scripts,
4090 use suEXEC or a CGI wrapper program to run your script. The temporary
4091 file is created with mode 0600 (neither world nor group readable).
4093 The temporary directory is selected using the following algorithm:
4095 1. if the current user (e.g. "nobody") has a directory named
4096 "tmp" in its home directory, use that (Unix systems only).
4098 2. if the environment variable TMPDIR exists, use the location
4101 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp,
4102 /tmp, /temp, ::Temporary Items, and \WWW_ROOT.
4104 Each of these locations is checked that it is a directory and is
4105 writable. If not, the algorithm tries the next choice.
4109 =head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS
4111 Many of the methods generate HTML tags. As described below, tag
4112 functions automatically generate both the opening and closing tags.
4115 print h1('Level 1 Header');
4119 <H1>Level 1 Header</H1>
4121 There will be some times when you want to produce the start and end
4122 tags yourself. In this case, you can use the form start_I<tag_name>
4123 and end_I<tag_name>, as in:
4125 print start_h1,'Level 1 Header',end_h1;
4127 With a few exceptions (described below), start_I<tag_name> and
4128 end_I<tag_name> functions are not generated automatically when you
4129 I<use CGI>. However, you can specify the tags you want to generate
4130 I<start/end> functions for by putting an asterisk in front of their
4131 name, or, alternatively, requesting either "start_I<tag_name>" or
4132 "end_I<tag_name>" in the import list.
4136 use CGI qw/:standard *table start_ul/;
4138 In this example, the following functions are generated in addition to
4143 =item 1. start_table() (generates a <TABLE> tag)
4145 =item 2. end_table() (generates a </TABLE> tag)
4147 =item 3. start_ul() (generates a <UL> tag)
4149 =item 4. end_ul() (generates a </UL> tag)
4153 =head1 GENERATING DYNAMIC DOCUMENTS
4155 Most of CGI.pm's functions deal with creating documents on the fly.
4156 Generally you will produce the HTTP header first, followed by the
4157 document itself. CGI.pm provides functions for generating HTTP
4158 headers of various types as well as for generating HTML. For creating
4159 GIF images, see the GD.pm module.
4161 Each of these functions produces a fragment of HTML or HTTP which you
4162 can print out directly so that it displays in the browser window,
4163 append to a string, or save to a file for later use.
4165 =head2 CREATING A STANDARD HTTP HEADER:
4167 Normally the first thing you will do in any CGI script is print out an
4168 HTTP header. This tells the browser what type of document to expect,
4169 and gives other optional information, such as the language, expiration
4170 date, and whether to cache the document. The header can also be
4171 manipulated for special purposes, such as server push and pay per view
4174 print $query->header;
4178 print $query->header('image/gif');
4182 print $query->header('text/html','204 No response');
4186 print $query->header(-type=>'image/gif',
4188 -status=>'402 Payment required',
4193 header() returns the Content-type: header. You can provide your own
4194 MIME type if you choose, otherwise it defaults to text/html. An
4195 optional second parameter specifies the status code and a human-readable
4196 message. For example, you can specify 204, "No response" to create a
4197 script that tells the browser to do nothing at all.
4199 The last example shows the named argument style for passing arguments
4200 to the CGI methods using named parameters. Recognized parameters are
4201 B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named
4202 parameters will be stripped of their initial hyphens and turned into
4203 header fields, allowing you to specify any HTTP header you desire.
4204 Internal underscores will be turned into hyphens:
4206 print $query->header(-Content_length=>3002);
4208 Most browsers will not cache the output from CGI scripts. Every time
4209 the browser reloads the page, the script is invoked anew. You can
4210 change this behavior with the B<-expires> parameter. When you specify
4211 an absolute or relative expiration interval with this parameter, some
4212 browsers and proxy servers will cache the script's output until the
4213 indicated expiration date. The following forms are all valid for the
4216 +30s 30 seconds from now
4217 +10m ten minutes from now
4218 +1h one hour from now
4219 -1d yesterday (i.e. "ASAP!")
4222 +10y in ten years time
4223 Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date
4225 The B<-cookie> parameter generates a header that tells the browser to provide
4226 a "magic cookie" during all subsequent transactions with your script.
4227 Netscape cookies have a special format that includes interesting attributes
4228 such as expiration time. Use the cookie() method to create and retrieve
4231 The B<-nph> parameter, if set to a true value, will issue the correct
4232 headers to work with a NPH (no-parse-header) script. This is important
4233 to use with certain servers, such as Microsoft Internet Explorer, which
4234 expect all their scripts to be NPH.
4236 =head2 GENERATING A REDIRECTION HEADER
4238 print $query->redirect('http://somewhere.else/in/movie/land');
4240 Sometimes you don't want to produce a document yourself, but simply
4241 redirect the browser elsewhere, perhaps choosing a URL based on the
4242 time of day or the identity of the user.
4244 The redirect() function redirects the browser to a different URL. If
4245 you use redirection like this, you should B<not> print out a header as
4246 well. As of version 2.0, we produce both the unofficial Location:
4247 header and the official URI: header. This should satisfy most servers
4250 One hint I can offer is that relative links may not work correctly
4251 when you generate a redirection to another document on your site.
4252 This is due to a well-intentioned optimization that some servers use.
4253 The solution to this is to use the full URL (including the http: part)
4254 of the document you are redirecting to.
4256 You can also use named arguments:
4258 print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
4261 The B<-nph> parameter, if set to a true value, will issue the correct
4262 headers to work with a NPH (no-parse-header) script. This is important
4263 to use with certain servers, such as Microsoft Internet Explorer, which
4264 expect all their scripts to be NPH.
4266 =head2 CREATING THE HTML DOCUMENT HEADER
4268 print $query->start_html(-title=>'Secrets of the Pyramids',
4269 -author=>'fred@capricorn.org',
4272 -meta=>{'keywords'=>'pharaoh secret mummy',
4273 'copyright'=>'copyright 1996 King Tut'},
4274 -style=>{'src'=>'/styles/style1.css'},
4277 After creating the HTTP header, most CGI scripts will start writing
4278 out an HTML document. The start_html() routine creates the top of the
4279 page, along with a lot of optional information that controls the
4280 page's appearance and behavior.
4282 This method returns a canned HTML header and the opening <BODY> tag.
4283 All parameters are optional. In the named parameter form, recognized
4284 parameters are -title, -author, -base, -xbase and -target (see below
4285 for the explanation). Any additional parameters you provide, such as
4286 the Netscape unofficial BGCOLOR attribute, are added to the <BODY>
4287 tag. Additional parameters must be proceeded by a hyphen.
4289 The argument B<-xbase> allows you to provide an HREF for the <BASE> tag
4290 different from the current location, as in
4292 -xbase=>"http://home.mcom.com/"
4294 All relative links will be interpreted relative to this tag.
4296 The argument B<-target> allows you to provide a default target frame
4297 for all the links and fill-out forms on the page. See the Netscape
4298 documentation on frames for details of how to manipulate this.
4300 -target=>"answer_window"
4302 All relative links will be interpreted relative to this tag.
4303 You add arbitrary meta information to the header with the B<-meta>
4304 argument. This argument expects a reference to an associative array
4305 containing name/value pairs of meta information. These will be turned
4306 into a series of header <META> tags that look something like this:
4308 <META NAME="keywords" CONTENT="pharaoh secret mummy">
4309 <META NAME="description" CONTENT="copyright 1996 King Tut">
4311 There is no support for the HTTP-EQUIV type of <META> tag. This is
4312 because you can modify the HTTP header directly with the B<header()>
4313 method. For example, if you want to send the Refresh: header, do it
4314 in the header() method:
4316 print $q->header(-Refresh=>'10; URL=http://www.capricorn.com');
4318 The B<-style> tag is used to incorporate cascading stylesheets into
4319 your code. See the section on CASCADING STYLESHEETS for more information.
4321 You can place other arbitrary HTML elements to the <HEAD> section with the
4322 B<-head> tag. For example, to place the rarely-used <LINK> element in the
4323 head section, use this:
4325 print start_html(-head=>Link({-rel=>'next',
4326 -href=>'http://www.capricorn.com/s2.html'}));
4328 To incorporate multiple HTML elements into the <HEAD> section, just pass an
4331 print start_html(-head=>[
4333 -href=>'http://www.capricorn.com/s2.html'}),
4334 Link({-rel=>'previous',
4335 -href=>'http://www.capricorn.com/s1.html'})
4339 JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
4340 B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
4341 to add Netscape JavaScript calls to your pages. B<-script> should
4342 point to a block of text containing JavaScript function definitions.
4343 This block will be placed within a <SCRIPT> block inside the HTML (not
4344 HTTP) header. The block is placed in the header in order to give your
4345 page a fighting chance of having all its JavaScript functions in place
4346 even if the user presses the stop button before the page has loaded
4347 completely. CGI.pm attempts to format the script in such a way that
4348 JavaScript-naive browsers will not choke on the code: unfortunately
4349 there are some browsers, such as Chimera for Unix, that get confused
4352 The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
4353 code to execute when the page is respectively opened and closed by the
4354 browser. Usually these parameters are calls to functions defined in the
4358 print $query->header;
4360 // Ask a silly question
4361 function riddle_me_this() {
4362 var r = prompt("What walks on four legs in the morning, " +
4363 "two legs in the afternoon, " +
4364 "and three legs in the evening?");
4367 // Get a silly answer
4368 function response(answer) {
4369 if (answer == "man")
4370 alert("Right you are!");
4372 alert("Wrong! Guess again.");
4375 print $query->start_html(-title=>'The Riddle of the Sphinx',
4378 Use the B<-noScript> parameter to pass some HTML text that will be displayed on
4379 browsers that do not have JavaScript (or browsers where JavaScript is turned
4382 Netscape 3.0 recognizes several attributes of the <SCRIPT> tag,
4383 including LANGUAGE and SRC. The latter is particularly interesting,
4384 as it allows you to keep the JavaScript code in a file or CGI script
4385 rather than cluttering up each page with the source. To use these
4386 attributes pass a HASH reference in the B<-script> parameter containing
4387 one or more of -language, -src, or -code:
4389 print $q->start_html(-title=>'The Riddle of the Sphinx',
4390 -script=>{-language=>'JAVASCRIPT',
4391 -src=>'/javascript/sphinx.js'}
4394 print $q->(-title=>'The Riddle of the Sphinx',
4395 -script=>{-language=>'PERLSCRIPT',
4396 -code=>'print "hello world!\n;"'}
4400 A final feature allows you to incorporate multiple <SCRIPT> sections into the
4401 header. Just pass the list of script sections as an array reference.
4402 this allows you to specify different source files for different dialects
4403 of JavaScript. Example:
4405 print $q->start_html(-title=>'The Riddle of the Sphinx',
4407 { -language => 'JavaScript1.0',
4408 -src => '/javascript/utilities10.js'
4410 { -language => 'JavaScript1.1',
4411 -src => '/javascript/utilities11.js'
4413 { -language => 'JavaScript1.2',
4414 -src => '/javascript/utilities12.js'
4416 { -language => 'JavaScript28.2',
4417 -src => '/javascript/utilities219.js'
4423 If this looks a bit extreme, take my advice and stick with straight CGI scripting.
4427 http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
4429 for more information about JavaScript.
4431 The old-style positional parameters are as follows:
4435 =item B<Parameters:>
4443 The author's e-mail address (will create a <LINK REV="MADE"> tag if present
4447 A 'true' flag if you want to include a <BASE> tag in the header. This
4448 helps resolve relative addresses to absolute ones when the document is moved,
4449 but makes the document hierarchy non-portable. Use with care!
4453 Any other parameters you want to include in the <BODY> tag. This is a good
4454 place to put Netscape extensions, such as colors and wallpaper patterns.
4458 =head2 ENDING THE HTML DOCUMENT:
4460 print $query->end_html
4462 This ends an HTML document by printing the </BODY></HTML> tags.
4464 =head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
4466 $myself = $query->self_url;
4467 print "<A HREF=$myself>I'm talking to myself.</A>";
4469 self_url() will return a URL, that, when selected, will reinvoke
4470 this script with all its state information intact. This is most
4471 useful when you want to jump around within the document using
4472 internal anchors but you don't want to disrupt the current contents
4473 of the form(s). Something like this will do the trick.
4475 $myself = $query->self_url;
4476 print "<A HREF=$myself#table1>See table 1</A>";
4477 print "<A HREF=$myself#table2>See table 2</A>";
4478 print "<A HREF=$myself#yourself>See for yourself</A>";
4480 If you want more control over what's returned, using the B<url()>
4483 You can also retrieve the unprocessed query string with query_string():
4485 $the_string = $query->query_string;
4487 =head2 OBTAINING THE SCRIPT'S URL
4489 $full_url = $query->url();
4490 $full_url = $query->url(-full=>1); #alternative syntax
4491 $relative_url = $query->url(-relative=>1);
4492 $absolute_url = $query->url(-absolute=>1);
4493 $url_with_path = $query->url(-path_info=>1);
4494 $url_with_path_and_query = $query->url(-path_info=>1,-query=>1);
4496 B<url()> returns the script's URL in a variety of formats. Called
4497 without any arguments, it returns the full form of the URL, including
4498 host name and port number
4500 http://your.host.com/path/to/script.cgi
4502 You can modify this format with the following named arguments:
4508 If true, produce an absolute URL, e.g.
4514 Produce a relative URL. This is useful if you want to reinvoke your
4515 script with different parameters. For example:
4521 Produce the full URL, exactly as if called without any arguments.
4522 This overrides the -relative and -absolute arguments.
4524 =item B<-path> (B<-path_info>)
4526 Append the additional path information to the URL. This can be
4527 combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info>
4528 is provided as a synonym.
4530 =item B<-query> (B<-query_string>)
4532 Append the query string to the URL. This can be combined with
4533 B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
4538 =head2 MIXING POST AND URL PARAMETERS
4540 $color = $query->url_param('color');
4542 It is possible for a script to receive CGI parameters in the URL as
4543 well as in the fill-out form by creating a form that POSTs to a URL
4544 containing a query string (a "?" mark followed by arguments). The
4545 B<param()> method will always return the contents of the POSTed
4546 fill-out form, ignoring the URL's query string. To retrieve URL
4547 parameters, call the B<url_param()> method. Use it in the same way as
4548 B<param()>. The main difference is that it allows you to read the
4549 parameters, but not set them.
4552 Under no circumstances will the contents of the URL query string
4553 interfere with similarly-named CGI parameters in POSTed forms. If you
4554 try to mix a URL query string with a form submitted with the GET
4555 method, the results will not be what you expect.
4557 =head1 CREATING STANDARD HTML ELEMENTS:
4559 CGI.pm defines general HTML shortcut methods for most, if not all of
4560 the HTML 3 and HTML 4 tags. HTML shortcuts are named after a single
4561 HTML element and return a fragment of HTML text that you can then
4562 print or manipulate as you like. Each shortcut returns a fragment of
4563 HTML code that you can append to a string, save to a file, or, most
4564 commonly, print out so that it displays in the browser window.
4566 This example shows how to use the HTML methods:
4569 print $q->blockquote(
4570 "Many years ago on the island of",
4571 $q->a({href=>"http://crete.org/"},"Crete"),
4572 "there lived a Minotaur named",
4573 $q->strong("Fred."),
4577 This results in the following HTML code (extra newlines have been
4578 added for readability):
4581 Many years ago on the island of
4582 <a HREF="http://crete.org/">Crete</a> there lived
4583 a minotaur named <strong>Fred.</strong>
4587 If you find the syntax for calling the HTML shortcuts awkward, you can
4588 import them into your namespace and dispense with the object syntax
4589 completely (see the next section for more details):
4591 use CGI ':standard';
4593 "Many years ago on the island of",
4594 a({href=>"http://crete.org/"},"Crete"),
4595 "there lived a minotaur named",
4600 =head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
4602 The HTML methods will accept zero, one or multiple arguments. If you
4603 provide no arguments, you get a single tag:
4607 If you provide one or more string arguments, they are concatenated
4608 together with spaces and placed between opening and closing tags:
4610 print h1("Chapter","1"); # <H1>Chapter 1</H1>"
4612 If the first argument is an associative array reference, then the keys
4613 and values of the associative array become the HTML tag's attributes:
4615 print a({-href=>'fred.html',-target=>'_new'},
4616 "Open a new frame");
4618 <A HREF="fred.html",TARGET="_new">Open a new frame</A>
4620 You may dispense with the dashes in front of the attribute names if
4623 print img {src=>'fred.gif',align=>'LEFT'};
4625 <IMG ALIGN="LEFT" SRC="fred.gif">
4627 Sometimes an HTML tag attribute has no argument. For example, ordered
4628 lists can be marked as COMPACT. The syntax for this is an argument that
4629 that points to an undef string:
4631 print ol({compact=>undef},li('one'),li('two'),li('three'));
4633 Prior to CGI.pm version 2.41, providing an empty ('') string as an
4634 attribute argument was the same as providing undef. However, this has
4635 changed in order to accommodate those who want to create tags of the form
4636 <IMG ALT="">. The difference is shown in these two pieces of code:
4639 img({alt=>undef}) <IMG ALT>
4640 img({alt=>''}) <IMT ALT="">
4642 =head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
4644 One of the cool features of the HTML shortcuts is that they are
4645 distributive. If you give them an argument consisting of a
4646 B<reference> to a list, the tag will be distributed across each
4647 element of the list. For example, here's one way to make an ordered
4651 li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']);
4654 This example will result in HTML output that looks like this:
4657 <LI TYPE="disc">Sneezy</LI>
4658 <LI TYPE="disc">Doc</LI>
4659 <LI TYPE="disc">Sleepy</LI>
4660 <LI TYPE="disc">Happy</LI>
4663 This is extremely useful for creating tables. For example:
4665 print table({-border=>undef},
4666 caption('When Should You Eat Your Vegetables?'),
4667 Tr({-align=>CENTER,-valign=>TOP},
4669 th(['Vegetable', 'Breakfast','Lunch','Dinner']),
4670 td(['Tomatoes' , 'no', 'yes', 'yes']),
4671 td(['Broccoli' , 'no', 'no', 'yes']),
4672 td(['Onions' , 'yes','yes', 'yes'])
4677 =head2 HTML SHORTCUTS AND LIST INTERPOLATION
4679 Consider this bit of code:
4681 print blockquote(em('Hi'),'mom!'));
4683 It will ordinarily return the string that you probably expect, namely:
4685 <BLOCKQUOTE><EM>Hi</EM> mom!</BLOCKQUOTE>
4687 Note the space between the element "Hi" and the element "mom!".
4688 CGI.pm puts the extra space there using array interpolation, which is
4689 controlled by the magic $" variable. Sometimes this extra space is
4690 not what you want, for example, when you are trying to align a series
4691 of images. In this case, you can simply change the value of $" to an
4696 print blockquote(em('Hi'),'mom!'));
4699 I suggest you put the code in a block as shown here. Otherwise the
4700 change to $" will affect all subsequent code until you explicitly
4703 =head2 NON-STANDARD HTML SHORTCUTS
4705 A few HTML tags don't follow the standard pattern for various
4708 B<comment()> generates an HTML comment (<!-- comment -->). Call it
4711 print comment('here is my comment');
4713 Because of conflicts with built-in Perl functions, the following functions
4714 begin with initial caps:
4723 In addition, start_html(), end_html(), start_form(), end_form(),
4724 start_multipart_form() and all the fill-out form tags are special.
4725 See their respective sections.
4727 =head2 PRETTY-PRINTING HTML
4729 By default, all the HTML produced by these functions comes out as one
4730 long line without carriage returns or indentation. This is yuck, but
4731 it does reduce the size of the documents by 10-20%. To get
4732 pretty-printed output, please use L<CGI::Pretty>, a subclass
4733 contributed by Brian Paulsen.
4735 =head1 CREATING FILL-OUT FORMS:
4737 I<General note> The various form-creating methods all return strings
4738 to the caller, containing the tag or tags that will create the requested
4739 form element. You are responsible for actually printing out these strings.
4740 It's set up this way so that you can place formatting tags
4741 around the form elements.
4743 I<Another note> The default values that you specify for the forms are only
4744 used the B<first> time the script is invoked (when there is no query
4745 string). On subsequent invocations of the script (when there is a query
4746 string), the former values are used even if they are blank.
4748 If you want to change the value of a field from its previous value, you have two
4751 (1) call the param() method to set it.
4753 (2) use the -override (alias -force) parameter (a new feature in version 2.15).
4754 This forces the default value to be used, regardless of the previous value:
4756 print $query->textfield(-name=>'field_name',
4757 -default=>'starting value',
4762 I<Yet another note> By default, the text and labels of form elements are
4763 escaped according to HTML rules. This means that you can safely use
4764 "<CLICK ME>" as the label for a button. However, it also interferes with
4765 your ability to incorporate special HTML character sequences, such as Á,
4766 into your fields. If you wish to turn off automatic escaping, call the
4767 autoEscape() method with a false value immediately after creating the CGI object:
4770 $query->autoEscape(undef);
4773 =head2 CREATING AN ISINDEX TAG
4775 print $query->isindex(-action=>$action);
4779 print $query->isindex($action);
4781 Prints out an <ISINDEX> tag. Not very exciting. The parameter
4782 -action specifies the URL of the script to process the query. The
4783 default is to process the query with the current script.
4785 =head2 STARTING AND ENDING A FORM
4787 print $query->startform(-method=>$method,
4789 -enctype=>$encoding);
4790 <... various form stuff ...>
4791 print $query->endform;
4795 print $query->startform($method,$action,$encoding);
4796 <... various form stuff ...>
4797 print $query->endform;
4799 startform() will return a <FORM> tag with the optional method,
4800 action and form encoding that you specify. The defaults are:
4804 enctype: application/x-www-form-urlencoded
4806 endform() returns the closing </FORM> tag.
4808 Startform()'s enctype argument tells the browser how to package the various
4809 fields of the form before sending the form to the server. Two
4810 values are possible:
4814 =item B<application/x-www-form-urlencoded>
4816 This is the older type of encoding used by all browsers prior to
4817 Netscape 2.0. It is compatible with many CGI scripts and is
4818 suitable for short fields containing text data. For your
4819 convenience, CGI.pm stores the name of this encoding
4820 type in B<$CGI::URL_ENCODED>.
4822 =item B<multipart/form-data>
4824 This is the newer type of encoding introduced by Netscape 2.0.
4825 It is suitable for forms that contain very large fields or that
4826 are intended for transferring binary data. Most importantly,
4827 it enables the "file upload" feature of Netscape 2.0 forms. For
4828 your convenience, CGI.pm stores the name of this encoding type
4829 in B<&CGI::MULTIPART>
4831 Forms that use this type of encoding are not easily interpreted
4832 by CGI scripts unless they use CGI.pm or another library designed
4837 For compatibility, the startform() method uses the older form of
4838 encoding by default. If you want to use the newer form of encoding
4839 by default, you can call B<start_multipart_form()> instead of
4842 JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
4843 for use with JavaScript. The -name parameter gives the
4844 form a name so that it can be identified and manipulated by
4845 JavaScript functions. -onSubmit should point to a JavaScript
4846 function that will be executed just before the form is submitted to your
4847 server. You can use this opportunity to check the contents of the form
4848 for consistency and completeness. If you find something wrong, you
4849 can put up an alert box or maybe fix things up yourself. You can
4850 abort the submission by returning false from this function.
4852 Usually the bulk of JavaScript functions are defined in a <SCRIPT>
4853 block in the HTML header and -onSubmit points to one of these function
4854 call. See start_html() for details.
4856 =head2 CREATING A TEXT FIELD
4858 print $query->textfield(-name=>'field_name',
4859 -default=>'starting value',
4864 print $query->textfield('field_name','starting value',50,80);
4866 textfield() will return a text input field.
4874 The first parameter is the required name for the field (-name).
4878 The optional second parameter is the default starting value for the field
4879 contents (-default).
4883 The optional third parameter is the size of the field in
4888 The optional fourth parameter is the maximum number of characters the
4889 field will accept (-maxlength).
4893 As with all these methods, the field will be initialized with its
4894 previous contents from earlier invocations of the script.
4895 When the form is processed, the value of the text field can be
4898 $value = $query->param('foo');
4900 If you want to reset it from its initial value after the script has been
4901 called once, you can do so like this:
4903 $query->param('foo',"I'm taking over this value!");
4905 NEW AS OF VERSION 2.15: If you don't want the field to take on its previous
4906 value, you can force its current value by using the -override (alias -force)
4909 print $query->textfield(-name=>'field_name',
4910 -default=>'starting value',
4915 JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>,
4916 B<-onBlur>, B<-onMouseOver>, B<-onMouseOut> and B<-onSelect>
4917 parameters to register JavaScript event handlers. The onChange
4918 handler will be called whenever the user changes the contents of the
4919 text field. You can do text validation if you like. onFocus and
4920 onBlur are called respectively when the insertion point moves into and
4921 out of the text field. onSelect is called when the user changes the
4922 portion of the text that is selected.
4924 =head2 CREATING A BIG TEXT FIELD
4926 print $query->textarea(-name=>'foo',
4927 -default=>'starting value',
4933 print $query->textarea('foo','starting value',10,50);
4935 textarea() is just like textfield, but it allows you to specify
4936 rows and columns for a multiline text entry box. You can provide
4937 a starting value for the field, which can be long and contain
4940 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> ,
4941 B<-onMouseOver>, B<-onMouseOut>, and B<-onSelect> parameters are
4942 recognized. See textfield().
4944 =head2 CREATING A PASSWORD FIELD
4946 print $query->password_field(-name=>'secret',
4947 -value=>'starting value',
4952 print $query->password_field('secret','starting value',50,80);
4954 password_field() is identical to textfield(), except that its contents
4955 will be starred out on the web page.
4957 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
4958 B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
4959 recognized. See textfield().
4961 =head2 CREATING A FILE UPLOAD FIELD
4963 print $query->filefield(-name=>'uploaded_file',
4964 -default=>'starting value',
4969 print $query->filefield('uploaded_file','starting value',50,80);
4971 filefield() will return a file upload field for Netscape 2.0 browsers.
4972 In order to take full advantage of this I<you must use the new
4973 multipart encoding scheme> for the form. You can do this either
4974 by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>,
4975 or by calling the new method B<start_multipart_form()> instead of
4976 vanilla B<startform()>.
4984 The first parameter is the required name for the field (-name).
4988 The optional second parameter is the starting value for the field contents
4989 to be used as the default file name (-default).
4991 For security reasons, browsers don't pay any attention to this field,
4992 and so the starting value will always be blank. Worse, the field
4993 loses its "sticky" behavior and forgets its previous contents. The
4994 starting value field is called for in the HTML specification, however,
4995 and possibly some browser will eventually provide support for it.
4999 The optional third parameter is the size of the field in
5004 The optional fourth parameter is the maximum number of characters the
5005 field will accept (-maxlength).
5009 When the form is processed, you can retrieve the entered filename
5012 $filename = $query->param('uploaded_file');
5014 Different browsers will return slightly different things for the
5015 name. Some browsers return the filename only. Others return the full
5016 path to the file, using the path conventions of the user's machine.
5017 Regardless, the name returned is always the name of the file on the
5018 I<user's> machine, and is unrelated to the name of the temporary file
5019 that CGI.pm creates during upload spooling (see below).
5021 The filename returned is also a file handle. You can read the contents
5022 of the file using standard Perl file reading calls:
5024 # Read a text file and print it out
5025 while (<$filename>) {
5029 # Copy a binary file to somewhere safe
5030 open (OUTFILE,">>/usr/local/web/users/feedback");
5031 while ($bytesread=read($filename,$buffer,1024)) {
5032 print OUTFILE $buffer;
5035 However, there are problems with the dual nature of the upload fields.
5036 If you C<use strict>, then Perl will complain when you try to use a
5037 string as a filehandle. You can get around this by placing the file
5038 reading code in a block containing the C<no strict> pragma. More
5039 seriously, it is possible for the remote user to type garbage into the
5040 upload field, in which case what you get from param() is not a
5041 filehandle at all, but a string.
5043 To be safe, use the I<upload()> function (new in version 2.47). When
5044 called with the name of an upload field, I<upload()> returns a
5045 filehandle, or undef if the parameter is not a valid filehandle.
5047 $fh = $query->upload('uploaded_file');
5052 This is the recommended idiom.
5054 When a file is uploaded the browser usually sends along some
5055 information along with it in the format of headers. The information
5056 usually includes the MIME content type. Future browsers may send
5057 other information as well (such as modification date and size). To
5058 retrieve this information, call uploadInfo(). It returns a reference to
5059 an associative array containing all the document headers.
5061 $filename = $query->param('uploaded_file');
5062 $type = $query->uploadInfo($filename)->{'Content-Type'};
5063 unless ($type eq 'text/html') {
5064 die "HTML FILES ONLY!";
5067 If you are using a machine that recognizes "text" and "binary" data
5068 modes, be sure to understand when and how to use them (see the Camel book).
5069 Otherwise you may find that binary files are corrupted during file
5072 There are occasionally problems involving parsing the uploaded file.
5073 This usually happens when the user presses "Stop" before the upload is
5074 finished. In this case, CGI.pm will return undef for the name of the
5075 uploaded file and set I<cgi_error()> to the string "400 Bad request
5076 (malformed multipart POST)". This error message is designed so that
5077 you can incorporate it into a status code to be sent to the browser.
5080 $file = $query->upload('uploaded_file');
5081 if (!$file && $query->cgi_error) {
5082 print $query->header(-status=>$query->cgi_error);
5086 You are free to create a custom HTML page to complain about the error,
5089 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
5090 B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
5091 recognized. See textfield() for details.
5093 =head2 CREATING A POPUP MENU
5095 print $query->popup_menu('menu_name',
5096 ['eenie','meenie','minie'],
5101 %labels = ('eenie'=>'your first choice',
5102 'meenie'=>'your second choice',
5103 'minie'=>'your third choice');
5104 print $query->popup_menu('menu_name',
5105 ['eenie','meenie','minie'],
5108 -or (named parameter style)-
5110 print $query->popup_menu(-name=>'menu_name',
5111 -values=>['eenie','meenie','minie'],
5115 popup_menu() creates a menu.
5121 The required first argument is the menu's name (-name).
5125 The required second argument (-values) is an array B<reference>
5126 containing the list of menu items in the menu. You can pass the
5127 method an anonymous array, as shown in the example, or a reference to
5128 a named array, such as "\@foo".
5132 The optional third parameter (-default) is the name of the default
5133 menu choice. If not specified, the first item will be the default.
5134 The values of the previous choice will be maintained across queries.
5138 The optional fourth parameter (-labels) is provided for people who
5139 want to use different values for the user-visible label inside the
5140 popup menu nd the value returned to your script. It's a pointer to an
5141 associative array relating menu values to user-visible labels. If you
5142 leave this parameter blank, the menu values will be displayed by
5143 default. (You can also leave a label undefined if you want to).
5147 When the form is processed, the selected value of the popup menu can
5150 $popup_menu_value = $query->param('menu_name');
5152 JAVASCRIPTING: popup_menu() recognizes the following event handlers:
5153 B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>, and
5154 B<-onBlur>. See the textfield() section for details on when these
5155 handlers are called.
5157 =head2 CREATING A SCROLLING LIST
5159 print $query->scrolling_list('list_name',
5160 ['eenie','meenie','minie','moe'],
5161 ['eenie','moe'],5,'true');
5164 print $query->scrolling_list('list_name',
5165 ['eenie','meenie','minie','moe'],
5166 ['eenie','moe'],5,'true',
5171 print $query->scrolling_list(-name=>'list_name',
5172 -values=>['eenie','meenie','minie','moe'],
5173 -default=>['eenie','moe'],
5178 scrolling_list() creates a scrolling list.
5182 =item B<Parameters:>
5186 The first and second arguments are the list name (-name) and values
5187 (-values). As in the popup menu, the second argument should be an
5192 The optional third argument (-default) can be either a reference to a
5193 list containing the values to be selected by default, or can be a
5194 single value to select. If this argument is missing or undefined,
5195 then nothing is selected when the list first appears. In the named
5196 parameter version, you can use the synonym "-defaults" for this
5201 The optional fourth argument is the size of the list (-size).
5205 The optional fifth argument can be set to true to allow multiple
5206 simultaneous selections (-multiple). Otherwise only one selection
5207 will be allowed at a time.
5211 The optional sixth argument is a pointer to an associative array
5212 containing long user-visible labels for the list items (-labels).
5213 If not provided, the values will be displayed.
5215 When this form is processed, all selected list items will be returned as
5216 a list under the parameter name 'list_name'. The values of the
5217 selected items can be retrieved with:
5219 @selected = $query->param('list_name');
5223 JAVASCRIPTING: scrolling_list() recognizes the following event
5224 handlers: B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>
5225 and B<-onBlur>. See textfield() for the description of when these
5226 handlers are called.
5228 =head2 CREATING A GROUP OF RELATED CHECKBOXES
5230 print $query->checkbox_group(-name=>'group_name',
5231 -values=>['eenie','meenie','minie','moe'],
5232 -default=>['eenie','moe'],
5236 print $query->checkbox_group('group_name',
5237 ['eenie','meenie','minie','moe'],
5238 ['eenie','moe'],'true',\%labels);
5240 HTML3-COMPATIBLE BROWSERS ONLY:
5242 print $query->checkbox_group(-name=>'group_name',
5243 -values=>['eenie','meenie','minie','moe'],
5244 -rows=2,-columns=>2);
5247 checkbox_group() creates a list of checkboxes that are related
5252 =item B<Parameters:>
5256 The first and second arguments are the checkbox name and values,
5257 respectively (-name and -values). As in the popup menu, the second
5258 argument should be an array reference. These values are used for the
5259 user-readable labels printed next to the checkboxes as well as for the
5260 values passed to your script in the query string.
5264 The optional third argument (-default) can be either a reference to a
5265 list containing the values to be checked by default, or can be a
5266 single value to checked. If this argument is missing or undefined,
5267 then nothing is selected when the list first appears.
5271 The optional fourth argument (-linebreak) can be set to true to place
5272 line breaks between the checkboxes so that they appear as a vertical
5273 list. Otherwise, they will be strung together on a horizontal line.
5277 The optional fifth argument is a pointer to an associative array
5278 relating the checkbox values to the user-visible labels that will
5279 be printed next to them (-labels). If not provided, the values will
5280 be used as the default.
5284 B<HTML3-compatible browsers> (such as Netscape) can take advantage of
5285 the optional parameters B<-rows>, and B<-columns>. These parameters
5286 cause checkbox_group() to return an HTML3 compatible table containing
5287 the checkbox group formatted with the specified number of rows and
5288 columns. You can provide just the -columns parameter if you wish;
5289 checkbox_group will calculate the correct number of rows for you.
5291 To include row and column headings in the returned table, you
5292 can use the B<-rowheaders> and B<-colheaders> parameters. Both
5293 of these accept a pointer to an array of headings to use.
5294 The headings are just decorative. They don't reorganize the
5295 interpretation of the checkboxes -- they're still a single named
5300 When the form is processed, all checked boxes will be returned as
5301 a list under the parameter name 'group_name'. The values of the
5302 "on" checkboxes can be retrieved with:
5304 @turned_on = $query->param('group_name');
5306 The value returned by checkbox_group() is actually an array of button
5307 elements. You can capture them and use them within tables, lists,
5308 or in other creative ways:
5310 @h = $query->checkbox_group(-name=>'group_name',-values=>\@values);
5311 &use_in_creative_way(@h);
5313 JAVASCRIPTING: checkbox_group() recognizes the B<-onClick>
5314 parameter. This specifies a JavaScript code fragment or
5315 function call to be executed every time the user clicks on
5316 any of the buttons in the group. You can retrieve the identity
5317 of the particular button clicked on using the "this" variable.
5319 =head2 CREATING A STANDALONE CHECKBOX
5321 print $query->checkbox(-name=>'checkbox_name',
5322 -checked=>'checked',
5324 -label=>'CLICK ME');
5328 print $query->checkbox('checkbox_name','checked','ON','CLICK ME');
5330 checkbox() is used to create an isolated checkbox that isn't logically
5331 related to any others.
5335 =item B<Parameters:>
5339 The first parameter is the required name for the checkbox (-name). It
5340 will also be used for the user-readable label printed next to the
5345 The optional second parameter (-checked) specifies that the checkbox
5346 is turned on by default. Synonyms are -selected and -on.
5350 The optional third parameter (-value) specifies the value of the
5351 checkbox when it is checked. If not provided, the word "on" is
5356 The optional fourth parameter (-label) is the user-readable label to
5357 be attached to the checkbox. If not provided, the checkbox name is
5362 The value of the checkbox can be retrieved using:
5364 $turned_on = $query->param('checkbox_name');
5366 JAVASCRIPTING: checkbox() recognizes the B<-onClick>
5367 parameter. See checkbox_group() for further details.
5369 =head2 CREATING A RADIO BUTTON GROUP
5371 print $query->radio_group(-name=>'group_name',
5372 -values=>['eenie','meenie','minie'],
5379 print $query->radio_group('group_name',['eenie','meenie','minie'],
5380 'meenie','true',\%labels);
5383 HTML3-COMPATIBLE BROWSERS ONLY:
5385 print $query->radio_group(-name=>'group_name',
5386 -values=>['eenie','meenie','minie','moe'],
5387 -rows=2,-columns=>2);
5389 radio_group() creates a set of logically-related radio buttons
5390 (turning one member of the group on turns the others off)
5394 =item B<Parameters:>
5398 The first argument is the name of the group and is required (-name).
5402 The second argument (-values) is the list of values for the radio
5403 buttons. The values and the labels that appear on the page are
5404 identical. Pass an array I<reference> in the second argument, either
5405 using an anonymous array, as shown, or by referencing a named array as
5410 The optional third parameter (-default) is the name of the default
5411 button to turn on. If not specified, the first item will be the
5412 default. You can provide a nonexistent button name, such as "-" to
5413 start up with no buttons selected.
5417 The optional fourth parameter (-linebreak) can be set to 'true' to put
5418 line breaks between the buttons, creating a vertical list.
5422 The optional fifth parameter (-labels) is a pointer to an associative
5423 array relating the radio button values to user-visible labels to be
5424 used in the display. If not provided, the values themselves are
5429 B<HTML3-compatible browsers> (such as Netscape) can take advantage
5431 parameters B<-rows>, and B<-columns>. These parameters cause
5432 radio_group() to return an HTML3 compatible table containing
5433 the radio group formatted with the specified number of rows
5434 and columns. You can provide just the -columns parameter if you
5435 wish; radio_group will calculate the correct number of rows
5438 To include row and column headings in the returned table, you
5439 can use the B<-rowheader> and B<-colheader> parameters. Both
5440 of these accept a pointer to an array of headings to use.
5441 The headings are just decorative. They don't reorganize the
5442 interpretation of the radio buttons -- they're still a single named
5447 When the form is processed, the selected radio button can
5450 $which_radio_button = $query->param('group_name');
5452 The value returned by radio_group() is actually an array of button
5453 elements. You can capture them and use them within tables, lists,
5454 or in other creative ways:
5456 @h = $query->radio_group(-name=>'group_name',-values=>\@values);
5457 &use_in_creative_way(@h);
5459 =head2 CREATING A SUBMIT BUTTON
5461 print $query->submit(-name=>'button_name',
5466 print $query->submit('button_name','value');
5468 submit() will create the query submission button. Every form
5469 should have one of these.
5473 =item B<Parameters:>
5477 The first argument (-name) is optional. You can give the button a
5478 name if you have several submission buttons in your form and you want
5479 to distinguish between them. The name will also be used as the
5480 user-visible label. Be aware that a few older browsers don't deal with this correctly and
5481 B<never> send back a value from a button.
5485 The second argument (-value) is also optional. This gives the button
5486 a value that will be passed to your script in the query string.
5490 You can figure out which button was pressed by using different
5491 values for each one:
5493 $which_one = $query->param('button_name');
5495 JAVASCRIPTING: radio_group() recognizes the B<-onClick>
5496 parameter. See checkbox_group() for further details.
5498 =head2 CREATING A RESET BUTTON
5502 reset() creates the "reset" button. Note that it restores the
5503 form to its value from the last time the script was called,
5504 NOT necessarily to the defaults.
5506 Note that this conflicts with the Perl reset() built-in. Use
5507 CORE::reset() to get the original reset function.
5509 =head2 CREATING A DEFAULT BUTTON
5511 print $query->defaults('button_label')
5513 defaults() creates a button that, when invoked, will cause the
5514 form to be completely reset to its defaults, wiping out all the
5515 changes the user ever made.
5517 =head2 CREATING A HIDDEN FIELD
5519 print $query->hidden(-name=>'hidden_name',
5520 -default=>['value1','value2'...]);
5524 print $query->hidden('hidden_name','value1','value2'...);
5526 hidden() produces a text field that can't be seen by the user. It
5527 is useful for passing state variable information from one invocation
5528 of the script to the next.
5532 =item B<Parameters:>
5536 The first argument is required and specifies the name of this
5541 The second argument is also required and specifies its value
5542 (-default). In the named parameter style of calling, you can provide
5543 a single value here or a reference to a whole list
5547 Fetch the value of a hidden field this way:
5549 $hidden_value = $query->param('hidden_name');
5551 Note, that just like all the other form elements, the value of a
5552 hidden field is "sticky". If you want to replace a hidden field with
5553 some other values after the script has been called once you'll have to
5556 $query->param('hidden_name','new','values','here');
5558 =head2 CREATING A CLICKABLE IMAGE BUTTON
5560 print $query->image_button(-name=>'button_name',
5561 -src=>'/source/URL',
5566 print $query->image_button('button_name','/source/URL','MIDDLE');
5568 image_button() produces a clickable image. When it's clicked on the
5569 position of the click is returned to your script as "button_name.x"
5570 and "button_name.y", where "button_name" is the name you've assigned
5573 JAVASCRIPTING: image_button() recognizes the B<-onClick>
5574 parameter. See checkbox_group() for further details.
5578 =item B<Parameters:>
5582 The first argument (-name) is required and specifies the name of this
5587 The second argument (-src) is also required and specifies the URL
5590 The third option (-align, optional) is an alignment type, and may be
5591 TOP, BOTTOM or MIDDLE
5595 Fetch the value of the button this way:
5596 $x = $query->param('button_name.x');
5597 $y = $query->param('button_name.y');
5599 =head2 CREATING A JAVASCRIPT ACTION BUTTON
5601 print $query->button(-name=>'button_name',
5602 -value=>'user visible label',
5603 -onClick=>"do_something()");
5607 print $query->button('button_name',"do_something()");
5609 button() produces a button that is compatible with Netscape 2.0's
5610 JavaScript. When it's pressed the fragment of JavaScript code
5611 pointed to by the B<-onClick> parameter will be executed. On
5612 non-Netscape browsers this form element will probably not even
5617 Netscape browsers versions 1.1 and higher, and all versions of
5618 Internet Explorer, support a so-called "cookie" designed to help
5619 maintain state within a browser session. CGI.pm has several methods
5620 that support cookies.
5622 A cookie is a name=value pair much like the named parameters in a CGI
5623 query string. CGI scripts create one or more cookies and send
5624 them to the browser in the HTTP header. The browser maintains a list
5625 of cookies that belong to a particular Web server, and returns them
5626 to the CGI script during subsequent interactions.
5628 In addition to the required name=value pair, each cookie has several
5629 optional attributes:
5633 =item 1. an expiration time
5635 This is a time/date string (in a special GMT format) that indicates
5636 when a cookie expires. The cookie will be saved and returned to your
5637 script until this expiration date is reached if the user exits
5638 the browser and restarts it. If an expiration date isn't specified, the cookie
5639 will remain active until the user quits the browser.
5643 This is a partial or complete domain name for which the cookie is
5644 valid. The browser will return the cookie to any host that matches
5645 the partial domain name. For example, if you specify a domain name
5646 of ".capricorn.com", then the browser will return the cookie to
5647 Web servers running on any of the machines "www.capricorn.com",
5648 "www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
5649 must contain at least two periods to prevent attempts to match
5650 on top level domains like ".edu". If no domain is specified, then
5651 the browser will only return the cookie to servers on the host the
5652 cookie originated from.
5656 If you provide a cookie path attribute, the browser will check it
5657 against your script's URL before returning the cookie. For example,
5658 if you specify the path "/cgi-bin", then the cookie will be returned
5659 to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
5660 and "/cgi-bin/customer_service/complain.pl", but not to the script
5661 "/cgi-private/site_admin.pl". By default, path is set to "/", which
5662 causes the cookie to be sent to any CGI script on your site.
5664 =item 4. a "secure" flag
5666 If the "secure" attribute is set, the cookie will only be sent to your
5667 script if the CGI request is occurring on a secure channel, such as SSL.
5671 The interface to HTTP cookies is the B<cookie()> method:
5673 $cookie = $query->cookie(-name=>'sessionID',
5676 -path=>'/cgi-bin/database',
5677 -domain=>'.capricorn.org',
5679 print $query->header(-cookie=>$cookie);
5681 B<cookie()> creates a new cookie. Its parameters include:
5687 The name of the cookie (required). This can be any string at all.
5688 Although browsers limit their cookie names to non-whitespace
5689 alphanumeric characters, CGI.pm removes this restriction by escaping
5690 and unescaping cookies behind the scenes.
5694 The value of the cookie. This can be any scalar value,
5695 array reference, or even associative array reference. For example,
5696 you can store an entire associative array into a cookie this way:
5698 $cookie=$query->cookie(-name=>'family information',
5699 -value=>\%childrens_ages);
5703 The optional partial path for which this cookie will be valid, as described
5708 The optional partial domain for which this cookie will be valid, as described
5713 The optional expiration date for this cookie. The format is as described
5714 in the section on the B<header()> method:
5716 "+1h" one hour from now
5720 If set to true, this cookie will only be used within a secure
5725 The cookie created by cookie() must be incorporated into the HTTP
5726 header within the string returned by the header() method:
5728 print $query->header(-cookie=>$my_cookie);
5730 To create multiple cookies, give header() an array reference:
5732 $cookie1 = $query->cookie(-name=>'riddle_name',
5733 -value=>"The Sphynx's Question");
5734 $cookie2 = $query->cookie(-name=>'answers',
5736 print $query->header(-cookie=>[$cookie1,$cookie2]);
5738 To retrieve a cookie, request it by name by calling cookie()
5739 method without the B<-value> parameter:
5743 %answers = $query->cookie(-name=>'answers');
5744 # $query->cookie('answers') will work too!
5746 The cookie and CGI namespaces are separate. If you have a parameter
5747 named 'answers' and a cookie named 'answers', the values retrieved by
5748 param() and cookie() are independent of each other. However, it's
5749 simple to turn a CGI parameter into a cookie, and vice-versa:
5751 # turn a CGI parameter into a cookie
5752 $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]);
5754 $q->param(-name=>'answers',-value=>[$q->cookie('answers')]);
5756 See the B<cookie.cgi> example script for some ideas on how to use
5757 cookies effectively.
5759 =head1 WORKING WITH FRAMES
5761 It's possible for CGI.pm scripts to write into several browser panels
5762 and windows using the HTML 4 frame mechanism. There are three
5763 techniques for defining new frames programmatically:
5767 =item 1. Create a <Frameset> document
5769 After writing out the HTTP header, instead of creating a standard
5770 HTML document using the start_html() call, create a <FRAMESET>
5771 document that defines the frames on the page. Specify your script(s)
5772 (with appropriate parameters) as the SRC for each of the frames.
5774 There is no specific support for creating <FRAMESET> sections
5775 in CGI.pm, but the HTML is very simple to write. See the frame
5776 documentation in Netscape's home pages for details
5778 http://home.netscape.com/assist/net_sites/frames.html
5780 =item 2. Specify the destination for the document in the HTTP header
5782 You may provide a B<-target> parameter to the header() method:
5784 print $q->header(-target=>'ResultsWindow');
5786 This will tell the browser to load the output of your script into the
5787 frame named "ResultsWindow". If a frame of that name doesn't already
5788 exist, the browser will pop up a new window and load your script's
5789 document into that. There are a number of magic names that you can
5790 use for targets. See the frame documents on Netscape's home pages for
5793 =item 3. Specify the destination for the document in the <FORM> tag
5795 You can specify the frame to load in the FORM tag itself. With
5796 CGI.pm it looks like this:
5798 print $q->startform(-target=>'ResultsWindow');
5800 When your script is reinvoked by the form, its output will be loaded
5801 into the frame named "ResultsWindow". If one doesn't already exist
5802 a new window will be created.
5806 The script "frameset.cgi" in the examples directory shows one way to
5807 create pages in which the fill-out form and the response live in
5808 side-by-side frames.
5810 =head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
5812 CGI.pm has limited support for HTML3's cascading style sheets (css).
5813 To incorporate a stylesheet into your document, pass the
5814 start_html() method a B<-style> parameter. The value of this
5815 parameter may be a scalar, in which case it is incorporated directly
5816 into a <STYLE> section, or it may be a hash reference. In the latter
5817 case you should provide the hash with one or more of B<-src> or
5818 B<-code>. B<-src> points to a URL where an externally-defined
5819 stylesheet can be found. B<-code> points to a scalar value to be
5820 incorporated into a <STYLE> section. Style definitions in B<-code>
5821 override similarly-named ones in B<-src>, hence the name "cascading."
5823 You may also specify the type of the stylesheet by adding the optional
5824 B<-type> parameter to the hash pointed to by B<-style>. If not
5825 specified, the style defaults to 'text/css'.
5827 To refer to a style within the body of your document, add the
5828 B<-class> parameter to any HTML element:
5830 print h1({-class=>'Fancy'},'Welcome to the Party');
5832 Or define styles on the fly with the B<-style> parameter:
5834 print h1({-style=>'Color: red;'},'Welcome to Hell');
5836 You may also use the new B<span()> element to apply a style to a
5839 print span({-style=>'Color: red;'},
5840 h1('Welcome to Hell'),
5841 "Where did that handbasket get to?"
5844 Note that you must import the ":html3" definitions to have the
5845 B<span()> method available. Here's a quick and dirty example of using
5846 CSS's. See the CSS specification at
5847 http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
5849 use CGI qw/:standard :html3/;
5851 #here's a stylesheet incorporated directly into the page
5861 font-family: sans-serif;
5867 print start_html( -title=>'CGI with Style',
5868 -style=>{-src=>'http://www.capricorn.com/style/st1.css',
5871 print h1('CGI with Style'),
5873 "Better read the cascading style sheet spec before playing with this!"),
5874 span({-style=>'color: magenta'},
5875 "Look Mom, no hands!",
5883 If you are running the script
5884 from the command line or in the perl debugger, you can pass the script
5885 a list of keywords or parameter=value pairs on the command line or
5886 from standard input (you don't have to worry about tricking your
5887 script into reading from environment variables).
5888 You can pass keywords like this:
5890 your_script.pl keyword1 keyword2 keyword3
5894 your_script.pl keyword1+keyword2+keyword3
5898 your_script.pl name1=value1 name2=value2
5902 your_script.pl name1=value1&name2=value2
5904 or even as newline-delimited parameters on standard input.
5906 When debugging, you can use quotes and backslashes to escape
5907 characters in the familiar shell manner, letting you place
5908 spaces and other funny characters in your parameter=value
5911 your_script.pl "name1='I am a long value'" "name2=two\ words"
5913 =head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
5915 The dump() method produces a string consisting of all the query's
5916 name/value pairs formatted nicely as a nested list. This is useful
5917 for debugging purposes:
5922 Produces something that looks like:
5936 As a shortcut, you can interpolate the entire CGI object into a string
5937 and it will be replaced with the a nice HTML dump shown above:
5940 print "<H2>Current Values</H2> $query\n";
5942 =head1 FETCHING ENVIRONMENT VARIABLES
5944 Some of the more useful environment variables can be fetched
5945 through this interface. The methods are as follows:
5951 Return a list of MIME types that the remote browser accepts. If you
5952 give this method a single argument corresponding to a MIME type, as in
5953 $query->Accept('text/html'), it will return a floating point value
5954 corresponding to the browser's preference for this type from 0.0
5955 (don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept
5956 list are handled correctly.
5958 Note that the capitalization changed between version 2.43 and 2.44 in
5959 order to avoid conflict with Perl's accept() function.
5961 =item B<raw_cookie()>
5963 Returns the HTTP_COOKIE variable, an HTTP extension implemented by
5964 Netscape browsers version 1.1 and higher, and all versions of Internet
5965 Explorer. Cookies have a special format, and this method call just
5966 returns the raw form (?cookie dough). See cookie() for ways of
5967 setting and retrieving cooked cookies.
5969 Called with no parameters, raw_cookie() returns the packed cookie
5970 structure. You can separate it into individual cookies by splitting
5971 on the character sequence "; ". Called with the name of a cookie,
5972 retrieves the B<unescaped> form of the cookie. You can use the
5973 regular cookie() method to get the names, or use the raw_fetch()
5974 method from the CGI::Cookie module.
5976 =item B<user_agent()>
5978 Returns the HTTP_USER_AGENT variable. If you give
5979 this method a single argument, it will attempt to
5980 pattern match on it, allowing you to do something
5981 like $query->user_agent(netscape);
5983 =item B<path_info()>
5985 Returns additional path information from the script URL.
5986 E.G. fetching /cgi-bin/your_script/additional/stuff will
5987 result in $query->path_info() returning
5990 NOTE: The Microsoft Internet Information Server
5991 is broken with respect to additional path information. If
5992 you use the Perl DLL library, the IIS server will attempt to
5993 execute the additional path information as a Perl script.
5994 If you use the ordinary file associations mapping, the
5995 path information will be present in the environment,
5996 but incorrect. The best thing to do is to avoid using additional
5997 path information in CGI scripts destined for use with IIS.
5999 =item B<path_translated()>
6001 As per path_info() but returns the additional
6002 path information translated into a physical path, e.g.
6003 "/usr/local/etc/httpd/htdocs/additional/stuff".
6005 The Microsoft IIS is broken with respect to the translated
6008 =item B<remote_host()>
6010 Returns either the remote host name or IP address.
6011 if the former is unavailable.
6013 =item B<script_name()>
6014 Return the script name as a partial URL, for self-refering
6019 Return the URL of the page the browser was viewing
6020 prior to fetching your script. Not available for all
6023 =item B<auth_type ()>
6025 Return the authorization/verification method in use for this
6028 =item B<server_name ()>
6030 Returns the name of the server, usually the machine's host
6033 =item B<virtual_host ()>
6035 When using virtual hosts, returns the name of the host that
6036 the browser attempted to contact
6038 =item B<server_software ()>
6040 Returns the server software and version number.
6042 =item B<remote_user ()>
6044 Return the authorization/verification name used for user
6045 verification, if this script is protected.
6047 =item B<user_name ()>
6049 Attempt to obtain the remote user's name, using a variety of different
6050 techniques. This only works with older browsers such as Mosaic.
6051 Newer browsers do not report the user name for privacy reasons!
6053 =item B<request_method()>
6055 Returns the method used to access your script, usually
6056 one of 'POST', 'GET' or 'HEAD'.
6058 =item B<content_type()>
6060 Returns the content_type of data submitted in a POST, generally
6061 multipart/form-data or application/x-www-form-urlencoded
6065 Called with no arguments returns the list of HTTP environment
6066 variables, including such things as HTTP_USER_AGENT,
6067 HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the
6068 like-named HTTP header fields in the request. Called with the name of
6069 an HTTP header field, returns its value. Capitalization and the use
6070 of hyphens versus underscores are not significant.
6072 For example, all three of these examples are equivalent:
6074 $requested_language = $q->http('Accept-language');
6075 $requested_language = $q->http('Accept_language');
6076 $requested_language = $q->http('HTTP_ACCEPT_LANGUAGE');
6080 The same as I<http()>, but operates on the HTTPS environment variables
6081 present when the SSL protocol is in effect. Can be used to determine
6082 whether SSL is turned on.
6086 =head1 USING NPH SCRIPTS
6088 NPH, or "no-parsed-header", scripts bypass the server completely by
6089 sending the complete HTTP header directly to the browser. This has
6090 slight performance benefits, but is of most use for taking advantage
6091 of HTTP extensions that are not directly supported by your server,
6092 such as server push and PICS headers.
6094 Servers use a variety of conventions for designating CGI scripts as
6095 NPH. Many Unix servers look at the beginning of the script's name for
6096 the prefix "nph-". The Macintosh WebSTAR server and Microsoft's
6097 Internet Information Server, in contrast, try to decide whether a
6098 program is an NPH script by examining the first line of script output.
6101 CGI.pm supports NPH scripts with a special NPH mode. When in this
6102 mode, CGI.pm will output the necessary extra header information when
6103 the header() and redirect() methods are
6106 The Microsoft Internet Information Server requires NPH mode. As of version
6107 2.30, CGI.pm will automatically detect when the script is running under IIS
6108 and put itself into this mode. You do not need to do this manually, although
6109 it won't hurt anything if you do.
6111 There are a number of ways to put CGI.pm into NPH mode:
6115 =item In the B<use> statement
6117 Simply add the "-nph" pragmato the list of symbols to be imported into
6120 use CGI qw(:standard -nph)
6122 =item By calling the B<nph()> method:
6124 Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
6128 =item By using B<-nph> parameters in the B<header()> and B<redirect()> statements:
6130 print $q->header(-nph=>1);
6136 CGI.pm provides three simple functions for producing multipart
6137 documents of the type needed to implement server push. These
6138 functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To
6139 import these into your namespace, you must import the ":push" set.
6140 You are also advised to put the script into NPH mode and to set $| to
6141 1 to avoid buffering problems.
6143 Here is a simple script that demonstrates server push:
6145 #!/usr/local/bin/perl
6146 use CGI qw/:push -nph/;
6148 print multipart_init(-boundary=>'----------------here we go!');
6150 print multipart_start(-type=>'text/plain'),
6151 "The current time is ",scalar(localtime),"\n",
6156 This script initializes server push by calling B<multipart_init()>.
6157 It then enters an infinite loop in which it begins a new multipart
6158 section by calling B<multipart_start()>, prints the current local time,
6159 and ends a multipart section with B<multipart_end()>. It then sleeps
6160 a second, and begins again.
6164 =item multipart_init()
6166 multipart_init(-boundary=>$boundary);
6168 Initialize the multipart system. The -boundary argument specifies
6169 what MIME boundary string to use to separate parts of the document.
6170 If not provided, CGI.pm chooses a reasonable boundary for you.
6172 =item multipart_start()
6174 multipart_start(-type=>$type)
6176 Start a new part of the multipart document using the specified MIME
6177 type. If not specified, text/html is assumed.
6179 =item multipart_end()
6183 End a part. You must remember to call multipart_end() once for each
6188 Users interested in server push applications should also have a look
6189 at the CGI::Push module.
6191 =head1 Avoiding Denial of Service Attacks
6193 A potential problem with CGI.pm is that, by default, it attempts to
6194 process form POSTings no matter how large they are. A wily hacker
6195 could attack your site by sending a CGI script a huge POST of many
6196 megabytes. CGI.pm will attempt to read the entire POST into a
6197 variable, growing hugely in size until it runs out of memory. While
6198 the script attempts to allocate the memory the system may slow down
6199 dramatically. This is a form of denial of service attack.
6201 Another possible attack is for the remote user to force CGI.pm to
6202 accept a huge file upload. CGI.pm will accept the upload and store it
6203 in a temporary directory even if your script doesn't expect to receive
6204 an uploaded file. CGI.pm will delete the file automatically when it
6205 terminates, but in the meantime the remote user may have filled up the
6206 server's disk space, causing problems for other programs.
6208 The best way to avoid denial of service attacks is to limit the amount
6209 of memory, CPU time and disk space that CGI scripts can use. Some Web
6210 servers come with built-in facilities to accomplish this. In other
6211 cases, you can use the shell I<limit> or I<ulimit>
6212 commands to put ceilings on CGI resource usage.
6215 CGI.pm also has some simple built-in protections against denial of
6216 service attacks, but you must activate them before you can use them.
6217 These take the form of two global variables in the CGI name space:
6221 =item B<$CGI::POST_MAX>
6223 If set to a non-negative integer, this variable puts a ceiling
6224 on the size of POSTings, in bytes. If CGI.pm detects a POST
6225 that is greater than the ceiling, it will immediately exit with an error
6226 message. This value will affect both ordinary POSTs and
6227 multipart POSTs, meaning that it limits the maximum size of file
6228 uploads as well. You should set this to a reasonably high
6229 value, such as 1 megabyte.
6231 =item B<$CGI::DISABLE_UPLOADS>
6233 If set to a non-zero value, this will disable file uploads
6234 completely. Other fill-out form values will work as usual.
6238 You can use these variables in either of two ways.
6242 =item B<1. On a script-by-script basis>
6244 Set the variable at the top of the script, right after the "use" statement:
6246 use CGI qw/:standard/;
6247 use CGI::Carp 'fatalsToBrowser';
6248 $CGI::POST_MAX=1024 * 100; # max 100K posts
6249 $CGI::DISABLE_UPLOADS = 1; # no uploads
6251 =item B<2. Globally for all scripts>
6253 Open up CGI.pm, find the definitions for $POST_MAX and
6254 $DISABLE_UPLOADS, and set them to the desired values. You'll
6255 find them towards the top of the file in a subroutine named
6256 initialize_globals().
6260 An attempt to send a POST larger than $POST_MAX bytes will cause
6261 I<param()> to return an empty CGI parameter list. You can test for
6262 this event by checking I<cgi_error()>, either after you create the CGI
6263 object or, if you are using the function-oriented interface, call
6264 <param()> for the first time. If the POST was intercepted, then
6265 cgi_error() will return the message "413 POST too large".
6267 This error message is actually defined by the HTTP protocol, and is
6268 designed to be returned to the browser as the CGI script's status
6271 $uploaded_file = param('upload');
6272 if (!$uploaded_file && cgi_error()) {
6273 print header(-status=>cgi_error());
6277 However it isn't clear that any browser currently knows what to do
6278 with this status code. It might be better just to create an
6279 HTML page that warns the user of the problem.
6281 =head1 COMPATIBILITY WITH CGI-LIB.PL
6283 To make it easier to port existing programs that use cgi-lib.pl the
6284 compatibility routine "ReadParse" is provided. Porting is simple:
6287 require "cgi-lib.pl";
6289 print "The value of the antique is $in{antique}.\n";
6294 print "The value of the antique is $in{antique}.\n";
6296 CGI.pm's ReadParse() routine creates a tied variable named %in,
6297 which can be accessed to obtain the query variables. Like
6298 ReadParse, you can also provide your own variable. Infrequently
6299 used features of ReadParse, such as the creation of @in and $in
6300 variables, are not supported.
6302 Once you use ReadParse, you can retrieve the query object itself
6306 print $q->textfield(-name=>'wow',
6307 -value=>'does this really work?');
6309 This allows you to start using the more interesting features
6310 of CGI.pm without rewriting your old scripts from scratch.
6312 =head1 AUTHOR INFORMATION
6314 Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
6316 This library is free software; you can redistribute it and/or modify
6317 it under the same terms as Perl itself.
6319 Address bug reports and comments to: lstein@cshl.org. When sending
6320 bug reports, please provide the version of CGI.pm, the version of
6321 Perl, the name and version of your Web server, and the name and
6322 version of the operating system you are using. If the problem is even
6323 remotely browser dependent, please provide information about the
6324 affected browers as well.
6328 Thanks very much to:
6332 =item Matt Heffron (heffron@falstaff.css.beckman.com)
6334 =item James Taylor (james.taylor@srs.gov)
6336 =item Scott Anguish <sanguish@digifix.com>
6338 =item Mike Jewell (mlj3u@virginia.edu)
6340 =item Timothy Shimmin (tes@kbs.citri.edu.au)
6342 =item Joergen Haegg (jh@axis.se)
6344 =item Laurent Delfosse (delfosse@delfosse.com)
6346 =item Richard Resnick (applepi1@aol.com)
6348 =item Craig Bishop (csb@barwonwater.vic.gov.au)
6350 =item Tony Curtis (tc@vcpc.univie.ac.at)
6352 =item Tim Bunce (Tim.Bunce@ig.co.uk)
6354 =item Tom Christiansen (tchrist@convex.com)
6356 =item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
6358 =item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
6360 =item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
6362 =item Stephen Dahmen (joyfire@inxpress.net)
6364 =item Ed Jordan (ed@fidalgo.net)
6366 =item David Alan Pisoni (david@cnation.com)
6368 =item Doug MacEachern (dougm@opengroup.org)
6370 =item Robin Houston (robin@oneworld.org)
6372 =item ...and many many more...
6374 for suggestions and bug fixes.
6378 =head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
6381 #!/usr/local/bin/perl
6387 print $query->header;
6388 print $query->start_html("Example CGI.pm Form");
6389 print "<H1> Example CGI.pm Form</H1>\n";
6390 &print_prompt($query);
6393 print $query->end_html;
6398 print $query->startform;
6399 print "<EM>What's your name?</EM><BR>";
6400 print $query->textfield('name');
6401 print $query->checkbox('Not my real name');
6403 print "<P><EM>Where can you find English Sparrows?</EM><BR>";
6404 print $query->checkbox_group(
6405 -name=>'Sparrow locations',
6406 -values=>[England,France,Spain,Asia,Hoboken],
6408 -defaults=>[England,Asia]);
6410 print "<P><EM>How far can they fly?</EM><BR>",
6411 $query->radio_group(
6413 -values=>['10 ft','1 mile','10 miles','real far'],
6414 -default=>'1 mile');
6416 print "<P><EM>What's your favorite color?</EM> ";
6417 print $query->popup_menu(-name=>'Color',
6418 -values=>['black','brown','red','yellow'],
6421 print $query->hidden('Reference','Monty Python and the Holy Grail');
6423 print "<P><EM>What have you got there?</EM><BR>";
6424 print $query->scrolling_list(
6425 -name=>'possessions',
6426 -values=>['A Coconut','A Grail','An Icon',
6427 'A Sword','A Ticket'],
6431 print "<P><EM>Any parting comments?</EM><BR>";
6432 print $query->textarea(-name=>'Comments',
6436 print "<P>",$query->reset;
6437 print $query->submit('Action','Shout');
6438 print $query->submit('Action','Scream');
6439 print $query->endform;
6447 print "<H2>Here are the current settings in this form</H2>";
6449 foreach $key ($query->param) {
6450 print "<STRONG>$key</STRONG> -> ";
6451 @values = $query->param($key);
6452 print join(", ",@values),"<BR>\n";
6459 <ADDRESS>Lincoln D. Stein</ADDRESS><BR>
6460 <A HREF="/">Home Page</A>
6466 This module has grown large and monolithic. Furthermore it's doing many
6467 things, such as handling URLs, parsing CGI input, writing HTML, etc., that
6468 are also done in the LWP modules. It should be discarded in favor of
6469 the CGI::* modules, but somehow I continue to work on it.
6471 Note that the code is truly contorted in order to avoid spurious
6472 warnings when programs are run with the B<-w> switch.
6476 L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>,
6477 L<CGI::Base>, L<CGI::Form>, L<CGI::Push>, L<CGI::Fast>,