5 # See the bottom of this file for the POD documentation. Search for the
8 # You can run this file through either pod2man or pod2html to produce pretty
9 # documentation in manual or html file format (these utilities are part of the
10 # Perl 5 distribution).
12 # Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
13 # It may be used and modified freely, but I do request that this copyright
14 # notice remain attached to the file. You may modify this module as you
15 # wish, but if you redistribute a modified version, please attach a note
16 # listing the modifications you have made.
18 # The most recent version and complete docs are available at:
19 # http://stein.cshl.org/WWW/software/CGI/
21 $CGI::revision = '$Id: CGI.pm,v 1.185 2005/08/03 21:14:55 lstein Exp $';
22 $CGI::VERSION='3.11_01';
24 # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
25 # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
26 # $CGITempFile::TMPDIRECTORY = '/usr/tmp';
27 use CGI::Util qw(rearrange make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
29 #use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
30 # 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
32 use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
33 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
37 $TAINTED = substr("$0$^X",0,0);
40 $MOD_PERL = 0; # no mod_perl by default
43 # >>>>> Here are some globals that you might want to adjust <<<<<<
44 sub initialize_globals {
45 # Set this to 1 to enable copious autoloader debugging messages
48 # Set this to 1 to generate XTML-compatible output
51 # Change this to the preferred DTD to print in start_html()
52 # or use default_dtd('text of DTD to use');
53 $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
54 'http://www.w3.org/TR/html4/loose.dtd' ] ;
56 # Set this to 1 to enable NOSTICKY scripts
58 # 1) use CGI qw(-nosticky)
59 # 2) $CGI::nosticky(1)
62 # Set this to 1 to enable NPH scripts
66 # 3) print header(-nph=>1)
69 # Set this to 1 to enable debugging from @ARGV
70 # Set to 2 to enable debugging from STDIN
73 # Set this to 1 to make the temporary files created
74 # during file uploads safe from prying eyes
76 # 1) use CGI qw(:private_tempfiles)
77 # 2) CGI::private_tempfiles(1);
78 $PRIVATE_TEMPFILES = 0;
80 # Set this to 1 to cause files uploaded in multipart documents
81 # to be closed, instead of caching the file handle
83 # 1) use CGI qw(:close_upload_files)
84 # 2) $CGI::close_upload_files(1);
85 # Uploads with many files run out of file handles.
86 # Also, for performance, since the file is already on disk,
87 # it can just be renamed, instead of read and written.
88 $CLOSE_UPLOAD_FILES = 0;
90 # Set this to a positive value to limit the size of a POSTing
91 # to a certain number of bytes:
94 # Change this to 1 to disable uploads entirely:
97 # Automatically determined -- don't change
100 # Change this to 1 to suppress redundant HTTP headers
103 # separate the name=value pairs by semicolons rather than ampersands
104 $USE_PARAM_SEMICOLONS = 1;
106 # Do not include undefined params parsed from query string
107 # use CGI qw(-no_undef_params);
108 $NO_UNDEF_PARAMS = 0;
110 # Other globals that you shouldn't worry about.
113 $DTD_PUBLIC_IDENTIFIER = "";
116 undef $QUERY_CHARSET;
117 undef %QUERY_FIELDNAMES;
119 # prevent complaints by mod_perl
123 # ------------------ START OF THE LIBRARY ------------
125 *end_form = \&endform;
128 initialize_globals();
130 # FIGURE OUT THE OS WE'RE RUNNING UNDER
131 # Some systems support the $^O variable. If not
132 # available then require() the Config library
136 $OS = $Config::Config{'osname'};
139 if ($OS =~ /^MSWin/i) {
141 } elsif ($OS =~ /^VMS/i) {
143 } elsif ($OS =~ /^dos/i) {
145 } elsif ($OS =~ /^MacOS/i) {
147 } elsif ($OS =~ /^os2/i) {
149 } elsif ($OS =~ /^epoc/i) {
151 } elsif ($OS =~ /^cygwin/i) {
157 # Some OS logic. Binary mode enabled on DOS, NT and VMS
158 $needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN)/;
160 # This is the default class for the CGI object to use when all else fails.
161 $DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
163 # This is where to look for autoloaded routines.
164 $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
166 # The path separator is a slash, backslash or semicolon, depending
169 UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/',
170 WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
173 # This no longer seems to be necessary
174 # Turn on NPH scripts by default when running under IIS server!
175 # $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
176 $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
178 # Turn on special checking for Doug MacEachern's modperl
179 if (exists $ENV{MOD_PERL}) {
180 # mod_perl handlers may run system() on scripts using CGI.pm;
181 # Make sure so we don't get fooled by inherited $ENV{MOD_PERL}
182 if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
184 require Apache2::Response;
185 require Apache2::RequestRec;
186 require Apache2::RequestUtil;
187 require Apache2::RequestIO;
195 # Turn on special checking for ActiveState's PerlEx
196 $PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
198 # Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
199 # of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
200 # and sometimes CR). The most popular VMS web server
201 # doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
202 # use ASCII, so \015\012 means something different. I find this all
204 $EBCDIC = "\t" ne "\011";
213 if ($needs_binmode) {
214 $CGI::DefaultClass->binmode(\*main::STDOUT);
215 $CGI::DefaultClass->binmode(\*main::STDIN);
216 $CGI::DefaultClass->binmode(\*main::STDERR);
220 ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
221 tt u i b blockquote pre img a address cite samp dfn html head
222 base body Link nextid title meta kbd start_html end_html
223 input Select option comment charset escapeHTML/],
224 ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param
225 embed basefont style span layer ilayer font frameset frame script small big Area Map/],
226 ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
227 ins label legend noframes noscript object optgroup Q
229 ':netscape'=>[qw/blink fontsize center/],
230 ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
231 submit reset defaults radio_group popup_menu button autoEscape
232 scrolling_list image_button start_form end_form startform endform
233 start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
234 ':cgi'=>[qw/param upload path_info path_translated request_uri url self_url script_name
236 raw_cookie request_method query_string Accept user_agent remote_host content_type
237 remote_addr referer server_name server_software server_port server_protocol virtual_port
238 virtual_host remote_ident auth_type http append
239 save_parameters restore_parameters param_fetch
240 remote_user user_name header redirect import_names put
241 Delete Delete_all url_param cgi_error/],
242 ':ssl' => [qw/https/],
243 ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
244 ':html' => [qw/:html2 :html3 :html4 :netscape/],
245 ':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
246 ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
247 ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/]
250 # Custom 'can' method for both autoloaded and non-autoloaded subroutines.
251 # Author: Cees Hek <cees@sitesuite.com.au>
254 my($class, $method) = @_;
256 # See if UNIVERSAL::can finds it.
258 if (my $func = $class -> SUPER::can($method) ){
262 # Try to compile the function.
265 # _compile looks at $AUTOLOAD for the function name.
267 local $AUTOLOAD = join "::", $class, $method;
271 # Now that the function is loaded (if it exists)
272 # just use UNIVERSAL::can again to do the work.
274 return $class -> SUPER::can($method);
277 # to import symbols into caller
281 # This causes modules to clash.
285 $self->_setup_symbols(@_);
286 my ($callpack, $callfile, $callline) = caller;
288 # To allow overriding, search through the packages
289 # Till we find one in which the correct subroutine is defined.
290 my @packages = ($self,@{"$self\:\:ISA"});
291 foreach $sym (keys %EXPORT) {
293 my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
294 foreach $pck (@packages) {
295 if (defined(&{"$pck\:\:$sym"})) {
300 *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
306 $pack->_setup_symbols('-compile',@_);
311 return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
313 return ($tag) unless $EXPORT_TAGS{$tag};
314 foreach (@{$EXPORT_TAGS{$tag}}) {
315 push(@r,&expand_tags($_));
321 # The new routine. This will check the current environment
322 # for an existing query string, and initialize itself, if so.
325 my($class,@initializer) = @_;
328 bless $self,ref $class || $class || $DefaultClass;
329 if (ref($initializer[0])
330 && (UNIVERSAL::isa($initializer[0],'Apache')
332 UNIVERSAL::isa($initializer[0],'Apache2::RequestRec')
334 $self->r(shift @initializer);
336 if (ref($initializer[0])
337 && (UNIVERSAL::isa($initializer[0],'CODE'))) {
338 $self->upload_hook(shift @initializer, shift @initializer);
341 if ($MOD_PERL == 1) {
342 $self->r(Apache->request) unless $self->r;
344 $r->register_cleanup(\&CGI::_reset_globals);
347 # XXX: once we have the new API
348 # will do a real PerlOptions -SetupEnv check
349 $self->r(Apache2::RequestUtil->request) unless $self->r;
351 $r->subprocess_env unless exists $ENV{REQUEST_METHOD};
352 $r->pool->cleanup_register(\&CGI::_reset_globals);
356 $self->_reset_globals if $PERLEX;
357 $self->init(@initializer);
361 # We provide a DESTROY method so that we can ensure that
362 # temporary files are closed (via Fh->DESTROY) before they
363 # are unlinked (via CGITempFile->DESTROY) because it is not
364 # possible to unlink an open file on Win32. We explicitly
365 # call DESTROY on each, rather than just undefing them and
366 # letting Perl DESTROY them by garbage collection, in case the
367 # user is still holding any reference to them as well.
370 foreach my $href (values %{$self->{'.tmpfiles'}}) {
371 $href->{hndl}->DESTROY if defined $href->{hndl};
372 $href->{name}->DESTROY if defined $href->{name};
378 my $r = $self->{'.r'};
379 $self->{'.r'} = shift if @_;
384 my ($self,$hook,$data) = self_or_default(@_);
385 $self->{'.upload_hook'} = $hook;
386 $self->{'.upload_data'} = $data;
390 # Returns the value(s)of a named parameter.
391 # If invoked in a list context, returns the
392 # entire list. Otherwise returns the first
393 # member of the list.
394 # If name is not provided, return a list of all
395 # the known parameters names available.
396 # If more than one argument is provided, the
397 # second and subsequent arguments are used to
398 # set the value of the parameter.
401 my($self,@p) = self_or_default(@_);
402 return $self->all_parameters unless @p;
403 my($name,$value,@other);
405 # For compatibility between old calling style and use_named_parameters() style,
406 # we have to special case for a single parameter present.
408 ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
411 if (substr($p[0],0,1) eq '-') {
412 @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
414 foreach ($value,@other) {
415 push(@values,$_) if defined($_);
418 # If values is provided, then we set it.
420 $self->add_parameter($name);
421 $self->{$name}=[@values];
427 return unless defined($name) && $self->{$name};
428 return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
431 sub self_or_default {
432 return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
433 unless (defined($_[0]) &&
434 (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
436 $Q = $CGI::DefaultClass->new unless defined($Q);
439 return wantarray ? @_ : $Q;
443 local $^W=0; # prevent a warning
444 if (defined($_[0]) &&
445 (substr(ref($_[0]),0,3) eq 'CGI'
446 || UNIVERSAL::isa($_[0],'CGI'))) {
449 return ($DefaultClass,@_);
453 ########################################
454 # THESE METHODS ARE MORE OR LESS PRIVATE
455 # GO TO THE __DATA__ SECTION TO SEE MORE
457 ########################################
459 # Initialize the query object from the environment.
460 # If a parameter list is found, this object will be set
461 # to an associative array in which parameter names are keys
462 # and the values are stored as lists
463 # If a keyword list is found, this method creates a bogus
464 # parameter list with the single parameter 'keywords'.
468 my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
470 my $initializer = shift; # for backward compatibility
473 # set autoescaping on by default
474 $self->{'escape'} = 1;
476 # if we get called more than once, we want to initialize
477 # ourselves from the original query (which may be gone
478 # if it was read from STDIN originally.)
479 if (defined(@QUERY_PARAM) && !defined($initializer)) {
480 foreach (@QUERY_PARAM) {
481 $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
483 $self->charset($QUERY_CHARSET);
484 $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
488 $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
489 $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
491 $fh = to_filehandle($initializer) if $initializer;
493 # set charset to the safe ISO-8859-1
494 $self->charset('ISO-8859-1');
498 # avoid unreasonably large postings
499 if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
500 # quietly read and discard the post
502 my $max = $content_length;
504 (my $bytes = $MOD_PERL
505 ? $self->r->read($buffer,$max < 10000 ? $max : 10000)
506 : read(STDIN,$buffer,$max < 10000 ? $max : 10000)
508 $self->cgi_error("413 Request entity too large");
513 # Process multipart postings, but only if the initializer is
516 && defined($ENV{'CONTENT_TYPE'})
517 && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
518 && !defined($initializer)
520 my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
521 $self->read_multipart($boundary,$content_length);
525 # If initializer is defined, then read parameters
527 if (defined($initializer)) {
528 if (UNIVERSAL::isa($initializer,'CGI')) {
529 $query_string = $initializer->query_string;
532 if (ref($initializer) && ref($initializer) eq 'HASH') {
533 foreach (keys %$initializer) {
534 $self->param('-name'=>$_,'-value'=>$initializer->{$_});
539 if (defined($fh) && ($fh ne '')) {
545 # massage back into standard format
546 if ("@lines" =~ /=/) {
547 $query_string=join("&",@lines);
549 $query_string=join("+",@lines);
554 if (defined($fh) && ($fh ne '')) {
560 # massage back into standard format
561 if ("@lines" =~ /=/) {
562 $query_string=join("&",@lines);
564 $query_string=join("+",@lines);
569 # last chance -- treat it as a string
570 $initializer = $$initializer if ref($initializer) eq 'SCALAR';
571 $query_string = $initializer;
576 # If method is GET or HEAD, fetch the query from
578 if ($meth=~/^(GET|HEAD)$/) {
580 $query_string = $self->r->args;
582 $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
583 $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
588 if ($meth eq 'POST') {
589 $self->read_from_client(\$query_string,$content_length,0)
590 if $content_length > 0;
591 # Some people want to have their cake and eat it too!
592 # Uncomment this line to have the contents of the query string
593 # APPENDED to the POST data.
594 # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
598 # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
599 # Check the command line and then the standard input for data.
600 # We use the shellwords package in order to behave the way that
601 # UN*X programmers expect.
604 my $cmdline_ret = read_from_cmdline();
605 $query_string = $cmdline_ret->{'query_string'};
606 if (defined($cmdline_ret->{'subpath'}))
608 $self->path_info($cmdline_ret->{'subpath'});
613 # YL: Begin Change for XML handler 10/19/2001
615 && defined($ENV{'CONTENT_TYPE'})
616 && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
617 && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
618 my($param) = 'POSTDATA' ;
619 $self->add_parameter($param) ;
620 push (@{$self->{$param}},$query_string);
621 undef $query_string ;
623 # YL: End Change for XML handler 10/19/2001
625 # We now have the query string in hand. We do slightly
626 # different things for keyword lists and parameter lists.
627 if (defined $query_string && length $query_string) {
628 if ($query_string =~ /[&=;]/) {
629 $self->parse_params($query_string);
631 $self->add_parameter('keywords');
632 $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
636 # Special case. Erase everything if there is a field named
638 if ($self->param('.defaults')) {
642 # Associative array containing our defined fieldnames
643 $self->{'.fieldnames'} = {};
644 foreach ($self->param('.cgifields')) {
645 $self->{'.fieldnames'}->{$_}++;
648 # Clear out our default submission button flag if present
649 $self->delete('.submit');
650 $self->delete('.cgifields');
652 $self->save_request unless defined $initializer;
655 # FUNCTIONS TO OVERRIDE:
656 # Turn a string into a filehandle
659 return undef unless $thingy;
660 return $thingy if UNIVERSAL::isa($thingy,'GLOB');
661 return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
664 while (my $package = caller($caller++)) {
665 my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
666 return $tmp if defined(fileno($tmp));
672 # send output to the browser
674 my($self,@p) = self_or_default(@_);
678 # print to standard output (for overriding in mod_perl)
684 # get/set last cgi_error
686 my ($self,$err) = self_or_default(@_);
687 $self->{'.cgi_error'} = $err if defined $err;
688 return $self->{'.cgi_error'};
693 # We're going to play with the package globals now so that if we get called
694 # again, we initialize ourselves in exactly the same way. This allows
695 # us to have several of these objects.
696 @QUERY_PARAM = $self->param; # save list of parameters
697 foreach (@QUERY_PARAM) {
698 next unless defined $_;
699 $QUERY_PARAM{$_}=$self->{$_};
701 $QUERY_CHARSET = $self->charset;
702 %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
706 my($self,$tosplit) = @_;
707 my(@pairs) = split(/[&;]/,$tosplit);
710 ($param,$value) = split('=',$_,2);
711 next unless defined $param;
712 next if $NO_UNDEF_PARAMS and not defined $value;
713 $value = '' unless defined $value;
714 $param = unescape($param);
715 $value = unescape($value);
716 $self->add_parameter($param);
717 push (@{$self->{$param}},$value);
723 return unless defined $param;
724 push (@{$self->{'.parameters'}},$param)
725 unless defined($self->{$param});
730 return () unless defined($self) && $self->{'.parameters'};
731 return () unless @{$self->{'.parameters'}};
732 return @{$self->{'.parameters'}};
735 # put a filehandle into binary mode (DOS)
737 return unless defined($_[1]) && defined fileno($_[1]);
738 CORE::binmode($_[1]);
742 my ($self,$tagname) = @_;
745 my (\$q,\$a,\@rest) = self_or_default(\@_);
747 if (ref(\$a) && ref(\$a) eq 'HASH') {
748 my(\@attr) = make_attributes(\$a,\$q->{'escape'});
749 \$attr = " \@attr" if \@attr;
751 unshift \@rest,\$a if defined \$a;
754 if ($tagname=~/start_(\w+)/i) {
755 $func .= qq! return "<\L$1\E\$attr>";} !;
756 } elsif ($tagname=~/end_(\w+)/i) {
757 $func .= qq! return "<\L/$1\E>"; } !;
760 return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest;
761 my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
762 my \@result = map { "\$tag\$_\$untag" }
763 (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
771 print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
772 my $func = &_compile;
777 my($func) = $AUTOLOAD;
778 my($pack,$func_name);
780 local($1,$2); # this fixes an obscure variable suicide problem.
781 $func=~/(.+)::([^:]+)$/;
782 ($pack,$func_name) = ($1,$2);
783 $pack=~s/::SUPER$//; # fix another obscure problem
784 $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
785 unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
787 my($sub) = \%{"$pack\:\:SUBS"};
789 my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
791 eval "package $pack; $$auto";
792 croak("$AUTOLOAD: $@") if $@;
793 $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
795 my($code) = $sub->{$func_name};
797 $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
799 (my $base = $func_name) =~ s/^(start_|end_)//i;
800 if ($EXPORT{':any'} ||
803 (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
804 && $EXPORT_OK{$base}) {
805 $code = $CGI::DefaultClass->_make_tag_func($func_name);
808 croak("Undefined subroutine $AUTOLOAD\n") unless $code;
810 eval "package $pack; $code";
813 croak("$AUTOLOAD: $@");
816 CORE::delete($sub->{$func_name}); #free storage
817 return "$pack\:\:$func_name";
823 return '' unless $value;
824 return $XHTML ? qq( selected="selected") : qq( selected);
830 return '' unless $value;
831 return $XHTML ? qq( checked="checked") : qq( checked);
834 sub _reset_globals { initialize_globals(); }
840 # to avoid reexporting unwanted variables
844 $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
845 $NPH++, next if /^[:-]nph$/;
846 $NOSTICKY++, next if /^[:-]nosticky$/;
847 $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
848 $DEBUG=2, next if /^[:-][Dd]ebug$/;
849 $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
850 $XHTML++, next if /^[:-]xhtml$/;
851 $XHTML=0, next if /^[:-]no_?xhtml$/;
852 $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
853 $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
854 $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
855 $EXPORT{$_}++, next if /^[:-]any$/;
856 $compile++, next if /^[:-]compile$/;
857 $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
859 # This is probably extremely evil code -- to be deleted some day.
860 if (/^[-]autoload$/) {
861 my($pkg) = caller(1);
862 *{"${pkg}::AUTOLOAD"} = sub {
863 my($routine) = $AUTOLOAD;
864 $routine =~ s/^.*::/CGI::/;
870 foreach (&expand_tags($_)) {
871 tr/a-zA-Z0-9_//cd; # don't allow weird function names
875 _compile_all(keys %EXPORT) if $compile;
880 my ($self,$charset) = self_or_default(@_);
881 $self->{'.charset'} = $charset if defined $charset;
886 my ($self,$new_value) = self_or_default(@_);
887 $self->{'.elid'} = $new_value if defined $new_value;
888 sprintf('%010d',$self->{'.elid'}++);
892 my ($self,$new_value) = self_or_default(@_);
893 $self->{'.etab'} ||= 1;
894 $self->{'.etab'} = $new_value if defined $new_value;
898 ###############################################################################
899 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
900 ###############################################################################
901 $AUTOLOADED_ROUTINES = ''; # get rid of -w warning
902 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
906 'URL_ENCODED'=> <<'END_OF_FUNC',
907 sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
910 'MULTIPART' => <<'END_OF_FUNC',
911 sub MULTIPART { 'multipart/form-data'; }
914 'SERVER_PUSH' => <<'END_OF_FUNC',
915 sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
918 'new_MultipartBuffer' => <<'END_OF_FUNC',
919 # Create a new multipart buffer
920 sub new_MultipartBuffer {
921 my($self,$boundary,$length) = @_;
922 return MultipartBuffer->new($self,$boundary,$length);
926 'read_from_client' => <<'END_OF_FUNC',
927 # Read data from a file handle
928 sub read_from_client {
929 my($self, $buff, $len, $offset) = @_;
930 local $^W=0; # prevent a warning
932 ? $self->r->read($$buff, $len, $offset)
933 : read(\*STDIN, $$buff, $len, $offset);
937 'delete' => <<'END_OF_FUNC',
939 # Deletes the named parameter entirely.
942 my($self,@p) = self_or_default(@_);
943 my(@names) = rearrange([NAME],@p);
944 my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
946 foreach my $name (@to_delete)
948 CORE::delete $self->{$name};
949 CORE::delete $self->{'.fieldnames'}->{$name};
952 @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
957 #### Method: import_names
958 # Import all parameters into the given namespace.
959 # Assumes namespace 'Q' if not specified
961 'import_names' => <<'END_OF_FUNC',
963 my($self,$namespace,$delete) = self_or_default(@_);
964 $namespace = 'Q' unless defined($namespace);
965 die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
966 if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
967 # can anyone find an easier way to do this?
968 foreach (keys %{"${namespace}::"}) {
969 local *symbol = "${namespace}::${_}";
975 my($param,@value,$var);
976 foreach $param ($self->param) {
977 # protect against silly names
978 ($var = $param)=~tr/a-zA-Z0-9_/_/c;
979 $var =~ s/^(?=\d)/_/;
980 local *symbol = "${namespace}::$var";
981 @value = $self->param($param);
988 #### Method: keywords
989 # Keywords acts a bit differently. Calling it in a list context
990 # returns the list of keywords.
991 # Calling it in a scalar context gives you the size of the list.
993 'keywords' => <<'END_OF_FUNC',
995 my($self,@values) = self_or_default(@_);
996 # If values is provided, then we set it.
997 $self->{'keywords'}=[@values] if @values;
998 my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
1003 # These are some tie() interfaces for compatibility
1004 # with Steve Brenner's cgi-lib.pl routines
1005 'Vars' => <<'END_OF_FUNC',
1010 return %in if wantarray;
1015 # These are some tie() interfaces for compatibility
1016 # with Steve Brenner's cgi-lib.pl routines
1017 'ReadParse' => <<'END_OF_FUNC',
1024 *in=*{"${pkg}::in"};
1027 return scalar(keys %in);
1031 'PrintHeader' => <<'END_OF_FUNC',
1033 my($self) = self_or_default(@_);
1034 return $self->header();
1038 'HtmlTop' => <<'END_OF_FUNC',
1040 my($self,@p) = self_or_default(@_);
1041 return $self->start_html(@p);
1045 'HtmlBot' => <<'END_OF_FUNC',
1047 my($self,@p) = self_or_default(@_);
1048 return $self->end_html(@p);
1052 'SplitParam' => <<'END_OF_FUNC',
1055 my (@params) = split ("\0", $param);
1056 return (wantarray ? @params : $params[0]);
1060 'MethGet' => <<'END_OF_FUNC',
1062 return request_method() eq 'GET';
1066 'MethPost' => <<'END_OF_FUNC',
1068 return request_method() eq 'POST';
1072 'TIEHASH' => <<'END_OF_FUNC',
1076 if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
1079 return $Q ||= $class->new(@_);
1083 'STORE' => <<'END_OF_FUNC',
1088 my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
1089 $self->param(-name=>$tag,-value=>\@vals);
1093 'FETCH' => <<'END_OF_FUNC',
1095 return $_[0] if $_[1] eq 'CGI';
1096 return undef unless defined $_[0]->param($_[1]);
1097 return join("\0",$_[0]->param($_[1]));
1101 'FIRSTKEY' => <<'END_OF_FUNC',
1103 $_[0]->{'.iterator'}=0;
1104 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1108 'NEXTKEY' => <<'END_OF_FUNC',
1110 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1114 'EXISTS' => <<'END_OF_FUNC',
1116 exists $_[0]->{$_[1]};
1120 'DELETE' => <<'END_OF_FUNC',
1122 $_[0]->delete($_[1]);
1126 'CLEAR' => <<'END_OF_FUNC',
1134 # Append a new value to an existing query
1136 'append' => <<'EOF',
1138 my($self,@p) = self_or_default(@_);
1139 my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
1140 my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
1142 $self->add_parameter($name);
1143 push(@{$self->{$name}},@values);
1145 return $self->param($name);
1149 #### Method: delete_all
1150 # Delete all parameters
1152 'delete_all' => <<'EOF',
1154 my($self) = self_or_default(@_);
1155 my @param = $self->param();
1156 $self->delete(@param);
1160 'Delete' => <<'EOF',
1162 my($self,@p) = self_or_default(@_);
1167 'Delete_all' => <<'EOF',
1169 my($self,@p) = self_or_default(@_);
1170 $self->delete_all(@p);
1174 #### Method: autoescape
1175 # If you want to turn off the autoescaping features,
1176 # call this method with undef as the argument
1177 'autoEscape' => <<'END_OF_FUNC',
1179 my($self,$escape) = self_or_default(@_);
1180 my $d = $self->{'escape'};
1181 $self->{'escape'} = $escape;
1187 #### Method: version
1188 # Return the current version
1190 'version' => <<'END_OF_FUNC',
1196 #### Method: url_param
1197 # Return a parameter in the QUERY_STRING, regardless of
1198 # whether this was a POST or a GET
1200 'url_param' => <<'END_OF_FUNC',
1202 my ($self,@p) = self_or_default(@_);
1203 my $name = shift(@p);
1204 return undef unless exists($ENV{QUERY_STRING});
1205 unless (exists($self->{'.url_param'})) {
1206 $self->{'.url_param'}={}; # empty hash
1207 if ($ENV{QUERY_STRING} =~ /=/) {
1208 my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
1211 ($param,$value) = split('=',$_,2);
1212 $param = unescape($param);
1213 $value = unescape($value);
1214 push(@{$self->{'.url_param'}->{$param}},$value);
1217 $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
1220 return keys %{$self->{'.url_param'}} unless defined($name);
1221 return () unless $self->{'.url_param'}->{$name};
1222 return wantarray ? @{$self->{'.url_param'}->{$name}}
1223 : $self->{'.url_param'}->{$name}->[0];
1228 # Returns a string in which all the known parameter/value
1229 # pairs are represented as nested lists, mainly for the purposes
1232 'Dump' => <<'END_OF_FUNC',
1234 my($self) = self_or_default(@_);
1235 my($param,$value,@result);
1236 return '<ul></ul>' unless $self->param;
1237 push(@result,"<ul>");
1238 foreach $param ($self->param) {
1239 my($name)=$self->escapeHTML($param);
1240 push(@result,"<li><strong>$param</strong></li>");
1241 push(@result,"<ul>");
1242 foreach $value ($self->param($param)) {
1243 $value = $self->escapeHTML($value);
1244 $value =~ s/\n/<br \/>\n/g;
1245 push(@result,"<li>$value</li>");
1247 push(@result,"</ul>");
1249 push(@result,"</ul>");
1250 return join("\n",@result);
1254 #### Method as_string
1256 # synonym for "dump"
1258 'as_string' => <<'END_OF_FUNC',
1265 # Write values out to a filehandle in such a way that they can
1266 # be reinitialized by the filehandle form of the new() method
1268 'save' => <<'END_OF_FUNC',
1270 my($self,$filehandle) = self_or_default(@_);
1271 $filehandle = to_filehandle($filehandle);
1273 local($,) = ''; # set print field separator back to a sane value
1274 local($\) = ''; # set output line separator to a sane value
1275 foreach $param ($self->param) {
1276 my($escaped_param) = escape($param);
1278 foreach $value ($self->param($param)) {
1279 print $filehandle "$escaped_param=",escape("$value"),"\n";
1282 foreach (keys %{$self->{'.fieldnames'}}) {
1283 print $filehandle ".cgifields=",escape("$_"),"\n";
1285 print $filehandle "=\n"; # end of record
1290 #### Method: save_parameters
1291 # An alias for save() that is a better name for exportation.
1292 # Only intended to be used with the function (non-OO) interface.
1294 'save_parameters' => <<'END_OF_FUNC',
1295 sub save_parameters {
1297 return save(to_filehandle($fh));
1301 #### Method: restore_parameters
1302 # A way to restore CGI parameters from an initializer.
1303 # Only intended to be used with the function (non-OO) interface.
1305 'restore_parameters' => <<'END_OF_FUNC',
1306 sub restore_parameters {
1307 $Q = $CGI::DefaultClass->new(@_);
1311 #### Method: multipart_init
1312 # Return a Content-Type: style header for server-push
1313 # This has to be NPH on most web servers, and it is advisable to set $| = 1
1315 # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1316 # contribution, updated by Andrew Benham (adsb@bigfoot.com)
1318 'multipart_init' => <<'END_OF_FUNC',
1319 sub multipart_init {
1320 my($self,@p) = self_or_default(@_);
1321 my($boundary,@other) = rearrange([BOUNDARY],@p);
1322 $boundary = $boundary || '------- =_aaaaaaaaaa0';
1323 $self->{'separator'} = "$CRLF--$boundary$CRLF";
1324 $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
1325 $type = SERVER_PUSH($boundary);
1326 return $self->header(
1329 (map { split "=", $_, 2 } @other),
1330 ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
1335 #### Method: multipart_start
1336 # Return a Content-Type: style header for server-push, start of section
1338 # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1339 # contribution, updated by Andrew Benham (adsb@bigfoot.com)
1341 'multipart_start' => <<'END_OF_FUNC',
1342 sub multipart_start {
1344 my($self,@p) = self_or_default(@_);
1345 my($type,@other) = rearrange([TYPE],@p);
1346 $type = $type || 'text/html';
1347 push(@header,"Content-Type: $type");
1349 # rearrange() was designed for the HTML portion, so we
1350 # need to fix it up a little.
1352 # Don't use \s because of perl bug 21951
1353 next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
1354 ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
1356 push(@header,@other);
1357 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1363 #### Method: multipart_end
1364 # Return a MIME boundary separator for server-push, end of section
1366 # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1369 'multipart_end' => <<'END_OF_FUNC',
1371 my($self,@p) = self_or_default(@_);
1372 return $self->{'separator'};
1377 #### Method: multipart_final
1378 # Return a MIME boundary separator for server-push, end of all sections
1380 # Contributed by Andrew Benham (adsb@bigfoot.com)
1382 'multipart_final' => <<'END_OF_FUNC',
1383 sub multipart_final {
1384 my($self,@p) = self_or_default(@_);
1385 return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
1391 # Return a Content-Type: style header
1394 'header' => <<'END_OF_FUNC',
1396 my($self,@p) = self_or_default(@_);
1399 return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
1401 my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
1402 rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
1403 'STATUS',['COOKIE','COOKIES'],'TARGET',
1404 'EXPIRES','NPH','CHARSET',
1405 'ATTACHMENT','P3P'],@p);
1408 if (defined $charset) {
1409 $self->charset($charset);
1411 $charset = $self->charset;
1414 # rearrange() was designed for the HTML portion, so we
1415 # need to fix it up a little.
1417 # Don't use \s because of perl bug 21951
1418 next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
1419 ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
1422 $type ||= 'text/html' unless defined($type);
1423 $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/ and $charset ne '';
1425 # Maybe future compatibility. Maybe not.
1426 my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
1427 push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
1428 push(@header,"Server: " . &server_software()) if $nph;
1430 push(@header,"Status: $status") if $status;
1431 push(@header,"Window-Target: $target") if $target;
1433 $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
1434 push(@header,qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p"));
1436 # push all the cookies -- there may be several
1438 my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
1440 my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
1441 push(@header,"Set-Cookie: $cs") if $cs ne '';
1444 # if the user indicates an expiration time, then we need
1445 # both an Expires and a Date header (so that the browser is
1447 push(@header,"Expires: " . expires($expires,'http'))
1449 push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
1450 push(@header,"Pragma: no-cache") if $self->cache();
1451 push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
1452 push(@header,map {ucfirst $_} @other);
1453 push(@header,"Content-Type: $type") if $type ne '';
1454 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1455 if ($MOD_PERL and not $nph) {
1456 $self->r->send_cgi_header($header);
1465 # Control whether header() will produce the no-cache
1468 'cache' => <<'END_OF_FUNC',
1470 my($self,$new_value) = self_or_default(@_);
1471 $new_value = '' unless $new_value;
1472 if ($new_value ne '') {
1473 $self->{'cache'} = $new_value;
1475 return $self->{'cache'};
1480 #### Method: redirect
1481 # Return a Location: style header
1484 'redirect' => <<'END_OF_FUNC',
1486 my($self,@p) = self_or_default(@_);
1487 my($url,$target,$status,$cookie,$nph,@other) =
1488 rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p);
1489 $status = '302 Moved' unless defined $status;
1490 $url ||= $self->self_url;
1492 foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
1494 '-Status' => $status,
1497 unshift(@o,'-Target'=>$target) if $target;
1498 unshift(@o,'-Type'=>'');
1500 unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
1501 return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
1506 #### Method: start_html
1507 # Canned HTML header
1510 # $title -> (optional) The title for this HTML document (-title)
1511 # $author -> (optional) e-mail address of the author (-author)
1512 # $base -> (optional) if set to true, will enter the BASE address of this document
1513 # for resolving relative references (-base)
1514 # $xbase -> (optional) alternative base at some remote location (-xbase)
1515 # $target -> (optional) target window to load all links into (-target)
1516 # $script -> (option) Javascript code (-script)
1517 # $no_script -> (option) Javascript <noscript> tag (-noscript)
1518 # $meta -> (optional) Meta information tags
1519 # $head -> (optional) any other elements you'd like to incorporate into the <head> tag
1520 # (a scalar or array ref)
1521 # $style -> (optional) reference to an external style sheet
1522 # @other -> (optional) any other named parameters you'd like to incorporate into
1525 'start_html' => <<'END_OF_FUNC',
1527 my($self,@p) = &self_or_default(@_);
1528 my($title,$author,$base,$xbase,$script,$noscript,
1529 $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) =
1530 rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,
1531 META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p);
1533 $self->element_id(0);
1534 $self->element_tab(0);
1536 $encoding = 'iso-8859-1' unless defined $encoding;
1538 # Need to sort out the DTD before it's okay to call escapeHTML().
1539 my(@result,$xml_dtd);
1541 if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
1542 $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
1544 $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
1547 $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
1550 $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
1551 $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
1552 push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml;
1554 if (ref($dtd) && ref($dtd) eq 'ARRAY') {
1555 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
1556 $DTD_PUBLIC_IDENTIFIER = $dtd->[0];
1558 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
1559 $DTD_PUBLIC_IDENTIFIER = $dtd;
1562 # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
1563 # call escapeHTML(). Strangely enough, the title needs to be escaped as
1564 # HTML while the author needs to be escaped as a URL.
1565 $title = $self->escapeHTML($title || 'Untitled Document');
1566 $author = $self->escape($author);
1568 if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2)/i) {
1569 $lang = "" unless defined $lang;
1573 $lang = 'en-US' unless defined $lang;
1576 my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : '';
1577 my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />)
1578 if $XHTML && $encoding && !$declare_xml;
1580 push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>)
1581 : ($lang ? qq(<html lang="$lang">) : "<html>")
1582 . "<head><title>$title</title>");
1583 if (defined $author) {
1584 push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
1585 : "<link rev=\"made\" href=\"mailto:$author\">");
1588 if ($base || $xbase || $target) {
1589 my $href = $xbase || $self->url('-path'=>1);
1590 my $t = $target ? qq/ target="$target"/ : '';
1591 push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
1594 if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
1595 foreach (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
1596 : qq(<meta name="$_" content="$meta->{$_}">)); }
1599 push(@result,ref($head) ? @$head : $head) if $head;
1601 # handle the infrequently-used -style and -script parameters
1602 push(@result,$self->_style($style)) if defined $style;
1603 push(@result,$self->_script($script)) if defined $script;
1604 push(@result,$meta_bits) if defined $meta_bits;
1606 # handle -noscript parameter
1607 push(@result,<<END) if $noscript;
1613 my($other) = @other ? " @other" : '';
1614 push(@result,"</head>\n<body$other>\n");
1615 return join("\n",@result);
1620 # internal method for generating a CSS style section
1622 '_style' => <<'END_OF_FUNC',
1624 my ($self,$style) = @_;
1626 my $type = 'text/css';
1628 my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
1629 my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
1631 my @s = ref($style) eq 'ARRAY' ? @$style : $style;
1635 my($src,$code,$verbatim,$stype,$foo,@other) =
1636 rearrange([qw(SRC CODE VERBATIM TYPE FOO)],
1638 ref($s) eq 'ARRAY' ? @$s : %$s));
1639 $type = $stype if $stype;
1640 my $other = @other ? join ' ',@other : '';
1642 if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
1643 { # If it is, push a LINK tag for each one
1644 foreach $src (@$src)
1646 push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
1647 : qq(<link rel="stylesheet" type="$type" href="$src"$other>)) if $src;
1651 { # Otherwise, push the single -src, if it exists.
1652 push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
1653 : qq(<link rel="stylesheet" type="$type" href="$src"$other>)
1657 my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim;
1658 push(@result, "<style type=\"text/css\">\n$_\n</style>") foreach @v;
1660 my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code;
1661 push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) foreach @c;
1665 push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
1666 : qq(<link rel="stylesheet" type="$type" href="$src"$other>));
1673 '_script' => <<'END_OF_FUNC',
1675 my ($self,$script) = @_;
1678 my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
1679 foreach $script (@scripts) {
1680 my($src,$code,$language);
1681 if (ref($script)) { # script is a hash
1682 ($src,$code,$language, $type) =
1683 rearrange([SRC,CODE,LANGUAGE,TYPE],
1684 '-foo'=>'bar', # a trick to allow the '-' to be omitted
1685 ref($script) eq 'ARRAY' ? @$script : %$script);
1686 # User may not have specified language
1687 $language ||= 'JavaScript';
1688 unless (defined $type) {
1689 $type = lc $language;
1690 # strip '1.2' from 'javascript1.2'
1691 $type =~ s/^(\D+).*$/text\/$1/;
1694 ($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript');
1697 my $comment = '//'; # javascript by default
1698 $comment = '#' if $type=~/perl|tcl/i;
1699 $comment = "'" if $type=~/vbscript/i;
1701 my ($cdata_start,$cdata_end);
1703 $cdata_start = "$comment<![CDATA[\n";
1704 $cdata_end .= "\n$comment]]>";
1706 $cdata_start = "\n<!-- Hide script\n";
1707 $cdata_end = $comment;
1708 $cdata_end .= " End script hiding -->\n";
1711 push(@satts,'src'=>$src) if $src;
1712 push(@satts,'language'=>$language) unless defined $type;
1713 push(@satts,'type'=>$type);
1714 $code = $cdata_start . $code . $cdata_end if defined $code;
1715 push(@result,$self->script({@satts},$code || ''));
1721 #### Method: end_html
1722 # End an HTML document.
1723 # Trivial method for completeness. Just returns "</body>"
1725 'end_html' => <<'END_OF_FUNC',
1727 return "\n</body>\n</html>";
1732 ################################
1733 # METHODS USED IN BUILDING FORMS
1734 ################################
1736 #### Method: isindex
1737 # Just prints out the isindex tag.
1739 # $action -> optional URL of script to run
1741 # A string containing a <isindex> tag
1742 'isindex' => <<'END_OF_FUNC',
1744 my($self,@p) = self_or_default(@_);
1745 my($action,@other) = rearrange([ACTION],@p);
1746 $action = qq/ action="$action"/ if $action;
1747 my($other) = @other ? " @other" : '';
1748 return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>";
1753 #### Method: startform
1756 # $method -> optional submission method to use (GET or POST)
1757 # $action -> optional URL of script to run
1758 # $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1759 'startform' => <<'END_OF_FUNC',
1761 my($self,@p) = self_or_default(@_);
1763 my($method,$action,$enctype,@other) =
1764 rearrange([METHOD,ACTION,ENCTYPE],@p);
1766 $method = $self->escapeHTML(lc($method) || 'post');
1767 $enctype = $self->escapeHTML($enctype || &URL_ENCODED);
1768 if (defined $action) {
1769 $action = $self->escapeHTML($action);
1772 $action = $self->escapeHTML($self->url(-absolute=>1,-path=>1));
1773 if (exists $ENV{QUERY_STRING} && length($ENV{QUERY_STRING})>0) {
1774 $action .= "?".$self->escapeHTML($ENV{QUERY_STRING},1);
1777 $action = qq(action="$action");
1778 my($other) = @other ? " @other" : '';
1779 $self->{'.parametersToAdd'}={};
1780 return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
1785 #### Method: start_form
1786 # synonym for startform
1787 'start_form' => <<'END_OF_FUNC',
1789 $XHTML ? &start_multipart_form : &startform;
1793 'end_multipart_form' => <<'END_OF_FUNC',
1794 sub end_multipart_form {
1799 #### Method: start_multipart_form
1800 # synonym for startform
1801 'start_multipart_form' => <<'END_OF_FUNC',
1802 sub start_multipart_form {
1803 my($self,@p) = self_or_default(@_);
1804 if (defined($param[0]) && substr($param[0],0,1) eq '-') {
1806 $p{'-enctype'}=&MULTIPART;
1807 return $self->startform(%p);
1809 my($method,$action,@other) =
1810 rearrange([METHOD,ACTION],@p);
1811 return $self->startform($method,$action,&MULTIPART,@other);
1817 #### Method: endform
1819 'endform' => <<'END_OF_FUNC',
1821 my($self,@p) = self_or_default(@_);
1823 return wantarray ? ("</form>") : "\n</form>";
1825 return wantarray ? ("<div>",$self->get_fields,"</div>","</form>") :
1826 "<div>".$self->get_fields ."</div>\n</form>";
1832 '_textfield' => <<'END_OF_FUNC',
1834 my($self,$tag,@p) = self_or_default(@_);
1835 my($name,$default,$size,$maxlength,$override,$tabindex,@other) =
1836 rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p);
1838 my $current = $override ? $default :
1839 (defined($self->param($name)) ? $self->param($name) : $default);
1841 $current = defined($current) ? $self->escapeHTML($current,1) : '';
1842 $name = defined($name) ? $self->escapeHTML($name) : '';
1843 my($s) = defined($size) ? qq/ size="$size"/ : '';
1844 my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
1845 my($other) = @other ? " @other" : '';
1846 # this entered at cristy's request to fix problems with file upload fields
1847 # and WebTV -- not sure it won't break stuff
1848 my($value) = $current ne '' ? qq(value="$current") : '';
1849 $tabindex = $self->element_tab($tabindex);
1850 return $XHTML ? qq(<input type="$tag" name="$name" tabindex="$tabindex" $value$s$m$other />)
1851 : qq(<input type="$tag" name="$name" $value$s$m$other>);
1855 #### Method: textfield
1857 # $name -> Name of the text field
1858 # $default -> Optional default value of the field if not
1860 # $size -> Optional width of field in characaters.
1861 # $maxlength -> Optional maximum number of characters.
1863 # A string containing a <input type="text"> field
1865 'textfield' => <<'END_OF_FUNC',
1867 my($self,@p) = self_or_default(@_);
1868 $self->_textfield('text',@p);
1873 #### Method: filefield
1875 # $name -> Name of the file upload field
1876 # $size -> Optional width of field in characaters.
1877 # $maxlength -> Optional maximum number of characters.
1879 # A string containing a <input type="file"> field
1881 'filefield' => <<'END_OF_FUNC',
1883 my($self,@p) = self_or_default(@_);
1884 $self->_textfield('file',@p);
1889 #### Method: password
1890 # Create a "secret password" entry field
1892 # $name -> Name of the field
1893 # $default -> Optional default value of the field if not
1895 # $size -> Optional width of field in characters.
1896 # $maxlength -> Optional maximum characters that can be entered.
1898 # A string containing a <input type="password"> field
1900 'password_field' => <<'END_OF_FUNC',
1901 sub password_field {
1902 my ($self,@p) = self_or_default(@_);
1903 $self->_textfield('password',@p);
1907 #### Method: textarea
1909 # $name -> Name of the text field
1910 # $default -> Optional default value of the field if not
1912 # $rows -> Optional number of rows in text area
1913 # $columns -> Optional number of columns in text area
1915 # A string containing a <textarea></textarea> tag
1917 'textarea' => <<'END_OF_FUNC',
1919 my($self,@p) = self_or_default(@_);
1920 my($name,$default,$rows,$cols,$override,$tabindex,@other) =
1921 rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p);
1923 my($current)= $override ? $default :
1924 (defined($self->param($name)) ? $self->param($name) : $default);
1926 $name = defined($name) ? $self->escapeHTML($name) : '';
1927 $current = defined($current) ? $self->escapeHTML($current) : '';
1928 my($r) = $rows ? qq/ rows="$rows"/ : '';
1929 my($c) = $cols ? qq/ cols="$cols"/ : '';
1930 my($other) = @other ? " @other" : '';
1931 $tabindex = $self->element_tab($tabindex);
1932 return qq{<textarea name="$name" tabindex="$tabindex"$r$c$other>$current</textarea>};
1938 # Create a javascript button.
1940 # $name -> (optional) Name for the button. (-name)
1941 # $value -> (optional) Value of the button when selected (and visible name) (-value)
1942 # $onclick -> (optional) Text of the JavaScript to run when the button is
1945 # A string containing a <input type="button"> tag
1947 'button' => <<'END_OF_FUNC',
1949 my($self,@p) = self_or_default(@_);
1951 my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],
1952 [ONCLICK,SCRIPT],TABINDEX],@p);
1954 $label=$self->escapeHTML($label);
1955 $value=$self->escapeHTML($value,1);
1956 $script=$self->escapeHTML($script);
1959 $name = qq/ name="$label"/ if $label;
1960 $value = $value || $label;
1962 $val = qq/ value="$value"/ if $value;
1963 $script = qq/ onclick="$script"/ if $script;
1964 my($other) = @other ? " @other" : '';
1965 $tabindex = $self->element_tab($tabindex);
1966 return $XHTML ? qq(<input type="button" tabindex="$tabindex"$name$val$script$other />)
1967 : qq(<input type="button"$name$val$script$other>);
1973 # Create a "submit query" button.
1975 # $name -> (optional) Name for the button.
1976 # $value -> (optional) Value of the button when selected (also doubles as label).
1977 # $label -> (optional) Label printed on the button(also doubles as the value).
1979 # A string containing a <input type="submit"> tag
1981 'submit' => <<'END_OF_FUNC',
1983 my($self,@p) = self_or_default(@_);
1985 my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p);
1987 $label=$self->escapeHTML($label);
1988 $value=$self->escapeHTML($value,1);
1990 my $name = $NOSTICKY ? '' : ' name=".submit"';
1991 $name = qq/ name="$label"/ if defined($label);
1992 $value = defined($value) ? $value : $label;
1994 $val = qq/ value="$value"/ if defined($value);
1995 $tabindex = $self->element_tab($tabindex);
1996 my($other) = @other ? " @other" : '';
1997 return $XHTML ? qq(<input type="submit" tabindex="$tabindex"$name$val$other />)
1998 : qq(<input type="submit"$name$val$other>);
2004 # Create a "reset" button.
2006 # $name -> (optional) Name for the button.
2008 # A string containing a <input type="reset"> tag
2010 'reset' => <<'END_OF_FUNC',
2012 my($self,@p) = self_or_default(@_);
2013 my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p);
2014 $label=$self->escapeHTML($label);
2015 $value=$self->escapeHTML($value,1);
2016 my ($name) = ' name=".reset"';
2017 $name = qq/ name="$label"/ if defined($label);
2018 $value = defined($value) ? $value : $label;
2020 $val = qq/ value="$value"/ if defined($value);
2021 my($other) = @other ? " @other" : '';
2022 $tabindex = $self->element_tab($tabindex);
2023 return $XHTML ? qq(<input type="reset" tabindex="$tabindex"$name$val$other />)
2024 : qq(<input type="reset"$name$val$other>);
2029 #### Method: defaults
2030 # Create a "defaults" button.
2032 # $name -> (optional) Name for the button.
2034 # A string containing a <input type="submit" name=".defaults"> tag
2036 # Note: this button has a special meaning to the initialization script,
2037 # and tells it to ERASE the current query string so that your defaults
2040 'defaults' => <<'END_OF_FUNC',
2042 my($self,@p) = self_or_default(@_);
2044 my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p);
2046 $label=$self->escapeHTML($label,1);
2047 $label = $label || "Defaults";
2048 my($value) = qq/ value="$label"/;
2049 my($other) = @other ? " @other" : '';
2050 $tabindex = $self->element_tab($tabindex);
2051 return $XHTML ? qq(<input type="submit" name=".defaults" tabindex="$tabindex"$value$other />)
2052 : qq/<input type="submit" NAME=".defaults"$value$other>/;
2057 #### Method: comment
2058 # Create an HTML <!-- comment -->
2059 # Parameters: a string
2060 'comment' => <<'END_OF_FUNC',
2062 my($self,@p) = self_or_CGI(@_);
2063 return "<!-- @p -->";
2067 #### Method: checkbox
2068 # Create a checkbox that is not logically linked to any others.
2069 # The field value is "on" when the button is checked.
2071 # $name -> Name of the checkbox
2072 # $checked -> (optional) turned on by default if true
2073 # $value -> (optional) value of the checkbox, 'on' by default
2074 # $label -> (optional) a user-readable label printed next to the box.
2075 # Otherwise the checkbox name is used.
2077 # A string containing a <input type="checkbox"> field
2079 'checkbox' => <<'END_OF_FUNC',
2081 my($self,@p) = self_or_default(@_);
2083 my($name,$checked,$value,$label,$override,$tabindex,@other) =
2084 rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE],TABINDEX],@p);
2086 $value = defined $value ? $value : 'on';
2088 if (!$override && ($self->{'.fieldnames'}->{$name} ||
2089 defined $self->param($name))) {
2090 $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
2092 $checked = $self->_checked($checked);
2094 my($the_label) = defined $label ? $label : $name;
2095 $name = $self->escapeHTML($name);
2096 $value = $self->escapeHTML($value,1);
2097 $the_label = $self->escapeHTML($the_label);
2098 my($other) = @other ? " @other" : '';
2099 $tabindex = $self->element_tab($tabindex);
2100 $self->register_parameter($name);
2101 return $XHTML ? CGI::label(qq{<input type="checkbox" name="$name" value="$value" tabindex="$tabindex"$checked$other />$the_label})
2102 : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
2108 # Escape HTML -- used internally
2109 'escapeHTML' => <<'END_OF_FUNC',
2111 # hack to work around earlier hacks
2112 push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
2113 my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
2114 return undef unless defined($toencode);
2115 return $toencode if ref($self) && !$self->{'escape'};
2116 $toencode =~ s{&}{&}gso;
2117 $toencode =~ s{<}{<}gso;
2118 $toencode =~ s{>}{>}gso;
2119 if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
2120 # $quot; was accidentally omitted from the HTML 3.2 DTD -- see
2121 # <http://validator.w3.org/docs/errors.html#bad-entity> /
2122 # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
2123 $toencode =~ s{"}{"}gso;
2126 $toencode =~ s{"}{"}gso;
2128 my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' ||
2129 uc $self->{'.charset'} eq 'WINDOWS-1252';
2130 if ($latin) { # bug in some browsers
2131 $toencode =~ s{'}{'}gso;
2132 $toencode =~ s{\x8b}{‹}gso;
2133 $toencode =~ s{\x9b}{›}gso;
2134 if (defined $newlinestoo && $newlinestoo) {
2135 $toencode =~ s{\012}{ }gso;
2136 $toencode =~ s{\015}{ }gso;
2143 # unescape HTML -- used internally
2144 'unescapeHTML' => <<'END_OF_FUNC',
2146 # hack to work around earlier hacks
2147 push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
2148 my ($self,$string) = CGI::self_or_default(@_);
2149 return undef unless defined($string);
2150 my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
2152 # thanks to Randal Schwartz for the correct solution to this one
2153 $string=~ s[&(.*?);]{
2159 /^#(\d+)$/ && $latin ? chr($1) :
2160 /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
2167 # Internal procedure - don't use
2168 '_tableize' => <<'END_OF_FUNC',
2170 my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
2171 my @rowheaders = $rowheaders ? @$rowheaders : ();
2172 my @colheaders = $colheaders ? @$colheaders : ();
2175 if (defined($columns)) {
2176 $rows = int(0.99 + @elements/$columns) unless defined($rows);
2178 if (defined($rows)) {
2179 $columns = int(0.99 + @elements/$rows) unless defined($columns);
2182 # rearrange into a pretty table
2183 $result = "<table>";
2185 unshift(@colheaders,'') if @colheaders && @rowheaders;
2186 $result .= "<tr>" if @colheaders;
2187 foreach (@colheaders) {
2188 $result .= "<th>$_</th>";
2190 for ($row=0;$row<$rows;$row++) {
2192 $result .= "<th>$rowheaders[$row]</th>" if @rowheaders;
2193 for ($column=0;$column<$columns;$column++) {
2194 $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
2195 if defined($elements[$column*$rows + $row]);
2199 $result .= "</table>";
2205 #### Method: radio_group
2206 # Create a list of logically-linked radio buttons.
2208 # $name -> Common name for all the buttons.
2209 # $values -> A pointer to a regular array containing the
2210 # values for each button in the group.
2211 # $default -> (optional) Value of the button to turn on by default. Pass '-'
2212 # to turn _nothing_ on.
2213 # $linebreak -> (optional) Set to true to place linebreaks
2214 # between the buttons.
2215 # $labels -> (optional)
2216 # A pointer to an associative array of labels to print next to each checkbox
2217 # in the form $label{'value'}="Long explanatory label".
2218 # Otherwise the provided values are used as the labels.
2220 # An ARRAY containing a series of <input type="radio"> fields
2222 'radio_group' => <<'END_OF_FUNC',
2224 my($self,@p) = self_or_default(@_);
2225 $self->_box_group('radio',@p);
2229 #### Method: checkbox_group
2230 # Create a list of logically-linked checkboxes.
2232 # $name -> Common name for all the check boxes
2233 # $values -> A pointer to a regular array containing the
2234 # values for each checkbox in the group.
2235 # $defaults -> (optional)
2236 # 1. If a pointer to a regular array of checkbox values,
2237 # then this will be used to decide which
2238 # checkboxes to turn on by default.
2239 # 2. If a scalar, will be assumed to hold the
2240 # value of a single checkbox in the group to turn on.
2241 # $linebreak -> (optional) Set to true to place linebreaks
2242 # between the buttons.
2243 # $labels -> (optional)
2244 # A pointer to an associative array of labels to print next to each checkbox
2245 # in the form $label{'value'}="Long explanatory label".
2246 # Otherwise the provided values are used as the labels.
2248 # An ARRAY containing a series of <input type="checkbox"> fields
2251 'checkbox_group' => <<'END_OF_FUNC',
2252 sub checkbox_group {
2253 my($self,@p) = self_or_default(@_);
2254 $self->_box_group('checkbox',@p);
2258 '_box_group' => <<'END_OF_FUNC',
2261 my $box_type = shift;
2263 my($name,$values,$defaults,$linebreak,$labels,$attributes,
2264 $rows,$columns,$rowheaders,$colheaders,
2265 $override,$nolabels,$tabindex,@other) =
2266 rearrange([ NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,ATTRIBUTES,
2267 ROWS,[COLUMNS,COLS],ROWHEADERS,COLHEADERS,
2268 [OVERRIDE,FORCE],NOLABELS,TABINDEX
2270 my($result,$checked);
2273 my(@elements,@values);
2274 @values = $self->_set_values_and_labels($values,\$labels,$name);
2275 my %checked = $self->previous_or_default($name,$defaults,$override);
2277 # If no check array is specified, check the first by default
2278 $checked{$values[0]}++ if $box_type eq 'radio' && !%checked;
2280 $name=$self->escapeHTML($name);
2284 if (!ref $tabindex) {
2285 $self->element_tab($tabindex);
2286 } elsif (ref $tabindex eq 'ARRAY') {
2287 %tabs = map {$_=>$self->element_tab} @$tabindex;
2288 } elsif (ref $tabindex eq 'HASH') {
2292 %tabs = map {$_=>$self->element_tab} @values unless %tabs;
2294 my $other = @other ? " @other" : '';
2297 my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
2301 $break = $XHTML ? "<br />" : "<br>";
2307 unless (defined($nolabels) && $nolabels) {
2309 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2310 $label = $self->escapeHTML($label,1);
2312 my $attribs = $self->_set_attributes($_, $attributes);
2313 my $tab = qq( tabindex="$tabs{$_}") if exists $tabs{$_};
2314 $_=$self->escapeHTML($_);
2318 qq(<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs />$label)).${break};
2320 push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs>${label}${break}/);
2323 $self->register_parameter($name);
2324 return wantarray ? @elements : "@elements"
2325 unless defined($columns) || defined($rows);
2326 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
2331 #### Method: popup_menu
2332 # Create a popup menu.
2334 # $name -> Name for all the menu
2335 # $values -> A pointer to a regular array containing the
2336 # text of each menu item.
2337 # $default -> (optional) Default item to display
2338 # $labels -> (optional)
2339 # A pointer to an associative array of labels to print next to each checkbox
2340 # in the form $label{'value'}="Long explanatory label".
2341 # Otherwise the provided values are used as the labels.
2343 # A string containing the definition of a popup menu.
2345 'popup_menu' => <<'END_OF_FUNC',
2347 my($self,@p) = self_or_default(@_);
2349 my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) =
2350 rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
2351 ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
2352 my($result,$selected);
2354 if (!$override && defined($self->param($name))) {
2355 $selected = $self->param($name);
2357 $selected = $default;
2359 $name=$self->escapeHTML($name);
2360 my($other) = @other ? " @other" : '';
2363 @values = $self->_set_values_and_labels($values,\$labels,$name);
2364 $tabindex = $self->element_tab($tabindex);
2365 $result = qq/<select name="$name" tabindex="$tabindex"$other>\n/;
2368 foreach (split(/\n/)) {
2369 my $selectit = $XHTML ? 'selected="selected"' : 'selected';
2370 s/(value="$selected")/$selectit $1/ if defined $selected;
2375 my $attribs = $self->_set_attributes($_, $attributes);
2376 my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : '';
2378 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2379 my($value) = $self->escapeHTML($_);
2380 $label=$self->escapeHTML($label,1);
2381 $result .= "<option$selectit$attribs value=\"$value\">$label</option>\n";
2385 $result .= "</select>";
2391 #### Method: optgroup
2392 # Create a optgroup.
2394 # $name -> Label for the group
2395 # $values -> A pointer to a regular array containing the
2396 # values for each option line in the group.
2397 # $labels -> (optional)
2398 # A pointer to an associative array of labels to print next to each item
2399 # in the form $label{'value'}="Long explanatory label".
2400 # Otherwise the provided values are used as the labels.
2401 # $labeled -> (optional)
2402 # A true value indicates the value should be used as the label attribute
2403 # in the option elements.
2404 # The label attribute specifies the option label presented to the user.
2405 # This defaults to the content of the <option> element, but the label
2406 # attribute allows authors to more easily use optgroup without sacrificing
2407 # compatibility with browsers that do not support option groups.
2408 # $novals -> (optional)
2409 # A true value indicates to suppress the val attribute in the option elements
2411 # A string containing the definition of an option group.
2413 'optgroup' => <<'END_OF_FUNC',
2415 my($self,@p) = self_or_default(@_);
2416 my($name,$values,$attributes,$labeled,$noval,$labels,@other)
2417 = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p);
2419 my($result,@values);
2420 @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
2421 my($other) = @other ? " @other" : '';
2423 $name=$self->escapeHTML($name);
2424 $result = qq/<optgroup label="$name"$other>\n/;
2427 foreach (split(/\n/)) {
2428 my $selectit = $XHTML ? 'selected="selected"' : 'selected';
2429 s/(value="$selected")/$selectit $1/ if defined $selected;
2434 my $attribs = $self->_set_attributes($_, $attributes);
2436 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2437 $label=$self->escapeHTML($label);
2438 my($value)=$self->escapeHTML($_,1);
2439 $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
2440 : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
2441 : $novals ? "<option$attribs>$label</option>\n"
2442 : "<option$attribs value=\"$value\">$label</option>\n";
2445 $result .= "</optgroup>";
2451 #### Method: scrolling_list
2452 # Create a scrolling list.
2454 # $name -> name for the list
2455 # $values -> A pointer to a regular array containing the
2456 # values for each option line in the list.
2457 # $defaults -> (optional)
2458 # 1. If a pointer to a regular array of options,
2459 # then this will be used to decide which
2460 # lines to turn on by default.
2461 # 2. Otherwise holds the value of the single line to turn on.
2462 # $size -> (optional) Size of the list.
2463 # $multiple -> (optional) If set, allow multiple selections.
2464 # $labels -> (optional)
2465 # A pointer to an associative array of labels to print next to each checkbox
2466 # in the form $label{'value'}="Long explanatory label".
2467 # Otherwise the provided values are used as the labels.
2469 # A string containing the definition of a scrolling list.
2471 'scrolling_list' => <<'END_OF_FUNC',
2472 sub scrolling_list {
2473 my($self,@p) = self_or_default(@_);
2474 my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other)
2475 = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
2476 SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
2478 my($result,@values);
2479 @values = $self->_set_values_and_labels($values,\$labels,$name);
2481 $size = $size || scalar(@values);
2483 my(%selected) = $self->previous_or_default($name,$defaults,$override);
2484 my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
2485 my($has_size) = $size ? qq/ size="$size"/: '';
2486 my($other) = @other ? " @other" : '';
2488 $name=$self->escapeHTML($name);
2489 $tabindex = $self->element_tab($tabindex);
2490 $result = qq/<select name="$name" tabindex="$tabindex"$has_size$is_multiple$other>\n/;
2492 my($selectit) = $self->_selected($selected{$_});
2494 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2495 $label=$self->escapeHTML($label);
2496 my($value)=$self->escapeHTML($_,1);
2497 my $attribs = $self->_set_attributes($_, $attributes);
2498 $result .= "<option$selectit$attribs value=\"$value\">$label</option>\n";
2500 $result .= "</select>";
2501 $self->register_parameter($name);
2509 # $name -> Name of the hidden field
2510 # @default -> (optional) Initial values of field (may be an array)
2512 # $default->[initial values of field]
2514 # A string containing a <input type="hidden" name="name" value="value">
2516 'hidden' => <<'END_OF_FUNC',
2518 my($self,@p) = self_or_default(@_);
2520 # this is the one place where we departed from our standard
2521 # calling scheme, so we have to special-case (darn)
2523 my($name,$default,$override,@other) =
2524 rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
2526 my $do_override = 0;
2527 if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
2528 @value = ref($default) ? @{$default} : $default;
2529 $do_override = $override;
2531 foreach ($default,$override,@other) {
2532 push(@value,$_) if defined($_);
2536 # use previous values if override is not set
2537 my @prev = $self->param($name);
2538 @value = @prev if !$do_override && @prev;
2540 $name=$self->escapeHTML($name);
2542 $_ = defined($_) ? $self->escapeHTML($_,1) : '';
2543 push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
2544 : qq(<input type="hidden" name="$name" value="$_" @other>);
2546 return wantarray ? @result : join('',@result);
2551 #### Method: image_button
2553 # $name -> Name of the button
2554 # $src -> URL of the image source
2555 # $align -> Alignment style (TOP, BOTTOM or MIDDLE)
2557 # A string containing a <input type="image" name="name" src="url" align="alignment">
2559 'image_button' => <<'END_OF_FUNC',
2561 my($self,@p) = self_or_default(@_);
2563 my($name,$src,$alignment,@other) =
2564 rearrange([NAME,SRC,ALIGN],@p);
2566 my($align) = $alignment ? " align=\U\"$alignment\"" : '';
2567 my($other) = @other ? " @other" : '';
2568 $name=$self->escapeHTML($name);
2569 return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
2570 : qq/<input type="image" name="$name" src="$src"$align$other>/;
2575 #### Method: self_url
2576 # Returns a URL containing the current script and all its
2577 # param/value pairs arranged as a query. You can use this
2578 # to create a link that, when selected, will reinvoke the
2579 # script with all its state information preserved.
2581 'self_url' => <<'END_OF_FUNC',
2583 my($self,@p) = self_or_default(@_);
2584 return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
2589 # This is provided as a synonym to self_url() for people unfortunate
2590 # enough to have incorporated it into their programs already!
2591 'state' => <<'END_OF_FUNC',
2599 # Like self_url, but doesn't return the query string part of
2602 'url' => <<'END_OF_FUNC',
2604 my($self,@p) = self_or_default(@_);
2605 my ($relative,$absolute,$full,$path_info,$query,$base) =
2606 rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE'],@p);
2608 $full++ if $base || !($relative || $absolute);
2610 my $path = $self->path_info;
2611 my $script_name = $self->script_name;
2614 my $protocol = $self->protocol();
2615 $url = "$protocol://";
2616 my $vh = http('x_forwarded_host') || http('host');
2620 $url .= server_name();
2621 my $port = $self->server_port;
2623 unless (lc($protocol) eq 'http' && $port == 80)
2624 || (lc($protocol) eq 'https' && $port == 443);
2626 return $url if $base;
2627 $url .= $script_name;
2628 } elsif ($relative) {
2629 ($url) = $script_name =~ m!([^/]+)$!;
2630 } elsif ($absolute) {
2631 $url = $script_name;
2634 $url .= $path if $path_info and defined $path;
2635 $url .= "?" . $self->query_string if $query and $self->query_string;
2636 $url = '' unless defined $url;
2637 $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
2644 # Set or read a cookie from the specified name.
2645 # Cookie can then be passed to header().
2646 # Usual rules apply to the stickiness of -value.
2648 # -name -> name for this cookie (optional)
2649 # -value -> value of this cookie (scalar, array or hash)
2650 # -path -> paths for which this cookie is valid (optional)
2651 # -domain -> internet domain in which this cookie is valid (optional)
2652 # -secure -> if true, cookie only passed through secure channel (optional)
2653 # -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
2655 'cookie' => <<'END_OF_FUNC',
2657 my($self,@p) = self_or_default(@_);
2658 my($name,$value,$path,$domain,$secure,$expires) =
2659 rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
2661 require CGI::Cookie;
2663 # if no value is supplied, then we retrieve the
2664 # value of the cookie, if any. For efficiency, we cache the parsed
2665 # cookies in our state variables.
2666 unless ( defined($value) ) {
2667 $self->{'.cookies'} = CGI::Cookie->fetch
2668 unless $self->{'.cookies'};
2670 # If no name is supplied, then retrieve the names of all our cookies.
2671 return () unless $self->{'.cookies'};
2672 return keys %{$self->{'.cookies'}} unless $name;
2673 return () unless $self->{'.cookies'}->{$name};
2674 return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
2677 # If we get here, we're creating a new cookie
2678 return undef unless defined($name) && $name ne ''; # this is an error
2681 push(@param,'-name'=>$name);
2682 push(@param,'-value'=>$value);
2683 push(@param,'-domain'=>$domain) if $domain;
2684 push(@param,'-path'=>$path) if $path;
2685 push(@param,'-expires'=>$expires) if $expires;
2686 push(@param,'-secure'=>$secure) if $secure;
2688 return new CGI::Cookie(@param);
2692 'parse_keywordlist' => <<'END_OF_FUNC',
2693 sub parse_keywordlist {
2694 my($self,$tosplit) = @_;
2695 $tosplit = unescape($tosplit); # unescape the keywords
2696 $tosplit=~tr/+/ /; # pluses to spaces
2697 my(@keywords) = split(/\s+/,$tosplit);
2702 'param_fetch' => <<'END_OF_FUNC',
2704 my($self,@p) = self_or_default(@_);
2705 my($name) = rearrange([NAME],@p);
2706 unless (exists($self->{$name})) {
2707 $self->add_parameter($name);
2708 $self->{$name} = [];
2711 return $self->{$name};
2715 ###############################################
2716 # OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
2717 ###############################################
2719 #### Method: path_info
2720 # Return the extra virtual path information provided
2721 # after the URL (if any)
2723 'path_info' => <<'END_OF_FUNC',
2725 my ($self,$info) = self_or_default(@_);
2726 if (defined($info)) {
2727 $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
2728 $self->{'.path_info'} = $info;
2729 } elsif (! defined($self->{'.path_info'}) ) {
2730 my (undef,$path_info) = $self->_name_and_path_from_env;
2731 $self->{'.path_info'} = $path_info || '';
2732 # hack to fix broken path info in IIS
2733 $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
2736 return $self->{'.path_info'};
2740 # WE USE THIS TO COMPENSATE FOR A BUG IN APACHE 2 PRESENT AT LEAST UP THROUGH 2.0.54
2741 '_name_and_path_from_env' => <<'END_OF_FUNC',
2742 sub _name_and_path_from_env {
2744 my $raw_script_name = $ENV{SCRIPT_NAME} || '';
2745 my $raw_path_info = $ENV{PATH_INFO} || '';
2746 my $uri = $ENV{REQUEST_URI} || '';
2748 my @uri_double_slashes = $uri =~ m^(/{2,}?)^g;
2749 my @path_double_slashes = "$raw_script_name $raw_path_info" =~ m^(/{2,}?)^g;
2751 my $apache_bug = @uri_double_slashes != @path_double_slashes;
2752 return ($raw_script_name,$raw_path_info) unless $apache_bug;
2754 my $path_info_search = $raw_path_info;
2755 # these characters will not (necessarily) be escaped
2756 $path_info_search =~ s/([^a-zA-Z0-9$()':_.,+*\/;?=&-])/uc sprintf("%%%02x",ord($1))/eg;
2757 $path_info_search = quotemeta($path_info_search);
2758 $path_info_search =~ s!/!/+!g;
2759 if ($uri =~ m/^(.+)($path_info_search)/) {
2762 return ($raw_script_name,$raw_path_info);
2768 #### Method: request_method
2769 # Returns 'POST', 'GET', 'PUT' or 'HEAD'
2771 'request_method' => <<'END_OF_FUNC',
2772 sub request_method {
2773 return $ENV{'REQUEST_METHOD'};
2777 #### Method: content_type
2778 # Returns the content_type string
2780 'content_type' => <<'END_OF_FUNC',
2782 return $ENV{'CONTENT_TYPE'};
2786 #### Method: path_translated
2787 # Return the physical path information provided
2788 # by the URL (if any)
2790 'path_translated' => <<'END_OF_FUNC',
2791 sub path_translated {
2792 return $ENV{'PATH_TRANSLATED'};
2797 #### Method: request_uri
2798 # Return the literal request URI
2800 'request_uri' => <<'END_OF_FUNC',
2802 return $ENV{'REQUEST_URI'};
2807 #### Method: query_string
2808 # Synthesize a query string from our current
2811 'query_string' => <<'END_OF_FUNC',
2813 my($self) = self_or_default(@_);
2814 my($param,$value,@pairs);
2815 foreach $param ($self->param) {
2816 my($eparam) = escape($param);
2817 foreach $value ($self->param($param)) {
2818 $value = escape($value);
2819 next unless defined $value;
2820 push(@pairs,"$eparam=$value");
2823 foreach (keys %{$self->{'.fieldnames'}}) {
2824 push(@pairs,".cgifields=".escape("$_"));
2826 return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
2832 # Without parameters, returns an array of the
2833 # MIME types the browser accepts.
2834 # With a single parameter equal to a MIME
2835 # type, will return undef if the browser won't
2836 # accept it, 1 if the browser accepts it but
2837 # doesn't give a preference, or a floating point
2838 # value between 0.0 and 1.0 if the browser
2839 # declares a quantitative score for it.
2840 # This handles MIME type globs correctly.
2842 'Accept' => <<'END_OF_FUNC',
2844 my($self,$search) = self_or_CGI(@_);
2845 my(%prefs,$type,$pref,$pat);
2847 my(@accept) = split(',',$self->http('accept'));
2850 ($pref) = /q=(\d\.\d+|\d+)/;
2851 ($type) = m#(\S+/[^;]+)#;
2853 $prefs{$type}=$pref || 1;
2856 return keys %prefs unless $search;
2858 # if a search type is provided, we may need to
2859 # perform a pattern matching operation.
2860 # The MIME types use a glob mechanism, which
2861 # is easily translated into a perl pattern match
2863 # First return the preference for directly supported
2865 return $prefs{$search} if $prefs{$search};
2867 # Didn't get it, so try pattern matching.
2868 foreach (keys %prefs) {
2869 next unless /\*/; # not a pattern match
2870 ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2871 $pat =~ s/\*/.*/g; # turn it into a pattern
2872 return $prefs{$_} if $search=~/$pat/;
2878 #### Method: user_agent
2879 # If called with no parameters, returns the user agent.
2880 # If called with one parameter, does a pattern match (case
2881 # insensitive) on the user agent.
2883 'user_agent' => <<'END_OF_FUNC',
2885 my($self,$match)=self_or_CGI(@_);
2886 return $self->http('user_agent') unless $match;
2887 return $self->http('user_agent') =~ /$match/i;
2892 #### Method: raw_cookie
2893 # Returns the magic cookies for the session.
2894 # The cookies are not parsed or altered in any way, i.e.
2895 # cookies are returned exactly as given in the HTTP
2896 # headers. If a cookie name is given, only that cookie's
2897 # value is returned, otherwise the entire raw cookie
2900 'raw_cookie' => <<'END_OF_FUNC',
2902 my($self,$key) = self_or_CGI(@_);
2904 require CGI::Cookie;
2906 if (defined($key)) {
2907 $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
2908 unless $self->{'.raw_cookies'};
2910 return () unless $self->{'.raw_cookies'};
2911 return () unless $self->{'.raw_cookies'}->{$key};
2912 return $self->{'.raw_cookies'}->{$key};
2914 return $self->http('cookie') || $ENV{'COOKIE'} || '';
2918 #### Method: virtual_host
2919 # Return the name of the virtual_host, which
2920 # is not always the same as the server
2922 'virtual_host' => <<'END_OF_FUNC',
2924 my $vh = http('x_forwarded_host') || http('host') || server_name();
2925 $vh =~ s/:\d+$//; # get rid of port number
2930 #### Method: remote_host
2931 # Return the name of the remote host, or its IP
2932 # address if unavailable. If this variable isn't
2933 # defined, it returns "localhost" for debugging
2936 'remote_host' => <<'END_OF_FUNC',
2938 return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
2944 #### Method: remote_addr
2945 # Return the IP addr of the remote host.
2947 'remote_addr' => <<'END_OF_FUNC',
2949 return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
2954 #### Method: script_name
2955 # Return the partial URL to this script for
2956 # self-referencing scripts. Also see
2957 # self_url(), which returns a URL with all state information
2960 'script_name' => <<'END_OF_FUNC',
2962 my ($self,@p) = self_or_default(@_);
2964 $self->{'.script_name'} = shift;
2965 } elsif (!exists $self->{'.script_name'}) {
2966 my ($script_name,$path_info) = $self->_name_and_path_from_env();
2967 $self->{'.script_name'} = $script_name;
2969 return $self->{'.script_name'};
2974 #### Method: referer
2975 # Return the HTTP_REFERER: useful for generating
2978 'referer' => <<'END_OF_FUNC',
2980 my($self) = self_or_CGI(@_);
2981 return $self->http('referer');
2986 #### Method: server_name
2987 # Return the name of the server
2989 'server_name' => <<'END_OF_FUNC',
2991 return $ENV{'SERVER_NAME'} || 'localhost';
2995 #### Method: server_software
2996 # Return the name of the server software
2998 'server_software' => <<'END_OF_FUNC',
2999 sub server_software {
3000 return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
3004 #### Method: virtual_port
3005 # Return the server port, taking virtual hosts into account
3007 'virtual_port' => <<'END_OF_FUNC',
3009 my($self) = self_or_default(@_);
3010 my $vh = $self->http('x_forwarded_host') || $self->http('host');
3012 return ($vh =~ /:(\d+)$/)[0] || '80';
3014 return $self->server_port();
3019 #### Method: server_port
3020 # Return the tcp/ip port the server is running on
3022 'server_port' => <<'END_OF_FUNC',
3024 return $ENV{'SERVER_PORT'} || 80; # for debugging
3028 #### Method: server_protocol
3029 # Return the protocol (usually HTTP/1.0)
3031 'server_protocol' => <<'END_OF_FUNC',
3032 sub server_protocol {
3033 return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
3038 # Return the value of an HTTP variable, or
3039 # the list of variables if none provided
3041 'http' => <<'END_OF_FUNC',
3043 my ($self,$parameter) = self_or_CGI(@_);
3044 return $ENV{$parameter} if $parameter=~/^HTTP/;
3045 $parameter =~ tr/-/_/;
3046 return $ENV{"HTTP_\U$parameter\E"} if $parameter;
3048 foreach (keys %ENV) {
3049 push(@p,$_) if /^HTTP/;
3056 # Return the value of HTTPS
3058 'https' => <<'END_OF_FUNC',
3061 my ($self,$parameter) = self_or_CGI(@_);
3062 return $ENV{HTTPS} unless $parameter;
3063 return $ENV{$parameter} if $parameter=~/^HTTPS/;
3064 $parameter =~ tr/-/_/;
3065 return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
3067 foreach (keys %ENV) {
3068 push(@p,$_) if /^HTTPS/;
3074 #### Method: protocol
3075 # Return the protocol (http or https currently)
3077 'protocol' => <<'END_OF_FUNC',
3081 return 'https' if uc($self->https()) eq 'ON';
3082 return 'https' if $self->server_port == 443;
3083 my $prot = $self->server_protocol;
3084 my($protocol,$version) = split('/',$prot);
3085 return "\L$protocol\E";
3089 #### Method: remote_ident
3090 # Return the identity of the remote user
3091 # (but only if his host is running identd)
3093 'remote_ident' => <<'END_OF_FUNC',
3095 return $ENV{'REMOTE_IDENT'};
3100 #### Method: auth_type
3101 # Return the type of use verification/authorization in use, if any.
3103 'auth_type' => <<'END_OF_FUNC',
3105 return $ENV{'AUTH_TYPE'};
3110 #### Method: remote_user
3111 # Return the authorization name used for user
3114 'remote_user' => <<'END_OF_FUNC',
3116 return $ENV{'REMOTE_USER'};
3121 #### Method: user_name
3122 # Try to return the remote user's name by hook or by
3125 'user_name' => <<'END_OF_FUNC',
3127 my ($self) = self_or_CGI(@_);
3128 return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
3132 #### Method: nosticky
3133 # Set or return the NOSTICKY global flag
3135 'nosticky' => <<'END_OF_FUNC',
3137 my ($self,$param) = self_or_CGI(@_);
3138 $CGI::NOSTICKY = $param if defined($param);
3139 return $CGI::NOSTICKY;
3144 # Set or return the NPH global flag
3146 'nph' => <<'END_OF_FUNC',
3148 my ($self,$param) = self_or_CGI(@_);
3149 $CGI::NPH = $param if defined($param);
3154 #### Method: private_tempfiles
3155 # Set or return the private_tempfiles global flag
3157 'private_tempfiles' => <<'END_OF_FUNC',
3158 sub private_tempfiles {
3159 my ($self,$param) = self_or_CGI(@_);
3160 $CGI::PRIVATE_TEMPFILES = $param if defined($param);
3161 return $CGI::PRIVATE_TEMPFILES;
3164 #### Method: close_upload_files
3165 # Set or return the close_upload_files global flag
3167 'close_upload_files' => <<'END_OF_FUNC',
3168 sub close_upload_files {
3169 my ($self,$param) = self_or_CGI(@_);
3170 $CGI::CLOSE_UPLOAD_FILES = $param if defined($param);
3171 return $CGI::CLOSE_UPLOAD_FILES;
3176 #### Method: default_dtd
3177 # Set or return the default_dtd global
3179 'default_dtd' => <<'END_OF_FUNC',
3181 my ($self,$param,$param2) = self_or_CGI(@_);
3182 if (defined $param2 && defined $param) {
3183 $CGI::DEFAULT_DTD = [ $param, $param2 ];
3184 } elsif (defined $param) {
3185 $CGI::DEFAULT_DTD = $param;
3187 return $CGI::DEFAULT_DTD;
3191 # -------------- really private subroutines -----------------
3192 'previous_or_default' => <<'END_OF_FUNC',
3193 sub previous_or_default {
3194 my($self,$name,$defaults,$override) = @_;
3197 if (!$override && ($self->{'.fieldnames'}->{$name} ||
3198 defined($self->param($name)) ) ) {
3199 grep($selected{$_}++,$self->param($name));
3200 } elsif (defined($defaults) && ref($defaults) &&
3201 (ref($defaults) eq 'ARRAY')) {
3202 grep($selected{$_}++,@{$defaults});
3204 $selected{$defaults}++ if defined($defaults);
3211 'register_parameter' => <<'END_OF_FUNC',
3212 sub register_parameter {
3213 my($self,$param) = @_;
3214 $self->{'.parametersToAdd'}->{$param}++;
3218 'get_fields' => <<'END_OF_FUNC',
3221 return $self->CGI::hidden('-name'=>'.cgifields',
3222 '-values'=>[keys %{$self->{'.parametersToAdd'}}],
3227 'read_from_cmdline' => <<'END_OF_FUNC',
3228 sub read_from_cmdline {
3232 if ($DEBUG && @ARGV) {
3234 } elsif ($DEBUG > 1) {
3235 require "shellwords.pl";
3236 print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n";
3237 chomp(@lines = <STDIN>); # remove newlines
3238 $input = join(" ",@lines);
3239 @words = &shellwords($input);
3246 if ("@words"=~/=/) {
3247 $query_string = join('&',@words);
3249 $query_string = join('+',@words);
3251 if ($query_string =~ /^(.*?)\?(.*)$/)
3256 return { 'query_string' => $query_string, 'subpath' => $subpath };
3261 # subroutine: read_multipart
3263 # Read multipart data and store it into our parameters.
3264 # An interesting feature is that if any of the parts is a file, we
3265 # create a temporary file and open up a filehandle on it so that the
3266 # caller can read from it if necessary.
3268 'read_multipart' => <<'END_OF_FUNC',
3269 sub read_multipart {
3270 my($self,$boundary,$length) = @_;
3271 my($buffer) = $self->new_MultipartBuffer($boundary,$length);
3272 return unless $buffer;
3275 while (!$buffer->eof) {
3276 %header = $buffer->readHeader;
3279 $self->cgi_error("400 Bad request (malformed multipart POST)");
3283 my($param)= $header{'Content-Disposition'}=~/ name="([^;]*)"/;
3286 # Bug: Netscape doesn't escape quotation marks in file names!!!
3287 my($filename) = $header{'Content-Disposition'}=~/ filename="([^;]*)"/;
3288 # Test for Opera's multiple upload feature
3289 my($multipart) = ( defined( $header{'Content-Type'} ) &&
3290 $header{'Content-Type'} =~ /multipart\/mixed/ ) ?
3293 # add this parameter to our list
3294 $self->add_parameter($param);
3296 # If no filename specified, then just read the data and assign it
3297 # to our parameter list.
3298 if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
3299 my($value) = $buffer->readBody;
3301 push(@{$self->{$param}},$value);
3305 my ($tmpfile,$tmp,$filehandle);
3307 # If we get here, then we are dealing with a potentially large
3308 # uploaded form. Save the data to a temporary file, then open
3309 # the file for reading.
3311 # skip the file if uploads disabled
3312 if ($DISABLE_UPLOADS) {
3313 while (defined($data = $buffer->read)) { }
3317 # set the filename to some recognizable value
3318 if ( ( !defined($filename) || $filename eq '' ) && $multipart ) {
3319 $filename = "multipart/mixed";
3322 # choose a relatively unpredictable tmpfile sequence number
3323 my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
3324 for (my $cnt=10;$cnt>0;$cnt--) {
3325 next unless $tmpfile = new CGITempFile($seqno);
3326 $tmp = $tmpfile->as_string;
3327 last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
3328 $seqno += int rand(100);
3330 die "CGI open of tmpfile: $!\n" unless defined $filehandle;
3331 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
3332 && defined fileno($filehandle);
3334 # if this is an multipart/mixed attachment, save the header
3335 # together with the body for later parsing with an external
3336 # MIME parser module
3338 foreach ( keys %header ) {
3339 print $filehandle "$_: $header{$_}${CRLF}";
3341 print $filehandle "${CRLF}";
3347 while (defined($data = $buffer->read)) {
3348 if (defined $self->{'.upload_hook'})
3350 $totalbytes += length($data);
3351 &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
3353 print $filehandle $data;
3356 # back up to beginning of file
3357 seek($filehandle,0,0);
3359 ## Close the filehandle if requested this allows a multipart MIME
3360 ## upload to contain many files, and we won't die due to too many
3361 ## open file handles. The user can access the files using the hash
3363 close $filehandle if $CLOSE_UPLOAD_FILES;
3364 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
3366 # Save some information about the uploaded file where we can get
3368 $self->{'.tmpfiles'}->{fileno($filehandle)}= {
3369 hndl => $filehandle,
3373 push(@{$self->{$param}},$filehandle);
3379 'upload' =><<'END_OF_FUNC',
3381 my($self,$param_name) = self_or_default(@_);
3382 my @param = grep(ref && fileno($_), $self->param($param_name));
3383 return unless @param;
3384 return wantarray ? @param : $param[0];
3388 'tmpFileName' => <<'END_OF_FUNC',
3390 my($self,$filename) = self_or_default(@_);
3391 return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ?
3392 $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string
3397 'uploadInfo' => <<'END_OF_FUNC',
3399 my($self,$filename) = self_or_default(@_);
3400 return $self->{'.tmpfiles'}->{fileno($filename)}->{info};
3404 # internal routine, don't use
3405 '_set_values_and_labels' => <<'END_OF_FUNC',
3406 sub _set_values_and_labels {
3409 $$l = $v if ref($v) eq 'HASH' && !ref($$l);
3410 return $self->param($n) if !defined($v);
3411 return $v if !ref($v);
3412 return ref($v) eq 'HASH' ? keys %$v : @$v;
3416 # internal routine, don't use
3417 '_set_attributes' => <<'END_OF_FUNC',
3418 sub _set_attributes {
3420 my($element, $attributes) = @_;
3421 return '' unless defined($attributes->{$element});
3423 foreach my $attrib (keys %{$attributes->{$element}}) {
3424 (my $clean_attrib = $attrib) =~ s/^-//;
3425 $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" ";
3432 '_compile_all' => <<'END_OF_FUNC',
3435 next if defined(&$_);
3436 $AUTOLOAD = "CGI::$_";
3446 #########################################################
3447 # Globals and stubs for other packages that we use.
3448 #########################################################
3450 ################### Fh -- lightweight filehandle ###############
3459 *Fh::AUTOLOAD = \&CGI::AUTOLOAD;
3466 $AUTOLOADED_ROUTINES = ''; # prevent -w error
3467 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3469 'asString' => <<'END_OF_FUNC',
3472 # get rid of package name
3473 (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
3474 $i =~ s/%(..)/ chr(hex($1)) /eg;
3475 return $i.$CGI::TAINTED;
3477 # This was an extremely clever patch that allowed "use strict refs".
3478 # Unfortunately it relied on another bug that caused leaky file descriptors.
3479 # The underlying bug has been fixed, so this no longer works. However
3480 # "strict refs" still works for some reason.
3482 # return ${*{$self}{SCALAR}};
3487 'compare' => <<'END_OF_FUNC',
3491 return "$self" cmp $value;
3495 'new' => <<'END_OF_FUNC',
3497 my($pack,$name,$file,$delete) = @_;
3498 _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
3499 require Fcntl unless defined &Fcntl::O_RDWR;
3500 (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
3501 my $fv = ++$FH . $safename;
3502 my $ref = \*{"Fh::$fv"};
3503 $file =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
3505 sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
3506 unlink($safe) if $delete;
3507 CORE::delete $Fh::{$fv};
3508 return bless $ref,$pack;
3515 ######################## MultipartBuffer ####################
3516 package MultipartBuffer;
3518 use constant DEBUG => 0;
3520 # how many bytes to read at a time. We use
3521 # a 4K buffer by default.
3522 $INITIAL_FILLUNIT = 1024 * 4;
3523 $TIMEOUT = 240*60; # 4 hour timeout for big files
3524 $SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
3527 #reuse the autoload function
3528 *MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
3530 # avoid autoloader warnings
3533 ###############################################################################
3534 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3535 ###############################################################################
3536 $AUTOLOADED_ROUTINES = ''; # prevent -w error
3537 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3540 'new' => <<'END_OF_FUNC',
3542 my($package,$interface,$boundary,$length) = @_;
3543 $FILLUNIT = $INITIAL_FILLUNIT;
3544 $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always
3546 # If the user types garbage into the file upload field,
3547 # then Netscape passes NOTHING to the server (not good).
3548 # We may hang on this read in that case. So we implement
3549 # a read timeout. If nothing is ready to read
3550 # by then, we return.
3552 # Netscape seems to be a little bit unreliable
3553 # about providing boundary strings.
3554 my $boundary_read = 0;
3557 # Under the MIME spec, the boundary consists of the
3558 # characters "--" PLUS the Boundary string
3560 # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
3561 # the two extra hyphens. We do a special case here on the user-agent!!!!
3562 $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport');
3564 } else { # otherwise we find it ourselves
3566 ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
3567 $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl
3568 $length -= length($boundary);
3569 chomp($boundary); # remove the CRLF
3570 $/ = $old; # restore old line separator
3574 my $self = {LENGTH=>$length,
3575 CHUNKED=>!defined $length,
3576 BOUNDARY=>$boundary,
3577 INTERFACE=>$interface,
3581 $FILLUNIT = length($boundary)
3582 if length($boundary) > $FILLUNIT;
3584 my $retval = bless $self,ref $package || $package;
3586 # Read the preamble and the topmost (boundary) line plus the CRLF.
3587 unless ($boundary_read) {
3588 while ($self->read(0)) { }
3590 die "Malformed multipart POST: data truncated\n" if $self->eof;
3596 'readHeader' => <<'END_OF_FUNC',
3603 local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC;
3606 $self->fillBuffer($FILLUNIT);
3607 $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
3608 $ok++ if $self->{BUFFER} eq '';
3609 $bad++ if !$ok && $self->{LENGTH} <= 0;
3610 # this was a bad idea
3611 # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
3612 } until $ok || $bad;
3615 #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines!
3617 my($header) = substr($self->{BUFFER},0,$end+2);
3618 substr($self->{BUFFER},0,$end+4) = '';
3622 warn "untranslated header=$header\n" if DEBUG;
3623 $header = CGI::Util::ascii2ebcdic($header);
3624 warn "translated header=$header\n" if DEBUG;
3627 # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
3628 # (Folding Long Header Fields), 3.4.3 (Comments)
3629 # and 3.4.5 (Quoted-Strings).
3631 my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
3632 $header=~s/$CRLF\s+/ /og; # merge continuation lines
3634 while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
3635 my ($field_name,$field_value) = ($1,$2);
3636 $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
3637 $return{$field_name}=$field_value;
3643 # This reads and returns the body as a single scalar value.
3644 'readBody' => <<'END_OF_FUNC',
3650 #EBCDIC NOTE: want to translate returnval into EBCDIC HERE
3652 while (defined($data = $self->read)) {
3653 $returnval .= $data;
3657 warn "untranslated body=$returnval\n" if DEBUG;
3658 $returnval = CGI::Util::ascii2ebcdic($returnval);
3659 warn "translated body=$returnval\n" if DEBUG;
3665 # This will read $bytes or until the boundary is hit, whichever happens
3666 # first. After the boundary is hit, we return undef. The next read will
3667 # skip over the boundary and begin reading again;
3668 'read' => <<'END_OF_FUNC',
3670 my($self,$bytes) = @_;
3672 # default number of bytes to read
3673 $bytes = $bytes || $FILLUNIT;
3675 # Fill up our internal buffer in such a way that the boundary
3676 # is never split between reads.
3677 $self->fillBuffer($bytes);
3679 my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY};
3680 my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--';
3682 # Find the boundary in the buffer (it may not be there).
3683 my $start = index($self->{BUFFER},$boundary_start);
3685 warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG;
3687 # protect against malformed multipart POST operations
3688 die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0);
3690 #EBCDIC NOTE: want to translate boundary search into ASCII here.
3692 # If the boundary begins the data, then skip past it
3696 # clear us out completely if we've hit the last boundary.
3697 if (index($self->{BUFFER},$boundary_end)==0) {
3703 # just remove the boundary.
3704 substr($self->{BUFFER},0,length($boundary_start))='';
3705 $self->{BUFFER} =~ s/^\012\015?//;
3710 if ($start > 0) { # read up to the boundary
3711 $bytesToReturn = $start-2 > $bytes ? $bytes : $start;
3712 } else { # read the requested number of bytes
3713 # leave enough bytes in the buffer to allow us to read
3714 # the boundary. Thanks to Kevin Hendrick for finding
3716 $bytesToReturn = $bytes - (length($boundary_start)+1);
3719 my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
3720 substr($self->{BUFFER},0,$bytesToReturn)='';
3722 # If we hit the boundary, remove the CRLF from the end.
3723 return ($bytesToReturn==$start)
3724 ? substr($returnval,0,-2) : $returnval;
3729 # This fills up our internal buffer in such a way that the
3730 # boundary is never split between reads
3731 'fillBuffer' => <<'END_OF_FUNC',
3733 my($self,$bytes) = @_;
3734 return unless $self->{CHUNKED} || $self->{LENGTH};
3736 my($boundaryLength) = length($self->{BOUNDARY});
3737 my($bufferLength) = length($self->{BUFFER});
3738 my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
3739 $bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $self->{LENGTH} < $bytesToRead;
3741 # Try to read some data. We may hang here if the browser is screwed up.
3742 my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER},
3745 warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG;
3746 $self->{BUFFER} = '' unless defined $self->{BUFFER};
3748 # An apparent bug in the Apache server causes the read()
3749 # to return zero bytes repeatedly without blocking if the
3750 # remote user aborts during a file transfer. I don't know how
3751 # they manage this, but the workaround is to abort if we get
3752 # more than SPIN_LOOP_MAX consecutive zero reads.
3753 if ($bytesRead <= 0) {
3754 die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
3755 if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
3757 $self->{ZERO_LOOP_COUNTER}=0;
3760 $self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead;
3765 # Return true when we've finished reading
3766 'eof' => <<'END_OF_FUNC'
3769 return 1 if (length($self->{BUFFER}) == 0)
3770 && ($self->{LENGTH} <= 0);
3778 ####################################################################################
3779 ################################## TEMPORARY FILES #################################
3780 ####################################################################################
3781 package CGITempFile;
3784 undef $TMPDIRECTORY;
3786 $MAC = $CGI::OS eq 'MACINTOSH';
3787 my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
3788 unless ($TMPDIRECTORY) {
3789 @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
3790 "C:${SL}temp","${SL}tmp","${SL}temp",
3791 "${vol}${SL}Temporary Items",
3792 "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
3793 "C:${SL}system${SL}temp");
3794 unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'};
3796 # this feature was supposed to provide per-user tmpfiles, but
3797 # it is problematic.
3798 # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
3799 # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
3800 # : can generate a 'getpwuid() not implemented' exception, even though
3801 # : it's never called. Found under DOS/Win with the DJGPP perl port.
3802 # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
3803 # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
3806 do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
3809 $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
3816 # cute feature, but overload implementation broke it
3817 # %OVERLOAD = ('""'=>'as_string');
3818 *CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD;
3822 $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
3823 my $safe = $1; # untaint operation
3824 unlink $safe; # get rid of the file
3827 ###############################################################################
3828 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3829 ###############################################################################
3830 $AUTOLOADED_ROUTINES = ''; # prevent -w error
3831 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3834 'new' => <<'END_OF_FUNC',
3836 my($package,$sequence) = @_;
3838 find_tempdir() unless -w $TMPDIRECTORY;
3839 for (my $i = 0; $i < $MAXTRIES; $i++) {
3840 last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
3842 # check that it is a more-or-less valid filename
3843 return unless $filename =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$!;
3844 # this used to untaint, now it doesn't
3846 return bless \$filename;
3850 'as_string' => <<'END_OF_FUNC'
3862 # We get a whole bunch of warnings about "possibly uninitialized variables"
3863 # when running with the -w switch. Touch them all once to get rid of the
3864 # warnings. This is ugly and I hate it.
3869 $MultipartBuffer::SPIN_LOOP_MAX;
3870 $MultipartBuffer::CRLF;
3871 $MultipartBuffer::TIMEOUT;
3872 $MultipartBuffer::INITIAL_FILLUNIT;
3883 CGI - Simple Common Gateway Interface Class
3887 # CGI script that creates a fill-out form
3888 # and echoes back its values.
3890 use CGI qw/:standard/;
3892 start_html('A Simple Example'),
3893 h1('A Simple Example'),
3895 "What's your name? ",textfield('name'),p,
3896 "What's the combination?", p,
3897 checkbox_group(-name=>'words',
3898 -values=>['eenie','meenie','minie','moe'],
3899 -defaults=>['eenie','minie']), p,
3900 "What's your favorite color? ",
3901 popup_menu(-name=>'color',
3902 -values=>['red','green','blue','chartreuse']),p,
3908 my $name = param('name');
3909 my $keywords = join ', ',param('words');
3910 my $color = param('color');
3911 print "Your name is",em(escapeHTML($name)),p,
3912 "The keywords are: ",em(escapeHTML($keywords)),p,
3913 "Your favorite color is ",em(escapeHTML($color)),
3919 This perl library uses perl5 objects to make it easy to create Web
3920 fill-out forms and parse their contents. This package defines CGI
3921 objects, entities that contain the values of the current query string
3922 and other state variables. Using a CGI object's methods, you can
3923 examine keywords and parameters passed to your script, and create
3924 forms whose initial values are taken from the current query (thereby
3925 preserving state information). The module provides shortcut functions
3926 that produce boilerplate HTML, reducing typing and coding errors. It
3927 also provides functionality for some of the more advanced features of
3928 CGI scripting, including support for file uploads, cookies, cascading
3929 style sheets, server push, and frames.
3931 CGI.pm also provides a simple function-oriented programming style for
3932 those who don't need its object-oriented features.
3934 The current version of CGI.pm is available at
3936 http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
3937 ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
3941 =head2 PROGRAMMING STYLE
3943 There are two styles of programming with CGI.pm, an object-oriented
3944 style and a function-oriented style. In the object-oriented style you
3945 create one or more CGI objects and then use object methods to create
3946 the various elements of the page. Each CGI object starts out with the
3947 list of named parameters that were passed to your CGI script by the
3948 server. You can modify the objects, save them to a file or database
3949 and recreate them. Because each object corresponds to the "state" of
3950 the CGI script, and because each object's parameter list is
3951 independent of the others, this allows you to save the state of the
3952 script and restore it later.
3954 For example, using the object oriented style, here is how you create
3955 a simple "Hello World" HTML page:
3957 #!/usr/local/bin/perl -w
3958 use CGI; # load CGI routines
3959 $q = new CGI; # create new CGI object
3960 print $q->header, # create the HTTP header
3961 $q->start_html('hello world'), # start the HTML
3962 $q->h1('hello world'), # level 1 header
3963 $q->end_html; # end the HTML
3965 In the function-oriented style, there is one default CGI object that
3966 you rarely deal with directly. Instead you just call functions to
3967 retrieve CGI parameters, create HTML tags, manage cookies, and so
3968 on. This provides you with a cleaner programming interface, but
3969 limits you to using one CGI object at a time. The following example
3970 prints the same page, but uses the function-oriented interface.
3971 The main differences are that we now need to import a set of functions
3972 into our name space (usually the "standard" functions), and we don't
3973 need to create the CGI object.
3975 #!/usr/local/bin/perl
3976 use CGI qw/:standard/; # load standard CGI routines
3977 print header, # create the HTTP header
3978 start_html('hello world'), # start the HTML
3979 h1('hello world'), # level 1 header
3980 end_html; # end the HTML
3982 The examples in this document mainly use the object-oriented style.
3983 See HOW TO IMPORT FUNCTIONS for important information on
3984 function-oriented programming in CGI.pm
3986 =head2 CALLING CGI.PM ROUTINES
3988 Most CGI.pm routines accept several arguments, sometimes as many as 20
3989 optional ones! To simplify this interface, all routines use a named
3990 argument calling style that looks like this:
3992 print $q->header(-type=>'image/gif',-expires=>'+3d');
3994 Each argument name is preceded by a dash. Neither case nor order
3995 matters in the argument list. -type, -Type, and -TYPE are all
3996 acceptable. In fact, only the first argument needs to begin with a
3997 dash. If a dash is present in the first argument, CGI.pm assumes
3998 dashes for the subsequent ones.
4000 Several routines are commonly called with just one argument. In the
4001 case of these routines you can provide the single argument without an
4002 argument name. header() happens to be one of these routines. In this
4003 case, the single argument is the document type.
4005 print $q->header('text/html');
4007 Other such routines are documented below.
4009 Sometimes named arguments expect a scalar, sometimes a reference to an
4010 array, and sometimes a reference to a hash. Often, you can pass any
4011 type of argument and the routine will do whatever is most appropriate.
4012 For example, the param() routine is used to set a CGI parameter to a
4013 single or a multi-valued value. The two cases are shown below:
4015 $q->param(-name=>'veggie',-value=>'tomato');
4016 $q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']);
4018 A large number of routines in CGI.pm actually aren't specifically
4019 defined in the module, but are generated automatically as needed.
4020 These are the "HTML shortcuts," routines that generate HTML tags for
4021 use in dynamically-generated pages. HTML tags have both attributes
4022 (the attribute="value" pairs within the tag itself) and contents (the
4023 part between the opening and closing pairs.) To distinguish between
4024 attributes and contents, CGI.pm uses the convention of passing HTML
4025 attributes as a hash reference as the first argument, and the
4026 contents, if any, as any subsequent arguments. It works out like
4032 h1('some','contents'); <h1>some contents</h1>
4033 h1({-align=>left}); <h1 align="LEFT">
4034 h1({-align=>left},'contents'); <h1 align="LEFT">contents</h1>
4036 HTML tags are described in more detail later.
4038 Many newcomers to CGI.pm are puzzled by the difference between the
4039 calling conventions for the HTML shortcuts, which require curly braces
4040 around the HTML tag attributes, and the calling conventions for other
4041 routines, which manage to generate attributes without the curly
4042 brackets. Don't be confused. As a convenience the curly braces are
4043 optional in all but the HTML shortcuts. If you like, you can use
4044 curly braces when calling any routine that takes named arguments. For
4047 print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
4049 If you use the B<-w> switch, you will be warned that some CGI.pm argument
4050 names conflict with built-in Perl functions. The most frequent of
4051 these is the -values argument, used to create multi-valued menus,
4052 radio button clusters and the like. To get around this warning, you
4053 have several choices:
4059 Use another name for the argument, if one is available.
4060 For example, -value is an alias for -values.
4064 Change the capitalization, e.g. -Values
4068 Put quotes around the argument name, e.g. '-values'
4072 Many routines will do something useful with a named argument that it
4073 doesn't recognize. For example, you can produce non-standard HTTP
4074 header fields by providing them as named arguments:
4076 print $q->header(-type => 'text/html',
4077 -cost => 'Three smackers',
4078 -annoyance_level => 'high',
4079 -complaints_to => 'bit bucket');
4081 This will produce the following nonstandard HTTP header:
4084 Cost: Three smackers
4085 Annoyance-level: high
4086 Complaints-to: bit bucket
4087 Content-type: text/html
4089 Notice the way that underscores are translated automatically into
4090 hyphens. HTML-generating routines perform a different type of
4093 This feature allows you to keep up with the rapidly changing HTTP and
4096 =head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
4100 This will parse the input (from both POST and GET methods) and store
4101 it into a perl5 object called $query.
4103 =head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
4105 $query = new CGI(INPUTFILE);
4107 If you provide a file handle to the new() method, it will read
4108 parameters from the file (or STDIN, or whatever). The file can be in
4109 any of the forms describing below under debugging (i.e. a series of
4110 newline delimited TAG=VALUE pairs will work). Conveniently, this type
4111 of file is created by the save() method (see below). Multiple records
4112 can be saved and restored.
4114 Perl purists will be pleased to know that this syntax accepts
4115 references to file handles, or even references to filehandle globs,
4116 which is the "official" way to pass a filehandle:
4118 $query = new CGI(\*STDIN);
4120 You can also initialize the CGI object with a FileHandle or IO::File
4123 If you are using the function-oriented interface and want to
4124 initialize CGI state from a file handle, the way to do this is with
4125 B<restore_parameters()>. This will (re)initialize the
4126 default CGI object from the indicated file handle.
4128 open (IN,"test.in") || die;
4129 restore_parameters(IN);
4132 You can also initialize the query object from an associative array
4135 $query = new CGI( {'dinosaur'=>'barney',
4136 'song'=>'I love you',
4137 'friends'=>[qw/Jessica George Nancy/]}
4140 or from a properly formatted, URL-escaped query string:
4142 $query = new CGI('dinosaur=barney&color=purple');
4144 or from a previously existing CGI object (currently this clones the
4145 parameter list, but none of the other object-specific fields, such as
4148 $old_query = new CGI;
4149 $new_query = new CGI($old_query);
4151 To create an empty query, initialize it from an empty string or hash:
4153 $empty_query = new CGI("");
4157 $empty_query = new CGI({});
4159 =head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
4161 @keywords = $query->keywords
4163 If the script was invoked as the result of an <ISINDEX> search, the
4164 parsed keywords can be obtained as an array using the keywords() method.
4166 =head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
4168 @names = $query->param
4170 If the script was invoked with a parameter list
4171 (e.g. "name1=value1&name2=value2&name3=value3"), the param() method
4172 will return the parameter names as a list. If the script was invoked
4173 as an <ISINDEX> script and contains a string without ampersands
4174 (e.g. "value1+value2+value3") , there will be a single parameter named
4175 "keywords" containing the "+"-delimited keywords.
4177 NOTE: As of version 1.5, the array of parameter names returned will
4178 be in the same order as they were submitted by the browser.
4179 Usually this order is the same as the order in which the
4180 parameters are defined in the form (however, this isn't part
4181 of the spec, and so isn't guaranteed).
4183 =head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
4185 @values = $query->param('foo');
4189 $value = $query->param('foo');
4191 Pass the param() method a single argument to fetch the value of the
4192 named parameter. If the parameter is multivalued (e.g. from multiple
4193 selections in a scrolling list), you can ask to receive an array. Otherwise
4194 the method will return a single value.
4196 If a value is not given in the query string, as in the queries
4197 "name1=&name2=" or "name1&name2", it will be returned as an empty
4198 string. This feature is new in 2.63.
4201 If the parameter does not exist at all, then param() will return undef
4202 in a scalar context, and the empty list in a list context.
4205 =head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
4207 $query->param('foo','an','array','of','values');
4209 This sets the value for the named parameter 'foo' to an array of
4210 values. This is one way to change the value of a field AFTER
4211 the script has been invoked once before. (Another way is with
4212 the -override parameter accepted by all methods that generate
4215 param() also recognizes a named parameter style of calling described
4216 in more detail later:
4218 $query->param(-name=>'foo',-values=>['an','array','of','values']);
4222 $query->param(-name=>'foo',-value=>'the value');
4224 =head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
4226 $query->append(-name=>'foo',-values=>['yet','more','values']);
4228 This adds a value or list of values to the named parameter. The
4229 values are appended to the end of the parameter if it already exists.
4230 Otherwise the parameter is created. Note that this method only
4231 recognizes the named argument calling syntax.
4233 =head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
4235 $query->import_names('R');
4237 This creates a series of variables in the 'R' namespace. For example,
4238 $R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
4239 If no namespace is given, this method will assume 'Q'.
4240 WARNING: don't import anything into 'main'; this is a major security
4243 NOTE 1: Variable names are transformed as necessary into legal Perl
4244 variable names. All non-legal characters are transformed into
4245 underscores. If you need to keep the original names, you should use
4246 the param() method instead to access CGI variables by name.
4248 NOTE 2: In older versions, this method was called B<import()>. As of version 2.20,
4249 this name has been removed completely to avoid conflict with the built-in
4250 Perl module B<import> operator.
4252 =head2 DELETING A PARAMETER COMPLETELY:
4254 $query->delete('foo','bar','baz');
4256 This completely clears a list of parameters. It sometimes useful for
4257 resetting parameters that you don't want passed down between script
4260 If you are using the function call interface, use "Delete()" instead
4261 to avoid conflicts with Perl's built-in delete operator.
4263 =head2 DELETING ALL PARAMETERS:
4265 $query->delete_all();
4267 This clears the CGI object completely. It might be useful to ensure
4268 that all the defaults are taken when you create a fill-out form.
4270 Use Delete_all() instead if you are using the function call interface.
4272 =head2 DIRECT ACCESS TO THE PARAMETER LIST:
4274 $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
4275 unshift @{$q->param_fetch(-name=>'address')},'George Munster';
4277 If you need access to the parameter list in a way that isn't covered
4278 by the methods above, you can obtain a direct reference to it by
4279 calling the B<param_fetch()> method with the name of the . This
4280 will return an array reference to the named parameters, which you then
4281 can manipulate in any way you like.
4283 You can also use a named argument style using the B<-name> argument.
4285 =head2 FETCHING THE PARAMETER LIST AS A HASH:
4288 print $params->{'address'};
4289 @foo = split("\0",$params->{'foo'});
4295 Many people want to fetch the entire parameter list as a hash in which
4296 the keys are the names of the CGI parameters, and the values are the
4297 parameters' values. The Vars() method does this. Called in a scalar
4298 context, it returns the parameter list as a tied hash reference.
4299 Changing a key changes the value of the parameter in the underlying
4300 CGI parameter list. Called in a list context, it returns the
4301 parameter list as an ordinary hash. This allows you to read the
4302 contents of the parameter list, but not to change it.
4304 When using this, the thing you must watch out for are multivalued CGI
4305 parameters. Because a hash cannot distinguish between scalar and
4306 list context, multivalued parameters will be returned as a packed
4307 string, separated by the "\0" (null) character. You must split this
4308 packed string in order to get at the individual values. This is the
4309 convention introduced long ago by Steve Brenner in his cgi-lib.pl
4310 module for Perl version 4.
4312 If you wish to use Vars() as a function, import the I<:cgi-lib> set of
4313 function calls (also see the section on CGI-LIB compatibility).
4315 =head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
4317 $query->save(\*FILEHANDLE)
4319 This will write the current state of the form to the provided
4320 filehandle. You can read it back in by providing a filehandle
4321 to the new() method. Note that the filehandle can be a file, a pipe,
4324 The format of the saved file is:
4332 Both name and value are URL escaped. Multi-valued CGI parameters are
4333 represented as repeated names. A session record is delimited by a
4334 single = symbol. You can write out multiple records and read them
4335 back in with several calls to B<new>. You can do this across several
4336 sessions by opening the file in append mode, allowing you to create
4337 primitive guest books, or to keep a history of users' queries. Here's
4338 a short example of creating multiple session records:
4342 open (OUT,">>test.out") || die;
4344 foreach (0..$records) {
4346 $q->param(-name=>'counter',-value=>$_);
4351 # reopen for reading
4352 open (IN,"test.out") || die;
4354 my $q = new CGI(\*IN);
4355 print $q->param('counter'),"\n";
4358 The file format used for save/restore is identical to that used by the
4359 Whitehead Genome Center's data exchange format "Boulderio", and can be
4360 manipulated and even databased using Boulderio utilities. See
4362 http://stein.cshl.org/boulder/
4364 for further details.
4366 If you wish to use this method from the function-oriented (non-OO)
4367 interface, the exported name for this method is B<save_parameters()>.
4369 =head2 RETRIEVING CGI ERRORS
4371 Errors can occur while processing user input, particularly when
4372 processing uploaded files. When these errors occur, CGI will stop
4373 processing and return an empty parameter list. You can test for
4374 the existence and nature of errors using the I<cgi_error()> function.
4375 The error messages are formatted as HTTP status codes. You can either
4376 incorporate the error text into an HTML page, or use it as the value
4379 my $error = $q->cgi_error;
4381 print $q->header(-status=>$error),
4382 $q->start_html('Problems'),
4383 $q->h2('Request not processed'),
4388 When using the function-oriented interface (see the next section),
4389 errors may only occur the first time you call I<param()>. Be ready
4392 =head2 USING THE FUNCTION-ORIENTED INTERFACE
4394 To use the function-oriented interface, you must specify which CGI.pm
4395 routines or sets of routines to import into your script's namespace.
4396 There is a small overhead associated with this importation, but it
4399 use CGI <list of methods>;
4401 The listed methods will be imported into the current package; you can
4402 call them directly without creating a CGI object first. This example
4403 shows how to import the B<param()> and B<header()>
4404 methods, and then use them directly:
4406 use CGI 'param','header';
4407 print header('text/plain');
4408 $zipcode = param('zipcode');
4410 More frequently, you'll import common sets of functions by referring
4411 to the groups by name. All function sets are preceded with a ":"
4412 character as in ":html3" (for tags defined in the HTML 3 standard).
4414 Here is a list of the function sets you can import:
4420 Import all CGI-handling methods, such as B<param()>, B<path_info()>
4425 Import all fill-out form generating methods, such as B<textfield()>.
4429 Import all methods that generate HTML 2.0 standard elements.
4433 Import all methods that generate HTML 3.0 elements (such as
4434 <table>, <super> and <sub>).
4438 Import all methods that generate HTML 4 elements (such as
4439 <abbrev>, <acronym> and <thead>).
4443 Import all methods that generate Netscape-specific HTML extensions.
4447 Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
4452 Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'.
4456 Import all the available methods. For the full list, see the CGI.pm
4457 code, where the variable %EXPORT_TAGS is defined.
4461 If you import a function name that is not part of CGI.pm, the module
4462 will treat it as a new HTML tag and generate the appropriate
4463 subroutine. You can then use it like any other HTML tag. This is to
4464 provide for the rapidly-evolving HTML "standard." For example, say
4465 Microsoft comes out with a new tag called <gradient> (which causes the
4466 user's desktop to be flooded with a rotating gradient fill until his
4467 machine reboots). You don't need to wait for a new version of CGI.pm
4468 to start using it immediately:
4470 use CGI qw/:standard :html3 gradient/;
4471 print gradient({-start=>'red',-end=>'blue'});
4473 Note that in the interests of execution speed CGI.pm does B<not> use
4474 the standard L<Exporter> syntax for specifying load symbols. This may
4475 change in the future.
4477 If you import any of the state-maintaining CGI or form-generating
4478 methods, a default CGI object will be created and initialized
4479 automatically the first time you use any of the methods that require
4480 one to be present. This includes B<param()>, B<textfield()>,
4481 B<submit()> and the like. (If you need direct access to the CGI
4482 object, you can find it in the global variable B<$CGI::Q>). By
4483 importing CGI.pm methods, you can create visually elegant scripts:
4485 use CGI qw/:standard/;
4488 start_html('Simple Script'),
4489 h1('Simple Script'),
4491 "What's your name? ",textfield('name'),p,
4492 "What's the combination?",
4493 checkbox_group(-name=>'words',
4494 -values=>['eenie','meenie','minie','moe'],
4495 -defaults=>['eenie','moe']),p,
4496 "What's your favorite color?",
4497 popup_menu(-name=>'color',
4498 -values=>['red','green','blue','chartreuse']),p,
4505 "Your name is ",em(param('name')),p,
4506 "The keywords are: ",em(join(", ",param('words'))),p,
4507 "Your favorite color is ",em(param('color')),".\n";
4513 In addition to the function sets, there are a number of pragmas that
4514 you can import. Pragmas, which are always preceded by a hyphen,
4515 change the way that CGI.pm functions in various ways. Pragmas,
4516 function sets, and individual functions can all be imported in the
4517 same use() line. For example, the following use statement imports the
4518 standard set of functions and enables debugging mode (pragma
4521 use CGI qw/:standard -debug/;
4523 The current list of pragmas is as follows:
4529 When you I<use CGI -any>, then any method that the query object
4530 doesn't recognize will be interpreted as a new HTML tag. This allows
4531 you to support the next I<ad hoc> Netscape or Microsoft HTML
4532 extension. This lets you go wild with new and unsupported tags:
4536 print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
4538 Since using <cite>any</cite> causes any mistyped method name
4539 to be interpreted as an HTML tag, use it with care or not at
4544 This causes the indicated autoloaded methods to be compiled up front,
4545 rather than deferred to later. This is useful for scripts that run
4546 for an extended period of time under FastCGI or mod_perl, and for
4547 those destined to be crunched by Malcom Beattie's Perl compiler. Use
4548 it in conjunction with the methods or method families you plan to use.
4550 use CGI qw(-compile :standard :html3);
4554 use CGI qw(-compile :all);
4556 Note that using the -compile pragma in this way will always have
4557 the effect of importing the compiled functions into the current
4558 namespace. If you want to compile without importing use the
4559 compile() method instead:
4564 This is particularly useful in a mod_perl environment, in which you
4565 might want to precompile all CGI routines in a startup script, and
4566 then import the functions individually in each mod_perl script.
4570 By default the CGI module implements a state-preserving behavior
4571 called "sticky" fields. The way this works is that if you are
4572 regenerating a form, the methods that generate the form field values
4573 will interrogate param() to see if similarly-named parameters are
4574 present in the query string. If they find a like-named parameter, they
4575 will use it to set their default values.
4577 Sometimes this isn't what you want. The B<-nosticky> pragma prevents
4578 this behavior. You can also selectively change the sticky behavior in
4579 each element that you generate.
4581 =item -no_undef_params
4583 This keeps CGI.pm from including undef params in the parameter list.
4587 By default, CGI.pm versions 2.69 and higher emit XHTML
4588 (http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this
4589 feature. Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this
4592 If start_html()'s -dtd parameter specifies an HTML 2.0 or 3.2 DTD,
4593 XHTML will automatically be disabled without needing to use this
4598 This makes CGI.pm produce a header appropriate for an NPH (no
4599 parsed header) script. You may need to do other things as well
4600 to tell the server that the script is NPH. See the discussion
4601 of NPH scripts below.
4603 =item -newstyle_urls
4605 Separate the name=value pairs in CGI parameter query strings with
4606 semicolons rather than ampersands. For example:
4608 ?name=fred;age=24;favorite_color=3
4610 Semicolon-delimited query strings are always accepted, but will not be
4611 emitted by self_url() and query_string() unless the -newstyle_urls
4612 pragma is specified.
4614 This became the default in version 2.64.
4616 =item -oldstyle_urls
4618 Separate the name=value pairs in CGI parameter query strings with
4619 ampersands rather than semicolons. This is no longer the default.
4623 This overrides the autoloader so that any function in your program
4624 that is not recognized is referred to CGI.pm for possible evaluation.
4625 This allows you to use all the CGI.pm functions without adding them to
4626 your symbol table, which is of concern for mod_perl users who are
4627 worried about memory consumption. I<Warning:> when
4628 I<-autoload> is in effect, you cannot use "poetry mode"
4629 (functions without the parenthesis). Use I<hr()> rather
4630 than I<hr>, or add something like I<use subs qw/hr p header/>
4631 to the top of your script.
4635 This turns off the command-line processing features. If you want to
4636 run a CGI.pm script from the command line to produce HTML, and you
4637 don't want it to read CGI parameters from the command line or STDIN,
4638 then use this pragma:
4640 use CGI qw(-no_debug :standard);
4644 This turns on full debugging. In addition to reading CGI arguments
4645 from the command-line processing, CGI.pm will pause and try to read
4646 arguments from STDIN, producing the message "(offline mode: enter
4647 name=value pairs on standard input)" features.
4649 See the section on debugging for more details.
4651 =item -private_tempfiles
4653 CGI.pm can process uploaded file. Ordinarily it spools the uploaded
4654 file to a temporary directory, then deletes the file when done.
4655 However, this opens the risk of eavesdropping as described in the file
4656 upload section. Another CGI script author could peek at this data
4657 during the upload, even if it is confidential information. On Unix
4658 systems, the -private_tempfiles pragma will cause the temporary file
4659 to be unlinked as soon as it is opened and before any data is written
4660 into it, reducing, but not eliminating the risk of eavesdropping
4661 (there is still a potential race condition). To make life harder for
4662 the attacker, the program chooses tempfile names by calculating a 32
4663 bit checksum of the incoming HTTP headers.
4665 To ensure that the temporary file cannot be read by other CGI scripts,
4666 use suEXEC or a CGI wrapper program to run your script. The temporary
4667 file is created with mode 0600 (neither world nor group readable).
4669 The temporary directory is selected using the following algorithm:
4671 1. if the current user (e.g. "nobody") has a directory named
4672 "tmp" in its home directory, use that (Unix systems only).
4674 2. if the environment variable TMPDIR exists, use the location
4677 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp,
4678 /tmp, /temp, ::Temporary Items, and \WWW_ROOT.
4680 Each of these locations is checked that it is a directory and is
4681 writable. If not, the algorithm tries the next choice.
4685 =head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS
4687 Many of the methods generate HTML tags. As described below, tag
4688 functions automatically generate both the opening and closing tags.
4691 print h1('Level 1 Header');
4695 <h1>Level 1 Header</h1>
4697 There will be some times when you want to produce the start and end
4698 tags yourself. In this case, you can use the form start_I<tag_name>
4699 and end_I<tag_name>, as in:
4701 print start_h1,'Level 1 Header',end_h1;
4703 With a few exceptions (described below), start_I<tag_name> and
4704 end_I<tag_name> functions are not generated automatically when you
4705 I<use CGI>. However, you can specify the tags you want to generate
4706 I<start/end> functions for by putting an asterisk in front of their
4707 name, or, alternatively, requesting either "start_I<tag_name>" or
4708 "end_I<tag_name>" in the import list.
4712 use CGI qw/:standard *table start_ul/;
4714 In this example, the following functions are generated in addition to
4719 =item 1. start_table() (generates a <table> tag)
4721 =item 2. end_table() (generates a </table> tag)
4723 =item 3. start_ul() (generates a <ul> tag)
4725 =item 4. end_ul() (generates a </ul> tag)
4729 =head1 GENERATING DYNAMIC DOCUMENTS
4731 Most of CGI.pm's functions deal with creating documents on the fly.
4732 Generally you will produce the HTTP header first, followed by the
4733 document itself. CGI.pm provides functions for generating HTTP
4734 headers of various types as well as for generating HTML. For creating
4735 GIF images, see the GD.pm module.
4737 Each of these functions produces a fragment of HTML or HTTP which you
4738 can print out directly so that it displays in the browser window,
4739 append to a string, or save to a file for later use.
4741 =head2 CREATING A STANDARD HTTP HEADER:
4743 Normally the first thing you will do in any CGI script is print out an
4744 HTTP header. This tells the browser what type of document to expect,
4745 and gives other optional information, such as the language, expiration
4746 date, and whether to cache the document. The header can also be
4747 manipulated for special purposes, such as server push and pay per view
4754 print header('image/gif');
4758 print header('text/html','204 No response');
4762 print header(-type=>'image/gif',
4764 -status=>'402 Payment required',
4768 -attachment=>'foo.gif',
4771 header() returns the Content-type: header. You can provide your own
4772 MIME type if you choose, otherwise it defaults to text/html. An
4773 optional second parameter specifies the status code and a human-readable
4774 message. For example, you can specify 204, "No response" to create a
4775 script that tells the browser to do nothing at all.
4777 The last example shows the named argument style for passing arguments
4778 to the CGI methods using named parameters. Recognized parameters are
4779 B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named
4780 parameters will be stripped of their initial hyphens and turned into
4781 header fields, allowing you to specify any HTTP header you desire.
4782 Internal underscores will be turned into hyphens:
4784 print header(-Content_length=>3002);
4786 Most browsers will not cache the output from CGI scripts. Every time
4787 the browser reloads the page, the script is invoked anew. You can
4788 change this behavior with the B<-expires> parameter. When you specify
4789 an absolute or relative expiration interval with this parameter, some
4790 browsers and proxy servers will cache the script's output until the
4791 indicated expiration date. The following forms are all valid for the
4794 +30s 30 seconds from now
4795 +10m ten minutes from now
4796 +1h one hour from now
4797 -1d yesterday (i.e. "ASAP!")
4800 +10y in ten years time
4801 Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date
4803 The B<-cookie> parameter generates a header that tells the browser to provide
4804 a "magic cookie" during all subsequent transactions with your script.
4805 Netscape cookies have a special format that includes interesting attributes
4806 such as expiration time. Use the cookie() method to create and retrieve
4809 The B<-nph> parameter, if set to a true value, will issue the correct
4810 headers to work with a NPH (no-parse-header) script. This is important
4811 to use with certain servers that expect all their scripts to be NPH.
4813 The B<-charset> parameter can be used to control the character set
4814 sent to the browser. If not provided, defaults to ISO-8859-1. As a
4815 side effect, this sets the charset() method as well.
4817 The B<-attachment> parameter can be used to turn the page into an
4818 attachment. Instead of displaying the page, some browsers will prompt
4819 the user to save it to disk. The value of the argument is the
4820 suggested name for the saved file. In order for this to work, you may
4821 have to set the B<-type> to "application/octet-stream".
4823 The B<-p3p> parameter will add a P3P tag to the outgoing header. The
4824 parameter can be an arrayref or a space-delimited string of P3P tags.
4827 print header(-p3p=>[qw(CAO DSP LAW CURa)]);
4828 print header(-p3p=>'CAO DSP LAW CURa');
4830 In either case, the outgoing header will be formatted as:
4832 P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"
4834 =head2 GENERATING A REDIRECTION HEADER
4836 print redirect('http://somewhere.else/in/movie/land');
4838 Sometimes you don't want to produce a document yourself, but simply
4839 redirect the browser elsewhere, perhaps choosing a URL based on the
4840 time of day or the identity of the user.
4842 The redirect() function redirects the browser to a different URL. If
4843 you use redirection like this, you should B<not> print out a header as
4846 You should always use full URLs (including the http: or ftp: part) in
4847 redirection requests. Relative URLs will not work correctly.
4849 You can also use named arguments:
4851 print redirect(-uri=>'http://somewhere.else/in/movie/land',
4855 The B<-nph> parameter, if set to a true value, will issue the correct
4856 headers to work with a NPH (no-parse-header) script. This is important
4857 to use with certain servers, such as Microsoft IIS, which
4858 expect all their scripts to be NPH.
4860 The B<-status> parameter will set the status of the redirect. HTTP
4861 defines three different possible redirection status codes:
4863 301 Moved Permanently
4867 The default if not specified is 302, which means "moved temporarily."
4868 You may change the status to another status code if you wish. Be
4869 advised that changing the status to anything other than 301, 302 or
4870 303 will probably break redirection.
4872 =head2 CREATING THE HTML DOCUMENT HEADER
4874 print start_html(-title=>'Secrets of the Pyramids',
4875 -author=>'fred@capricorn.org',
4878 -meta=>{'keywords'=>'pharaoh secret mummy',
4879 'copyright'=>'copyright 1996 King Tut'},
4880 -style=>{'src'=>'/styles/style1.css'},
4883 After creating the HTTP header, most CGI scripts will start writing
4884 out an HTML document. The start_html() routine creates the top of the
4885 page, along with a lot of optional information that controls the
4886 page's appearance and behavior.
4888 This method returns a canned HTML header and the opening <body> tag.
4889 All parameters are optional. In the named parameter form, recognized
4890 parameters are -title, -author, -base, -xbase, -dtd, -lang and -target
4891 (see below for the explanation). Any additional parameters you
4892 provide, such as the Netscape unofficial BGCOLOR attribute, are added
4893 to the <body> tag. Additional parameters must be proceeded by a
4896 The argument B<-xbase> allows you to provide an HREF for the <base> tag
4897 different from the current location, as in
4899 -xbase=>"http://home.mcom.com/"
4901 All relative links will be interpreted relative to this tag.
4903 The argument B<-target> allows you to provide a default target frame
4904 for all the links and fill-out forms on the page. B<This is a
4905 non-standard HTTP feature which only works with Netscape browsers!>
4906 See the Netscape documentation on frames for details of how to
4909 -target=>"answer_window"
4911 All relative links will be interpreted relative to this tag.
4912 You add arbitrary meta information to the header with the B<-meta>
4913 argument. This argument expects a reference to an associative array
4914 containing name/value pairs of meta information. These will be turned
4915 into a series of header <meta> tags that look something like this:
4917 <meta name="keywords" content="pharaoh secret mummy">
4918 <meta name="description" content="copyright 1996 King Tut">
4920 To create an HTTP-EQUIV type of <meta> tag, use B<-head>, described
4923 The B<-style> argument is used to incorporate cascading stylesheets
4924 into your code. See the section on CASCADING STYLESHEETS for more
4927 The B<-lang> argument is used to incorporate a language attribute into
4928 the <html> tag. For example:
4930 print $q->start_html(-lang=>'fr-CA');
4932 The default if not specified is "en-US" for US English, unless the
4933 -dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the
4934 lang attribute is left off. You can force the lang attribute to left
4935 off in other cases by passing an empty string (-lang=>'').
4937 The B<-encoding> argument can be used to specify the character set for
4938 XHTML. It defaults to iso-8859-1 if not specified.
4940 The B<-declare_xml> argument, when used in conjunction with XHTML,
4941 will put a <?xml> declaration at the top of the HTML header. The sole
4942 purpose of this declaration is to declare the character set
4943 encoding. In the absence of -declare_xml, the output HTML will contain
4944 a <meta> tag that specifies the encoding, allowing the HTML to pass
4945 most validators. The default for -declare_xml is false.
4947 You can place other arbitrary HTML elements to the <head> section with the
4948 B<-head> tag. For example, to place the rarely-used <link> element in the
4949 head section, use this:
4951 print start_html(-head=>Link({-rel=>'next',
4952 -href=>'http://www.capricorn.com/s2.html'}));
4954 To incorporate multiple HTML elements into the <head> section, just pass an
4957 print start_html(-head=>[
4959 -href=>'http://www.capricorn.com/s2.html'}),
4960 Link({-rel=>'previous',
4961 -href=>'http://www.capricorn.com/s1.html'})
4965 And here's how to create an HTTP-EQUIV <meta> tag:
4967 print start_html(-head=>meta({-http_equiv => 'Content-Type',
4968 -content => 'text/html'}))
4971 JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
4972 B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
4973 to add Netscape JavaScript calls to your pages. B<-script> should
4974 point to a block of text containing JavaScript function definitions.
4975 This block will be placed within a <script> block inside the HTML (not
4976 HTTP) header. The block is placed in the header in order to give your
4977 page a fighting chance of having all its JavaScript functions in place
4978 even if the user presses the stop button before the page has loaded
4979 completely. CGI.pm attempts to format the script in such a way that
4980 JavaScript-naive browsers will not choke on the code: unfortunately
4981 there are some browsers, such as Chimera for Unix, that get confused
4984 The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
4985 code to execute when the page is respectively opened and closed by the
4986 browser. Usually these parameters are calls to functions defined in the
4992 // Ask a silly question
4993 function riddle_me_this() {
4994 var r = prompt("What walks on four legs in the morning, " +
4995 "two legs in the afternoon, " +
4996 "and three legs in the evening?");
4999 // Get a silly answer
5000 function response(answer) {
5001 if (answer == "man")
5002 alert("Right you are!");
5004 alert("Wrong! Guess again.");
5007 print start_html(-title=>'The Riddle of the Sphinx',
5010 Use the B<-noScript> parameter to pass some HTML text that will be displayed on
5011 browsers that do not have JavaScript (or browsers where JavaScript is turned
5014 Netscape 3.0 recognizes several attributes of the <script> tag,
5015 including LANGUAGE and SRC. The latter is particularly interesting,
5016 as it allows you to keep the JavaScript code in a file or CGI script
5017 rather than cluttering up each page with the source. To use these
5018 attributes pass a HASH reference in the B<-script> parameter containing
5019 one or more of -language, -src, or -code:
5021 print $q->start_html(-title=>'The Riddle of the Sphinx',
5022 -script=>{-language=>'JAVASCRIPT',
5023 -src=>'/javascript/sphinx.js'}
5026 print $q->(-title=>'The Riddle of the Sphinx',
5027 -script=>{-language=>'PERLSCRIPT',
5028 -code=>'print "hello world!\n;"'}
5032 A final feature allows you to incorporate multiple <script> sections into the
5033 header. Just pass the list of script sections as an array reference.
5034 this allows you to specify different source files for different dialects
5035 of JavaScript. Example:
5037 print $q->start_html(-title=>'The Riddle of the Sphinx',
5039 { -language => 'JavaScript1.0',
5040 -src => '/javascript/utilities10.js'
5042 { -language => 'JavaScript1.1',
5043 -src => '/javascript/utilities11.js'
5045 { -language => 'JavaScript1.2',
5046 -src => '/javascript/utilities12.js'
5048 { -language => 'JavaScript28.2',
5049 -src => '/javascript/utilities219.js'
5054 If this looks a bit extreme, take my advice and stick with straight CGI scripting.
5058 http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
5060 for more information about JavaScript.
5062 The old-style positional parameters are as follows:
5066 =item B<Parameters:>
5074 The author's e-mail address (will create a <link rev="MADE"> tag if present
5078 A 'true' flag if you want to include a <base> tag in the header. This
5079 helps resolve relative addresses to absolute ones when the document is moved,
5080 but makes the document hierarchy non-portable. Use with care!
5084 Any other parameters you want to include in the <body> tag. This is a good
5085 place to put Netscape extensions, such as colors and wallpaper patterns.
5089 =head2 ENDING THE HTML DOCUMENT:
5093 This ends an HTML document by printing the </body></html> tags.
5095 =head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
5098 print q(<a href="$myself">I'm talking to myself.</a>);
5100 self_url() will return a URL, that, when selected, will reinvoke
5101 this script with all its state information intact. This is most
5102 useful when you want to jump around within the document using
5103 internal anchors but you don't want to disrupt the current contents
5104 of the form(s). Something like this will do the trick.
5107 print "<a href=\"$myself#table1\">See table 1</a>";
5108 print "<a href=\"$myself#table2\">See table 2</a>";
5109 print "<a href=\"$myself#yourself\">See for yourself</a>";
5111 If you want more control over what's returned, using the B<url()>
5114 You can also retrieve the unprocessed query string with query_string():
5116 $the_string = query_string;
5118 =head2 OBTAINING THE SCRIPT'S URL
5121 $full_url = url(-full=>1); #alternative syntax
5122 $relative_url = url(-relative=>1);
5123 $absolute_url = url(-absolute=>1);
5124 $url_with_path = url(-path_info=>1);
5125 $url_with_path_and_query = url(-path_info=>1,-query=>1);
5126 $netloc = url(-base => 1);
5128 B<url()> returns the script's URL in a variety of formats. Called
5129 without any arguments, it returns the full form of the URL, including
5130 host name and port number
5132 http://your.host.com/path/to/script.cgi
5134 You can modify this format with the following named arguments:
5140 If true, produce an absolute URL, e.g.
5146 Produce a relative URL. This is useful if you want to reinvoke your
5147 script with different parameters. For example:
5153 Produce the full URL, exactly as if called without any arguments.
5154 This overrides the -relative and -absolute arguments.
5156 =item B<-path> (B<-path_info>)
5158 Append the additional path information to the URL. This can be
5159 combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info>
5160 is provided as a synonym.
5162 =item B<-query> (B<-query_string>)
5164 Append the query string to the URL. This can be combined with
5165 B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
5170 Generate just the protocol and net location, as in http://www.foo.com:8000
5174 =head2 MIXING POST AND URL PARAMETERS
5176 $color = url_param('color');
5178 It is possible for a script to receive CGI parameters in the URL as
5179 well as in the fill-out form by creating a form that POSTs to a URL
5180 containing a query string (a "?" mark followed by arguments). The
5181 B<param()> method will always return the contents of the POSTed
5182 fill-out form, ignoring the URL's query string. To retrieve URL
5183 parameters, call the B<url_param()> method. Use it in the same way as
5184 B<param()>. The main difference is that it allows you to read the
5185 parameters, but not set them.
5188 Under no circumstances will the contents of the URL query string
5189 interfere with similarly-named CGI parameters in POSTed forms. If you
5190 try to mix a URL query string with a form submitted with the GET
5191 method, the results will not be what you expect.
5193 =head1 CREATING STANDARD HTML ELEMENTS:
5195 CGI.pm defines general HTML shortcut methods for most, if not all of
5196 the HTML 3 and HTML 4 tags. HTML shortcuts are named after a single
5197 HTML element and return a fragment of HTML text that you can then
5198 print or manipulate as you like. Each shortcut returns a fragment of
5199 HTML code that you can append to a string, save to a file, or, most
5200 commonly, print out so that it displays in the browser window.
5202 This example shows how to use the HTML methods:
5204 print $q->blockquote(
5205 "Many years ago on the island of",
5206 $q->a({href=>"http://crete.org/"},"Crete"),
5207 "there lived a Minotaur named",
5208 $q->strong("Fred."),
5212 This results in the following HTML code (extra newlines have been
5213 added for readability):
5216 Many years ago on the island of
5217 <a href="http://crete.org/">Crete</a> there lived
5218 a minotaur named <strong>Fred.</strong>
5222 If you find the syntax for calling the HTML shortcuts awkward, you can
5223 import them into your namespace and dispense with the object syntax
5224 completely (see the next section for more details):
5226 use CGI ':standard';
5228 "Many years ago on the island of",
5229 a({href=>"http://crete.org/"},"Crete"),
5230 "there lived a minotaur named",
5235 =head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
5237 The HTML methods will accept zero, one or multiple arguments. If you
5238 provide no arguments, you get a single tag:
5242 If you provide one or more string arguments, they are concatenated
5243 together with spaces and placed between opening and closing tags:
5245 print h1("Chapter","1"); # <h1>Chapter 1</h1>"
5247 If the first argument is an associative array reference, then the keys
5248 and values of the associative array become the HTML tag's attributes:
5250 print a({-href=>'fred.html',-target=>'_new'},
5251 "Open a new frame");
5253 <a href="fred.html",target="_new">Open a new frame</a>
5255 You may dispense with the dashes in front of the attribute names if
5258 print img {src=>'fred.gif',align=>'LEFT'};
5260 <img align="LEFT" src="fred.gif">
5262 Sometimes an HTML tag attribute has no argument. For example, ordered
5263 lists can be marked as COMPACT. The syntax for this is an argument that
5264 that points to an undef string:
5266 print ol({compact=>undef},li('one'),li('two'),li('three'));
5268 Prior to CGI.pm version 2.41, providing an empty ('') string as an
5269 attribute argument was the same as providing undef. However, this has
5270 changed in order to accommodate those who want to create tags of the form
5271 <img alt="">. The difference is shown in these two pieces of code:
5274 img({alt=>undef}) <img alt>
5275 img({alt=>''}) <img alt="">
5277 =head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
5279 One of the cool features of the HTML shortcuts is that they are
5280 distributive. If you give them an argument consisting of a
5281 B<reference> to a list, the tag will be distributed across each
5282 element of the list. For example, here's one way to make an ordered
5286 li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy'])
5289 This example will result in HTML output that looks like this:
5292 <li type="disc">Sneezy</li>
5293 <li type="disc">Doc</li>
5294 <li type="disc">Sleepy</li>
5295 <li type="disc">Happy</li>
5298 This is extremely useful for creating tables. For example:
5300 print table({-border=>undef},
5301 caption('When Should You Eat Your Vegetables?'),
5302 Tr({-align=>CENTER,-valign=>TOP},
5304 th(['Vegetable', 'Breakfast','Lunch','Dinner']),
5305 td(['Tomatoes' , 'no', 'yes', 'yes']),
5306 td(['Broccoli' , 'no', 'no', 'yes']),
5307 td(['Onions' , 'yes','yes', 'yes'])
5312 =head2 HTML SHORTCUTS AND LIST INTERPOLATION
5314 Consider this bit of code:
5316 print blockquote(em('Hi'),'mom!'));
5318 It will ordinarily return the string that you probably expect, namely:
5320 <blockquote><em>Hi</em> mom!</blockquote>
5322 Note the space between the element "Hi" and the element "mom!".
5323 CGI.pm puts the extra space there using array interpolation, which is
5324 controlled by the magic $" variable. Sometimes this extra space is
5325 not what you want, for example, when you are trying to align a series
5326 of images. In this case, you can simply change the value of $" to an
5331 print blockquote(em('Hi'),'mom!'));
5334 I suggest you put the code in a block as shown here. Otherwise the
5335 change to $" will affect all subsequent code until you explicitly
5338 =head2 NON-STANDARD HTML SHORTCUTS
5340 A few HTML tags don't follow the standard pattern for various
5343 B<comment()> generates an HTML comment (<!-- comment -->). Call it
5346 print comment('here is my comment');
5348 Because of conflicts with built-in Perl functions, the following functions
5349 begin with initial caps:
5358 In addition, start_html(), end_html(), start_form(), end_form(),
5359 start_multipart_form() and all the fill-out form tags are special.
5360 See their respective sections.
5362 =head2 AUTOESCAPING HTML
5364 By default, all HTML that is emitted by the form-generating functions
5365 is passed through a function called escapeHTML():
5369 =item $escaped_string = escapeHTML("unescaped string");
5371 Escape HTML formatting characters in a string.
5375 Provided that you have specified a character set of ISO-8859-1 (the
5376 default), the standard HTML escaping rules will be used. The "<"
5377 character becomes "<", ">" becomes ">", "&" becomes "&", and
5378 the quote character becomes """. In addition, the hexadecimal
5379 0x8b and 0x9b characters, which some browsers incorrectly interpret
5380 as the left and right angle-bracket characters, are replaced by their
5381 numeric character entities ("‹" and "›"). If you manually change
5382 the charset, either by calling the charset() method explicitly or by
5383 passing a -charset argument to header(), then B<all> characters will
5384 be replaced by their numeric entities, since CGI.pm has no lookup
5385 table for all the possible encodings.
5387 The automatic escaping does not apply to other shortcuts, such as
5388 h1(). You should call escapeHTML() yourself on untrusted data in
5389 order to protect your pages against nasty tricks that people may enter
5390 into guestbooks, etc.. To change the character set, use charset().
5391 To turn autoescaping off completely, use autoEscape(0):
5395 =item $charset = charset([$charset]);
5397 Get or set the current character set.
5399 =item $flag = autoEscape([$flag]);
5401 Get or set the value of the autoescape flag.
5405 =head2 PRETTY-PRINTING HTML
5407 By default, all the HTML produced by these functions comes out as one
5408 long line without carriage returns or indentation. This is yuck, but
5409 it does reduce the size of the documents by 10-20%. To get
5410 pretty-printed output, please use L<CGI::Pretty>, a subclass
5411 contributed by Brian Paulsen.
5413 =head1 CREATING FILL-OUT FORMS:
5415 I<General note> The various form-creating methods all return strings
5416 to the caller, containing the tag or tags that will create the requested
5417 form element. You are responsible for actually printing out these strings.
5418 It's set up this way so that you can place formatting tags
5419 around the form elements.
5421 I<Another note> The default values that you specify for the forms are only
5422 used the B<first> time the script is invoked (when there is no query
5423 string). On subsequent invocations of the script (when there is a query
5424 string), the former values are used even if they are blank.
5426 If you want to change the value of a field from its previous value, you have two
5429 (1) call the param() method to set it.
5431 (2) use the -override (alias -force) parameter (a new feature in version 2.15).
5432 This forces the default value to be used, regardless of the previous value:
5434 print textfield(-name=>'field_name',
5435 -default=>'starting value',
5440 I<Yet another note> By default, the text and labels of form elements are
5441 escaped according to HTML rules. This means that you can safely use
5442 "<CLICK ME>" as the label for a button. However, it also interferes with
5443 your ability to incorporate special HTML character sequences, such as Á,
5444 into your fields. If you wish to turn off automatic escaping, call the
5445 autoEscape() method with a false value immediately after creating the CGI object:
5450 I<A Lurking Trap!> Some of the form-element generating methods return
5451 multiple tags. In a scalar context, the tags will be concatenated
5452 together with spaces, or whatever is the current value of the $"
5453 global. In a list context, the methods will return a list of
5454 elements, allowing you to modify them if you wish. Usually you will
5455 not notice this behavior, but beware of this:
5457 printf("%s\n",end_form())
5459 end_form() produces several tags, and only the first of them will be
5460 printed because the format only expects one value.
5465 =head2 CREATING AN ISINDEX TAG
5467 print isindex(-action=>$action);
5471 print isindex($action);
5473 Prints out an <isindex> tag. Not very exciting. The parameter
5474 -action specifies the URL of the script to process the query. The
5475 default is to process the query with the current script.
5477 =head2 STARTING AND ENDING A FORM
5479 print start_form(-method=>$method,
5481 -enctype=>$encoding);
5482 <... various form stuff ...>
5487 print start_form($method,$action,$encoding);
5488 <... various form stuff ...>
5491 start_form() will return a <form> tag with the optional method,
5492 action and form encoding that you specify. The defaults are:
5496 enctype: application/x-www-form-urlencoded
5498 endform() returns the closing </form> tag.
5500 Start_form()'s enctype argument tells the browser how to package the various
5501 fields of the form before sending the form to the server. Two
5502 values are possible:
5504 B<Note:> This method was previously named startform(), and startform()
5505 is still recognized as an alias.
5509 =item B<application/x-www-form-urlencoded>
5511 This is the older type of encoding used by all browsers prior to
5512 Netscape 2.0. It is compatible with many CGI scripts and is
5513 suitable for short fields containing text data. For your
5514 convenience, CGI.pm stores the name of this encoding
5515 type in B<&CGI::URL_ENCODED>.
5517 =item B<multipart/form-data>
5519 This is the newer type of encoding introduced by Netscape 2.0.
5520 It is suitable for forms that contain very large fields or that
5521 are intended for transferring binary data. Most importantly,
5522 it enables the "file upload" feature of Netscape 2.0 forms. For
5523 your convenience, CGI.pm stores the name of this encoding type
5524 in B<&CGI::MULTIPART>
5526 Forms that use this type of encoding are not easily interpreted
5527 by CGI scripts unless they use CGI.pm or another library designed
5530 If XHTML is activated (the default), then forms will be automatically
5531 created using this type of encoding.
5535 For compatibility, the start_form() method uses the older form of
5536 encoding by default. If you want to use the newer form of encoding
5537 by default, you can call B<start_multipart_form()> instead of
5540 JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
5541 for use with JavaScript. The -name parameter gives the
5542 form a name so that it can be identified and manipulated by
5543 JavaScript functions. -onSubmit should point to a JavaScript
5544 function that will be executed just before the form is submitted to your
5545 server. You can use this opportunity to check the contents of the form
5546 for consistency and completeness. If you find something wrong, you
5547 can put up an alert box or maybe fix things up yourself. You can
5548 abort the submission by returning false from this function.
5550 Usually the bulk of JavaScript functions are defined in a <script>
5551 block in the HTML header and -onSubmit points to one of these function
5552 call. See start_html() for details.
5554 =head2 FORM ELEMENTS
5556 After starting a form, you will typically create one or more
5557 textfields, popup menus, radio groups and other form elements. Each
5558 of these elements takes a standard set of named arguments. Some
5559 elements also have optional arguments. The standard arguments are as
5566 The name of the field. After submission this name can be used to
5567 retrieve the field's value using the param() method.
5569 =item B<-value>, B<-values>
5571 The initial value of the field which will be returned to the script
5572 after form submission. Some form elements, such as text fields, take
5573 a single scalar -value argument. Others, such as popup menus, take a
5574 reference to an array of values. The two arguments are synonyms.
5578 A numeric value that sets the order in which the form element receives
5579 focus when the user presses the tab key. Elements with lower values
5580 receive focus first.
5584 A string identifier that can be used to identify this element to
5585 JavaScript and DHTML.
5589 A boolean, which, if true, forces the element to take on the value
5590 specified by B<-value>, overriding the sticky behavior described
5591 earlier for the B<-no_sticky> pragma.
5593 =item B<-onChange>, B<-onFocus>, B<-onBlur>, B<-onMouseOver>, B<-onMouseOut>, B<-onSelect>
5595 These are used to assign JavaScript event handlers. See the
5596 JavaScripting section for more details.
5600 Other common arguments are described in the next section. In addition
5601 to these, all attributes described in the HTML specifications are
5604 =head2 CREATING A TEXT FIELD
5606 print textfield(-name=>'field_name',
5607 -value=>'starting value',
5612 print textfield('field_name','starting value',50,80);
5614 textfield() will return a text input field.
5622 The first parameter is the required name for the field (-name).
5626 The optional second parameter is the default starting value for the field
5627 contents (-value, formerly known as -default).
5631 The optional third parameter is the size of the field in
5636 The optional fourth parameter is the maximum number of characters the
5637 field will accept (-maxlength).
5641 As with all these methods, the field will be initialized with its
5642 previous contents from earlier invocations of the script.
5643 When the form is processed, the value of the text field can be
5646 $value = param('foo');
5648 If you want to reset it from its initial value after the script has been
5649 called once, you can do so like this:
5651 param('foo',"I'm taking over this value!");
5653 =head2 CREATING A BIG TEXT FIELD
5655 print textarea(-name=>'foo',
5656 -default=>'starting value',
5662 print textarea('foo','starting value',10,50);
5664 textarea() is just like textfield, but it allows you to specify
5665 rows and columns for a multiline text entry box. You can provide
5666 a starting value for the field, which can be long and contain
5669 =head2 CREATING A PASSWORD FIELD
5671 print password_field(-name=>'secret',
5672 -value=>'starting value',
5677 print password_field('secret','starting value',50,80);
5679 password_field() is identical to textfield(), except that its contents
5680 will be starred out on the web page.
5682 =head2 CREATING A FILE UPLOAD FIELD
5684 print filefield(-name=>'uploaded_file',
5685 -default=>'starting value',
5690 print filefield('uploaded_file','starting value',50,80);
5692 filefield() will return a file upload field for Netscape 2.0 browsers.
5693 In order to take full advantage of this I<you must use the new
5694 multipart encoding scheme> for the form. You can do this either
5695 by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>,
5696 or by calling the new method B<start_multipart_form()> instead of
5697 vanilla B<start_form()>.
5705 The first parameter is the required name for the field (-name).
5709 The optional second parameter is the starting value for the field contents
5710 to be used as the default file name (-default).
5712 For security reasons, browsers don't pay any attention to this field,
5713 and so the starting value will always be blank. Worse, the field
5714 loses its "sticky" behavior and forgets its previous contents. The
5715 starting value field is called for in the HTML specification, however,
5716 and possibly some browser will eventually provide support for it.
5720 The optional third parameter is the size of the field in
5725 The optional fourth parameter is the maximum number of characters the
5726 field will accept (-maxlength).
5730 When the form is processed, you can retrieve the entered filename
5733 $filename = param('uploaded_file');
5735 Different browsers will return slightly different things for the
5736 name. Some browsers return the filename only. Others return the full
5737 path to the file, using the path conventions of the user's machine.
5738 Regardless, the name returned is always the name of the file on the
5739 I<user's> machine, and is unrelated to the name of the temporary file
5740 that CGI.pm creates during upload spooling (see below).
5742 The filename returned is also a file handle. You can read the contents
5743 of the file using standard Perl file reading calls:
5745 # Read a text file and print it out
5746 while (<$filename>) {
5750 # Copy a binary file to somewhere safe
5751 open (OUTFILE,">>/usr/local/web/users/feedback");
5752 while ($bytesread=read($filename,$buffer,1024)) {
5753 print OUTFILE $buffer;
5756 However, there are problems with the dual nature of the upload fields.
5757 If you C<use strict>, then Perl will complain when you try to use a
5758 string as a filehandle. You can get around this by placing the file
5759 reading code in a block containing the C<no strict> pragma. More
5760 seriously, it is possible for the remote user to type garbage into the
5761 upload field, in which case what you get from param() is not a
5762 filehandle at all, but a string.
5764 To be safe, use the I<upload()> function (new in version 2.47). When
5765 called with the name of an upload field, I<upload()> returns a
5766 filehandle, or undef if the parameter is not a valid filehandle.
5768 $fh = upload('uploaded_file');
5773 In an list context, upload() will return an array of filehandles.
5774 This makes it possible to create forms that use the same name for
5775 multiple upload fields.
5777 This is the recommended idiom.
5779 When a file is uploaded the browser usually sends along some
5780 information along with it in the format of headers. The information
5781 usually includes the MIME content type. Future browsers may send
5782 other information as well (such as modification date and size). To
5783 retrieve this information, call uploadInfo(). It returns a reference to
5784 an associative array containing all the document headers.
5786 $filename = param('uploaded_file');
5787 $type = uploadInfo($filename)->{'Content-Type'};
5788 unless ($type eq 'text/html') {
5789 die "HTML FILES ONLY!";
5792 If you are using a machine that recognizes "text" and "binary" data
5793 modes, be sure to understand when and how to use them (see the Camel book).
5794 Otherwise you may find that binary files are corrupted during file
5797 There are occasionally problems involving parsing the uploaded file.
5798 This usually happens when the user presses "Stop" before the upload is
5799 finished. In this case, CGI.pm will return undef for the name of the
5800 uploaded file and set I<cgi_error()> to the string "400 Bad request
5801 (malformed multipart POST)". This error message is designed so that
5802 you can incorporate it into a status code to be sent to the browser.
5805 $file = upload('uploaded_file');
5806 if (!$file && cgi_error) {
5807 print header(-status=>cgi_error);
5811 You are free to create a custom HTML page to complain about the error,
5814 You can set up a callback that will be called whenever a file upload
5815 is being read during the form processing. This is much like the
5816 UPLOAD_HOOK facility available in Apache::Request, with the exception
5817 that the first argument to the callback is an Apache::Upload object,
5818 here it's the remote filename.
5821 $q->upload_hook(\&hook,$data);
5825 my ($filename, $buffer, $bytes_read, $data) = @_;
5826 print "Read $bytes_read bytes of $filename\n";
5829 If using the function-oriented interface, call the CGI::upload_hook()
5830 method before calling param() or any other CGI functions:
5832 CGI::upload_hook(\&hook,$data);
5834 This method is not exported by default. You will have to import it
5835 explicitly if you wish to use it without the CGI:: prefix.
5837 If you are using CGI.pm on a Windows platform and find that binary
5838 files get slightly larger when uploaded but that text files remain the
5839 same, then you have forgotten to activate binary mode on the output
5840 filehandle. Be sure to call binmode() on any handle that you create
5841 to write the uploaded file to disk.
5843 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
5844 B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
5845 recognized. See textfield() for details.
5847 =head2 CREATING A POPUP MENU
5849 print popup_menu('menu_name',
5850 ['eenie','meenie','minie'],
5855 %labels = ('eenie'=>'your first choice',
5856 'meenie'=>'your second choice',
5857 'minie'=>'your third choice');
5858 %attributes = ('eenie'=>{'class'=>'class of first choice'});
5859 print popup_menu('menu_name',
5860 ['eenie','meenie','minie'],
5861 'meenie',\%labels,\%attributes);
5863 -or (named parameter style)-
5865 print popup_menu(-name=>'menu_name',
5866 -values=>['eenie','meenie','minie'],
5869 -attributes=>\%attributes);
5871 popup_menu() creates a menu.
5877 The required first argument is the menu's name (-name).
5881 The required second argument (-values) is an array B<reference>
5882 containing the list of menu items in the menu. You can pass the
5883 method an anonymous array, as shown in the example, or a reference to
5884 a named array, such as "\@foo".
5888 The optional third parameter (-default) is the name of the default
5889 menu choice. If not specified, the first item will be the default.
5890 The values of the previous choice will be maintained across queries.
5894 The optional fourth parameter (-labels) is provided for people who
5895 want to use different values for the user-visible label inside the
5896 popup menu and the value returned to your script. It's a pointer to an
5897 associative array relating menu values to user-visible labels. If you
5898 leave this parameter blank, the menu values will be displayed by
5899 default. (You can also leave a label undefined if you want to).
5903 The optional fifth parameter (-attributes) is provided to assign
5904 any of the common HTML attributes to an individual menu item. It's
5905 a pointer to an associative array relating menu values to another
5906 associative array with the attribute's name as the key and the
5907 attribute's value as the value.
5911 When the form is processed, the selected value of the popup menu can
5914 $popup_menu_value = param('menu_name');
5916 =head2 CREATING AN OPTION GROUP
5918 Named parameter style
5920 print popup_menu(-name=>'menu_name',
5921 -values=>[qw/eenie meenie minie/,
5922 optgroup(-name=>'optgroup_name',
5923 -values => ['moe','catch'],
5924 -attributes=>{'catch'=>{'class'=>'red'}})],
5925 -labels=>{'eenie'=>'one',
5928 -default=>'meenie');
5931 print popup_menu('menu_name',
5932 ['eenie','meenie','minie',
5933 optgroup('optgroup_name', ['moe', 'catch'],
5934 {'catch'=>{'class'=>'red'}})],'meenie',
5935 {'eenie'=>'one','meenie'=>'two','minie'=>'three'});
5937 optgroup() creates an option group within a popup menu.
5943 The required first argument (B<-name>) is the label attribute of the
5944 optgroup and is B<not> inserted in the parameter list of the query.
5948 The required second argument (B<-values>) is an array reference
5949 containing the list of menu items in the menu. You can pass the
5950 method an anonymous array, as shown in the example, or a reference
5951 to a named array, such as \@foo. If you pass a HASH reference,
5952 the keys will be used for the menu values, and the values will be
5953 used for the menu labels (see -labels below).
5957 The optional third parameter (B<-labels>) allows you to pass a reference
5958 to an associative array containing user-visible labels for one or more
5959 of the menu items. You can use this when you want the user to see one
5960 menu string, but have the browser return your program a different one.
5961 If you don't specify this, the value string will be used instead
5962 ("eenie", "meenie" and "minie" in this example). This is equivalent
5963 to using a hash reference for the -values parameter.
5967 An optional fourth parameter (B<-labeled>) can be set to a true value
5968 and indicates that the values should be used as the label attribute
5969 for each option element within the optgroup.
5973 An optional fifth parameter (-novals) can be set to a true value and
5974 indicates to suppress the val attribute in each option element within
5977 See the discussion on optgroup at W3C
5978 (http://www.w3.org/TR/REC-html40/interact/forms.html#edef-OPTGROUP)
5983 An optional sixth parameter (-attributes) is provided to assign
5984 any of the common HTML attributes to an individual menu item. It's
5985 a pointer to an associative array relating menu values to another
5986 associative array with the attribute's name as the key and the
5987 attribute's value as the value.
5991 =head2 CREATING A SCROLLING LIST
5993 print scrolling_list('list_name',
5994 ['eenie','meenie','minie','moe'],
5995 ['eenie','moe'],5,'true',{'moe'=>{'class'=>'red'}});
5998 print scrolling_list('list_name',
5999 ['eenie','meenie','minie','moe'],
6000 ['eenie','moe'],5,'true',
6001 \%labels,%attributes);
6005 print scrolling_list(-name=>'list_name',
6006 -values=>['eenie','meenie','minie','moe'],
6007 -default=>['eenie','moe'],
6011 -attributes=>\%attributes);
6013 scrolling_list() creates a scrolling list.
6017 =item B<Parameters:>
6021 The first and second arguments are the list name (-name) and values
6022 (-values). As in the popup menu, the second argument should be an
6027 The optional third argument (-default) can be either a reference to a
6028 list containing the values to be selected by default, or can be a
6029 single value to select. If this argument is missing or undefined,
6030 then nothing is selected when the list first appears. In the named
6031 parameter version, you can use the synonym "-defaults" for this
6036 The optional fourth argument is the size of the list (-size).
6040 The optional fifth argument can be set to true to allow multiple
6041 simultaneous selections (-multiple). Otherwise only one selection
6042 will be allowed at a time.
6046 The optional sixth argument is a pointer to an associative array
6047 containing long user-visible labels for the list items (-labels).
6048 If not provided, the values will be displayed.
6052 The optional sixth parameter (-attributes) is provided to assign
6053 any of the common HTML attributes to an individual menu item. It's
6054 a pointer to an associative array relating menu values to another
6055 associative array with the attribute's name as the key and the
6056 attribute's value as the value.
6058 When this form is processed, all selected list items will be returned as
6059 a list under the parameter name 'list_name'. The values of the
6060 selected items can be retrieved with:
6062 @selected = param('list_name');
6066 =head2 CREATING A GROUP OF RELATED CHECKBOXES
6068 print checkbox_group(-name=>'group_name',
6069 -values=>['eenie','meenie','minie','moe'],
6070 -default=>['eenie','moe'],
6073 -attributes=>\%attributes);
6075 print checkbox_group('group_name',
6076 ['eenie','meenie','minie','moe'],
6077 ['eenie','moe'],'true',\%labels,
6078 {'moe'=>{'class'=>'red'}});
6080 HTML3-COMPATIBLE BROWSERS ONLY:
6082 print checkbox_group(-name=>'group_name',
6083 -values=>['eenie','meenie','minie','moe'],
6084 -rows=2,-columns=>2);
6087 checkbox_group() creates a list of checkboxes that are related
6092 =item B<Parameters:>
6096 The first and second arguments are the checkbox name and values,
6097 respectively (-name and -values). As in the popup menu, the second
6098 argument should be an array reference. These values are used for the
6099 user-readable labels printed next to the checkboxes as well as for the
6100 values passed to your script in the query string.
6104 The optional third argument (-default) can be either a reference to a
6105 list containing the values to be checked by default, or can be a
6106 single value to checked. If this argument is missing or undefined,
6107 then nothing is selected when the list first appears.
6111 The optional fourth argument (-linebreak) can be set to true to place
6112 line breaks between the checkboxes so that they appear as a vertical
6113 list. Otherwise, they will be strung together on a horizontal line.
6118 The optional b<-labels> argument is a pointer to an associative array
6119 relating the checkbox values to the user-visible labels that will be
6120 printed next to them. If not provided, the values will be used as the
6124 Modern browsers can take advantage of the optional parameters
6125 B<-rows>, and B<-columns>. These parameters cause checkbox_group() to
6126 return an HTML3 compatible table containing the checkbox group
6127 formatted with the specified number of rows and columns. You can
6128 provide just the -columns parameter if you wish; checkbox_group will
6129 calculate the correct number of rows for you.
6132 The optional B<-attributes> argument is provided to assign any of the
6133 common HTML attributes to an individual menu item. It's a pointer to
6134 an associative array relating menu values to another associative array
6135 with the attribute's name as the key and the attribute's value as the
6138 The optional B<-tabindex> argument can be used to control the order in which
6139 radio buttons receive focus when the user presses the tab button. If
6140 passed a scalar numeric value, the first element in the group will
6141 receive this tab index and subsequent elements will be incremented by
6142 one. If given a reference to an array of radio button values, then
6143 the indexes will be jiggered so that the order specified in the array
6144 will correspond to the tab order. You can also pass a reference to a
6145 hash in which the hash keys are the radio button values and the values
6146 are the tab indexes of each button. Examples:
6148 -tabindex => 100 # this group starts at index 100 and counts up
6149 -tabindex => ['moe','minie','eenie','meenie'] # tab in this order
6150 -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
6152 When the form is processed, all checked boxes will be returned as
6153 a list under the parameter name 'group_name'. The values of the
6154 "on" checkboxes can be retrieved with:
6156 @turned_on = param('group_name');
6158 The value returned by checkbox_group() is actually an array of button
6159 elements. You can capture them and use them within tables, lists,
6160 or in other creative ways:
6162 @h = checkbox_group(-name=>'group_name',-values=>\@values);
6163 &use_in_creative_way(@h);
6165 =head2 CREATING A STANDALONE CHECKBOX
6167 print checkbox(-name=>'checkbox_name',
6170 -label=>'CLICK ME');
6174 print checkbox('checkbox_name','checked','ON','CLICK ME');
6176 checkbox() is used to create an isolated checkbox that isn't logically
6177 related to any others.
6181 =item B<Parameters:>
6185 The first parameter is the required name for the checkbox (-name). It
6186 will also be used for the user-readable label printed next to the
6191 The optional second parameter (-checked) specifies that the checkbox
6192 is turned on by default. Synonyms are -selected and -on.
6196 The optional third parameter (-value) specifies the value of the
6197 checkbox when it is checked. If not provided, the word "on" is
6202 The optional fourth parameter (-label) is the user-readable label to
6203 be attached to the checkbox. If not provided, the checkbox name is
6208 The value of the checkbox can be retrieved using:
6210 $turned_on = param('checkbox_name');
6212 =head2 CREATING A RADIO BUTTON GROUP
6214 print radio_group(-name=>'group_name',
6215 -values=>['eenie','meenie','minie'],
6219 -attributes=>\%attributes);
6223 print radio_group('group_name',['eenie','meenie','minie'],
6224 'meenie','true',\%labels,\%attributes);
6227 HTML3-COMPATIBLE BROWSERS ONLY:
6229 print radio_group(-name=>'group_name',
6230 -values=>['eenie','meenie','minie','moe'],
6231 -rows=2,-columns=>2);
6233 radio_group() creates a set of logically-related radio buttons
6234 (turning one member of the group on turns the others off)
6238 =item B<Parameters:>
6242 The first argument is the name of the group and is required (-name).
6246 The second argument (-values) is the list of values for the radio
6247 buttons. The values and the labels that appear on the page are
6248 identical. Pass an array I<reference> in the second argument, either
6249 using an anonymous array, as shown, or by referencing a named array as
6254 The optional third parameter (-default) is the name of the default
6255 button to turn on. If not specified, the first item will be the
6256 default. You can provide a nonexistent button name, such as "-" to
6257 start up with no buttons selected.
6261 The optional fourth parameter (-linebreak) can be set to 'true' to put
6262 line breaks between the buttons, creating a vertical list.
6266 The optional fifth parameter (-labels) is a pointer to an associative
6267 array relating the radio button values to user-visible labels to be
6268 used in the display. If not provided, the values themselves are
6274 All modern browsers can take advantage of the optional parameters
6275 B<-rows>, and B<-columns>. These parameters cause radio_group() to
6276 return an HTML3 compatible table containing the radio group formatted
6277 with the specified number of rows and columns. You can provide just
6278 the -columns parameter if you wish; radio_group will calculate the
6279 correct number of rows for you.
6281 To include row and column headings in the returned table, you
6282 can use the B<-rowheader> and B<-colheader> parameters. Both
6283 of these accept a pointer to an array of headings to use.
6284 The headings are just decorative. They don't reorganize the
6285 interpretation of the radio buttons -- they're still a single named
6288 The optional B<-tabindex> argument can be used to control the order in which
6289 radio buttons receive focus when the user presses the tab button. If
6290 passed a scalar numeric value, the first element in the group will
6291 receive this tab index and subsequent elements will be incremented by
6292 one. If given a reference to an array of radio button values, then
6293 the indexes will be jiggered so that the order specified in the array
6294 will correspond to the tab order. You can also pass a reference to a
6295 hash in which the hash keys are the radio button values and the values
6296 are the tab indexes of each button. Examples:
6298 -tabindex => 100 # this group starts at index 100 and counts up
6299 -tabindex => ['moe','minie','eenie','meenie'] # tab in this order
6300 -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
6303 The optional B<-attributes> argument is provided to assign any of the
6304 common HTML attributes to an individual menu item. It's a pointer to
6305 an associative array relating menu values to another associative array
6306 with the attribute's name as the key and the attribute's value as the
6309 When the form is processed, the selected radio button can
6312 $which_radio_button = param('group_name');
6314 The value returned by radio_group() is actually an array of button
6315 elements. You can capture them and use them within tables, lists,
6316 or in other creative ways:
6318 @h = radio_group(-name=>'group_name',-values=>\@values);
6319 &use_in_creative_way(@h);
6321 =head2 CREATING A SUBMIT BUTTON
6323 print submit(-name=>'button_name',
6328 print submit('button_name','value');
6330 submit() will create the query submission button. Every form
6331 should have one of these.
6335 =item B<Parameters:>
6339 The first argument (-name) is optional. You can give the button a
6340 name if you have several submission buttons in your form and you want
6341 to distinguish between them.
6345 The second argument (-value) is also optional. This gives the button
6346 a value that will be passed to your script in the query string. The
6347 name will also be used as the user-visible label.
6351 You can use -label as an alias for -value. I always get confused
6352 about which of -name and -value changes the user-visible label on the
6357 You can figure out which button was pressed by using different
6358 values for each one:
6360 $which_one = param('button_name');
6362 =head2 CREATING A RESET BUTTON
6366 reset() creates the "reset" button. Note that it restores the
6367 form to its value from the last time the script was called,
6368 NOT necessarily to the defaults.
6370 Note that this conflicts with the Perl reset() built-in. Use
6371 CORE::reset() to get the original reset function.
6373 =head2 CREATING A DEFAULT BUTTON
6375 print defaults('button_label')
6377 defaults() creates a button that, when invoked, will cause the
6378 form to be completely reset to its defaults, wiping out all the
6379 changes the user ever made.
6381 =head2 CREATING A HIDDEN FIELD
6383 print hidden(-name=>'hidden_name',
6384 -default=>['value1','value2'...]);
6388 print hidden('hidden_name','value1','value2'...);
6390 hidden() produces a text field that can't be seen by the user. It
6391 is useful for passing state variable information from one invocation
6392 of the script to the next.
6396 =item B<Parameters:>
6400 The first argument is required and specifies the name of this
6405 The second argument is also required and specifies its value
6406 (-default). In the named parameter style of calling, you can provide
6407 a single value here or a reference to a whole list
6411 Fetch the value of a hidden field this way:
6413 $hidden_value = param('hidden_name');
6415 Note, that just like all the other form elements, the value of a
6416 hidden field is "sticky". If you want to replace a hidden field with
6417 some other values after the script has been called once you'll have to
6420 param('hidden_name','new','values','here');
6422 =head2 CREATING A CLICKABLE IMAGE BUTTON
6424 print image_button(-name=>'button_name',
6425 -src=>'/source/URL',
6430 print image_button('button_name','/source/URL','MIDDLE');
6432 image_button() produces a clickable image. When it's clicked on the
6433 position of the click is returned to your script as "button_name.x"
6434 and "button_name.y", where "button_name" is the name you've assigned
6439 =item B<Parameters:>
6443 The first argument (-name) is required and specifies the name of this
6448 The second argument (-src) is also required and specifies the URL
6451 The third option (-align, optional) is an alignment type, and may be
6452 TOP, BOTTOM or MIDDLE
6456 Fetch the value of the button this way:
6457 $x = param('button_name.x');
6458 $y = param('button_name.y');
6460 =head2 CREATING A JAVASCRIPT ACTION BUTTON
6462 print button(-name=>'button_name',
6463 -value=>'user visible label',
6464 -onClick=>"do_something()");
6468 print button('button_name',"do_something()");
6470 button() produces a button that is compatible with Netscape 2.0's
6471 JavaScript. When it's pressed the fragment of JavaScript code
6472 pointed to by the B<-onClick> parameter will be executed. On
6473 non-Netscape browsers this form element will probably not even
6478 Netscape browsers versions 1.1 and higher, and all versions of
6479 Internet Explorer, support a so-called "cookie" designed to help
6480 maintain state within a browser session. CGI.pm has several methods
6481 that support cookies.
6483 A cookie is a name=value pair much like the named parameters in a CGI
6484 query string. CGI scripts create one or more cookies and send
6485 them to the browser in the HTTP header. The browser maintains a list
6486 of cookies that belong to a particular Web server, and returns them
6487 to the CGI script during subsequent interactions.
6489 In addition to the required name=value pair, each cookie has several
6490 optional attributes:
6494 =item 1. an expiration time
6496 This is a time/date string (in a special GMT format) that indicates
6497 when a cookie expires. The cookie will be saved and returned to your
6498 script until this expiration date is reached if the user exits
6499 the browser and restarts it. If an expiration date isn't specified, the cookie
6500 will remain active until the user quits the browser.
6504 This is a partial or complete domain name for which the cookie is
6505 valid. The browser will return the cookie to any host that matches
6506 the partial domain name. For example, if you specify a domain name
6507 of ".capricorn.com", then the browser will return the cookie to
6508 Web servers running on any of the machines "www.capricorn.com",
6509 "www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
6510 must contain at least two periods to prevent attempts to match
6511 on top level domains like ".edu". If no domain is specified, then
6512 the browser will only return the cookie to servers on the host the
6513 cookie originated from.
6517 If you provide a cookie path attribute, the browser will check it
6518 against your script's URL before returning the cookie. For example,
6519 if you specify the path "/cgi-bin", then the cookie will be returned
6520 to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
6521 and "/cgi-bin/customer_service/complain.pl", but not to the script
6522 "/cgi-private/site_admin.pl". By default, path is set to "/", which
6523 causes the cookie to be sent to any CGI script on your site.
6525 =item 4. a "secure" flag
6527 If the "secure" attribute is set, the cookie will only be sent to your
6528 script if the CGI request is occurring on a secure channel, such as SSL.
6532 The interface to HTTP cookies is the B<cookie()> method:
6534 $cookie = cookie(-name=>'sessionID',
6537 -path=>'/cgi-bin/database',
6538 -domain=>'.capricorn.org',
6540 print header(-cookie=>$cookie);
6542 B<cookie()> creates a new cookie. Its parameters include:
6548 The name of the cookie (required). This can be any string at all.
6549 Although browsers limit their cookie names to non-whitespace
6550 alphanumeric characters, CGI.pm removes this restriction by escaping
6551 and unescaping cookies behind the scenes.
6555 The value of the cookie. This can be any scalar value,
6556 array reference, or even associative array reference. For example,
6557 you can store an entire associative array into a cookie this way:
6559 $cookie=cookie(-name=>'family information',
6560 -value=>\%childrens_ages);
6564 The optional partial path for which this cookie will be valid, as described
6569 The optional partial domain for which this cookie will be valid, as described
6574 The optional expiration date for this cookie. The format is as described
6575 in the section on the B<header()> method:
6577 "+1h" one hour from now
6581 If set to true, this cookie will only be used within a secure
6586 The cookie created by cookie() must be incorporated into the HTTP
6587 header within the string returned by the header() method:
6589 print header(-cookie=>$my_cookie);
6591 To create multiple cookies, give header() an array reference:
6593 $cookie1 = cookie(-name=>'riddle_name',
6594 -value=>"The Sphynx's Question");
6595 $cookie2 = cookie(-name=>'answers',
6597 print header(-cookie=>[$cookie1,$cookie2]);
6599 To retrieve a cookie, request it by name by calling cookie() method
6600 without the B<-value> parameter:
6604 $riddle = cookie('riddle_name');
6605 %answers = cookie('answers');
6607 Cookies created with a single scalar value, such as the "riddle_name"
6608 cookie, will be returned in that form. Cookies with array and hash
6609 values can also be retrieved.
6611 The cookie and CGI namespaces are separate. If you have a parameter
6612 named 'answers' and a cookie named 'answers', the values retrieved by
6613 param() and cookie() are independent of each other. However, it's
6614 simple to turn a CGI parameter into a cookie, and vice-versa:
6616 # turn a CGI parameter into a cookie
6617 $c=cookie(-name=>'answers',-value=>[param('answers')]);
6619 param(-name=>'answers',-value=>[cookie('answers')]);
6621 See the B<cookie.cgi> example script for some ideas on how to use
6622 cookies effectively.
6624 =head1 WORKING WITH FRAMES
6626 It's possible for CGI.pm scripts to write into several browser panels
6627 and windows using the HTML 4 frame mechanism. There are three
6628 techniques for defining new frames programmatically:
6632 =item 1. Create a <Frameset> document
6634 After writing out the HTTP header, instead of creating a standard
6635 HTML document using the start_html() call, create a <frameset>
6636 document that defines the frames on the page. Specify your script(s)
6637 (with appropriate parameters) as the SRC for each of the frames.
6639 There is no specific support for creating <frameset> sections
6640 in CGI.pm, but the HTML is very simple to write. See the frame
6641 documentation in Netscape's home pages for details
6643 http://home.netscape.com/assist/net_sites/frames.html
6645 =item 2. Specify the destination for the document in the HTTP header
6647 You may provide a B<-target> parameter to the header() method:
6649 print header(-target=>'ResultsWindow');
6651 This will tell the browser to load the output of your script into the
6652 frame named "ResultsWindow". If a frame of that name doesn't already
6653 exist, the browser will pop up a new window and load your script's
6654 document into that. There are a number of magic names that you can
6655 use for targets. See the frame documents on Netscape's home pages for
6658 =item 3. Specify the destination for the document in the <form> tag
6660 You can specify the frame to load in the FORM tag itself. With
6661 CGI.pm it looks like this:
6663 print start_form(-target=>'ResultsWindow');
6665 When your script is reinvoked by the form, its output will be loaded
6666 into the frame named "ResultsWindow". If one doesn't already exist
6667 a new window will be created.
6671 The script "frameset.cgi" in the examples directory shows one way to
6672 create pages in which the fill-out form and the response live in
6673 side-by-side frames.
6675 =head1 SUPPORT FOR JAVASCRIPT
6677 Netscape versions 2.0 and higher incorporate an interpreted language
6678 called JavaScript. Internet Explorer, 3.0 and higher, supports a
6679 closely-related dialect called JScript. JavaScript isn't the same as
6680 Java, and certainly isn't at all the same as Perl, which is a great
6681 pity. JavaScript allows you to programmatically change the contents of
6682 fill-out forms, create new windows, and pop up dialog box from within
6683 Netscape itself. From the point of view of CGI scripting, JavaScript
6684 is quite useful for validating fill-out forms prior to submitting
6687 You'll need to know JavaScript in order to use it. There are many good
6688 sources in bookstores and on the web.
6690 The usual way to use JavaScript is to define a set of functions in a
6691 <SCRIPT> block inside the HTML header and then to register event
6692 handlers in the various elements of the page. Events include such
6693 things as the mouse passing over a form element, a button being
6694 clicked, the contents of a text field changing, or a form being
6695 submitted. When an event occurs that involves an element that has
6696 registered an event handler, its associated JavaScript code gets
6699 The elements that can register event handlers include the <BODY> of an
6700 HTML document, hypertext links, all the various elements of a fill-out
6701 form, and the form itself. There are a large number of events, and
6702 each applies only to the elements for which it is relevant. Here is a
6709 The browser is loading the current document. Valid in:
6711 + The HTML <BODY> section only.
6715 The browser is closing the current page or frame. Valid for:
6717 + The HTML <BODY> section only.
6721 The user has pressed the submit button of a form. This event happens
6722 just before the form is submitted, and your function can return a
6723 value of false in order to abort the submission. Valid for:
6729 The mouse has clicked on an item in a fill-out form. Valid for:
6731 + Buttons (including submit, reset, and image buttons)
6737 The user has changed the contents of a field. Valid for:
6748 The user has selected a field to work with. Valid for:
6759 The user has deselected a field (gone to work somewhere else). Valid
6771 The user has changed the part of a text field that is selected. Valid
6779 =item B<onMouseOver>
6781 The mouse has moved over an element.
6792 The mouse has moved off an element.
6803 In order to register a JavaScript event handler with an HTML element,
6804 just use the event name as a parameter when you call the corresponding
6805 CGI method. For example, to have your validateAge() JavaScript code
6806 executed every time the textfield named "age" changes, generate the
6809 print textfield(-name=>'age',-onChange=>"validateAge(this)");
6811 This example assumes that you've already declared the validateAge()
6812 function by incorporating it into a <SCRIPT> block. The CGI.pm
6813 start_html() method provides a convenient way to create this section.
6815 Similarly, you can create a form that checks itself over for
6816 consistency and alerts the user if some essential value is missing by
6817 creating it this way:
6818 print startform(-onSubmit=>"validateMe(this)");
6820 See the javascript.cgi script for a demonstration of how this all
6824 =head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
6826 CGI.pm has limited support for HTML3's cascading style sheets (css).
6827 To incorporate a stylesheet into your document, pass the
6828 start_html() method a B<-style> parameter. The value of this
6829 parameter may be a scalar, in which case it is treated as the source
6830 URL for the stylesheet, or it may be a hash reference. In the latter
6831 case you should provide the hash with one or more of B<-src> or
6832 B<-code>. B<-src> points to a URL where an externally-defined
6833 stylesheet can be found. B<-code> points to a scalar value to be
6834 incorporated into a <style> section. Style definitions in B<-code>
6835 override similarly-named ones in B<-src>, hence the name "cascading."
6837 You may also specify the type of the stylesheet by adding the optional
6838 B<-type> parameter to the hash pointed to by B<-style>. If not
6839 specified, the style defaults to 'text/css'.
6841 To refer to a style within the body of your document, add the
6842 B<-class> parameter to any HTML element:
6844 print h1({-class=>'Fancy'},'Welcome to the Party');
6846 Or define styles on the fly with the B<-style> parameter:
6848 print h1({-style=>'Color: red;'},'Welcome to Hell');
6850 You may also use the new B<span()> element to apply a style to a
6853 print span({-style=>'Color: red;'},
6854 h1('Welcome to Hell'),
6855 "Where did that handbasket get to?"
6858 Note that you must import the ":html3" definitions to have the
6859 B<span()> method available. Here's a quick and dirty example of using
6860 CSS's. See the CSS specification at
6861 http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
6863 use CGI qw/:standard :html3/;
6865 #here's a stylesheet incorporated directly into the page
6875 font-family: sans-serif;
6881 print start_html( -title=>'CGI with Style',
6882 -style=>{-src=>'http://www.capricorn.com/style/st1.css',
6885 print h1('CGI with Style'),
6887 "Better read the cascading style sheet spec before playing with this!"),
6888 span({-style=>'color: magenta'},
6889 "Look Mom, no hands!",
6895 Pass an array reference to B<-code> or B<-src> in order to incorporate
6896 multiple stylesheets into your document.
6898 Should you wish to incorporate a verbatim stylesheet that includes
6899 arbitrary formatting in the header, you may pass a -verbatim tag to
6900 the -style hash, as follows:
6902 print start_html (-STYLE => {-verbatim => '@import
6903 url("/server-common/css/'.$cssFile.'");',
6904 -src => '/server-common/css/core.css'});
6908 This will generate an HTML header that contains this:
6910 <link rel="stylesheet" type="text/css" href="/server-common/css/core.css">
6911 <style type="text/css">
6912 @import url("/server-common/css/main.css");
6915 Any additional arguments passed in the -style value will be
6916 incorporated into the <link> tag. For example:
6918 start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'],
6923 <link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/>
6924 <link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/>
6928 To make more complicated <link> tags, use the Link() function
6929 and pass it to start_html() in the -head argument, as in:
6931 @h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}),
6932 Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'}));
6933 print start_html({-head=>\@h})
6937 If you are running the script from the command line or in the perl
6938 debugger, you can pass the script a list of keywords or
6939 parameter=value pairs on the command line or from standard input (you
6940 don't have to worry about tricking your script into reading from
6941 environment variables). You can pass keywords like this:
6943 your_script.pl keyword1 keyword2 keyword3
6947 your_script.pl keyword1+keyword2+keyword3
6951 your_script.pl name1=value1 name2=value2
6955 your_script.pl name1=value1&name2=value2
6957 To turn off this feature, use the -no_debug pragma.
6959 To test the POST method, you may enable full debugging with the -debug
6960 pragma. This will allow you to feed newline-delimited name=value
6961 pairs to the script on standard input.
6963 When debugging, you can use quotes and backslashes to escape
6964 characters in the familiar shell manner, letting you place
6965 spaces and other funny characters in your parameter=value
6968 your_script.pl "name1='I am a long value'" "name2=two\ words"
6970 Finally, you can set the path info for the script by prefixing the first
6971 name/value parameter with the path followed by a question mark (?):
6973 your_script.pl /your/path/here?name1=value1&name2=value2
6975 =head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
6977 The Dump() method produces a string consisting of all the query's
6978 name/value pairs formatted nicely as a nested list. This is useful
6979 for debugging purposes:
6984 Produces something that looks like:
6998 As a shortcut, you can interpolate the entire CGI object into a string
6999 and it will be replaced with the a nice HTML dump shown above:
7002 print "<h2>Current Values</h2> $query\n";
7004 =head1 FETCHING ENVIRONMENT VARIABLES
7006 Some of the more useful environment variables can be fetched
7007 through this interface. The methods are as follows:
7013 Return a list of MIME types that the remote browser accepts. If you
7014 give this method a single argument corresponding to a MIME type, as in
7015 Accept('text/html'), it will return a floating point value
7016 corresponding to the browser's preference for this type from 0.0
7017 (don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept
7018 list are handled correctly.
7020 Note that the capitalization changed between version 2.43 and 2.44 in
7021 order to avoid conflict with Perl's accept() function.
7023 =item B<raw_cookie()>
7025 Returns the HTTP_COOKIE variable, an HTTP extension implemented by
7026 Netscape browsers version 1.1 and higher, and all versions of Internet
7027 Explorer. Cookies have a special format, and this method call just
7028 returns the raw form (?cookie dough). See cookie() for ways of
7029 setting and retrieving cooked cookies.
7031 Called with no parameters, raw_cookie() returns the packed cookie
7032 structure. You can separate it into individual cookies by splitting
7033 on the character sequence "; ". Called with the name of a cookie,
7034 retrieves the B<unescaped> form of the cookie. You can use the
7035 regular cookie() method to get the names, or use the raw_fetch()
7036 method from the CGI::Cookie module.
7038 =item B<user_agent()>
7040 Returns the HTTP_USER_AGENT variable. If you give
7041 this method a single argument, it will attempt to
7042 pattern match on it, allowing you to do something
7043 like user_agent(netscape);
7045 =item B<path_info()>
7047 Returns additional path information from the script URL.
7048 E.G. fetching /cgi-bin/your_script/additional/stuff will result in
7049 path_info() returning "/additional/stuff".
7051 NOTE: The Microsoft Internet Information Server
7052 is broken with respect to additional path information. If
7053 you use the Perl DLL library, the IIS server will attempt to
7054 execute the additional path information as a Perl script.
7055 If you use the ordinary file associations mapping, the
7056 path information will be present in the environment,
7057 but incorrect. The best thing to do is to avoid using additional
7058 path information in CGI scripts destined for use with IIS.
7060 =item B<path_translated()>
7062 As per path_info() but returns the additional
7063 path information translated into a physical path, e.g.
7064 "/usr/local/etc/httpd/htdocs/additional/stuff".
7066 The Microsoft IIS is broken with respect to the translated
7069 =item B<remote_host()>
7071 Returns either the remote host name or IP address.
7072 if the former is unavailable.
7074 =item B<script_name()>
7075 Return the script name as a partial URL, for self-refering
7080 Return the URL of the page the browser was viewing
7081 prior to fetching your script. Not available for all
7084 =item B<auth_type ()>
7086 Return the authorization/verification method in use for this
7089 =item B<server_name ()>
7091 Returns the name of the server, usually the machine's host
7094 =item B<virtual_host ()>
7096 When using virtual hosts, returns the name of the host that
7097 the browser attempted to contact
7099 =item B<server_port ()>
7101 Return the port that the server is listening on.
7103 =item B<virtual_port ()>
7105 Like server_port() except that it takes virtual hosts into account.
7106 Use this when running with virtual hosts.
7108 =item B<server_software ()>
7110 Returns the server software and version number.
7112 =item B<remote_user ()>
7114 Return the authorization/verification name used for user
7115 verification, if this script is protected.
7117 =item B<user_name ()>
7119 Attempt to obtain the remote user's name, using a variety of different
7120 techniques. This only works with older browsers such as Mosaic.
7121 Newer browsers do not report the user name for privacy reasons!
7123 =item B<request_method()>
7125 Returns the method used to access your script, usually
7126 one of 'POST', 'GET' or 'HEAD'.
7128 =item B<content_type()>
7130 Returns the content_type of data submitted in a POST, generally
7131 multipart/form-data or application/x-www-form-urlencoded
7135 Called with no arguments returns the list of HTTP environment
7136 variables, including such things as HTTP_USER_AGENT,
7137 HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the
7138 like-named HTTP header fields in the request. Called with the name of
7139 an HTTP header field, returns its value. Capitalization and the use
7140 of hyphens versus underscores are not significant.
7142 For example, all three of these examples are equivalent:
7144 $requested_language = http('Accept-language');
7145 $requested_language = http('Accept_language');
7146 $requested_language = http('HTTP_ACCEPT_LANGUAGE');
7150 The same as I<http()>, but operates on the HTTPS environment variables
7151 present when the SSL protocol is in effect. Can be used to determine
7152 whether SSL is turned on.
7156 =head1 USING NPH SCRIPTS
7158 NPH, or "no-parsed-header", scripts bypass the server completely by
7159 sending the complete HTTP header directly to the browser. This has
7160 slight performance benefits, but is of most use for taking advantage
7161 of HTTP extensions that are not directly supported by your server,
7162 such as server push and PICS headers.
7164 Servers use a variety of conventions for designating CGI scripts as
7165 NPH. Many Unix servers look at the beginning of the script's name for
7166 the prefix "nph-". The Macintosh WebSTAR server and Microsoft's
7167 Internet Information Server, in contrast, try to decide whether a
7168 program is an NPH script by examining the first line of script output.
7171 CGI.pm supports NPH scripts with a special NPH mode. When in this
7172 mode, CGI.pm will output the necessary extra header information when
7173 the header() and redirect() methods are
7176 The Microsoft Internet Information Server requires NPH mode. As of
7177 version 2.30, CGI.pm will automatically detect when the script is
7178 running under IIS and put itself into this mode. You do not need to
7179 do this manually, although it won't hurt anything if you do. However,
7180 note that if you have applied Service Pack 6, much of the
7181 functionality of NPH scripts, including the ability to redirect while
7182 setting a cookie, b<do not work at all> on IIS without a special patch
7184 http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP:
7185 Non-Parsed Headers Stripped From CGI Applications That Have nph-
7190 =item In the B<use> statement
7192 Simply add the "-nph" pragmato the list of symbols to be imported into
7195 use CGI qw(:standard -nph)
7197 =item By calling the B<nph()> method:
7199 Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
7203 =item By using B<-nph> parameters
7205 in the B<header()> and B<redirect()> statements:
7207 print header(-nph=>1);
7213 CGI.pm provides four simple functions for producing multipart
7214 documents of the type needed to implement server push. These
7215 functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To
7216 import these into your namespace, you must import the ":push" set.
7217 You are also advised to put the script into NPH mode and to set $| to
7218 1 to avoid buffering problems.
7220 Here is a simple script that demonstrates server push:
7222 #!/usr/local/bin/perl
7223 use CGI qw/:push -nph/;
7225 print multipart_init(-boundary=>'----here we go!');
7227 print multipart_start(-type=>'text/plain'),
7228 "The current time is ",scalar(localtime),"\n";
7230 print multipart_end;
7232 print multipart_final;
7237 This script initializes server push by calling B<multipart_init()>.
7238 It then enters a loop in which it begins a new multipart section by
7239 calling B<multipart_start()>, prints the current local time,
7240 and ends a multipart section with B<multipart_end()>. It then sleeps
7241 a second, and begins again. On the final iteration, it ends the
7242 multipart section with B<multipart_final()> rather than with
7247 =item multipart_init()
7249 multipart_init(-boundary=>$boundary);
7251 Initialize the multipart system. The -boundary argument specifies
7252 what MIME boundary string to use to separate parts of the document.
7253 If not provided, CGI.pm chooses a reasonable boundary for you.
7255 =item multipart_start()
7257 multipart_start(-type=>$type)
7259 Start a new part of the multipart document using the specified MIME
7260 type. If not specified, text/html is assumed.
7262 =item multipart_end()
7266 End a part. You must remember to call multipart_end() once for each
7267 multipart_start(), except at the end of the last part of the multipart
7268 document when multipart_final() should be called instead of multipart_end().
7270 =item multipart_final()
7274 End all parts. You should call multipart_final() rather than
7275 multipart_end() at the end of the last part of the multipart document.
7279 Users interested in server push applications should also have a look
7280 at the CGI::Push module.
7282 Only Netscape Navigator supports server push. Internet Explorer
7285 =head1 Avoiding Denial of Service Attacks
7287 A potential problem with CGI.pm is that, by default, it attempts to
7288 process form POSTings no matter how large they are. A wily hacker
7289 could attack your site by sending a CGI script a huge POST of many
7290 megabytes. CGI.pm will attempt to read the entire POST into a
7291 variable, growing hugely in size until it runs out of memory. While
7292 the script attempts to allocate the memory the system may slow down
7293 dramatically. This is a form of denial of service attack.
7295 Another possible attack is for the remote user to force CGI.pm to
7296 accept a huge file upload. CGI.pm will accept the upload and store it
7297 in a temporary directory even if your script doesn't expect to receive
7298 an uploaded file. CGI.pm will delete the file automatically when it
7299 terminates, but in the meantime the remote user may have filled up the
7300 server's disk space, causing problems for other programs.
7302 The best way to avoid denial of service attacks is to limit the amount
7303 of memory, CPU time and disk space that CGI scripts can use. Some Web
7304 servers come with built-in facilities to accomplish this. In other
7305 cases, you can use the shell I<limit> or I<ulimit>
7306 commands to put ceilings on CGI resource usage.
7309 CGI.pm also has some simple built-in protections against denial of
7310 service attacks, but you must activate them before you can use them.
7311 These take the form of two global variables in the CGI name space:
7315 =item B<$CGI::POST_MAX>
7317 If set to a non-negative integer, this variable puts a ceiling
7318 on the size of POSTings, in bytes. If CGI.pm detects a POST
7319 that is greater than the ceiling, it will immediately exit with an error
7320 message. This value will affect both ordinary POSTs and
7321 multipart POSTs, meaning that it limits the maximum size of file
7322 uploads as well. You should set this to a reasonably high
7323 value, such as 1 megabyte.
7325 =item B<$CGI::DISABLE_UPLOADS>
7327 If set to a non-zero value, this will disable file uploads
7328 completely. Other fill-out form values will work as usual.
7332 You can use these variables in either of two ways.
7336 =item B<1. On a script-by-script basis>
7338 Set the variable at the top of the script, right after the "use" statement:
7340 use CGI qw/:standard/;
7341 use CGI::Carp 'fatalsToBrowser';
7342 $CGI::POST_MAX=1024 * 100; # max 100K posts
7343 $CGI::DISABLE_UPLOADS = 1; # no uploads
7345 =item B<2. Globally for all scripts>
7347 Open up CGI.pm, find the definitions for $POST_MAX and
7348 $DISABLE_UPLOADS, and set them to the desired values. You'll
7349 find them towards the top of the file in a subroutine named
7350 initialize_globals().
7354 An attempt to send a POST larger than $POST_MAX bytes will cause
7355 I<param()> to return an empty CGI parameter list. You can test for
7356 this event by checking I<cgi_error()>, either after you create the CGI
7357 object or, if you are using the function-oriented interface, call
7358 <param()> for the first time. If the POST was intercepted, then
7359 cgi_error() will return the message "413 POST too large".
7361 This error message is actually defined by the HTTP protocol, and is
7362 designed to be returned to the browser as the CGI script's status
7365 $uploaded_file = param('upload');
7366 if (!$uploaded_file && cgi_error()) {
7367 print header(-status=>cgi_error());
7371 However it isn't clear that any browser currently knows what to do
7372 with this status code. It might be better just to create an
7373 HTML page that warns the user of the problem.
7375 =head1 COMPATIBILITY WITH CGI-LIB.PL
7377 To make it easier to port existing programs that use cgi-lib.pl the
7378 compatibility routine "ReadParse" is provided. Porting is simple:
7382 require "cgi-lib.pl";
7384 print "The value of the antique is $in{antique}.\n";
7390 print "The value of the antique is $in{antique}.\n";
7392 CGI.pm's ReadParse() routine creates a tied variable named %in,
7393 which can be accessed to obtain the query variables. Like
7394 ReadParse, you can also provide your own variable. Infrequently
7395 used features of ReadParse, such as the creation of @in and $in
7396 variables, are not supported.
7398 Once you use ReadParse, you can retrieve the query object itself
7402 print textfield(-name=>'wow',
7403 -value=>'does this really work?');
7405 This allows you to start using the more interesting features
7406 of CGI.pm without rewriting your old scripts from scratch.
7408 =head1 AUTHOR INFORMATION
7410 Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
7412 This library is free software; you can redistribute it and/or modify
7413 it under the same terms as Perl itself.
7415 Address bug reports and comments to: lstein@cshl.org. When sending
7416 bug reports, please provide the version of CGI.pm, the version of
7417 Perl, the name and version of your Web server, and the name and
7418 version of the operating system you are using. If the problem is even
7419 remotely browser dependent, please provide information about the
7420 affected browers as well.
7424 Thanks very much to:
7428 =item Matt Heffron (heffron@falstaff.css.beckman.com)
7430 =item James Taylor (james.taylor@srs.gov)
7432 =item Scott Anguish <sanguish@digifix.com>
7434 =item Mike Jewell (mlj3u@virginia.edu)
7436 =item Timothy Shimmin (tes@kbs.citri.edu.au)
7438 =item Joergen Haegg (jh@axis.se)
7440 =item Laurent Delfosse (delfosse@delfosse.com)
7442 =item Richard Resnick (applepi1@aol.com)
7444 =item Craig Bishop (csb@barwonwater.vic.gov.au)
7446 =item Tony Curtis (tc@vcpc.univie.ac.at)
7448 =item Tim Bunce (Tim.Bunce@ig.co.uk)
7450 =item Tom Christiansen (tchrist@convex.com)
7452 =item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
7454 =item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
7456 =item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
7458 =item Stephen Dahmen (joyfire@inxpress.net)
7460 =item Ed Jordan (ed@fidalgo.net)
7462 =item David Alan Pisoni (david@cnation.com)
7464 =item Doug MacEachern (dougm@opengroup.org)
7466 =item Robin Houston (robin@oneworld.org)
7468 =item ...and many many more...
7470 for suggestions and bug fixes.
7474 =head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
7477 #!/usr/local/bin/perl
7479 use CGI ':standard';
7482 print start_html("Example CGI.pm Form");
7483 print "<h1> Example CGI.pm Form</h1>\n";
7491 print "<em>What's your name?</em><br>";
7492 print textfield('name');
7493 print checkbox('Not my real name');
7495 print "<p><em>Where can you find English Sparrows?</em><br>";
7496 print checkbox_group(
7497 -name=>'Sparrow locations',
7498 -values=>[England,France,Spain,Asia,Hoboken],
7500 -defaults=>[England,Asia]);
7502 print "<p><em>How far can they fly?</em><br>",
7505 -values=>['10 ft','1 mile','10 miles','real far'],
7506 -default=>'1 mile');
7508 print "<p><em>What's your favorite color?</em> ";
7509 print popup_menu(-name=>'Color',
7510 -values=>['black','brown','red','yellow'],
7513 print hidden('Reference','Monty Python and the Holy Grail');
7515 print "<p><em>What have you got there?</em><br>";
7516 print scrolling_list(
7517 -name=>'possessions',
7518 -values=>['A Coconut','A Grail','An Icon',
7519 'A Sword','A Ticket'],
7523 print "<p><em>Any parting comments?</em><br>";
7524 print textarea(-name=>'Comments',
7529 print submit('Action','Shout');
7530 print submit('Action','Scream');
7538 print "<h2>Here are the current settings in this form</h2>";
7540 foreach $key (param) {
7541 print "<strong>$key</strong> -> ";
7542 @values = param($key);
7543 print join(", ",@values),"<br>\n";
7550 <address>Lincoln D. Stein</address><br>
7551 <a href="/">Home Page</a>
7561 L<CGI::Carp>, L<CGI::Fast>, L<CGI::Pretty>