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.145 2003/12/10 15:16:08 lstein Exp $';
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);
42 $MOD_PERL = 0; # no mod_perl by default
44 # >>>>> Here are some globals that you might want to adjust <<<<<<
45 sub initialize_globals {
46 # Set this to 1 to enable copious autoloader debugging messages
49 # Set this to 1 to generate XTML-compatible output
52 # Change this to the preferred DTD to print in start_html()
53 # or use default_dtd('text of DTD to use');
54 $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
55 'http://www.w3.org/TR/html4/loose.dtd' ] ;
57 # Set this to 1 to enable NOSTICKY scripts
59 # 1) use CGI qw(-nosticky)
60 # 2) $CGI::nosticky(1)
63 # Set this to 1 to enable NPH scripts
67 # 3) print header(-nph=>1)
70 # Set this to 1 to enable debugging from @ARGV
71 # Set to 2 to enable debugging from STDIN
74 # Set this to 1 to make the temporary files created
75 # during file uploads safe from prying eyes
77 # 1) use CGI qw(:private_tempfiles)
78 # 2) CGI::private_tempfiles(1);
79 $PRIVATE_TEMPFILES = 0;
81 # Set this to 1 to cause files uploaded in multipart documents
82 # to be closed, instead of caching the file handle
84 # 1) use CGI qw(:close_upload_files)
85 # 2) $CGI::close_upload_files(1);
86 # Uploads with many files run out of file handles.
87 # Also, for performance, since the file is already on disk,
88 # it can just be renamed, instead of read and written.
89 $CLOSE_UPLOAD_FILES = 0;
91 # Set this to a positive value to limit the size of a POSTing
92 # to a certain number of bytes:
95 # Change this to 1 to disable uploads entirely:
98 # Automatically determined -- don't change
101 # Change this to 1 to suppress redundant HTTP headers
104 # separate the name=value pairs by semicolons rather than ampersands
105 $USE_PARAM_SEMICOLONS = 1;
107 # Do not include undefined params parsed from query string
108 # use CGI qw(-no_undef_params);
109 $NO_UNDEF_PARAMS = 0;
111 # Other globals that you shouldn't worry about.
116 undef $QUERY_CHARSET;
117 undef %QUERY_FIELDNAMES;
119 # prevent complaints by mod_perl
123 # ------------------ START OF THE LIBRARY ------------
126 initialize_globals();
128 # FIGURE OUT THE OS WE'RE RUNNING UNDER
129 # Some systems support the $^O variable. If not
130 # available then require() the Config library
134 $OS = $Config::Config{'osname'};
137 if ($OS =~ /^MSWin/i) {
139 } elsif ($OS =~ /^VMS/i) {
141 } elsif ($OS =~ /^dos/i) {
143 } elsif ($OS =~ /^MacOS/i) {
145 } elsif ($OS =~ /^os2/i) {
147 } elsif ($OS =~ /^epoc/i) {
149 } elsif ($OS =~ /^cygwin/i) {
155 # Some OS logic. Binary mode enabled on DOS, NT and VMS
156 $needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN)/;
158 # This is the default class for the CGI object to use when all else fails.
159 $DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
161 # This is where to look for autoloaded routines.
162 $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
164 # The path separator is a slash, backslash or semicolon, depending
167 UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/',
168 WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
171 # This no longer seems to be necessary
172 # Turn on NPH scripts by default when running under IIS server!
173 # $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
174 $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
176 # Turn on special checking for Doug MacEachern's modperl
177 if (exists $ENV{MOD_PERL}) {
178 eval "require mod_perl";
179 # mod_perl handlers may run system() on scripts using CGI.pm;
180 # Make sure so we don't get fooled by inherited $ENV{MOD_PERL}
181 if (defined $mod_perl::VERSION) {
182 if ($mod_perl::VERSION >= 1.99) {
184 require Apache::RequestRec;
185 require Apache::RequestUtil;
194 # Turn on special checking for ActiveState's PerlEx
195 $PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
197 # Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
198 # of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
199 # and sometimes CR). The most popular VMS web server
200 # doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
201 # use ASCII, so \015\012 means something different. I find this all
203 $EBCDIC = "\t" ne "\011";
212 if ($needs_binmode) {
213 $CGI::DefaultClass->binmode(\*main::STDOUT);
214 $CGI::DefaultClass->binmode(\*main::STDIN);
215 $CGI::DefaultClass->binmode(\*main::STDERR);
219 ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
220 tt u i b blockquote pre img a address cite samp dfn html head
221 base body Link nextid title meta kbd start_html end_html
222 input Select option comment charset escapeHTML/],
223 ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param
224 embed basefont style span layer ilayer font frameset frame script small big Area Map/],
225 ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
226 ins label legend noframes noscript object optgroup Q
228 ':netscape'=>[qw/blink fontsize center/],
229 ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
230 submit reset defaults radio_group popup_menu button autoEscape
231 scrolling_list image_button start_form end_form startform endform
232 start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
233 ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump
234 raw_cookie request_method query_string Accept user_agent remote_host content_type
235 remote_addr referer server_name server_software server_port server_protocol virtual_port
236 virtual_host remote_ident auth_type http append
237 save_parameters restore_parameters param_fetch
238 remote_user user_name header redirect import_names put
239 Delete Delete_all url_param cgi_error/],
240 ':ssl' => [qw/https/],
241 ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
242 ':html' => [qw/:html2 :html3 :html4 :netscape/],
243 ':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
244 ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
245 ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/]
248 # to import symbols into caller
252 # This causes modules to clash.
256 $self->_setup_symbols(@_);
257 my ($callpack, $callfile, $callline) = caller;
259 # To allow overriding, search through the packages
260 # Till we find one in which the correct subroutine is defined.
261 my @packages = ($self,@{"$self\:\:ISA"});
262 foreach $sym (keys %EXPORT) {
264 my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
265 foreach $pck (@packages) {
266 if (defined(&{"$pck\:\:$sym"})) {
271 *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
277 $pack->_setup_symbols('-compile',@_);
282 return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
284 return ($tag) unless $EXPORT_TAGS{$tag};
285 foreach (@{$EXPORT_TAGS{$tag}}) {
286 push(@r,&expand_tags($_));
292 # The new routine. This will check the current environment
293 # for an existing query string, and initialize itself, if so.
296 my($class,@initializer) = @_;
299 bless $self,ref $class || $class || $DefaultClass;
300 if (ref($initializer[0])
301 && (UNIVERSAL::isa($initializer[0],'Apache')
303 UNIVERSAL::isa($initializer[0],'Apache::RequestRec')
305 $self->r(shift @initializer);
308 $self->r(Apache->request) unless $self->r;
310 if ($MOD_PERL == 1) {
311 $r->register_cleanup(\&CGI::_reset_globals);
314 # XXX: once we have the new API
315 # will do a real PerlOptions -SetupEnv check
316 $r->subprocess_env unless exists $ENV{REQUEST_METHOD};
317 $r->pool->cleanup_register(\&CGI::_reset_globals);
321 $self->_reset_globals if $PERLEX;
322 $self->init(@initializer);
326 # We provide a DESTROY method so that we can ensure that
327 # temporary files are closed (via Fh->DESTROY) before they
328 # are unlinked (via CGITempFile->DESTROY) because it is not
329 # possible to unlink an open file on Win32. We explicitly
330 # call DESTROY on each, rather than just undefing them and
331 # letting Perl DESTROY them by garbage collection, in case the
332 # user is still holding any reference to them as well.
335 foreach my $href (values %{$self->{'.tmpfiles'}}) {
336 $href->{hndl}->DESTROY if defined $href->{hndl};
337 $href->{name}->DESTROY if defined $href->{name};
343 my $r = $self->{'.r'};
344 $self->{'.r'} = shift if @_;
349 my ($self,$hook,$data) = self_or_default(@_);
350 $self->{'.upload_hook'} = $hook;
351 $self->{'.upload_data'} = $data;
355 # Returns the value(s)of a named parameter.
356 # If invoked in a list context, returns the
357 # entire list. Otherwise returns the first
358 # member of the list.
359 # If name is not provided, return a list of all
360 # the known parameters names available.
361 # If more than one argument is provided, the
362 # second and subsequent arguments are used to
363 # set the value of the parameter.
366 my($self,@p) = self_or_default(@_);
367 return $self->all_parameters unless @p;
368 my($name,$value,@other);
370 # For compatibility between old calling style and use_named_parameters() style,
371 # we have to special case for a single parameter present.
373 ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
376 if (substr($p[0],0,1) eq '-') {
377 @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
379 foreach ($value,@other) {
380 push(@values,$_) if defined($_);
383 # If values is provided, then we set it.
385 $self->add_parameter($name);
386 $self->{$name}=[@values];
392 return unless defined($name) && $self->{$name};
393 return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
396 sub self_or_default {
397 return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
398 unless (defined($_[0]) &&
399 (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
401 $Q = $CGI::DefaultClass->new unless defined($Q);
404 return wantarray ? @_ : $Q;
408 local $^W=0; # prevent a warning
409 if (defined($_[0]) &&
410 (substr(ref($_[0]),0,3) eq 'CGI'
411 || UNIVERSAL::isa($_[0],'CGI'))) {
414 return ($DefaultClass,@_);
418 ########################################
419 # THESE METHODS ARE MORE OR LESS PRIVATE
420 # GO TO THE __DATA__ SECTION TO SEE MORE
422 ########################################
424 # Initialize the query object from the environment.
425 # If a parameter list is found, this object will be set
426 # to an associative array in which parameter names are keys
427 # and the values are stored as lists
428 # If a keyword list is found, this method creates a bogus
429 # parameter list with the single parameter 'keywords'.
433 my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
435 my $initializer = shift; # for backward compatibility
438 # set autoescaping on by default
439 $self->{'escape'} = 1;
441 # if we get called more than once, we want to initialize
442 # ourselves from the original query (which may be gone
443 # if it was read from STDIN originally.)
444 if (defined(@QUERY_PARAM) && !defined($initializer)) {
445 foreach (@QUERY_PARAM) {
446 $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
448 $self->charset($QUERY_CHARSET);
449 $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
453 $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
454 $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
456 $fh = to_filehandle($initializer) if $initializer;
458 # set charset to the safe ISO-8859-1
459 $self->charset('ISO-8859-1');
463 # avoid unreasonably large postings
464 if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
465 # quietly read and discard the post
467 my $max = $content_length;
469 (my $bytes = $MOD_PERL
470 ? $self->r->read($buffer,$max < 10000 ? $max : 10000)
471 : read(STDIN,$buffer,$max < 10000 ? $max : 10000)
473 $self->cgi_error("413 Request entity too large");
478 # Process multipart postings, but only if the initializer is
481 && defined($ENV{'CONTENT_TYPE'})
482 && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
483 && !defined($initializer)
485 my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
486 $self->read_multipart($boundary,$content_length);
490 # If initializer is defined, then read parameters
492 if (defined($initializer)) {
493 if (UNIVERSAL::isa($initializer,'CGI')) {
494 $query_string = $initializer->query_string;
497 if (ref($initializer) && ref($initializer) eq 'HASH') {
498 foreach (keys %$initializer) {
499 $self->param('-name'=>$_,'-value'=>$initializer->{$_});
504 if (defined($fh) && ($fh ne '')) {
510 # massage back into standard format
511 if ("@lines" =~ /=/) {
512 $query_string=join("&",@lines);
514 $query_string=join("+",@lines);
519 if (defined($fh) && ($fh ne '')) {
525 # massage back into standard format
526 if ("@lines" =~ /=/) {
527 $query_string=join("&",@lines);
529 $query_string=join("+",@lines);
534 # last chance -- treat it as a string
535 $initializer = $$initializer if ref($initializer) eq 'SCALAR';
536 $query_string = $initializer;
541 # If method is GET or HEAD, fetch the query from
543 if ($meth=~/^(GET|HEAD)$/) {
545 $query_string = $self->r->args;
547 $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
548 $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
553 if ($meth eq 'POST') {
554 $self->read_from_client(\$query_string,$content_length,0)
555 if $content_length > 0;
556 # Some people want to have their cake and eat it too!
557 # Uncomment this line to have the contents of the query string
558 # APPENDED to the POST data.
559 # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
563 # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
564 # Check the command line and then the standard input for data.
565 # We use the shellwords package in order to behave the way that
566 # UN*X programmers expect.
569 my $cmdline_ret = read_from_cmdline();
570 $query_string = $cmdline_ret->{'query_string'};
571 if (defined($cmdline_ret->{'subpath'}))
573 $self->path_info($cmdline_ret->{'subpath'});
578 # YL: Begin Change for XML handler 10/19/2001
580 && defined($ENV{'CONTENT_TYPE'})
581 && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
582 && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
583 my($param) = 'POSTDATA' ;
584 $self->add_parameter($param) ;
585 push (@{$self->{$param}},$query_string);
586 undef $query_string ;
588 # YL: End Change for XML handler 10/19/2001
590 # We now have the query string in hand. We do slightly
591 # different things for keyword lists and parameter lists.
592 if (defined $query_string && length $query_string) {
593 if ($query_string =~ /[&=;]/) {
594 $self->parse_params($query_string);
596 $self->add_parameter('keywords');
597 $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
601 # Special case. Erase everything if there is a field named
603 if ($self->param('.defaults')) {
607 # Associative array containing our defined fieldnames
608 $self->{'.fieldnames'} = {};
609 foreach ($self->param('.cgifields')) {
610 $self->{'.fieldnames'}->{$_}++;
613 # Clear out our default submission button flag if present
614 $self->delete('.submit');
615 $self->delete('.cgifields');
617 $self->save_request unless defined $initializer;
620 # FUNCTIONS TO OVERRIDE:
621 # Turn a string into a filehandle
624 return undef unless $thingy;
625 return $thingy if UNIVERSAL::isa($thingy,'GLOB');
626 return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
629 while (my $package = caller($caller++)) {
630 my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
631 return $tmp if defined(fileno($tmp));
637 # send output to the browser
639 my($self,@p) = self_or_default(@_);
643 # print to standard output (for overriding in mod_perl)
649 # get/set last cgi_error
651 my ($self,$err) = self_or_default(@_);
652 $self->{'.cgi_error'} = $err if defined $err;
653 return $self->{'.cgi_error'};
658 # We're going to play with the package globals now so that if we get called
659 # again, we initialize ourselves in exactly the same way. This allows
660 # us to have several of these objects.
661 @QUERY_PARAM = $self->param; # save list of parameters
662 foreach (@QUERY_PARAM) {
663 next unless defined $_;
664 $QUERY_PARAM{$_}=$self->{$_};
666 $QUERY_CHARSET = $self->charset;
667 %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
671 my($self,$tosplit) = @_;
672 my(@pairs) = split(/[&;]/,$tosplit);
675 ($param,$value) = split('=',$_,2);
676 next unless defined $param;
677 next if $NO_UNDEF_PARAMS and not defined $value;
678 $value = '' unless defined $value;
679 $param = unescape($param);
680 $value = unescape($value);
681 $self->add_parameter($param);
682 push (@{$self->{$param}},$value);
688 return unless defined $param;
689 push (@{$self->{'.parameters'}},$param)
690 unless defined($self->{$param});
695 return () unless defined($self) && $self->{'.parameters'};
696 return () unless @{$self->{'.parameters'}};
697 return @{$self->{'.parameters'}};
700 # put a filehandle into binary mode (DOS)
702 return unless defined($_[1]) && defined fileno($_[1]);
703 CORE::binmode($_[1]);
707 my ($self,$tagname) = @_;
710 my (\$q,\$a,\@rest) = self_or_default(\@_);
712 if (ref(\$a) && ref(\$a) eq 'HASH') {
713 my(\@attr) = make_attributes(\$a,\$q->{'escape'});
714 \$attr = " \@attr" if \@attr;
716 unshift \@rest,\$a if defined \$a;
719 if ($tagname=~/start_(\w+)/i) {
720 $func .= qq! return "<\L$1\E\$attr>";} !;
721 } elsif ($tagname=~/end_(\w+)/i) {
722 $func .= qq! return "<\L/$1\E>"; } !;
725 return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest;
726 my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
727 my \@result = map { "\$tag\$_\$untag" }
728 (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
736 print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
737 my $func = &_compile;
742 my($func) = $AUTOLOAD;
743 my($pack,$func_name);
745 local($1,$2); # this fixes an obscure variable suicide problem.
746 $func=~/(.+)::([^:]+)$/;
747 ($pack,$func_name) = ($1,$2);
748 $pack=~s/::SUPER$//; # fix another obscure problem
749 $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
750 unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
752 my($sub) = \%{"$pack\:\:SUBS"};
754 my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
755 eval "package $pack; $$auto";
756 croak("$AUTOLOAD: $@") if $@;
757 $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
759 my($code) = $sub->{$func_name};
761 $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
763 (my $base = $func_name) =~ s/^(start_|end_)//i;
764 if ($EXPORT{':any'} ||
767 (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
768 && $EXPORT_OK{$base}) {
769 $code = $CGI::DefaultClass->_make_tag_func($func_name);
772 croak("Undefined subroutine $AUTOLOAD\n") unless $code;
773 eval "package $pack; $code";
776 croak("$AUTOLOAD: $@");
779 CORE::delete($sub->{$func_name}); #free storage
780 return "$pack\:\:$func_name";
786 return '' unless $value;
787 return $XHTML ? qq( selected="selected") : qq( selected);
793 return '' unless $value;
794 return $XHTML ? qq( checked="checked") : qq( checked);
797 sub _reset_globals { initialize_globals(); }
803 # to avoid reexporting unwanted variables
807 $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
808 $NPH++, next if /^[:-]nph$/;
809 $NOSTICKY++, next if /^[:-]nosticky$/;
810 $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
811 $DEBUG=2, next if /^[:-][Dd]ebug$/;
812 $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
813 $XHTML++, next if /^[:-]xhtml$/;
814 $XHTML=0, next if /^[:-]no_?xhtml$/;
815 $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
816 $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
817 $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
818 $EXPORT{$_}++, next if /^[:-]any$/;
819 $compile++, next if /^[:-]compile$/;
820 $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
822 # This is probably extremely evil code -- to be deleted some day.
823 if (/^[-]autoload$/) {
824 my($pkg) = caller(1);
825 *{"${pkg}::AUTOLOAD"} = sub {
826 my($routine) = $AUTOLOAD;
827 $routine =~ s/^.*::/CGI::/;
833 foreach (&expand_tags($_)) {
834 tr/a-zA-Z0-9_//cd; # don't allow weird function names
838 _compile_all(keys %EXPORT) if $compile;
843 my ($self,$charset) = self_or_default(@_);
844 $self->{'.charset'} = $charset if defined $charset;
848 ###############################################################################
849 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
850 ###############################################################################
851 $AUTOLOADED_ROUTINES = ''; # get rid of -w warning
852 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
856 'URL_ENCODED'=> <<'END_OF_FUNC',
857 sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
860 'MULTIPART' => <<'END_OF_FUNC',
861 sub MULTIPART { 'multipart/form-data'; }
864 'SERVER_PUSH' => <<'END_OF_FUNC',
865 sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
868 'new_MultipartBuffer' => <<'END_OF_FUNC',
869 # Create a new multipart buffer
870 sub new_MultipartBuffer {
871 my($self,$boundary,$length) = @_;
872 return MultipartBuffer->new($self,$boundary,$length);
876 'read_from_client' => <<'END_OF_FUNC',
877 # Read data from a file handle
878 sub read_from_client {
879 my($self, $buff, $len, $offset) = @_;
880 local $^W=0; # prevent a warning
882 ? $self->r->read($$buff, $len, $offset)
883 : read(\*STDIN, $$buff, $len, $offset);
887 'delete' => <<'END_OF_FUNC',
889 # Deletes the named parameter entirely.
892 my($self,@p) = self_or_default(@_);
893 my(@names) = rearrange([NAME],@p);
894 my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
896 foreach my $name (@to_delete)
898 CORE::delete $self->{$name};
899 CORE::delete $self->{'.fieldnames'}->{$name};
902 @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
903 return wantarray ? () : undef;
907 #### Method: import_names
908 # Import all parameters into the given namespace.
909 # Assumes namespace 'Q' if not specified
911 'import_names' => <<'END_OF_FUNC',
913 my($self,$namespace,$delete) = self_or_default(@_);
914 $namespace = 'Q' unless defined($namespace);
915 die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
916 if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
917 # can anyone find an easier way to do this?
918 foreach (keys %{"${namespace}::"}) {
919 local *symbol = "${namespace}::${_}";
925 my($param,@value,$var);
926 foreach $param ($self->param) {
927 # protect against silly names
928 ($var = $param)=~tr/a-zA-Z0-9_/_/c;
929 $var =~ s/^(?=\d)/_/;
930 local *symbol = "${namespace}::$var";
931 @value = $self->param($param);
938 #### Method: keywords
939 # Keywords acts a bit differently. Calling it in a list context
940 # returns the list of keywords.
941 # Calling it in a scalar context gives you the size of the list.
943 'keywords' => <<'END_OF_FUNC',
945 my($self,@values) = self_or_default(@_);
946 # If values is provided, then we set it.
947 $self->{'keywords'}=[@values] if @values;
948 my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
953 # These are some tie() interfaces for compatibility
954 # with Steve Brenner's cgi-lib.pl routines
955 'Vars' => <<'END_OF_FUNC',
960 return %in if wantarray;
965 # These are some tie() interfaces for compatibility
966 # with Steve Brenner's cgi-lib.pl routines
967 'ReadParse' => <<'END_OF_FUNC',
977 return scalar(keys %in);
981 'PrintHeader' => <<'END_OF_FUNC',
983 my($self) = self_or_default(@_);
984 return $self->header();
988 'HtmlTop' => <<'END_OF_FUNC',
990 my($self,@p) = self_or_default(@_);
991 return $self->start_html(@p);
995 'HtmlBot' => <<'END_OF_FUNC',
997 my($self,@p) = self_or_default(@_);
998 return $self->end_html(@p);
1002 'SplitParam' => <<'END_OF_FUNC',
1005 my (@params) = split ("\0", $param);
1006 return (wantarray ? @params : $params[0]);
1010 'MethGet' => <<'END_OF_FUNC',
1012 return request_method() eq 'GET';
1016 'MethPost' => <<'END_OF_FUNC',
1018 return request_method() eq 'POST';
1022 'TIEHASH' => <<'END_OF_FUNC',
1026 if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
1029 return $Q ||= $class->new(@_);
1033 'STORE' => <<'END_OF_FUNC',
1038 my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
1039 $self->param(-name=>$tag,-value=>\@vals);
1043 'FETCH' => <<'END_OF_FUNC',
1045 return $_[0] if $_[1] eq 'CGI';
1046 return undef unless defined $_[0]->param($_[1]);
1047 return join("\0",$_[0]->param($_[1]));
1051 'FIRSTKEY' => <<'END_OF_FUNC',
1053 $_[0]->{'.iterator'}=0;
1054 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1058 'NEXTKEY' => <<'END_OF_FUNC',
1060 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
1064 'EXISTS' => <<'END_OF_FUNC',
1066 exists $_[0]->{$_[1]};
1070 'DELETE' => <<'END_OF_FUNC',
1072 $_[0]->delete($_[1]);
1076 'CLEAR' => <<'END_OF_FUNC',
1084 # Append a new value to an existing query
1086 'append' => <<'EOF',
1089 my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
1090 my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
1092 $self->add_parameter($name);
1093 push(@{$self->{$name}},@values);
1095 return $self->param($name);
1099 #### Method: delete_all
1100 # Delete all parameters
1102 'delete_all' => <<'EOF',
1104 my($self) = self_or_default(@_);
1105 my @param = $self->param();
1106 $self->delete(@param);
1110 'Delete' => <<'EOF',
1112 my($self,@p) = self_or_default(@_);
1117 'Delete_all' => <<'EOF',
1119 my($self,@p) = self_or_default(@_);
1120 $self->delete_all(@p);
1124 #### Method: autoescape
1125 # If you want to turn off the autoescaping features,
1126 # call this method with undef as the argument
1127 'autoEscape' => <<'END_OF_FUNC',
1129 my($self,$escape) = self_or_default(@_);
1130 my $d = $self->{'escape'};
1131 $self->{'escape'} = $escape;
1137 #### Method: version
1138 # Return the current version
1140 'version' => <<'END_OF_FUNC',
1146 #### Method: url_param
1147 # Return a parameter in the QUERY_STRING, regardless of
1148 # whether this was a POST or a GET
1150 'url_param' => <<'END_OF_FUNC',
1152 my ($self,@p) = self_or_default(@_);
1153 my $name = shift(@p);
1154 return undef unless exists($ENV{QUERY_STRING});
1155 unless (exists($self->{'.url_param'})) {
1156 $self->{'.url_param'}={}; # empty hash
1157 if ($ENV{QUERY_STRING} =~ /=/) {
1158 my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
1161 ($param,$value) = split('=',$_,2);
1162 $param = unescape($param);
1163 $value = unescape($value);
1164 push(@{$self->{'.url_param'}->{$param}},$value);
1167 $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
1170 return keys %{$self->{'.url_param'}} unless defined($name);
1171 return () unless $self->{'.url_param'}->{$name};
1172 return wantarray ? @{$self->{'.url_param'}->{$name}}
1173 : $self->{'.url_param'}->{$name}->[0];
1178 # Returns a string in which all the known parameter/value
1179 # pairs are represented as nested lists, mainly for the purposes
1182 'Dump' => <<'END_OF_FUNC',
1184 my($self) = self_or_default(@_);
1185 my($param,$value,@result);
1186 return '<ul></ul>' unless $self->param;
1187 push(@result,"<ul>");
1188 foreach $param ($self->param) {
1189 my($name)=$self->escapeHTML($param);
1190 push(@result,"<li><strong>$param</strong></li>");
1191 push(@result,"<ul>");
1192 foreach $value ($self->param($param)) {
1193 $value = $self->escapeHTML($value);
1194 $value =~ s/\n/<br \/>\n/g;
1195 push(@result,"<li>$value</li>");
1197 push(@result,"</ul>");
1199 push(@result,"</ul>");
1200 return join("\n",@result);
1204 #### Method as_string
1206 # synonym for "dump"
1208 'as_string' => <<'END_OF_FUNC',
1215 # Write values out to a filehandle in such a way that they can
1216 # be reinitialized by the filehandle form of the new() method
1218 'save' => <<'END_OF_FUNC',
1220 my($self,$filehandle) = self_or_default(@_);
1221 $filehandle = to_filehandle($filehandle);
1223 local($,) = ''; # set print field separator back to a sane value
1224 local($\) = ''; # set output line separator to a sane value
1225 foreach $param ($self->param) {
1226 my($escaped_param) = escape($param);
1228 foreach $value ($self->param($param)) {
1229 print $filehandle "$escaped_param=",escape("$value"),"\n";
1232 foreach (keys %{$self->{'.fieldnames'}}) {
1233 print $filehandle ".cgifields=",escape("$_"),"\n";
1235 print $filehandle "=\n"; # end of record
1240 #### Method: save_parameters
1241 # An alias for save() that is a better name for exportation.
1242 # Only intended to be used with the function (non-OO) interface.
1244 'save_parameters' => <<'END_OF_FUNC',
1245 sub save_parameters {
1247 return save(to_filehandle($fh));
1251 #### Method: restore_parameters
1252 # A way to restore CGI parameters from an initializer.
1253 # Only intended to be used with the function (non-OO) interface.
1255 'restore_parameters' => <<'END_OF_FUNC',
1256 sub restore_parameters {
1257 $Q = $CGI::DefaultClass->new(@_);
1261 #### Method: multipart_init
1262 # Return a Content-Type: style header for server-push
1263 # This has to be NPH on most web servers, and it is advisable to set $| = 1
1265 # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1266 # contribution, updated by Andrew Benham (adsb@bigfoot.com)
1268 'multipart_init' => <<'END_OF_FUNC',
1269 sub multipart_init {
1270 my($self,@p) = self_or_default(@_);
1271 my($boundary,@other) = rearrange([BOUNDARY],@p);
1272 $boundary = $boundary || '------- =_aaaaaaaaaa0';
1273 $self->{'separator'} = "$CRLF--$boundary$CRLF";
1274 $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
1275 $type = SERVER_PUSH($boundary);
1276 return $self->header(
1279 (map { split "=", $_, 2 } @other),
1280 ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
1285 #### Method: multipart_start
1286 # Return a Content-Type: style header for server-push, start of section
1288 # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1289 # contribution, updated by Andrew Benham (adsb@bigfoot.com)
1291 'multipart_start' => <<'END_OF_FUNC',
1292 sub multipart_start {
1294 my($self,@p) = self_or_default(@_);
1295 my($type,@other) = rearrange([TYPE],@p);
1296 $type = $type || 'text/html';
1297 push(@header,"Content-Type: $type");
1299 # rearrange() was designed for the HTML portion, so we
1300 # need to fix it up a little.
1302 # Don't use \s because of perl bug 21951
1303 next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
1304 ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
1306 push(@header,@other);
1307 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1313 #### Method: multipart_end
1314 # Return a MIME boundary separator for server-push, end of section
1316 # Many thanks to Ed Jordan <ed@fidalgo.net> for this
1319 'multipart_end' => <<'END_OF_FUNC',
1321 my($self,@p) = self_or_default(@_);
1322 return $self->{'separator'};
1327 #### Method: multipart_final
1328 # Return a MIME boundary separator for server-push, end of all sections
1330 # Contributed by Andrew Benham (adsb@bigfoot.com)
1332 'multipart_final' => <<'END_OF_FUNC',
1333 sub multipart_final {
1334 my($self,@p) = self_or_default(@_);
1335 return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
1341 # Return a Content-Type: style header
1344 'header' => <<'END_OF_FUNC',
1346 my($self,@p) = self_or_default(@_);
1349 return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
1351 my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
1352 rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
1353 'STATUS',['COOKIE','COOKIES'],'TARGET',
1354 'EXPIRES','NPH','CHARSET',
1355 'ATTACHMENT','P3P'],@p);
1358 if (defined $charset) {
1359 $self->charset($charset);
1361 $charset = $self->charset;
1364 # rearrange() was designed for the HTML portion, so we
1365 # need to fix it up a little.
1367 # Don't use \s because of perl bug 21951
1368 next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
1369 ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
1372 $type ||= 'text/html' unless defined($type);
1373 $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/ and $charset ne '';
1375 # Maybe future compatibility. Maybe not.
1376 my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
1377 push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
1378 push(@header,"Server: " . &server_software()) if $nph;
1380 push(@header,"Status: $status") if $status;
1381 push(@header,"Window-Target: $target") if $target;
1383 $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
1384 push(@header,qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p"));
1386 # push all the cookies -- there may be several
1388 my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
1390 my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
1391 push(@header,"Set-Cookie: $cs") if $cs ne '';
1394 # if the user indicates an expiration time, then we need
1395 # both an Expires and a Date header (so that the browser is
1397 push(@header,"Expires: " . expires($expires,'http'))
1399 push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
1400 push(@header,"Pragma: no-cache") if $self->cache();
1401 push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
1402 push(@header,map {ucfirst $_} @other);
1403 push(@header,"Content-Type: $type") if $type ne '';
1404 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1405 if ($MOD_PERL and not $nph) {
1406 $self->r->send_cgi_header($header);
1415 # Control whether header() will produce the no-cache
1418 'cache' => <<'END_OF_FUNC',
1420 my($self,$new_value) = self_or_default(@_);
1421 $new_value = '' unless $new_value;
1422 if ($new_value ne '') {
1423 $self->{'cache'} = $new_value;
1425 return $self->{'cache'};
1430 #### Method: redirect
1431 # Return a Location: style header
1434 'redirect' => <<'END_OF_FUNC',
1436 my($self,@p) = self_or_default(@_);
1437 my($url,$target,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,['COOKIE','COOKIES'],NPH],@p);
1438 $url ||= $self->self_url;
1440 foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
1442 '-Status' => '302 Moved',
1445 unshift(@o,'-Target'=>$target) if $target;
1446 unshift(@o,'-Type'=>'');
1448 unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
1449 return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
1454 #### Method: start_html
1455 # Canned HTML header
1458 # $title -> (optional) The title for this HTML document (-title)
1459 # $author -> (optional) e-mail address of the author (-author)
1460 # $base -> (optional) if set to true, will enter the BASE address of this document
1461 # for resolving relative references (-base)
1462 # $xbase -> (optional) alternative base at some remote location (-xbase)
1463 # $target -> (optional) target window to load all links into (-target)
1464 # $script -> (option) Javascript code (-script)
1465 # $no_script -> (option) Javascript <noscript> tag (-noscript)
1466 # $meta -> (optional) Meta information tags
1467 # $head -> (optional) any other elements you'd like to incorporate into the <head> tag
1468 # (a scalar or array ref)
1469 # $style -> (optional) reference to an external style sheet
1470 # @other -> (optional) any other named parameters you'd like to incorporate into
1473 'start_html' => <<'END_OF_FUNC',
1475 my($self,@p) = &self_or_default(@_);
1476 my($title,$author,$base,$xbase,$script,$noscript,
1477 $target,$meta,$head,$style,$dtd,$lang,$encoding,@other) =
1478 rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD,LANG,ENCODING],@p);
1480 $encoding = 'iso-8859-1' unless defined $encoding;
1482 # strangely enough, the title needs to be escaped as HTML
1483 # while the author needs to be escaped as a URL
1484 $title = $self->escapeHTML($title || 'Untitled Document');
1485 $author = $self->escape($author);
1486 $lang = 'en-US' unless defined $lang;
1487 my(@result,$xml_dtd);
1489 if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
1490 $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
1492 $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
1495 $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
1498 $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
1499 $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
1500 push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd;
1502 if (ref($dtd) && ref($dtd) eq 'ARRAY') {
1503 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
1505 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
1507 push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml" lang="$lang" xml:lang="$lang"><head><title>$title</title>)
1508 : ($lang ? qq(<html lang="$lang">) : "<html>")
1509 . "<head><title>$title</title>");
1510 if (defined $author) {
1511 push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
1512 : "<link rev=\"made\" href=\"mailto:$author\">");
1515 if ($base || $xbase || $target) {
1516 my $href = $xbase || $self->url('-path'=>1);
1517 my $t = $target ? qq/ target="$target"/ : '';
1518 push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
1521 if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
1522 foreach (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
1523 : qq(<meta name="$_" content="$meta->{$_}">)); }
1526 push(@result,ref($head) ? @$head : $head) if $head;
1528 # handle the infrequently-used -style and -script parameters
1529 push(@result,$self->_style($style)) if defined $style;
1530 push(@result,$self->_script($script)) if defined $script;
1532 # handle -noscript parameter
1533 push(@result,<<END) if $noscript;
1539 my($other) = @other ? " @other" : '';
1540 push(@result,"</head><body$other>");
1541 return join("\n",@result);
1546 # internal method for generating a CSS style section
1548 '_style' => <<'END_OF_FUNC',
1550 my ($self,$style) = @_;
1552 my $type = 'text/css';
1554 my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
1555 my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
1558 my($src,$code,$verbatim,$stype,$foo,@other) =
1559 rearrange([SRC,CODE,VERBATIM,TYPE],
1560 '-foo'=>'bar', # trick to allow dash to be omitted
1561 ref($style) eq 'ARRAY' ? @$style : %$style);
1562 $type = $stype if $stype;
1563 my $other = @other ? join ' ',@other : '';
1565 if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
1566 { # If it is, push a LINK tag for each one
1567 foreach $src (@$src)
1569 push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
1570 : qq(<link rel="stylesheet" type="$type" href="$src"$other>)) if $src;
1574 { # Otherwise, push the single -src, if it exists.
1575 push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
1576 : qq(<link rel="stylesheet" type="$type" href="$src"$other>)
1580 push(@result, "<style type=\"text/css\">\n$verbatim\n</style>");
1582 push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code;
1585 push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
1586 : qq(<link rel="stylesheet" type="$type" href="$src"$other>));
1592 '_script' => <<'END_OF_FUNC',
1594 my ($self,$script) = @_;
1597 my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
1598 foreach $script (@scripts) {
1599 my($src,$code,$language);
1600 if (ref($script)) { # script is a hash
1601 ($src,$code,$language, $type) =
1602 rearrange([SRC,CODE,LANGUAGE,TYPE],
1603 '-foo'=>'bar', # a trick to allow the '-' to be omitted
1604 ref($script) eq 'ARRAY' ? @$script : %$script);
1605 # User may not have specified language
1606 $language ||= 'JavaScript';
1607 unless (defined $type) {
1608 $type = lc $language;
1609 # strip '1.2' from 'javascript1.2'
1610 $type =~ s/^(\D+).*$/text\/$1/;
1613 ($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript');
1616 my $comment = '//'; # javascript by default
1617 $comment = '#' if $type=~/perl|tcl/i;
1618 $comment = "'" if $type=~/vbscript/i;
1620 my ($cdata_start,$cdata_end);
1622 $cdata_start = "$comment<![CDATA[\n";
1623 $cdata_end .= "\n$comment]]>";
1625 $cdata_start = "\n<!-- Hide script\n";
1626 $cdata_end = $comment;
1627 $cdata_end .= " End script hiding -->\n";
1630 push(@satts,'src'=>$src) if $src;
1631 push(@satts,'language'=>$language) unless defined $type;
1632 push(@satts,'type'=>$type);
1633 $code = "$cdata_start$code$cdata_end" if defined $code;
1634 push(@result,script({@satts},$code || ''));
1640 #### Method: end_html
1641 # End an HTML document.
1642 # Trivial method for completeness. Just returns "</body>"
1644 'end_html' => <<'END_OF_FUNC',
1646 return "</body></html>";
1651 ################################
1652 # METHODS USED IN BUILDING FORMS
1653 ################################
1655 #### Method: isindex
1656 # Just prints out the isindex tag.
1658 # $action -> optional URL of script to run
1660 # A string containing a <isindex> tag
1661 'isindex' => <<'END_OF_FUNC',
1663 my($self,@p) = self_or_default(@_);
1664 my($action,@other) = rearrange([ACTION],@p);
1665 $action = qq/ action="$action"/ if $action;
1666 my($other) = @other ? " @other" : '';
1667 return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>";
1672 #### Method: startform
1675 # $method -> optional submission method to use (GET or POST)
1676 # $action -> optional URL of script to run
1677 # $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1678 'startform' => <<'END_OF_FUNC',
1680 my($self,@p) = self_or_default(@_);
1682 my($method,$action,$enctype,@other) =
1683 rearrange([METHOD,ACTION,ENCTYPE],@p);
1685 $method = lc($method) || 'post';
1686 $enctype = $enctype || &URL_ENCODED;
1687 unless (defined $action) {
1689 $action = $self->escapeHTML($self->url(-absolute=>1,-path=>1));
1690 if (length($ENV{QUERY_STRING})>0) {
1691 $action .= "?".$self->escapeHTML($ENV{QUERY_STRING},1);
1694 $action = qq(action="$action");
1695 my($other) = @other ? " @other" : '';
1696 $self->{'.parametersToAdd'}={};
1697 return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
1702 #### Method: start_form
1703 # synonym for startform
1704 'start_form' => <<'END_OF_FUNC',
1710 'end_multipart_form' => <<'END_OF_FUNC',
1711 sub end_multipart_form {
1716 #### Method: start_multipart_form
1717 # synonym for startform
1718 'start_multipart_form' => <<'END_OF_FUNC',
1719 sub start_multipart_form {
1720 my($self,@p) = self_or_default(@_);
1721 if (defined($param[0]) && substr($param[0],0,1) eq '-') {
1723 $p{'-enctype'}=&MULTIPART;
1724 return $self->startform(%p);
1726 my($method,$action,@other) =
1727 rearrange([METHOD,ACTION],@p);
1728 return $self->startform($method,$action,&MULTIPART,@other);
1734 #### Method: endform
1736 'endform' => <<'END_OF_FUNC',
1738 my($self,@p) = self_or_default(@_);
1740 return wantarray ? ("</form>") : "\n</form>";
1742 return wantarray ? ("<div>",$self->get_fields,"</div>","</form>") :
1743 "<div>".$self->get_fields ."</div>\n</form>";
1749 #### Method: end_form
1750 # synonym for endform
1751 'end_form' => <<'END_OF_FUNC',
1758 '_textfield' => <<'END_OF_FUNC',
1760 my($self,$tag,@p) = self_or_default(@_);
1761 my($name,$default,$size,$maxlength,$override,@other) =
1762 rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1764 my $current = $override ? $default :
1765 (defined($self->param($name)) ? $self->param($name) : $default);
1767 $current = defined($current) ? $self->escapeHTML($current,1) : '';
1768 $name = defined($name) ? $self->escapeHTML($name) : '';
1769 my($s) = defined($size) ? qq/ size="$size"/ : '';
1770 my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
1771 my($other) = @other ? " @other" : '';
1772 # this entered at cristy's request to fix problems with file upload fields
1773 # and WebTV -- not sure it won't break stuff
1774 my($value) = $current ne '' ? qq(value="$current") : '';
1775 return $XHTML ? qq(<input type="$tag" name="$name" $value$s$m$other />)
1776 : qq(<input type="$tag" name="$name" $value$s$m$other>);
1780 #### Method: textfield
1782 # $name -> Name of the text field
1783 # $default -> Optional default value of the field if not
1785 # $size -> Optional width of field in characaters.
1786 # $maxlength -> Optional maximum number of characters.
1788 # A string containing a <input type="text"> field
1790 'textfield' => <<'END_OF_FUNC',
1792 my($self,@p) = self_or_default(@_);
1793 $self->_textfield('text',@p);
1798 #### Method: filefield
1800 # $name -> Name of the file upload field
1801 # $size -> Optional width of field in characaters.
1802 # $maxlength -> Optional maximum number of characters.
1804 # A string containing a <input type="file"> field
1806 'filefield' => <<'END_OF_FUNC',
1808 my($self,@p) = self_or_default(@_);
1809 $self->_textfield('file',@p);
1814 #### Method: password
1815 # Create a "secret password" entry field
1817 # $name -> Name of the field
1818 # $default -> Optional default value of the field if not
1820 # $size -> Optional width of field in characters.
1821 # $maxlength -> Optional maximum characters that can be entered.
1823 # A string containing a <input type="password"> field
1825 'password_field' => <<'END_OF_FUNC',
1826 sub password_field {
1827 my ($self,@p) = self_or_default(@_);
1828 $self->_textfield('password',@p);
1832 #### Method: textarea
1834 # $name -> Name of the text field
1835 # $default -> Optional default value of the field if not
1837 # $rows -> Optional number of rows in text area
1838 # $columns -> Optional number of columns in text area
1840 # A string containing a <textarea></textarea> tag
1842 'textarea' => <<'END_OF_FUNC',
1844 my($self,@p) = self_or_default(@_);
1846 my($name,$default,$rows,$cols,$override,@other) =
1847 rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
1849 my($current)= $override ? $default :
1850 (defined($self->param($name)) ? $self->param($name) : $default);
1852 $name = defined($name) ? $self->escapeHTML($name) : '';
1853 $current = defined($current) ? $self->escapeHTML($current) : '';
1854 my($r) = $rows ? qq/ rows="$rows"/ : '';
1855 my($c) = $cols ? qq/ cols="$cols"/ : '';
1856 my($other) = @other ? " @other" : '';
1857 return qq{<textarea name="$name"$r$c$other>$current</textarea>};
1863 # Create a javascript button.
1865 # $name -> (optional) Name for the button. (-name)
1866 # $value -> (optional) Value of the button when selected (and visible name) (-value)
1867 # $onclick -> (optional) Text of the JavaScript to run when the button is
1870 # A string containing a <input type="button"> tag
1872 'button' => <<'END_OF_FUNC',
1874 my($self,@p) = self_or_default(@_);
1876 my($label,$value,$script,@other) = rearrange([NAME,[VALUE,LABEL],
1877 [ONCLICK,SCRIPT]],@p);
1879 $label=$self->escapeHTML($label);
1880 $value=$self->escapeHTML($value,1);
1881 $script=$self->escapeHTML($script);
1884 $name = qq/ name="$label"/ if $label;
1885 $value = $value || $label;
1887 $val = qq/ value="$value"/ if $value;
1888 $script = qq/ onclick="$script"/ if $script;
1889 my($other) = @other ? " @other" : '';
1890 return $XHTML ? qq(<input type="button"$name$val$script$other />)
1891 : qq(<input type="button"$name$val$script$other>);
1897 # Create a "submit query" button.
1899 # $name -> (optional) Name for the button.
1900 # $value -> (optional) Value of the button when selected (also doubles as label).
1901 # $label -> (optional) Label printed on the button(also doubles as the value).
1903 # A string containing a <input type="submit"> tag
1905 'submit' => <<'END_OF_FUNC',
1907 my($self,@p) = self_or_default(@_);
1909 my($label,$value,@other) = rearrange([NAME,[VALUE,LABEL]],@p);
1911 $label=$self->escapeHTML($label);
1912 $value=$self->escapeHTML($value,1);
1914 my($name) = ' name=".submit"' unless $NOSTICKY;
1915 $name = qq/ name="$label"/ if defined($label);
1916 $value = defined($value) ? $value : $label;
1918 $val = qq/ value="$value"/ if defined($value);
1919 my($other) = @other ? " @other" : '';
1920 return $XHTML ? qq(<input type="submit"$name$val$other />)
1921 : qq(<input type="submit"$name$val$other>);
1927 # Create a "reset" button.
1929 # $name -> (optional) Name for the button.
1931 # A string containing a <input type="reset"> tag
1933 'reset' => <<'END_OF_FUNC',
1935 my($self,@p) = self_or_default(@_);
1936 my($label,$value,@other) = rearrange(['NAME',['VALUE','LABEL']],@p);
1937 $label=$self->escapeHTML($label);
1938 $value=$self->escapeHTML($value,1);
1939 my ($name) = ' name=".reset"';
1940 $name = qq/ name="$label"/ if defined($label);
1941 $value = defined($value) ? $value : $label;
1943 $val = qq/ value="$value"/ if defined($value);
1944 my($other) = @other ? " @other" : '';
1945 return $XHTML ? qq(<input type="reset"$name$val$other />)
1946 : qq(<input type="reset"$name$val$other>);
1951 #### Method: defaults
1952 # Create a "defaults" button.
1954 # $name -> (optional) Name for the button.
1956 # A string containing a <input type="submit" name=".defaults"> tag
1958 # Note: this button has a special meaning to the initialization script,
1959 # and tells it to ERASE the current query string so that your defaults
1962 'defaults' => <<'END_OF_FUNC',
1964 my($self,@p) = self_or_default(@_);
1966 my($label,@other) = rearrange([[NAME,VALUE]],@p);
1968 $label=$self->escapeHTML($label,1);
1969 $label = $label || "Defaults";
1970 my($value) = qq/ value="$label"/;
1971 my($other) = @other ? " @other" : '';
1972 return $XHTML ? qq(<input type="submit" name=".defaults"$value$other />)
1973 : qq/<input type="submit" NAME=".defaults"$value$other>/;
1978 #### Method: comment
1979 # Create an HTML <!-- comment -->
1980 # Parameters: a string
1981 'comment' => <<'END_OF_FUNC',
1983 my($self,@p) = self_or_CGI(@_);
1984 return "<!-- @p -->";
1988 #### Method: checkbox
1989 # Create a checkbox that is not logically linked to any others.
1990 # The field value is "on" when the button is checked.
1992 # $name -> Name of the checkbox
1993 # $checked -> (optional) turned on by default if true
1994 # $value -> (optional) value of the checkbox, 'on' by default
1995 # $label -> (optional) a user-readable label printed next to the box.
1996 # Otherwise the checkbox name is used.
1998 # A string containing a <input type="checkbox"> field
2000 'checkbox' => <<'END_OF_FUNC',
2002 my($self,@p) = self_or_default(@_);
2004 my($name,$checked,$value,$label,$override,@other) =
2005 rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
2007 $value = defined $value ? $value : 'on';
2009 if (!$override && ($self->{'.fieldnames'}->{$name} ||
2010 defined $self->param($name))) {
2011 $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
2013 $checked = $self->_checked($checked);
2015 my($the_label) = defined $label ? $label : $name;
2016 $name = $self->escapeHTML($name);
2017 $value = $self->escapeHTML($value,1);
2018 $the_label = $self->escapeHTML($the_label);
2019 my($other) = @other ? " @other" : '';
2020 $self->register_parameter($name);
2021 return $XHTML ? qq{<input type="checkbox" name="$name" value="$value"$checked$other />$the_label}
2022 : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
2027 #### Method: checkbox_group
2028 # Create a list of logically-linked checkboxes.
2030 # $name -> Common name for all the check boxes
2031 # $values -> A pointer to a regular array containing the
2032 # values for each checkbox in the group.
2033 # $defaults -> (optional)
2034 # 1. If a pointer to a regular array of checkbox values,
2035 # then this will be used to decide which
2036 # checkboxes to turn on by default.
2037 # 2. If a scalar, will be assumed to hold the
2038 # value of a single checkbox in the group to turn on.
2039 # $linebreak -> (optional) Set to true to place linebreaks
2040 # between the buttons.
2041 # $labels -> (optional)
2042 # A pointer to an associative array of labels to print next to each checkbox
2043 # in the form $label{'value'}="Long explanatory label".
2044 # Otherwise the provided values are used as the labels.
2046 # An ARRAY containing a series of <input type="checkbox"> fields
2048 'checkbox_group' => <<'END_OF_FUNC',
2049 sub checkbox_group {
2050 my($self,@p) = self_or_default(@_);
2052 my($name,$values,$defaults,$linebreak,$labels,$attributes,$rows,$columns,
2053 $rowheaders,$colheaders,$override,$nolabels,@other) =
2054 rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
2055 LINEBREAK,LABELS,ATTRIBUTES,ROWS,[COLUMNS,COLS],
2056 ROWHEADERS,COLHEADERS,
2057 [OVERRIDE,FORCE],NOLABELS],@p);
2059 my($checked,$break,$result,$label);
2061 my(%checked) = $self->previous_or_default($name,$defaults,$override);
2064 $break = $XHTML ? "<br />" : "<br>";
2069 $name=$self->escapeHTML($name);
2071 # Create the elements
2072 my(@elements,@values);
2074 @values = $self->_set_values_and_labels($values,\$labels,$name);
2076 my($other) = @other ? " @other" : '';
2078 $checked = $self->_checked($checked{$_});
2080 unless (defined($nolabels) && $nolabels) {
2082 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2083 $label = $self->escapeHTML($label);
2085 my $attribs = $self->_set_attributes($_, $attributes);
2086 $_ = $self->escapeHTML($_,1);
2087 push(@elements,$XHTML ? qq(<input type="checkbox" name="$name" value="$_"$checked$other$attribs />${label}${break})
2088 : qq/<input type="checkbox" name="$name" value="$_"$checked$other$attribs>${label}${break}/);
2090 $self->register_parameter($name);
2091 return wantarray ? @elements : join(' ',@elements)
2092 unless defined($columns) || defined($rows);
2093 $rows = 1 if $rows && $rows < 1;
2094 $cols = 1 if $cols && $cols < 1;
2095 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
2099 # Escape HTML -- used internally
2100 'escapeHTML' => <<'END_OF_FUNC',
2102 # hack to work around earlier hacks
2103 push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
2104 my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
2105 return undef unless defined($toencode);
2106 return $toencode if ref($self) && !$self->{'escape'};
2107 $toencode =~ s{&}{&}gso;
2108 $toencode =~ s{<}{<}gso;
2109 $toencode =~ s{>}{>}gso;
2110 $toencode =~ s{"}{"}gso;
2111 my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' ||
2112 uc $self->{'.charset'} eq 'WINDOWS-1252';
2113 if ($latin) { # bug in some browsers
2114 $toencode =~ s{'}{'}gso;
2115 $toencode =~ s{\x8b}{‹}gso;
2116 $toencode =~ s{\x9b}{›}gso;
2117 if (defined $newlinestoo && $newlinestoo) {
2118 $toencode =~ s{\012}{ }gso;
2119 $toencode =~ s{\015}{ }gso;
2126 # unescape HTML -- used internally
2127 'unescapeHTML' => <<'END_OF_FUNC',
2129 my ($self,$string) = CGI::self_or_default(@_);
2130 return undef unless defined($string);
2131 my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
2133 # thanks to Randal Schwartz for the correct solution to this one
2134 $string=~ s[&(.*?);]{
2140 /^#(\d+)$/ && $latin ? chr($1) :
2141 /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
2148 # Internal procedure - don't use
2149 '_tableize' => <<'END_OF_FUNC',
2151 my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
2152 $rowheaders = [] unless defined $rowheaders;
2153 $colheaders = [] unless defined $colheaders;
2156 if (defined($columns)) {
2157 $rows = int(0.99 + @elements/$columns) unless defined($rows);
2159 if (defined($rows)) {
2160 $columns = int(0.99 + @elements/$rows) unless defined($columns);
2163 # rearrange into a pretty table
2164 $result = "<table>";
2166 unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
2167 $result .= "<tr>" if @{$colheaders};
2168 foreach (@{$colheaders}) {
2169 $result .= "<th>$_</th>";
2171 for ($row=0;$row<$rows;$row++) {
2173 $result .= "<th>$rowheaders->[$row]</th>" if @$rowheaders;
2174 for ($column=0;$column<$columns;$column++) {
2175 $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
2176 if defined($elements[$column*$rows + $row]);
2180 $result .= "</table>";
2186 #### Method: radio_group
2187 # Create a list of logically-linked radio buttons.
2189 # $name -> Common name for all the buttons.
2190 # $values -> A pointer to a regular array containing the
2191 # values for each button in the group.
2192 # $default -> (optional) Value of the button to turn on by default. Pass '-'
2193 # to turn _nothing_ on.
2194 # $linebreak -> (optional) Set to true to place linebreaks
2195 # between the buttons.
2196 # $labels -> (optional)
2197 # A pointer to an associative array of labels to print next to each checkbox
2198 # in the form $label{'value'}="Long explanatory label".
2199 # Otherwise the provided values are used as the labels.
2201 # An ARRAY containing a series of <input type="radio"> fields
2203 'radio_group' => <<'END_OF_FUNC',
2205 my($self,@p) = self_or_default(@_);
2207 my($name,$values,$default,$linebreak,$labels,$attributes,
2208 $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
2209 rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,ATTRIBUTES,
2210 ROWS,[COLUMNS,COLS],
2211 ROWHEADERS,COLHEADERS,
2212 [OVERRIDE,FORCE],NOLABELS],@p);
2213 my($result,$checked);
2215 if (!$override && defined($self->param($name))) {
2216 $checked = $self->param($name);
2218 $checked = $default;
2220 my(@elements,@values);
2221 @values = $self->_set_values_and_labels($values,\$labels,$name);
2223 # If no check array is specified, check the first by default
2224 $checked = $values[0] unless defined($checked) && $checked ne '';
2225 $name=$self->escapeHTML($name);
2227 my($other) = @other ? " @other" : '';
2229 my($checkit) = $checked eq $_ ? qq/ checked="checked"/ : '';
2232 $break = $XHTML ? "<br />" : "<br>";
2238 unless (defined($nolabels) && $nolabels) {
2240 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2241 $label = $self->escapeHTML($label,1);
2243 my $attribs = $self->_set_attributes($_, $attributes);
2244 $_=$self->escapeHTML($_);
2245 push(@elements,$XHTML ? qq(<input type="radio" name="$name" value="$_"$checkit$other$attribs />${label}${break})
2246 : qq/<input type="radio" name="$name" value="$_"$checkit$other$attribs>${label}${break}/);
2248 $self->register_parameter($name);
2249 return wantarray ? @elements : join(' ',@elements)
2250 unless defined($columns) || defined($rows);
2251 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
2256 #### Method: popup_menu
2257 # Create a popup menu.
2259 # $name -> Name for all the menu
2260 # $values -> A pointer to a regular array containing the
2261 # text of each menu item.
2262 # $default -> (optional) Default item to display
2263 # $labels -> (optional)
2264 # A pointer to an associative array of labels to print next to each checkbox
2265 # in the form $label{'value'}="Long explanatory label".
2266 # Otherwise the provided values are used as the labels.
2268 # A string containing the definition of a popup menu.
2270 'popup_menu' => <<'END_OF_FUNC',
2272 my($self,@p) = self_or_default(@_);
2274 my($name,$values,$default,$labels,$attributes,$override,@other) =
2275 rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
2276 ATTRIBUTES,[OVERRIDE,FORCE]],@p);
2277 my($result,$selected);
2279 if (!$override && defined($self->param($name))) {
2280 $selected = $self->param($name);
2282 $selected = $default;
2284 $name=$self->escapeHTML($name);
2285 my($other) = @other ? " @other" : '';
2288 @values = $self->_set_values_and_labels($values,\$labels,$name);
2290 $result = qq/<select name="$name"$other>\n/;
2293 foreach (split(/\n/)) {
2294 my $selectit = $XHTML ? 'selected="selected"' : 'selected';
2295 s/(value="$selected")/$selectit $1/ if defined $selected;
2300 my $attribs = $self->_set_attributes($_, $attributes);
2301 my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : '';
2303 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2304 my($value) = $self->escapeHTML($_);
2305 $label=$self->escapeHTML($label,1);
2306 $result .= "<option$selectit$attribs value=\"$value\">$label</option>\n";
2310 $result .= "</select>";
2316 #### Method: optgroup
2317 # Create a optgroup.
2319 # $name -> Label for the group
2320 # $values -> A pointer to a regular array containing the
2321 # values for each option line in the group.
2322 # $labels -> (optional)
2323 # A pointer to an associative array of labels to print next to each item
2324 # in the form $label{'value'}="Long explanatory label".
2325 # Otherwise the provided values are used as the labels.
2326 # $labeled -> (optional)
2327 # A true value indicates the value should be used as the label attribute
2328 # in the option elements.
2329 # The label attribute specifies the option label presented to the user.
2330 # This defaults to the content of the <option> element, but the label
2331 # attribute allows authors to more easily use optgroup without sacrificing
2332 # compatibility with browsers that do not support option groups.
2333 # $novals -> (optional)
2334 # A true value indicates to suppress the val attribute in the option elements
2336 # A string containing the definition of an option group.
2338 'optgroup' => <<'END_OF_FUNC',
2340 my($self,@p) = self_or_default(@_);
2341 my($name,$values,$attributes,$labeled,$noval,$labels,@other)
2342 = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p);
2344 my($result,@values);
2345 @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
2346 my($other) = @other ? " @other" : '';
2348 $name=$self->escapeHTML($name);
2349 $result = qq/<optgroup label="$name"$other>\n/;
2352 foreach (split(/\n/)) {
2353 my $selectit = $XHTML ? 'selected="selected"' : 'selected';
2354 s/(value="$selected")/$selectit $1/ if defined $selected;
2359 my $attribs = $self->_set_attributes($_, $attributes);
2361 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2362 $label=$self->escapeHTML($label);
2363 my($value)=$self->escapeHTML($_,1);
2364 $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
2365 : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
2366 : $novals ? "<option$attribs>$label</option>\n"
2367 : "<option$attribs value=\"$value\">$label</option>\n";
2370 $result .= "</optgroup>";
2376 #### Method: scrolling_list
2377 # Create a scrolling list.
2379 # $name -> name for the list
2380 # $values -> A pointer to a regular array containing the
2381 # values for each option line in the list.
2382 # $defaults -> (optional)
2383 # 1. If a pointer to a regular array of options,
2384 # then this will be used to decide which
2385 # lines to turn on by default.
2386 # 2. Otherwise holds the value of the single line to turn on.
2387 # $size -> (optional) Size of the list.
2388 # $multiple -> (optional) If set, allow multiple selections.
2389 # $labels -> (optional)
2390 # A pointer to an associative array of labels to print next to each checkbox
2391 # in the form $label{'value'}="Long explanatory label".
2392 # Otherwise the provided values are used as the labels.
2394 # A string containing the definition of a scrolling list.
2396 'scrolling_list' => <<'END_OF_FUNC',
2397 sub scrolling_list {
2398 my($self,@p) = self_or_default(@_);
2399 my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,@other)
2400 = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
2401 SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE]],@p);
2403 my($result,@values);
2404 @values = $self->_set_values_and_labels($values,\$labels,$name);
2406 $size = $size || scalar(@values);
2408 my(%selected) = $self->previous_or_default($name,$defaults,$override);
2409 my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
2410 my($has_size) = $size ? qq/ size="$size"/: '';
2411 my($other) = @other ? " @other" : '';
2413 $name=$self->escapeHTML($name);
2414 $result = qq/<select name="$name"$has_size$is_multiple$other>\n/;
2416 my($selectit) = $self->_selected($selected{$_});
2418 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2419 $label=$self->escapeHTML($label);
2420 my($value)=$self->escapeHTML($_,1);
2421 my $attribs = $self->_set_attributes($_, $attributes);
2422 $result .= "<option$selectit$attribs value=\"$value\">$label</option>\n";
2424 $result .= "</select>";
2425 $self->register_parameter($name);
2433 # $name -> Name of the hidden field
2434 # @default -> (optional) Initial values of field (may be an array)
2436 # $default->[initial values of field]
2438 # A string containing a <input type="hidden" name="name" value="value">
2440 'hidden' => <<'END_OF_FUNC',
2442 my($self,@p) = self_or_default(@_);
2444 # this is the one place where we departed from our standard
2445 # calling scheme, so we have to special-case (darn)
2447 my($name,$default,$override,@other) =
2448 rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
2450 my $do_override = 0;
2451 if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
2452 @value = ref($default) ? @{$default} : $default;
2453 $do_override = $override;
2455 foreach ($default,$override,@other) {
2456 push(@value,$_) if defined($_);
2460 # use previous values if override is not set
2461 my @prev = $self->param($name);
2462 @value = @prev if !$do_override && @prev;
2464 $name=$self->escapeHTML($name);
2466 $_ = defined($_) ? $self->escapeHTML($_,1) : '';
2467 push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" />)
2468 : qq(<input type="hidden" name="$name" value="$_">);
2470 return wantarray ? @result : join('',@result);
2475 #### Method: image_button
2477 # $name -> Name of the button
2478 # $src -> URL of the image source
2479 # $align -> Alignment style (TOP, BOTTOM or MIDDLE)
2481 # A string containing a <input type="image" name="name" src="url" align="alignment">
2483 'image_button' => <<'END_OF_FUNC',
2485 my($self,@p) = self_or_default(@_);
2487 my($name,$src,$alignment,@other) =
2488 rearrange([NAME,SRC,ALIGN],@p);
2490 my($align) = $alignment ? " align=\U\"$alignment\"" : '';
2491 my($other) = @other ? " @other" : '';
2492 $name=$self->escapeHTML($name);
2493 return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
2494 : qq/<input type="image" name="$name" src="$src"$align$other>/;
2499 #### Method: self_url
2500 # Returns a URL containing the current script and all its
2501 # param/value pairs arranged as a query. You can use this
2502 # to create a link that, when selected, will reinvoke the
2503 # script with all its state information preserved.
2505 'self_url' => <<'END_OF_FUNC',
2507 my($self,@p) = self_or_default(@_);
2508 return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
2513 # This is provided as a synonym to self_url() for people unfortunate
2514 # enough to have incorporated it into their programs already!
2515 'state' => <<'END_OF_FUNC',
2523 # Like self_url, but doesn't return the query string part of
2526 'url' => <<'END_OF_FUNC',
2528 my($self,@p) = self_or_default(@_);
2529 my ($relative,$absolute,$full,$path_info,$query,$base) =
2530 rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE'],@p);
2532 $full++ if $base || !($relative || $absolute);
2534 my $path = $self->path_info;
2535 my $script_name = $self->script_name;
2537 # for compatibility with Apache's MultiViews
2538 if (exists($ENV{REQUEST_URI})) {
2540 $script_name = unescape($ENV{REQUEST_URI});
2541 $script_name =~ s/\?.+$//; # strip query string
2543 if (exists($ENV{PATH_INFO})) {
2544 my $encoded_path = quotemeta($ENV{PATH_INFO});
2545 $script_name =~ s/$encoded_path$//i;
2550 my $protocol = $self->protocol();
2551 $url = "$protocol://";
2552 my $vh = http('host');
2556 $url .= server_name();
2557 my $port = $self->server_port;
2559 unless (lc($protocol) eq 'http' && $port == 80)
2560 || (lc($protocol) eq 'https' && $port == 443);
2562 return $url if $base;
2563 $url .= $script_name;
2564 } elsif ($relative) {
2565 ($url) = $script_name =~ m!([^/]+)$!;
2566 } elsif ($absolute) {
2567 $url = $script_name;
2570 $url .= $path if $path_info and defined $path;
2571 $url .= "?" . $self->query_string if $query and $self->query_string;
2572 $url = '' unless defined $url;
2573 $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
2580 # Set or read a cookie from the specified name.
2581 # Cookie can then be passed to header().
2582 # Usual rules apply to the stickiness of -value.
2584 # -name -> name for this cookie (optional)
2585 # -value -> value of this cookie (scalar, array or hash)
2586 # -path -> paths for which this cookie is valid (optional)
2587 # -domain -> internet domain in which this cookie is valid (optional)
2588 # -secure -> if true, cookie only passed through secure channel (optional)
2589 # -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
2591 'cookie' => <<'END_OF_FUNC',
2593 my($self,@p) = self_or_default(@_);
2594 my($name,$value,$path,$domain,$secure,$expires) =
2595 rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
2597 require CGI::Cookie;
2599 # if no value is supplied, then we retrieve the
2600 # value of the cookie, if any. For efficiency, we cache the parsed
2601 # cookies in our state variables.
2602 unless ( defined($value) ) {
2603 $self->{'.cookies'} = CGI::Cookie->fetch
2604 unless $self->{'.cookies'};
2606 # If no name is supplied, then retrieve the names of all our cookies.
2607 return () unless $self->{'.cookies'};
2608 return keys %{$self->{'.cookies'}} unless $name;
2609 return () unless $self->{'.cookies'}->{$name};
2610 return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
2613 # If we get here, we're creating a new cookie
2614 return undef unless defined($name) && $name ne ''; # this is an error
2617 push(@param,'-name'=>$name);
2618 push(@param,'-value'=>$value);
2619 push(@param,'-domain'=>$domain) if $domain;
2620 push(@param,'-path'=>$path) if $path;
2621 push(@param,'-expires'=>$expires) if $expires;
2622 push(@param,'-secure'=>$secure) if $secure;
2624 return new CGI::Cookie(@param);
2628 'parse_keywordlist' => <<'END_OF_FUNC',
2629 sub parse_keywordlist {
2630 my($self,$tosplit) = @_;
2631 $tosplit = unescape($tosplit); # unescape the keywords
2632 $tosplit=~tr/+/ /; # pluses to spaces
2633 my(@keywords) = split(/\s+/,$tosplit);
2638 'param_fetch' => <<'END_OF_FUNC',
2640 my($self,@p) = self_or_default(@_);
2641 my($name) = rearrange([NAME],@p);
2642 unless (exists($self->{$name})) {
2643 $self->add_parameter($name);
2644 $self->{$name} = [];
2647 return $self->{$name};
2651 ###############################################
2652 # OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
2653 ###############################################
2655 #### Method: path_info
2656 # Return the extra virtual path information provided
2657 # after the URL (if any)
2659 'path_info' => <<'END_OF_FUNC',
2661 my ($self,$info) = self_or_default(@_);
2662 if (defined($info)) {
2663 $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
2664 $self->{'.path_info'} = $info;
2665 } elsif (! defined($self->{'.path_info'}) ) {
2666 $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ?
2667 $ENV{'PATH_INFO'} : '';
2669 # hack to fix broken path info in IIS
2670 $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
2673 return $self->{'.path_info'};
2678 #### Method: request_method
2679 # Returns 'POST', 'GET', 'PUT' or 'HEAD'
2681 'request_method' => <<'END_OF_FUNC',
2682 sub request_method {
2683 return $ENV{'REQUEST_METHOD'};
2687 #### Method: content_type
2688 # Returns the content_type string
2690 'content_type' => <<'END_OF_FUNC',
2692 return $ENV{'CONTENT_TYPE'};
2696 #### Method: path_translated
2697 # Return the physical path information provided
2698 # by the URL (if any)
2700 'path_translated' => <<'END_OF_FUNC',
2701 sub path_translated {
2702 return $ENV{'PATH_TRANSLATED'};
2707 #### Method: query_string
2708 # Synthesize a query string from our current
2711 'query_string' => <<'END_OF_FUNC',
2713 my($self) = self_or_default(@_);
2714 my($param,$value,@pairs);
2715 foreach $param ($self->param) {
2716 my($eparam) = escape($param);
2717 foreach $value ($self->param($param)) {
2718 $value = escape($value);
2719 next unless defined $value;
2720 push(@pairs,"$eparam=$value");
2723 foreach (keys %{$self->{'.fieldnames'}}) {
2724 push(@pairs,".cgifields=".escape("$_"));
2726 return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
2732 # Without parameters, returns an array of the
2733 # MIME types the browser accepts.
2734 # With a single parameter equal to a MIME
2735 # type, will return undef if the browser won't
2736 # accept it, 1 if the browser accepts it but
2737 # doesn't give a preference, or a floating point
2738 # value between 0.0 and 1.0 if the browser
2739 # declares a quantitative score for it.
2740 # This handles MIME type globs correctly.
2742 'Accept' => <<'END_OF_FUNC',
2744 my($self,$search) = self_or_CGI(@_);
2745 my(%prefs,$type,$pref,$pat);
2747 my(@accept) = split(',',$self->http('accept'));
2750 ($pref) = /q=(\d\.\d+|\d+)/;
2751 ($type) = m#(\S+/[^;]+)#;
2753 $prefs{$type}=$pref || 1;
2756 return keys %prefs unless $search;
2758 # if a search type is provided, we may need to
2759 # perform a pattern matching operation.
2760 # The MIME types use a glob mechanism, which
2761 # is easily translated into a perl pattern match
2763 # First return the preference for directly supported
2765 return $prefs{$search} if $prefs{$search};
2767 # Didn't get it, so try pattern matching.
2768 foreach (keys %prefs) {
2769 next unless /\*/; # not a pattern match
2770 ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2771 $pat =~ s/\*/.*/g; # turn it into a pattern
2772 return $prefs{$_} if $search=~/$pat/;
2778 #### Method: user_agent
2779 # If called with no parameters, returns the user agent.
2780 # If called with one parameter, does a pattern match (case
2781 # insensitive) on the user agent.
2783 'user_agent' => <<'END_OF_FUNC',
2785 my($self,$match)=self_or_CGI(@_);
2786 return $self->http('user_agent') unless $match;
2787 return $self->http('user_agent') =~ /$match/i;
2792 #### Method: raw_cookie
2793 # Returns the magic cookies for the session.
2794 # The cookies are not parsed or altered in any way, i.e.
2795 # cookies are returned exactly as given in the HTTP
2796 # headers. If a cookie name is given, only that cookie's
2797 # value is returned, otherwise the entire raw cookie
2800 'raw_cookie' => <<'END_OF_FUNC',
2802 my($self,$key) = self_or_CGI(@_);
2804 require CGI::Cookie;
2806 if (defined($key)) {
2807 $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
2808 unless $self->{'.raw_cookies'};
2810 return () unless $self->{'.raw_cookies'};
2811 return () unless $self->{'.raw_cookies'}->{$key};
2812 return $self->{'.raw_cookies'}->{$key};
2814 return $self->http('cookie') || $ENV{'COOKIE'} || '';
2818 #### Method: virtual_host
2819 # Return the name of the virtual_host, which
2820 # is not always the same as the server
2822 'virtual_host' => <<'END_OF_FUNC',
2824 my $vh = http('host') || server_name();
2825 $vh =~ s/:\d+$//; # get rid of port number
2830 #### Method: remote_host
2831 # Return the name of the remote host, or its IP
2832 # address if unavailable. If this variable isn't
2833 # defined, it returns "localhost" for debugging
2836 'remote_host' => <<'END_OF_FUNC',
2838 return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
2844 #### Method: remote_addr
2845 # Return the IP addr of the remote host.
2847 'remote_addr' => <<'END_OF_FUNC',
2849 return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
2854 #### Method: script_name
2855 # Return the partial URL to this script for
2856 # self-referencing scripts. Also see
2857 # self_url(), which returns a URL with all state information
2860 'script_name' => <<'END_OF_FUNC',
2862 return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'});
2863 # These are for debugging
2864 return "/$0" unless $0=~/^\//;
2870 #### Method: referer
2871 # Return the HTTP_REFERER: useful for generating
2874 'referer' => <<'END_OF_FUNC',
2876 my($self) = self_or_CGI(@_);
2877 return $self->http('referer');
2882 #### Method: server_name
2883 # Return the name of the server
2885 'server_name' => <<'END_OF_FUNC',
2887 return $ENV{'SERVER_NAME'} || 'localhost';
2891 #### Method: server_software
2892 # Return the name of the server software
2894 'server_software' => <<'END_OF_FUNC',
2895 sub server_software {
2896 return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
2900 #### Method: virtual_port
2901 # Return the server port, taking virtual hosts into account
2903 'virtual_port' => <<'END_OF_FUNC',
2905 my($self) = self_or_default(@_);
2906 my $vh = $self->http('host');
2908 return ($vh =~ /:(\d+)$/)[0] || '80';
2910 return $self->server_port();
2915 #### Method: server_port
2916 # Return the tcp/ip port the server is running on
2918 'server_port' => <<'END_OF_FUNC',
2920 return $ENV{'SERVER_PORT'} || 80; # for debugging
2924 #### Method: server_protocol
2925 # Return the protocol (usually HTTP/1.0)
2927 'server_protocol' => <<'END_OF_FUNC',
2928 sub server_protocol {
2929 return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
2934 # Return the value of an HTTP variable, or
2935 # the list of variables if none provided
2937 'http' => <<'END_OF_FUNC',
2939 my ($self,$parameter) = self_or_CGI(@_);
2940 return $ENV{$parameter} if $parameter=~/^HTTP/;
2941 $parameter =~ tr/-/_/;
2942 return $ENV{"HTTP_\U$parameter\E"} if $parameter;
2944 foreach (keys %ENV) {
2945 push(@p,$_) if /^HTTP/;
2952 # Return the value of HTTPS
2954 'https' => <<'END_OF_FUNC',
2957 my ($self,$parameter) = self_or_CGI(@_);
2958 return $ENV{HTTPS} unless $parameter;
2959 return $ENV{$parameter} if $parameter=~/^HTTPS/;
2960 $parameter =~ tr/-/_/;
2961 return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
2963 foreach (keys %ENV) {
2964 push(@p,$_) if /^HTTPS/;
2970 #### Method: protocol
2971 # Return the protocol (http or https currently)
2973 'protocol' => <<'END_OF_FUNC',
2977 return 'https' if uc($self->https()) eq 'ON';
2978 return 'https' if $self->server_port == 443;
2979 my $prot = $self->server_protocol;
2980 my($protocol,$version) = split('/',$prot);
2981 return "\L$protocol\E";
2985 #### Method: remote_ident
2986 # Return the identity of the remote user
2987 # (but only if his host is running identd)
2989 'remote_ident' => <<'END_OF_FUNC',
2991 return $ENV{'REMOTE_IDENT'};
2996 #### Method: auth_type
2997 # Return the type of use verification/authorization in use, if any.
2999 'auth_type' => <<'END_OF_FUNC',
3001 return $ENV{'AUTH_TYPE'};
3006 #### Method: remote_user
3007 # Return the authorization name used for user
3010 'remote_user' => <<'END_OF_FUNC',
3012 return $ENV{'REMOTE_USER'};
3017 #### Method: user_name
3018 # Try to return the remote user's name by hook or by
3021 'user_name' => <<'END_OF_FUNC',
3023 my ($self) = self_or_CGI(@_);
3024 return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
3028 #### Method: nosticky
3029 # Set or return the NOSTICKY global flag
3031 'nosticky' => <<'END_OF_FUNC',
3033 my ($self,$param) = self_or_CGI(@_);
3034 $CGI::NOSTICKY = $param if defined($param);
3035 return $CGI::NOSTICKY;
3040 # Set or return the NPH global flag
3042 'nph' => <<'END_OF_FUNC',
3044 my ($self,$param) = self_or_CGI(@_);
3045 $CGI::NPH = $param if defined($param);
3050 #### Method: private_tempfiles
3051 # Set or return the private_tempfiles global flag
3053 'private_tempfiles' => <<'END_OF_FUNC',
3054 sub private_tempfiles {
3055 my ($self,$param) = self_or_CGI(@_);
3056 $CGI::PRIVATE_TEMPFILES = $param if defined($param);
3057 return $CGI::PRIVATE_TEMPFILES;
3060 #### Method: close_upload_files
3061 # Set or return the close_upload_files global flag
3063 'close_upload_files' => <<'END_OF_FUNC',
3064 sub close_upload_files {
3065 my ($self,$param) = self_or_CGI(@_);
3066 $CGI::CLOSE_UPLOAD_FILES = $param if defined($param);
3067 return $CGI::CLOSE_UPLOAD_FILES;
3072 #### Method: default_dtd
3073 # Set or return the default_dtd global
3075 'default_dtd' => <<'END_OF_FUNC',
3077 my ($self,$param,$param2) = self_or_CGI(@_);
3078 if (defined $param2 && defined $param) {
3079 $CGI::DEFAULT_DTD = [ $param, $param2 ];
3080 } elsif (defined $param) {
3081 $CGI::DEFAULT_DTD = $param;
3083 return $CGI::DEFAULT_DTD;
3087 # -------------- really private subroutines -----------------
3088 'previous_or_default' => <<'END_OF_FUNC',
3089 sub previous_or_default {
3090 my($self,$name,$defaults,$override) = @_;
3093 if (!$override && ($self->{'.fieldnames'}->{$name} ||
3094 defined($self->param($name)) ) ) {
3095 grep($selected{$_}++,$self->param($name));
3096 } elsif (defined($defaults) && ref($defaults) &&
3097 (ref($defaults) eq 'ARRAY')) {
3098 grep($selected{$_}++,@{$defaults});
3100 $selected{$defaults}++ if defined($defaults);
3107 'register_parameter' => <<'END_OF_FUNC',
3108 sub register_parameter {
3109 my($self,$param) = @_;
3110 $self->{'.parametersToAdd'}->{$param}++;
3114 'get_fields' => <<'END_OF_FUNC',
3117 return $self->CGI::hidden('-name'=>'.cgifields',
3118 '-values'=>[keys %{$self->{'.parametersToAdd'}}],
3123 'read_from_cmdline' => <<'END_OF_FUNC',
3124 sub read_from_cmdline {
3128 if ($DEBUG && @ARGV) {
3130 } elsif ($DEBUG > 1) {
3131 require "shellwords.pl";
3132 print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n";
3133 chomp(@lines = <STDIN>); # remove newlines
3134 $input = join(" ",@lines);
3135 @words = &shellwords($input);
3142 if ("@words"=~/=/) {
3143 $query_string = join('&',@words);
3145 $query_string = join('+',@words);
3147 if ($query_string =~ /^(.*?)\?(.*)$/)
3152 return { 'query_string' => $query_string, 'subpath' => $subpath };
3157 # subroutine: read_multipart
3159 # Read multipart data and store it into our parameters.
3160 # An interesting feature is that if any of the parts is a file, we
3161 # create a temporary file and open up a filehandle on it so that the
3162 # caller can read from it if necessary.
3164 'read_multipart' => <<'END_OF_FUNC',
3165 sub read_multipart {
3166 my($self,$boundary,$length) = @_;
3167 my($buffer) = $self->new_MultipartBuffer($boundary,$length);
3168 return unless $buffer;
3171 while (!$buffer->eof) {
3172 %header = $buffer->readHeader;
3175 $self->cgi_error("400 Bad request (malformed multipart POST)");
3179 my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
3182 # Bug: Netscape doesn't escape quotation marks in file names!!!
3183 my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\"]*)"?/;
3184 # Test for Opera's multiple upload feature
3185 my($multipart) = ( defined( $header{'Content-Type'} ) &&
3186 $header{'Content-Type'} =~ /multipart\/mixed/ ) ?
3189 # add this parameter to our list
3190 $self->add_parameter($param);
3192 # If no filename specified, then just read the data and assign it
3193 # to our parameter list.
3194 if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
3195 my($value) = $buffer->readBody;
3197 push(@{$self->{$param}},$value);
3201 my ($tmpfile,$tmp,$filehandle);
3203 # If we get here, then we are dealing with a potentially large
3204 # uploaded form. Save the data to a temporary file, then open
3205 # the file for reading.
3207 # skip the file if uploads disabled
3208 if ($DISABLE_UPLOADS) {
3209 while (defined($data = $buffer->read)) { }
3213 # set the filename to some recognizable value
3214 if ( ( !defined($filename) || $filename eq '' ) && $multipart ) {
3215 $filename = "multipart/mixed";
3218 # choose a relatively unpredictable tmpfile sequence number
3219 my $seqno = unpack("%16C*",join('',localtime,values %ENV));
3220 for (my $cnt=10;$cnt>0;$cnt--) {
3221 next unless $tmpfile = new CGITempFile($seqno);
3222 $tmp = $tmpfile->as_string;
3223 last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
3224 $seqno += int rand(100);
3226 die "CGI open of tmpfile: $!\n" unless defined $filehandle;
3227 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
3228 && defined fileno($filehandle);
3230 # if this is an multipart/mixed attachment, save the header
3231 # together with the body for later parsing with an external
3232 # MIME parser module
3234 foreach ( keys %header ) {
3235 print $filehandle "$_: $header{$_}${CRLF}";
3237 print $filehandle "${CRLF}";
3243 while (defined($data = $buffer->read)) {
3244 if (defined $self->{'.upload_hook'})
3246 $totalbytes += length($data);
3247 &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
3249 print $filehandle $data;
3252 # back up to beginning of file
3253 seek($filehandle,0,0);
3255 ## Close the filehandle if requested this allows a multipart MIME
3256 ## upload to contain many files, and we won't die due to too many
3257 ## open file handles. The user can access the files using the hash
3259 close $filehandle if $CLOSE_UPLOAD_FILES;
3260 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
3262 # Save some information about the uploaded file where we can get
3264 $self->{'.tmpfiles'}->{fileno($filehandle)}= {
3265 hndl => $filehandle,
3269 push(@{$self->{$param}},$filehandle);
3275 'upload' =><<'END_OF_FUNC',
3277 my($self,$param_name) = self_or_default(@_);
3278 my @param = grep(ref && fileno($_), $self->param($param_name));
3279 return unless @param;
3280 return wantarray ? @param : $param[0];
3284 'tmpFileName' => <<'END_OF_FUNC',
3286 my($self,$filename) = self_or_default(@_);
3287 return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ?
3288 $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string
3293 'uploadInfo' => <<'END_OF_FUNC',
3295 my($self,$filename) = self_or_default(@_);
3296 return $self->{'.tmpfiles'}->{fileno($filename)}->{info};
3300 # internal routine, don't use
3301 '_set_values_and_labels' => <<'END_OF_FUNC',
3302 sub _set_values_and_labels {
3305 $$l = $v if ref($v) eq 'HASH' && !ref($$l);
3306 return $self->param($n) if !defined($v);
3307 return $v if !ref($v);
3308 return ref($v) eq 'HASH' ? keys %$v : @$v;
3312 # internal routine, don't use
3313 '_set_attributes' => <<'END_OF_FUNC',
3314 sub _set_attributes {
3316 my($element, $attributes) = @_;
3317 return '' unless defined($attributes->{$element});
3319 foreach my $attrib (keys %{$attributes->{$element}}) {
3321 $attribs .= "@{[lc($attrib)]}=\"$attributes->{$element}{$attrib}\" ";
3328 '_compile_all' => <<'END_OF_FUNC',
3331 next if defined(&$_);
3332 $AUTOLOAD = "CGI::$_";
3342 #########################################################
3343 # Globals and stubs for other packages that we use.
3344 #########################################################
3346 ################### Fh -- lightweight filehandle ###############
3355 *Fh::AUTOLOAD = \&CGI::AUTOLOAD;
3357 $AUTOLOADED_ROUTINES = ''; # prevent -w error
3358 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3360 'asString' => <<'END_OF_FUNC',
3363 # get rid of package name
3364 (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
3365 $i =~ s/%(..)/ chr(hex($1)) /eg;
3366 return $i.$CGI::TAINTED;
3368 # This was an extremely clever patch that allowed "use strict refs".
3369 # Unfortunately it relied on another bug that caused leaky file descriptors.
3370 # The underlying bug has been fixed, so this no longer works. However
3371 # "strict refs" still works for some reason.
3373 # return ${*{$self}{SCALAR}};
3378 'compare' => <<'END_OF_FUNC',
3382 return "$self" cmp $value;
3386 'new' => <<'END_OF_FUNC',
3388 my($pack,$name,$file,$delete) = @_;
3389 _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
3390 require Fcntl unless defined &Fcntl::O_RDWR;
3391 (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
3392 my $fv = ++$FH . $safename;
3393 my $ref = \*{"Fh::$fv"};
3394 $file =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
3396 sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
3397 unlink($safe) if $delete;
3398 CORE::delete $Fh::{$fv};
3399 return bless $ref,$pack;
3403 'DESTROY' => <<'END_OF_FUNC',
3413 ######################## MultipartBuffer ####################
3414 package MultipartBuffer;
3416 use constant DEBUG => 0;
3418 # how many bytes to read at a time. We use
3419 # a 4K buffer by default.
3420 $INITIAL_FILLUNIT = 1024 * 4;
3421 $TIMEOUT = 240*60; # 4 hour timeout for big files
3422 $SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
3425 #reuse the autoload function
3426 *MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
3428 # avoid autoloader warnings
3431 ###############################################################################
3432 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3433 ###############################################################################
3434 $AUTOLOADED_ROUTINES = ''; # prevent -w error
3435 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3438 'new' => <<'END_OF_FUNC',
3440 my($package,$interface,$boundary,$length) = @_;
3441 $FILLUNIT = $INITIAL_FILLUNIT;
3442 $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always
3444 # If the user types garbage into the file upload field,
3445 # then Netscape passes NOTHING to the server (not good).
3446 # We may hang on this read in that case. So we implement
3447 # a read timeout. If nothing is ready to read
3448 # by then, we return.
3450 # Netscape seems to be a little bit unreliable
3451 # about providing boundary strings.
3452 my $boundary_read = 0;
3455 # Under the MIME spec, the boundary consists of the
3456 # characters "--" PLUS the Boundary string
3458 # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
3459 # the two extra hyphens. We do a special case here on the user-agent!!!!
3460 $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport');
3462 } else { # otherwise we find it ourselves
3464 ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
3465 $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl
3466 $length -= length($boundary);
3467 chomp($boundary); # remove the CRLF
3468 $/ = $old; # restore old line separator
3472 my $self = {LENGTH=>$length,
3473 BOUNDARY=>$boundary,
3474 INTERFACE=>$interface,
3478 $FILLUNIT = length($boundary)
3479 if length($boundary) > $FILLUNIT;
3481 my $retval = bless $self,ref $package || $package;
3483 # Read the preamble and the topmost (boundary) line plus the CRLF.
3484 unless ($boundary_read) {
3485 while ($self->read(0)) { }
3487 die "Malformed multipart POST: data truncated\n" if $self->eof;
3493 'readHeader' => <<'END_OF_FUNC',
3500 local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC;
3503 $self->fillBuffer($FILLUNIT);
3504 $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
3505 $ok++ if $self->{BUFFER} eq '';
3506 $bad++ if !$ok && $self->{LENGTH} <= 0;
3507 # this was a bad idea
3508 # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
3509 } until $ok || $bad;
3512 #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines!
3514 my($header) = substr($self->{BUFFER},0,$end+2);
3515 substr($self->{BUFFER},0,$end+4) = '';
3519 warn "untranslated header=$header\n" if DEBUG;
3520 $header = CGI::Util::ascii2ebcdic($header);
3521 warn "translated header=$header\n" if DEBUG;
3524 # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
3525 # (Folding Long Header Fields), 3.4.3 (Comments)
3526 # and 3.4.5 (Quoted-Strings).
3528 my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
3529 $header=~s/$CRLF\s+/ /og; # merge continuation lines
3531 while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
3532 my ($field_name,$field_value) = ($1,$2);
3533 $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
3534 $return{$field_name}=$field_value;
3540 # This reads and returns the body as a single scalar value.
3541 'readBody' => <<'END_OF_FUNC',
3547 #EBCDIC NOTE: want to translate returnval into EBCDIC HERE
3549 while (defined($data = $self->read)) {
3550 $returnval .= $data;
3554 warn "untranslated body=$returnval\n" if DEBUG;
3555 $returnval = CGI::Util::ascii2ebcdic($returnval);
3556 warn "translated body=$returnval\n" if DEBUG;
3562 # This will read $bytes or until the boundary is hit, whichever happens
3563 # first. After the boundary is hit, we return undef. The next read will
3564 # skip over the boundary and begin reading again;
3565 'read' => <<'END_OF_FUNC',
3567 my($self,$bytes) = @_;
3569 # default number of bytes to read
3570 $bytes = $bytes || $FILLUNIT;
3572 # Fill up our internal buffer in such a way that the boundary
3573 # is never split between reads.
3574 $self->fillBuffer($bytes);
3576 my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY};
3577 my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--';
3579 # Find the boundary in the buffer (it may not be there).
3580 my $start = index($self->{BUFFER},$boundary_start);
3582 warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG;
3583 # protect against malformed multipart POST operations
3584 die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
3587 #EBCDIC NOTE: want to translate boundary search into ASCII here.
3589 # If the boundary begins the data, then skip past it
3593 # clear us out completely if we've hit the last boundary.
3594 if (index($self->{BUFFER},$boundary_end)==0) {
3600 # just remove the boundary.
3601 substr($self->{BUFFER},0,length($boundary_start))='';
3602 $self->{BUFFER} =~ s/^\012\015?//;
3607 if ($start > 0) { # read up to the boundary
3608 $bytesToReturn = $start-2 > $bytes ? $bytes : $start;
3609 } else { # read the requested number of bytes
3610 # leave enough bytes in the buffer to allow us to read
3611 # the boundary. Thanks to Kevin Hendrick for finding
3613 $bytesToReturn = $bytes - (length($boundary_start)+1);
3616 my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
3617 substr($self->{BUFFER},0,$bytesToReturn)='';
3619 # If we hit the boundary, remove the CRLF from the end.
3620 return ($bytesToReturn==$start)
3621 ? substr($returnval,0,-2) : $returnval;
3626 # This fills up our internal buffer in such a way that the
3627 # boundary is never split between reads
3628 'fillBuffer' => <<'END_OF_FUNC',
3630 my($self,$bytes) = @_;
3631 return unless $self->{LENGTH};
3633 my($boundaryLength) = length($self->{BOUNDARY});
3634 my($bufferLength) = length($self->{BUFFER});
3635 my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
3636 $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
3638 # Try to read some data. We may hang here if the browser is screwed up.
3639 my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER},
3642 warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG;
3643 $self->{BUFFER} = '' unless defined $self->{BUFFER};
3645 # An apparent bug in the Apache server causes the read()
3646 # to return zero bytes repeatedly without blocking if the
3647 # remote user aborts during a file transfer. I don't know how
3648 # they manage this, but the workaround is to abort if we get
3649 # more than SPIN_LOOP_MAX consecutive zero reads.
3650 if ($bytesRead == 0) {
3651 die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
3652 if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
3654 $self->{ZERO_LOOP_COUNTER}=0;
3657 $self->{LENGTH} -= $bytesRead;
3662 # Return true when we've finished reading
3663 'eof' => <<'END_OF_FUNC'
3666 return 1 if (length($self->{BUFFER}) == 0)
3667 && ($self->{LENGTH} <= 0);
3675 ####################################################################################
3676 ################################## TEMPORARY FILES #################################
3677 ####################################################################################
3678 package CGITempFile;
3681 undef $TMPDIRECTORY;
3683 $MAC = $CGI::OS eq 'MACINTOSH';
3684 my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
3685 unless ($TMPDIRECTORY) {
3686 @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
3687 "C:${SL}temp","${SL}tmp","${SL}temp",
3688 "${vol}${SL}Temporary Items",
3689 "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
3690 "C:${SL}system${SL}temp");
3691 unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'};
3693 # this feature was supposed to provide per-user tmpfiles, but
3694 # it is problematic.
3695 # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
3696 # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
3697 # : can generate a 'getpwuid() not implemented' exception, even though
3698 # : it's never called. Found under DOS/Win with the DJGPP perl port.
3699 # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
3700 # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
3703 do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
3706 $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
3713 # cute feature, but overload implementation broke it
3714 # %OVERLOAD = ('""'=>'as_string');
3715 *CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD;
3719 $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
3720 my $safe = $1; # untaint operation
3721 unlink $safe; # get rid of the file
3724 ###############################################################################
3725 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3726 ###############################################################################
3727 $AUTOLOADED_ROUTINES = ''; # prevent -w error
3728 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3731 'new' => <<'END_OF_FUNC',
3733 my($package,$sequence) = @_;
3735 find_tempdir() unless -w $TMPDIRECTORY;
3736 for (my $i = 0; $i < $MAXTRIES; $i++) {
3737 last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
3739 # check that it is a more-or-less valid filename
3740 return unless $filename =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$!;
3741 # this used to untaint, now it doesn't
3743 return bless \$filename;
3747 'as_string' => <<'END_OF_FUNC'
3759 # We get a whole bunch of warnings about "possibly uninitialized variables"
3760 # when running with the -w switch. Touch them all once to get rid of the
3761 # warnings. This is ugly and I hate it.
3766 $MultipartBuffer::SPIN_LOOP_MAX;
3767 $MultipartBuffer::CRLF;
3768 $MultipartBuffer::TIMEOUT;
3769 $MultipartBuffer::INITIAL_FILLUNIT;
3780 CGI - Simple Common Gateway Interface Class
3784 # CGI script that creates a fill-out form
3785 # and echoes back its values.
3787 use CGI qw/:standard/;
3789 start_html('A Simple Example'),
3790 h1('A Simple Example'),
3792 "What's your name? ",textfield('name'),p,
3793 "What's the combination?", p,
3794 checkbox_group(-name=>'words',
3795 -values=>['eenie','meenie','minie','moe'],
3796 -defaults=>['eenie','minie']), p,
3797 "What's your favorite color? ",
3798 popup_menu(-name=>'color',
3799 -values=>['red','green','blue','chartreuse']),p,
3805 print "Your name is",em(param('name')),p,
3806 "The keywords are: ",em(join(", ",param('words'))),p,
3807 "Your favorite color is ",em(param('color')),
3813 This perl library uses perl5 objects to make it easy to create Web
3814 fill-out forms and parse their contents. This package defines CGI
3815 objects, entities that contain the values of the current query string
3816 and other state variables. Using a CGI object's methods, you can
3817 examine keywords and parameters passed to your script, and create
3818 forms whose initial values are taken from the current query (thereby
3819 preserving state information). The module provides shortcut functions
3820 that produce boilerplate HTML, reducing typing and coding errors. It
3821 also provides functionality for some of the more advanced features of
3822 CGI scripting, including support for file uploads, cookies, cascading
3823 style sheets, server push, and frames.
3825 CGI.pm also provides a simple function-oriented programming style for
3826 those who don't need its object-oriented features.
3828 The current version of CGI.pm is available at
3830 http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
3831 ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
3835 =head2 PROGRAMMING STYLE
3837 There are two styles of programming with CGI.pm, an object-oriented
3838 style and a function-oriented style. In the object-oriented style you
3839 create one or more CGI objects and then use object methods to create
3840 the various elements of the page. Each CGI object starts out with the
3841 list of named parameters that were passed to your CGI script by the
3842 server. You can modify the objects, save them to a file or database
3843 and recreate them. Because each object corresponds to the "state" of
3844 the CGI script, and because each object's parameter list is
3845 independent of the others, this allows you to save the state of the
3846 script and restore it later.
3848 For example, using the object oriented style, here is how you create
3849 a simple "Hello World" HTML page:
3851 #!/usr/local/bin/perl -w
3852 use CGI; # load CGI routines
3853 $q = new CGI; # create new CGI object
3854 print $q->header, # create the HTTP header
3855 $q->start_html('hello world'), # start the HTML
3856 $q->h1('hello world'), # level 1 header
3857 $q->end_html; # end the HTML
3859 In the function-oriented style, there is one default CGI object that
3860 you rarely deal with directly. Instead you just call functions to
3861 retrieve CGI parameters, create HTML tags, manage cookies, and so
3862 on. This provides you with a cleaner programming interface, but
3863 limits you to using one CGI object at a time. The following example
3864 prints the same page, but uses the function-oriented interface.
3865 The main differences are that we now need to import a set of functions
3866 into our name space (usually the "standard" functions), and we don't
3867 need to create the CGI object.
3869 #!/usr/local/bin/perl
3870 use CGI qw/:standard/; # load standard CGI routines
3871 print header, # create the HTTP header
3872 start_html('hello world'), # start the HTML
3873 h1('hello world'), # level 1 header
3874 end_html; # end the HTML
3876 The examples in this document mainly use the object-oriented style.
3877 See HOW TO IMPORT FUNCTIONS for important information on
3878 function-oriented programming in CGI.pm
3880 =head2 CALLING CGI.PM ROUTINES
3882 Most CGI.pm routines accept several arguments, sometimes as many as 20
3883 optional ones! To simplify this interface, all routines use a named
3884 argument calling style that looks like this:
3886 print $q->header(-type=>'image/gif',-expires=>'+3d');
3888 Each argument name is preceded by a dash. Neither case nor order
3889 matters in the argument list. -type, -Type, and -TYPE are all
3890 acceptable. In fact, only the first argument needs to begin with a
3891 dash. If a dash is present in the first argument, CGI.pm assumes
3892 dashes for the subsequent ones.
3894 Several routines are commonly called with just one argument. In the
3895 case of these routines you can provide the single argument without an
3896 argument name. header() happens to be one of these routines. In this
3897 case, the single argument is the document type.
3899 print $q->header('text/html');
3901 Other such routines are documented below.
3903 Sometimes named arguments expect a scalar, sometimes a reference to an
3904 array, and sometimes a reference to a hash. Often, you can pass any
3905 type of argument and the routine will do whatever is most appropriate.
3906 For example, the param() routine is used to set a CGI parameter to a
3907 single or a multi-valued value. The two cases are shown below:
3909 $q->param(-name=>'veggie',-value=>'tomato');
3910 $q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']);
3912 A large number of routines in CGI.pm actually aren't specifically
3913 defined in the module, but are generated automatically as needed.
3914 These are the "HTML shortcuts," routines that generate HTML tags for
3915 use in dynamically-generated pages. HTML tags have both attributes
3916 (the attribute="value" pairs within the tag itself) and contents (the
3917 part between the opening and closing pairs.) To distinguish between
3918 attributes and contents, CGI.pm uses the convention of passing HTML
3919 attributes as a hash reference as the first argument, and the
3920 contents, if any, as any subsequent arguments. It works out like
3926 h1('some','contents'); <h1>some contents</h1>
3927 h1({-align=>left}); <h1 align="LEFT">
3928 h1({-align=>left},'contents'); <h1 align="LEFT">contents</h1>
3930 HTML tags are described in more detail later.
3932 Many newcomers to CGI.pm are puzzled by the difference between the
3933 calling conventions for the HTML shortcuts, which require curly braces
3934 around the HTML tag attributes, and the calling conventions for other
3935 routines, which manage to generate attributes without the curly
3936 brackets. Don't be confused. As a convenience the curly braces are
3937 optional in all but the HTML shortcuts. If you like, you can use
3938 curly braces when calling any routine that takes named arguments. For
3941 print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
3943 If you use the B<-w> switch, you will be warned that some CGI.pm argument
3944 names conflict with built-in Perl functions. The most frequent of
3945 these is the -values argument, used to create multi-valued menus,
3946 radio button clusters and the like. To get around this warning, you
3947 have several choices:
3953 Use another name for the argument, if one is available.
3954 For example, -value is an alias for -values.
3958 Change the capitalization, e.g. -Values
3962 Put quotes around the argument name, e.g. '-values'
3966 Many routines will do something useful with a named argument that it
3967 doesn't recognize. For example, you can produce non-standard HTTP
3968 header fields by providing them as named arguments:
3970 print $q->header(-type => 'text/html',
3971 -cost => 'Three smackers',
3972 -annoyance_level => 'high',
3973 -complaints_to => 'bit bucket');
3975 This will produce the following nonstandard HTTP header:
3978 Cost: Three smackers
3979 Annoyance-level: high
3980 Complaints-to: bit bucket
3981 Content-type: text/html
3983 Notice the way that underscores are translated automatically into
3984 hyphens. HTML-generating routines perform a different type of
3987 This feature allows you to keep up with the rapidly changing HTTP and
3990 =head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
3994 This will parse the input (from both POST and GET methods) and store
3995 it into a perl5 object called $query.
3997 =head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
3999 $query = new CGI(INPUTFILE);
4001 If you provide a file handle to the new() method, it will read
4002 parameters from the file (or STDIN, or whatever). The file can be in
4003 any of the forms describing below under debugging (i.e. a series of
4004 newline delimited TAG=VALUE pairs will work). Conveniently, this type
4005 of file is created by the save() method (see below). Multiple records
4006 can be saved and restored.
4008 Perl purists will be pleased to know that this syntax accepts
4009 references to file handles, or even references to filehandle globs,
4010 which is the "official" way to pass a filehandle:
4012 $query = new CGI(\*STDIN);
4014 You can also initialize the CGI object with a FileHandle or IO::File
4017 If you are using the function-oriented interface and want to
4018 initialize CGI state from a file handle, the way to do this is with
4019 B<restore_parameters()>. This will (re)initialize the
4020 default CGI object from the indicated file handle.
4022 open (IN,"test.in") || die;
4023 restore_parameters(IN);
4026 You can also initialize the query object from an associative array
4029 $query = new CGI( {'dinosaur'=>'barney',
4030 'song'=>'I love you',
4031 'friends'=>[qw/Jessica George Nancy/]}
4034 or from a properly formatted, URL-escaped query string:
4036 $query = new CGI('dinosaur=barney&color=purple');
4038 or from a previously existing CGI object (currently this clones the
4039 parameter list, but none of the other object-specific fields, such as
4042 $old_query = new CGI;
4043 $new_query = new CGI($old_query);
4045 To create an empty query, initialize it from an empty string or hash:
4047 $empty_query = new CGI("");
4051 $empty_query = new CGI({});
4053 =head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
4055 @keywords = $query->keywords
4057 If the script was invoked as the result of an <ISINDEX> search, the
4058 parsed keywords can be obtained as an array using the keywords() method.
4060 =head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
4062 @names = $query->param
4064 If the script was invoked with a parameter list
4065 (e.g. "name1=value1&name2=value2&name3=value3"), the param() method
4066 will return the parameter names as a list. If the script was invoked
4067 as an <ISINDEX> script and contains a string without ampersands
4068 (e.g. "value1+value2+value3") , there will be a single parameter named
4069 "keywords" containing the "+"-delimited keywords.
4071 NOTE: As of version 1.5, the array of parameter names returned will
4072 be in the same order as they were submitted by the browser.
4073 Usually this order is the same as the order in which the
4074 parameters are defined in the form (however, this isn't part
4075 of the spec, and so isn't guaranteed).
4077 =head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
4079 @values = $query->param('foo');
4083 $value = $query->param('foo');
4085 Pass the param() method a single argument to fetch the value of the
4086 named parameter. If the parameter is multivalued (e.g. from multiple
4087 selections in a scrolling list), you can ask to receive an array. Otherwise
4088 the method will return a single value.
4090 If a value is not given in the query string, as in the queries
4091 "name1=&name2=" or "name1&name2", it will be returned as an empty
4092 string. This feature is new in 2.63.
4095 If the parameter does not exist at all, then param() will return undef
4096 in a scalar context, and the empty list in a list context.
4099 =head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
4101 $query->param('foo','an','array','of','values');
4103 This sets the value for the named parameter 'foo' to an array of
4104 values. This is one way to change the value of a field AFTER
4105 the script has been invoked once before. (Another way is with
4106 the -override parameter accepted by all methods that generate
4109 param() also recognizes a named parameter style of calling described
4110 in more detail later:
4112 $query->param(-name=>'foo',-values=>['an','array','of','values']);
4116 $query->param(-name=>'foo',-value=>'the value');
4118 =head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
4120 $query->append(-name=>'foo',-values=>['yet','more','values']);
4122 This adds a value or list of values to the named parameter. The
4123 values are appended to the end of the parameter if it already exists.
4124 Otherwise the parameter is created. Note that this method only
4125 recognizes the named argument calling syntax.
4127 =head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
4129 $query->import_names('R');
4131 This creates a series of variables in the 'R' namespace. For example,
4132 $R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
4133 If no namespace is given, this method will assume 'Q'.
4134 WARNING: don't import anything into 'main'; this is a major security
4137 NOTE 1: Variable names are transformed as necessary into legal Perl
4138 variable names. All non-legal characters are transformed into
4139 underscores. If you need to keep the original names, you should use
4140 the param() method instead to access CGI variables by name.
4142 NOTE 2: In older versions, this method was called B<import()>. As of version 2.20,
4143 this name has been removed completely to avoid conflict with the built-in
4144 Perl module B<import> operator.
4146 =head2 DELETING A PARAMETER COMPLETELY:
4148 $query->delete('foo','bar','baz');
4150 This completely clears a list of parameters. It sometimes useful for
4151 resetting parameters that you don't want passed down between script
4154 If you are using the function call interface, use "Delete()" instead
4155 to avoid conflicts with Perl's built-in delete operator.
4157 =head2 DELETING ALL PARAMETERS:
4159 $query->delete_all();
4161 This clears the CGI object completely. It might be useful to ensure
4162 that all the defaults are taken when you create a fill-out form.
4164 Use Delete_all() instead if you are using the function call interface.
4166 =head2 DIRECT ACCESS TO THE PARAMETER LIST:
4168 $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
4169 unshift @{$q->param_fetch(-name=>'address')},'George Munster';
4171 If you need access to the parameter list in a way that isn't covered
4172 by the methods above, you can obtain a direct reference to it by
4173 calling the B<param_fetch()> method with the name of the . This
4174 will return an array reference to the named parameters, which you then
4175 can manipulate in any way you like.
4177 You can also use a named argument style using the B<-name> argument.
4179 =head2 FETCHING THE PARAMETER LIST AS A HASH:
4182 print $params->{'address'};
4183 @foo = split("\0",$params->{'foo'});
4189 Many people want to fetch the entire parameter list as a hash in which
4190 the keys are the names of the CGI parameters, and the values are the
4191 parameters' values. The Vars() method does this. Called in a scalar
4192 context, it returns the parameter list as a tied hash reference.
4193 Changing a key changes the value of the parameter in the underlying
4194 CGI parameter list. Called in a list context, it returns the
4195 parameter list as an ordinary hash. This allows you to read the
4196 contents of the parameter list, but not to change it.
4198 When using this, the thing you must watch out for are multivalued CGI
4199 parameters. Because a hash cannot distinguish between scalar and
4200 list context, multivalued parameters will be returned as a packed
4201 string, separated by the "\0" (null) character. You must split this
4202 packed string in order to get at the individual values. This is the
4203 convention introduced long ago by Steve Brenner in his cgi-lib.pl
4204 module for Perl version 4.
4206 If you wish to use Vars() as a function, import the I<:cgi-lib> set of
4207 function calls (also see the section on CGI-LIB compatibility).
4209 =head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
4211 $query->save(FILEHANDLE)
4213 This will write the current state of the form to the provided
4214 filehandle. You can read it back in by providing a filehandle
4215 to the new() method. Note that the filehandle can be a file, a pipe,
4218 The format of the saved file is:
4226 Both name and value are URL escaped. Multi-valued CGI parameters are
4227 represented as repeated names. A session record is delimited by a
4228 single = symbol. You can write out multiple records and read them
4229 back in with several calls to B<new>. You can do this across several
4230 sessions by opening the file in append mode, allowing you to create
4231 primitive guest books, or to keep a history of users' queries. Here's
4232 a short example of creating multiple session records:
4236 open (OUT,">>test.out") || die;
4238 foreach (0..$records) {
4240 $q->param(-name=>'counter',-value=>$_);
4245 # reopen for reading
4246 open (IN,"test.out") || die;
4248 my $q = new CGI(IN);
4249 print $q->param('counter'),"\n";
4252 The file format used for save/restore is identical to that used by the
4253 Whitehead Genome Center's data exchange format "Boulderio", and can be
4254 manipulated and even databased using Boulderio utilities. See
4256 http://stein.cshl.org/boulder/
4258 for further details.
4260 If you wish to use this method from the function-oriented (non-OO)
4261 interface, the exported name for this method is B<save_parameters()>.
4263 =head2 RETRIEVING CGI ERRORS
4265 Errors can occur while processing user input, particularly when
4266 processing uploaded files. When these errors occur, CGI will stop
4267 processing and return an empty parameter list. You can test for
4268 the existence and nature of errors using the I<cgi_error()> function.
4269 The error messages are formatted as HTTP status codes. You can either
4270 incorporate the error text into an HTML page, or use it as the value
4273 my $error = $q->cgi_error;
4275 print $q->header(-status=>$error),
4276 $q->start_html('Problems'),
4277 $q->h2('Request not processed'),
4282 When using the function-oriented interface (see the next section),
4283 errors may only occur the first time you call I<param()>. Be ready
4286 =head2 USING THE FUNCTION-ORIENTED INTERFACE
4288 To use the function-oriented interface, you must specify which CGI.pm
4289 routines or sets of routines to import into your script's namespace.
4290 There is a small overhead associated with this importation, but it
4293 use CGI <list of methods>;
4295 The listed methods will be imported into the current package; you can
4296 call them directly without creating a CGI object first. This example
4297 shows how to import the B<param()> and B<header()>
4298 methods, and then use them directly:
4300 use CGI 'param','header';
4301 print header('text/plain');
4302 $zipcode = param('zipcode');
4304 More frequently, you'll import common sets of functions by referring
4305 to the groups by name. All function sets are preceded with a ":"
4306 character as in ":html3" (for tags defined in the HTML 3 standard).
4308 Here is a list of the function sets you can import:
4314 Import all CGI-handling methods, such as B<param()>, B<path_info()>
4319 Import all fill-out form generating methods, such as B<textfield()>.
4323 Import all methods that generate HTML 2.0 standard elements.
4327 Import all methods that generate HTML 3.0 elements (such as
4328 <table>, <super> and <sub>).
4332 Import all methods that generate HTML 4 elements (such as
4333 <abbrev>, <acronym> and <thead>).
4337 Import all methods that generate Netscape-specific HTML extensions.
4341 Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
4346 Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'.
4350 Import all the available methods. For the full list, see the CGI.pm
4351 code, where the variable %EXPORT_TAGS is defined.
4355 If you import a function name that is not part of CGI.pm, the module
4356 will treat it as a new HTML tag and generate the appropriate
4357 subroutine. You can then use it like any other HTML tag. This is to
4358 provide for the rapidly-evolving HTML "standard." For example, say
4359 Microsoft comes out with a new tag called <gradient> (which causes the
4360 user's desktop to be flooded with a rotating gradient fill until his
4361 machine reboots). You don't need to wait for a new version of CGI.pm
4362 to start using it immediately:
4364 use CGI qw/:standard :html3 gradient/;
4365 print gradient({-start=>'red',-end=>'blue'});
4367 Note that in the interests of execution speed CGI.pm does B<not> use
4368 the standard L<Exporter> syntax for specifying load symbols. This may
4369 change in the future.
4371 If you import any of the state-maintaining CGI or form-generating
4372 methods, a default CGI object will be created and initialized
4373 automatically the first time you use any of the methods that require
4374 one to be present. This includes B<param()>, B<textfield()>,
4375 B<submit()> and the like. (If you need direct access to the CGI
4376 object, you can find it in the global variable B<$CGI::Q>). By
4377 importing CGI.pm methods, you can create visually elegant scripts:
4379 use CGI qw/:standard/;
4382 start_html('Simple Script'),
4383 h1('Simple Script'),
4385 "What's your name? ",textfield('name'),p,
4386 "What's the combination?",
4387 checkbox_group(-name=>'words',
4388 -values=>['eenie','meenie','minie','moe'],
4389 -defaults=>['eenie','moe']),p,
4390 "What's your favorite color?",
4391 popup_menu(-name=>'color',
4392 -values=>['red','green','blue','chartreuse']),p,
4399 "Your name is ",em(param('name')),p,
4400 "The keywords are: ",em(join(", ",param('words'))),p,
4401 "Your favorite color is ",em(param('color')),".\n";
4407 In addition to the function sets, there are a number of pragmas that
4408 you can import. Pragmas, which are always preceded by a hyphen,
4409 change the way that CGI.pm functions in various ways. Pragmas,
4410 function sets, and individual functions can all be imported in the
4411 same use() line. For example, the following use statement imports the
4412 standard set of functions and enables debugging mode (pragma
4415 use CGI qw/:standard -debug/;
4417 The current list of pragmas is as follows:
4423 When you I<use CGI -any>, then any method that the query object
4424 doesn't recognize will be interpreted as a new HTML tag. This allows
4425 you to support the next I<ad hoc> Netscape or Microsoft HTML
4426 extension. This lets you go wild with new and unsupported tags:
4430 print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
4432 Since using <cite>any</cite> causes any mistyped method name
4433 to be interpreted as an HTML tag, use it with care or not at
4438 This causes the indicated autoloaded methods to be compiled up front,
4439 rather than deferred to later. This is useful for scripts that run
4440 for an extended period of time under FastCGI or mod_perl, and for
4441 those destined to be crunched by Malcom Beattie's Perl compiler. Use
4442 it in conjunction with the methods or method families you plan to use.
4444 use CGI qw(-compile :standard :html3);
4448 use CGI qw(-compile :all);
4450 Note that using the -compile pragma in this way will always have
4451 the effect of importing the compiled functions into the current
4452 namespace. If you want to compile without importing use the
4453 compile() method instead:
4458 This is particularly useful in a mod_perl environment, in which you
4459 might want to precompile all CGI routines in a startup script, and
4460 then import the functions individually in each mod_perl script.
4464 This makes CGI.pm not generating the hidden fields .submit
4465 and .cgifields. It is very useful if you don't want to
4466 have the hidden fields appear in the querystring in a GET method.
4467 For example, a search script generated this way will have
4468 a very nice url with search parameters for bookmarking.
4470 =item -no_undef_params
4472 This keeps CGI.pm from including undef params in the parameter list.
4476 By default, CGI.pm versions 2.69 and higher emit XHTML
4477 (http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this
4478 feature. Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this
4483 This makes CGI.pm produce a header appropriate for an NPH (no
4484 parsed header) script. You may need to do other things as well
4485 to tell the server that the script is NPH. See the discussion
4486 of NPH scripts below.
4488 =item -newstyle_urls
4490 Separate the name=value pairs in CGI parameter query strings with
4491 semicolons rather than ampersands. For example:
4493 ?name=fred;age=24;favorite_color=3
4495 Semicolon-delimited query strings are always accepted, but will not be
4496 emitted by self_url() and query_string() unless the -newstyle_urls
4497 pragma is specified.
4499 This became the default in version 2.64.
4501 =item -oldstyle_urls
4503 Separate the name=value pairs in CGI parameter query strings with
4504 ampersands rather than semicolons. This is no longer the default.
4508 This overrides the autoloader so that any function in your program
4509 that is not recognized is referred to CGI.pm for possible evaluation.
4510 This allows you to use all the CGI.pm functions without adding them to
4511 your symbol table, which is of concern for mod_perl users who are
4512 worried about memory consumption. I<Warning:> when
4513 I<-autoload> is in effect, you cannot use "poetry mode"
4514 (functions without the parenthesis). Use I<hr()> rather
4515 than I<hr>, or add something like I<use subs qw/hr p header/>
4516 to the top of your script.
4520 This turns off the command-line processing features. If you want to
4521 run a CGI.pm script from the command line to produce HTML, and you
4522 don't want it to read CGI parameters from the command line or STDIN,
4523 then use this pragma:
4525 use CGI qw(-no_debug :standard);
4529 This turns on full debugging. In addition to reading CGI arguments
4530 from the command-line processing, CGI.pm will pause and try to read
4531 arguments from STDIN, producing the message "(offline mode: enter
4532 name=value pairs on standard input)" features.
4534 See the section on debugging for more details.
4536 =item -private_tempfiles
4538 CGI.pm can process uploaded file. Ordinarily it spools the uploaded
4539 file to a temporary directory, then deletes the file when done.
4540 However, this opens the risk of eavesdropping as described in the file
4541 upload section. Another CGI script author could peek at this data
4542 during the upload, even if it is confidential information. On Unix
4543 systems, the -private_tempfiles pragma will cause the temporary file
4544 to be unlinked as soon as it is opened and before any data is written
4545 into it, reducing, but not eliminating the risk of eavesdropping
4546 (there is still a potential race condition). To make life harder for
4547 the attacker, the program chooses tempfile names by calculating a 32
4548 bit checksum of the incoming HTTP headers.
4550 To ensure that the temporary file cannot be read by other CGI scripts,
4551 use suEXEC or a CGI wrapper program to run your script. The temporary
4552 file is created with mode 0600 (neither world nor group readable).
4554 The temporary directory is selected using the following algorithm:
4556 1. if the current user (e.g. "nobody") has a directory named
4557 "tmp" in its home directory, use that (Unix systems only).
4559 2. if the environment variable TMPDIR exists, use the location
4562 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp,
4563 /tmp, /temp, ::Temporary Items, and \WWW_ROOT.
4565 Each of these locations is checked that it is a directory and is
4566 writable. If not, the algorithm tries the next choice.
4570 =head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS
4572 Many of the methods generate HTML tags. As described below, tag
4573 functions automatically generate both the opening and closing tags.
4576 print h1('Level 1 Header');
4580 <h1>Level 1 Header</h1>
4582 There will be some times when you want to produce the start and end
4583 tags yourself. In this case, you can use the form start_I<tag_name>
4584 and end_I<tag_name>, as in:
4586 print start_h1,'Level 1 Header',end_h1;
4588 With a few exceptions (described below), start_I<tag_name> and
4589 end_I<tag_name> functions are not generated automatically when you
4590 I<use CGI>. However, you can specify the tags you want to generate
4591 I<start/end> functions for by putting an asterisk in front of their
4592 name, or, alternatively, requesting either "start_I<tag_name>" or
4593 "end_I<tag_name>" in the import list.
4597 use CGI qw/:standard *table start_ul/;
4599 In this example, the following functions are generated in addition to
4604 =item 1. start_table() (generates a <table> tag)
4606 =item 2. end_table() (generates a </table> tag)
4608 =item 3. start_ul() (generates a <ul> tag)
4610 =item 4. end_ul() (generates a </ul> tag)
4614 =head1 GENERATING DYNAMIC DOCUMENTS
4616 Most of CGI.pm's functions deal with creating documents on the fly.
4617 Generally you will produce the HTTP header first, followed by the
4618 document itself. CGI.pm provides functions for generating HTTP
4619 headers of various types as well as for generating HTML. For creating
4620 GIF images, see the GD.pm module.
4622 Each of these functions produces a fragment of HTML or HTTP which you
4623 can print out directly so that it displays in the browser window,
4624 append to a string, or save to a file for later use.
4626 =head2 CREATING A STANDARD HTTP HEADER:
4628 Normally the first thing you will do in any CGI script is print out an
4629 HTTP header. This tells the browser what type of document to expect,
4630 and gives other optional information, such as the language, expiration
4631 date, and whether to cache the document. The header can also be
4632 manipulated for special purposes, such as server push and pay per view
4635 print $query->header;
4639 print $query->header('image/gif');
4643 print $query->header('text/html','204 No response');
4647 print $query->header(-type=>'image/gif',
4649 -status=>'402 Payment required',
4653 -attachment=>'foo.gif',
4656 header() returns the Content-type: header. You can provide your own
4657 MIME type if you choose, otherwise it defaults to text/html. An
4658 optional second parameter specifies the status code and a human-readable
4659 message. For example, you can specify 204, "No response" to create a
4660 script that tells the browser to do nothing at all.
4662 The last example shows the named argument style for passing arguments
4663 to the CGI methods using named parameters. Recognized parameters are
4664 B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named
4665 parameters will be stripped of their initial hyphens and turned into
4666 header fields, allowing you to specify any HTTP header you desire.
4667 Internal underscores will be turned into hyphens:
4669 print $query->header(-Content_length=>3002);
4671 Most browsers will not cache the output from CGI scripts. Every time
4672 the browser reloads the page, the script is invoked anew. You can
4673 change this behavior with the B<-expires> parameter. When you specify
4674 an absolute or relative expiration interval with this parameter, some
4675 browsers and proxy servers will cache the script's output until the
4676 indicated expiration date. The following forms are all valid for the
4679 +30s 30 seconds from now
4680 +10m ten minutes from now
4681 +1h one hour from now
4682 -1d yesterday (i.e. "ASAP!")
4685 +10y in ten years time
4686 Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date
4688 The B<-cookie> parameter generates a header that tells the browser to provide
4689 a "magic cookie" during all subsequent transactions with your script.
4690 Netscape cookies have a special format that includes interesting attributes
4691 such as expiration time. Use the cookie() method to create and retrieve
4694 The B<-nph> parameter, if set to a true value, will issue the correct
4695 headers to work with a NPH (no-parse-header) script. This is important
4696 to use with certain servers that expect all their scripts to be NPH.
4698 The B<-charset> parameter can be used to control the character set
4699 sent to the browser. If not provided, defaults to ISO-8859-1. As a
4700 side effect, this sets the charset() method as well.
4702 The B<-attachment> parameter can be used to turn the page into an
4703 attachment. Instead of displaying the page, some browsers will prompt
4704 the user to save it to disk. The value of the argument is the
4705 suggested name for the saved file. In order for this to work, you may
4706 have to set the B<-type> to "application/octet-stream".
4708 The B<-p3p> parameter will add a P3P tag to the outgoing header. The
4709 parameter can be an arrayref or a space-delimited string of P3P tags.
4712 print header(-p3p=>[qw(CAO DSP LAW CURa)]);
4713 print header(-p3p=>'CAO DSP LAW CURa');
4715 In either case, the outgoing header will be formatted as:
4717 P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"
4719 =head2 GENERATING A REDIRECTION HEADER
4721 print $query->redirect('http://somewhere.else/in/movie/land');
4723 Sometimes you don't want to produce a document yourself, but simply
4724 redirect the browser elsewhere, perhaps choosing a URL based on the
4725 time of day or the identity of the user.
4727 The redirect() function redirects the browser to a different URL. If
4728 you use redirection like this, you should B<not> print out a header as
4731 You should always use full URLs (including the http: or ftp: part) in
4732 redirection requests. Relative URLs will not work correctly.
4734 You can also use named arguments:
4736 print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
4739 The B<-nph> parameter, if set to a true value, will issue the correct
4740 headers to work with a NPH (no-parse-header) script. This is important
4741 to use with certain servers, such as Microsoft IIS, which
4742 expect all their scripts to be NPH.
4744 =head2 CREATING THE HTML DOCUMENT HEADER
4746 print $query->start_html(-title=>'Secrets of the Pyramids',
4747 -author=>'fred@capricorn.org',
4750 -meta=>{'keywords'=>'pharaoh secret mummy',
4751 'copyright'=>'copyright 1996 King Tut'},
4752 -style=>{'src'=>'/styles/style1.css'},
4755 After creating the HTTP header, most CGI scripts will start writing
4756 out an HTML document. The start_html() routine creates the top of the
4757 page, along with a lot of optional information that controls the
4758 page's appearance and behavior.
4760 This method returns a canned HTML header and the opening <body> tag.
4761 All parameters are optional. In the named parameter form, recognized
4762 parameters are -title, -author, -base, -xbase, -dtd, -lang and -target
4763 (see below for the explanation). Any additional parameters you
4764 provide, such as the Netscape unofficial BGCOLOR attribute, are added
4765 to the <body> tag. Additional parameters must be proceeded by a
4768 The argument B<-xbase> allows you to provide an HREF for the <base> tag
4769 different from the current location, as in
4771 -xbase=>"http://home.mcom.com/"
4773 All relative links will be interpreted relative to this tag.
4775 The argument B<-target> allows you to provide a default target frame
4776 for all the links and fill-out forms on the page. B<This is a
4777 non-standard HTTP feature which only works with Netscape browsers!>
4778 See the Netscape documentation on frames for details of how to
4781 -target=>"answer_window"
4783 All relative links will be interpreted relative to this tag.
4784 You add arbitrary meta information to the header with the B<-meta>
4785 argument. This argument expects a reference to an associative array
4786 containing name/value pairs of meta information. These will be turned
4787 into a series of header <meta> tags that look something like this:
4789 <meta name="keywords" content="pharaoh secret mummy">
4790 <meta name="description" content="copyright 1996 King Tut">
4792 To create an HTTP-EQUIV type of <meta> tag, use B<-head>, described
4795 The B<-style> argument is used to incorporate cascading stylesheets
4796 into your code. See the section on CASCADING STYLESHEETS for more
4799 The B<-lang> argument is used to incorporate a language attribute into
4800 the <html> tag. The default if not specified is "en-US" for US
4801 English. For example:
4803 print $q->start_html(-lang=>'fr-CA');
4805 To leave off the lang attribute, as you must do if you want to generate
4806 legal HTML 3.2 or earlier, pass the empty string (-lang=>'').
4808 The B<-encoding> argument can be used to specify the character set for
4809 XHTML. It defaults to iso-8859-1 if not specified.
4811 You can place other arbitrary HTML elements to the <head> section with the
4812 B<-head> tag. For example, to place the rarely-used <link> element in the
4813 head section, use this:
4815 print start_html(-head=>Link({-rel=>'next',
4816 -href=>'http://www.capricorn.com/s2.html'}));
4818 To incorporate multiple HTML elements into the <head> section, just pass an
4821 print start_html(-head=>[
4823 -href=>'http://www.capricorn.com/s2.html'}),
4824 Link({-rel=>'previous',
4825 -href=>'http://www.capricorn.com/s1.html'})
4829 And here's how to create an HTTP-EQUIV <meta> tag:
4831 print start_html(-head=>meta({-http_equiv => 'Content-Type',
4832 -content => 'text/html'}))
4835 JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
4836 B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
4837 to add Netscape JavaScript calls to your pages. B<-script> should
4838 point to a block of text containing JavaScript function definitions.
4839 This block will be placed within a <script> block inside the HTML (not
4840 HTTP) header. The block is placed in the header in order to give your
4841 page a fighting chance of having all its JavaScript functions in place
4842 even if the user presses the stop button before the page has loaded
4843 completely. CGI.pm attempts to format the script in such a way that
4844 JavaScript-naive browsers will not choke on the code: unfortunately
4845 there are some browsers, such as Chimera for Unix, that get confused
4848 The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
4849 code to execute when the page is respectively opened and closed by the
4850 browser. Usually these parameters are calls to functions defined in the
4854 print $query->header;
4856 // Ask a silly question
4857 function riddle_me_this() {
4858 var r = prompt("What walks on four legs in the morning, " +
4859 "two legs in the afternoon, " +
4860 "and three legs in the evening?");
4863 // Get a silly answer
4864 function response(answer) {
4865 if (answer == "man")
4866 alert("Right you are!");
4868 alert("Wrong! Guess again.");
4871 print $query->start_html(-title=>'The Riddle of the Sphinx',
4874 Use the B<-noScript> parameter to pass some HTML text that will be displayed on
4875 browsers that do not have JavaScript (or browsers where JavaScript is turned
4878 Netscape 3.0 recognizes several attributes of the <script> tag,
4879 including LANGUAGE and SRC. The latter is particularly interesting,
4880 as it allows you to keep the JavaScript code in a file or CGI script
4881 rather than cluttering up each page with the source. To use these
4882 attributes pass a HASH reference in the B<-script> parameter containing
4883 one or more of -language, -src, or -code:
4885 print $q->start_html(-title=>'The Riddle of the Sphinx',
4886 -script=>{-language=>'JAVASCRIPT',
4887 -src=>'/javascript/sphinx.js'}
4890 print $q->(-title=>'The Riddle of the Sphinx',
4891 -script=>{-language=>'PERLSCRIPT',
4892 -code=>'print "hello world!\n;"'}
4896 A final feature allows you to incorporate multiple <script> sections into the
4897 header. Just pass the list of script sections as an array reference.
4898 this allows you to specify different source files for different dialects
4899 of JavaScript. Example:
4901 print $q->start_html(-title=>'The Riddle of the Sphinx',
4903 { -language => 'JavaScript1.0',
4904 -src => '/javascript/utilities10.js'
4906 { -language => 'JavaScript1.1',
4907 -src => '/javascript/utilities11.js'
4909 { -language => 'JavaScript1.2',
4910 -src => '/javascript/utilities12.js'
4912 { -language => 'JavaScript28.2',
4913 -src => '/javascript/utilities219.js'
4918 If this looks a bit extreme, take my advice and stick with straight CGI scripting.
4922 http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
4924 for more information about JavaScript.
4926 The old-style positional parameters are as follows:
4930 =item B<Parameters:>
4938 The author's e-mail address (will create a <link rev="MADE"> tag if present
4942 A 'true' flag if you want to include a <base> tag in the header. This
4943 helps resolve relative addresses to absolute ones when the document is moved,
4944 but makes the document hierarchy non-portable. Use with care!
4948 Any other parameters you want to include in the <body> tag. This is a good
4949 place to put Netscape extensions, such as colors and wallpaper patterns.
4953 =head2 ENDING THE HTML DOCUMENT:
4955 print $query->end_html
4957 This ends an HTML document by printing the </body></html> tags.
4959 =head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
4961 $myself = $query->self_url;
4962 print q(<a href="$myself">I'm talking to myself.</a>);
4964 self_url() will return a URL, that, when selected, will reinvoke
4965 this script with all its state information intact. This is most
4966 useful when you want to jump around within the document using
4967 internal anchors but you don't want to disrupt the current contents
4968 of the form(s). Something like this will do the trick.
4970 $myself = $query->self_url;
4971 print "<a href=\"$myself#table1\">See table 1</a>";
4972 print "<a href=\"$myself#table2\">See table 2</a>";
4973 print "<a href=\"$myself#yourself\">See for yourself</a>";
4975 If you want more control over what's returned, using the B<url()>
4978 You can also retrieve the unprocessed query string with query_string():
4980 $the_string = $query->query_string;
4982 =head2 OBTAINING THE SCRIPT'S URL
4984 $full_url = $query->url();
4985 $full_url = $query->url(-full=>1); #alternative syntax
4986 $relative_url = $query->url(-relative=>1);
4987 $absolute_url = $query->url(-absolute=>1);
4988 $url_with_path = $query->url(-path_info=>1);
4989 $url_with_path_and_query = $query->url(-path_info=>1,-query=>1);
4990 $netloc = $query->url(-base => 1);
4992 B<url()> returns the script's URL in a variety of formats. Called
4993 without any arguments, it returns the full form of the URL, including
4994 host name and port number
4996 http://your.host.com/path/to/script.cgi
4998 You can modify this format with the following named arguments:
5004 If true, produce an absolute URL, e.g.
5010 Produce a relative URL. This is useful if you want to reinvoke your
5011 script with different parameters. For example:
5017 Produce the full URL, exactly as if called without any arguments.
5018 This overrides the -relative and -absolute arguments.
5020 =item B<-path> (B<-path_info>)
5022 Append the additional path information to the URL. This can be
5023 combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info>
5024 is provided as a synonym.
5026 =item B<-query> (B<-query_string>)
5028 Append the query string to the URL. This can be combined with
5029 B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
5034 Generate just the protocol and net location, as in http://www.foo.com:8000
5038 =head2 MIXING POST AND URL PARAMETERS
5040 $color = $query->url_param('color');
5042 It is possible for a script to receive CGI parameters in the URL as
5043 well as in the fill-out form by creating a form that POSTs to a URL
5044 containing a query string (a "?" mark followed by arguments). The
5045 B<param()> method will always return the contents of the POSTed
5046 fill-out form, ignoring the URL's query string. To retrieve URL
5047 parameters, call the B<url_param()> method. Use it in the same way as
5048 B<param()>. The main difference is that it allows you to read the
5049 parameters, but not set them.
5052 Under no circumstances will the contents of the URL query string
5053 interfere with similarly-named CGI parameters in POSTed forms. If you
5054 try to mix a URL query string with a form submitted with the GET
5055 method, the results will not be what you expect.
5057 =head1 CREATING STANDARD HTML ELEMENTS:
5059 CGI.pm defines general HTML shortcut methods for most, if not all of
5060 the HTML 3 and HTML 4 tags. HTML shortcuts are named after a single
5061 HTML element and return a fragment of HTML text that you can then
5062 print or manipulate as you like. Each shortcut returns a fragment of
5063 HTML code that you can append to a string, save to a file, or, most
5064 commonly, print out so that it displays in the browser window.
5066 This example shows how to use the HTML methods:
5069 print $q->blockquote(
5070 "Many years ago on the island of",
5071 $q->a({href=>"http://crete.org/"},"Crete"),
5072 "there lived a Minotaur named",
5073 $q->strong("Fred."),
5077 This results in the following HTML code (extra newlines have been
5078 added for readability):
5081 Many years ago on the island of
5082 <a href="http://crete.org/">Crete</a> there lived
5083 a minotaur named <strong>Fred.</strong>
5087 If you find the syntax for calling the HTML shortcuts awkward, you can
5088 import them into your namespace and dispense with the object syntax
5089 completely (see the next section for more details):
5091 use CGI ':standard';
5093 "Many years ago on the island of",
5094 a({href=>"http://crete.org/"},"Crete"),
5095 "there lived a minotaur named",
5100 =head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
5102 The HTML methods will accept zero, one or multiple arguments. If you
5103 provide no arguments, you get a single tag:
5107 If you provide one or more string arguments, they are concatenated
5108 together with spaces and placed between opening and closing tags:
5110 print h1("Chapter","1"); # <h1>Chapter 1</h1>"
5112 If the first argument is an associative array reference, then the keys
5113 and values of the associative array become the HTML tag's attributes:
5115 print a({-href=>'fred.html',-target=>'_new'},
5116 "Open a new frame");
5118 <a href="fred.html",target="_new">Open a new frame</a>
5120 You may dispense with the dashes in front of the attribute names if
5123 print img {src=>'fred.gif',align=>'LEFT'};
5125 <img align="LEFT" src="fred.gif">
5127 Sometimes an HTML tag attribute has no argument. For example, ordered
5128 lists can be marked as COMPACT. The syntax for this is an argument that
5129 that points to an undef string:
5131 print ol({compact=>undef},li('one'),li('two'),li('three'));
5133 Prior to CGI.pm version 2.41, providing an empty ('') string as an
5134 attribute argument was the same as providing undef. However, this has
5135 changed in order to accommodate those who want to create tags of the form
5136 <img alt="">. The difference is shown in these two pieces of code:
5139 img({alt=>undef}) <img alt>
5140 img({alt=>''}) <img alt="">
5142 =head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
5144 One of the cool features of the HTML shortcuts is that they are
5145 distributive. If you give them an argument consisting of a
5146 B<reference> to a list, the tag will be distributed across each
5147 element of the list. For example, here's one way to make an ordered
5151 li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy'])
5154 This example will result in HTML output that looks like this:
5157 <li type="disc">Sneezy</li>
5158 <li type="disc">Doc</li>
5159 <li type="disc">Sleepy</li>
5160 <li type="disc">Happy</li>
5163 This is extremely useful for creating tables. For example:
5165 print table({-border=>undef},
5166 caption('When Should You Eat Your Vegetables?'),
5167 Tr({-align=>CENTER,-valign=>TOP},
5169 th(['Vegetable', 'Breakfast','Lunch','Dinner']),
5170 td(['Tomatoes' , 'no', 'yes', 'yes']),
5171 td(['Broccoli' , 'no', 'no', 'yes']),
5172 td(['Onions' , 'yes','yes', 'yes'])
5177 =head2 HTML SHORTCUTS AND LIST INTERPOLATION
5179 Consider this bit of code:
5181 print blockquote(em('Hi'),'mom!'));
5183 It will ordinarily return the string that you probably expect, namely:
5185 <blockquote><em>Hi</em> mom!</blockquote>
5187 Note the space between the element "Hi" and the element "mom!".
5188 CGI.pm puts the extra space there using array interpolation, which is
5189 controlled by the magic $" variable. Sometimes this extra space is
5190 not what you want, for example, when you are trying to align a series
5191 of images. In this case, you can simply change the value of $" to an
5196 print blockquote(em('Hi'),'mom!'));
5199 I suggest you put the code in a block as shown here. Otherwise the
5200 change to $" will affect all subsequent code until you explicitly
5203 =head2 NON-STANDARD HTML SHORTCUTS
5205 A few HTML tags don't follow the standard pattern for various
5208 B<comment()> generates an HTML comment (<!-- comment -->). Call it
5211 print comment('here is my comment');
5213 Because of conflicts with built-in Perl functions, the following functions
5214 begin with initial caps:
5223 In addition, start_html(), end_html(), start_form(), end_form(),
5224 start_multipart_form() and all the fill-out form tags are special.
5225 See their respective sections.
5227 =head2 AUTOESCAPING HTML
5229 By default, all HTML that is emitted by the form-generating functions
5230 is passed through a function called escapeHTML():
5234 =item $escaped_string = escapeHTML("unescaped string");
5236 Escape HTML formatting characters in a string.
5240 Provided that you have specified a character set of ISO-8859-1 (the
5241 default), the standard HTML escaping rules will be used. The "<"
5242 character becomes "<", ">" becomes ">", "&" becomes "&", and
5243 the quote character becomes """. In addition, the hexadecimal
5244 0x8b and 0x9b characters, which some browsers incorrectly interpret
5245 as the left and right angle-bracket characters, are replaced by their
5246 numeric character entities ("‹" and "›"). If you manually change
5247 the charset, either by calling the charset() method explicitly or by
5248 passing a -charset argument to header(), then B<all> characters will
5249 be replaced by their numeric entities, since CGI.pm has no lookup
5250 table for all the possible encodings.
5252 The automatic escaping does not apply to other shortcuts, such as
5253 h1(). You should call escapeHTML() yourself on untrusted data in
5254 order to protect your pages against nasty tricks that people may enter
5255 into guestbooks, etc.. To change the character set, use charset().
5256 To turn autoescaping off completely, use autoEscape(0):
5260 =item $charset = charset([$charset]);
5262 Get or set the current character set.
5264 =item $flag = autoEscape([$flag]);
5266 Get or set the value of the autoescape flag.
5270 =head2 PRETTY-PRINTING HTML
5272 By default, all the HTML produced by these functions comes out as one
5273 long line without carriage returns or indentation. This is yuck, but
5274 it does reduce the size of the documents by 10-20%. To get
5275 pretty-printed output, please use L<CGI::Pretty>, a subclass
5276 contributed by Brian Paulsen.
5278 =head1 CREATING FILL-OUT FORMS:
5280 I<General note> The various form-creating methods all return strings
5281 to the caller, containing the tag or tags that will create the requested
5282 form element. You are responsible for actually printing out these strings.
5283 It's set up this way so that you can place formatting tags
5284 around the form elements.
5286 I<Another note> The default values that you specify for the forms are only
5287 used the B<first> time the script is invoked (when there is no query
5288 string). On subsequent invocations of the script (when there is a query
5289 string), the former values are used even if they are blank.
5291 If you want to change the value of a field from its previous value, you have two
5294 (1) call the param() method to set it.
5296 (2) use the -override (alias -force) parameter (a new feature in version 2.15).
5297 This forces the default value to be used, regardless of the previous value:
5299 print $query->textfield(-name=>'field_name',
5300 -default=>'starting value',
5305 I<Yet another note> By default, the text and labels of form elements are
5306 escaped according to HTML rules. This means that you can safely use
5307 "<CLICK ME>" as the label for a button. However, it also interferes with
5308 your ability to incorporate special HTML character sequences, such as Á,
5309 into your fields. If you wish to turn off automatic escaping, call the
5310 autoEscape() method with a false value immediately after creating the CGI object:
5313 $query->autoEscape(undef);
5315 =head2 CREATING AN ISINDEX TAG
5317 print $query->isindex(-action=>$action);
5321 print $query->isindex($action);
5323 Prints out an <isindex> tag. Not very exciting. The parameter
5324 -action specifies the URL of the script to process the query. The
5325 default is to process the query with the current script.
5327 =head2 STARTING AND ENDING A FORM
5329 print $query->start_form(-method=>$method,
5331 -enctype=>$encoding);
5332 <... various form stuff ...>
5333 print $query->endform;
5337 print $query->start_form($method,$action,$encoding);
5338 <... various form stuff ...>
5339 print $query->endform;
5341 start_form() will return a <form> tag with the optional method,
5342 action and form encoding that you specify. The defaults are:
5346 enctype: application/x-www-form-urlencoded
5348 endform() returns the closing </form> tag.
5350 Start_form()'s enctype argument tells the browser how to package the various
5351 fields of the form before sending the form to the server. Two
5352 values are possible:
5354 B<Note:> This method was previously named startform(), and startform()
5355 is still recognized as an alias.
5359 =item B<application/x-www-form-urlencoded>
5361 This is the older type of encoding used by all browsers prior to
5362 Netscape 2.0. It is compatible with many CGI scripts and is
5363 suitable for short fields containing text data. For your
5364 convenience, CGI.pm stores the name of this encoding
5365 type in B<&CGI::URL_ENCODED>.
5367 =item B<multipart/form-data>
5369 This is the newer type of encoding introduced by Netscape 2.0.
5370 It is suitable for forms that contain very large fields or that
5371 are intended for transferring binary data. Most importantly,
5372 it enables the "file upload" feature of Netscape 2.0 forms. For
5373 your convenience, CGI.pm stores the name of this encoding type
5374 in B<&CGI::MULTIPART>
5376 Forms that use this type of encoding are not easily interpreted
5377 by CGI scripts unless they use CGI.pm or another library designed
5382 For compatibility, the start_form() method uses the older form of
5383 encoding by default. If you want to use the newer form of encoding
5384 by default, you can call B<start_multipart_form()> instead of
5387 JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
5388 for use with JavaScript. The -name parameter gives the
5389 form a name so that it can be identified and manipulated by
5390 JavaScript functions. -onSubmit should point to a JavaScript
5391 function that will be executed just before the form is submitted to your
5392 server. You can use this opportunity to check the contents of the form
5393 for consistency and completeness. If you find something wrong, you
5394 can put up an alert box or maybe fix things up yourself. You can
5395 abort the submission by returning false from this function.
5397 Usually the bulk of JavaScript functions are defined in a <script>
5398 block in the HTML header and -onSubmit points to one of these function
5399 call. See start_html() for details.
5401 =head2 CREATING A TEXT FIELD
5403 print $query->textfield(-name=>'field_name',
5404 -default=>'starting value',
5409 print $query->textfield('field_name','starting value',50,80);
5411 textfield() will return a text input field.
5419 The first parameter is the required name for the field (-name).
5423 The optional second parameter is the default starting value for the field
5424 contents (-default).
5428 The optional third parameter is the size of the field in
5433 The optional fourth parameter is the maximum number of characters the
5434 field will accept (-maxlength).
5438 As with all these methods, the field will be initialized with its
5439 previous contents from earlier invocations of the script.
5440 When the form is processed, the value of the text field can be
5443 $value = $query->param('foo');
5445 If you want to reset it from its initial value after the script has been
5446 called once, you can do so like this:
5448 $query->param('foo',"I'm taking over this value!");
5450 NEW AS OF VERSION 2.15: If you don't want the field to take on its previous
5451 value, you can force its current value by using the -override (alias -force)
5454 print $query->textfield(-name=>'field_name',
5455 -default=>'starting value',
5460 JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>,
5461 B<-onBlur>, B<-onMouseOver>, B<-onMouseOut> and B<-onSelect>
5462 parameters to register JavaScript event handlers. The onChange
5463 handler will be called whenever the user changes the contents of the
5464 text field. You can do text validation if you like. onFocus and
5465 onBlur are called respectively when the insertion point moves into and
5466 out of the text field. onSelect is called when the user changes the
5467 portion of the text that is selected.
5469 =head2 CREATING A BIG TEXT FIELD
5471 print $query->textarea(-name=>'foo',
5472 -default=>'starting value',
5478 print $query->textarea('foo','starting value',10,50);
5480 textarea() is just like textfield, but it allows you to specify
5481 rows and columns for a multiline text entry box. You can provide
5482 a starting value for the field, which can be long and contain
5485 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> ,
5486 B<-onMouseOver>, B<-onMouseOut>, and B<-onSelect> parameters are
5487 recognized. See textfield().
5489 =head2 CREATING A PASSWORD FIELD
5491 print $query->password_field(-name=>'secret',
5492 -value=>'starting value',
5497 print $query->password_field('secret','starting value',50,80);
5499 password_field() is identical to textfield(), except that its contents
5500 will be starred out on the web page.
5502 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
5503 B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
5504 recognized. See textfield().
5506 =head2 CREATING A FILE UPLOAD FIELD
5508 print $query->filefield(-name=>'uploaded_file',
5509 -default=>'starting value',
5514 print $query->filefield('uploaded_file','starting value',50,80);
5516 filefield() will return a file upload field for Netscape 2.0 browsers.
5517 In order to take full advantage of this I<you must use the new
5518 multipart encoding scheme> for the form. You can do this either
5519 by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>,
5520 or by calling the new method B<start_multipart_form()> instead of
5521 vanilla B<start_form()>.
5529 The first parameter is the required name for the field (-name).
5533 The optional second parameter is the starting value for the field contents
5534 to be used as the default file name (-default).
5536 For security reasons, browsers don't pay any attention to this field,
5537 and so the starting value will always be blank. Worse, the field
5538 loses its "sticky" behavior and forgets its previous contents. The
5539 starting value field is called for in the HTML specification, however,
5540 and possibly some browser will eventually provide support for it.
5544 The optional third parameter is the size of the field in
5549 The optional fourth parameter is the maximum number of characters the
5550 field will accept (-maxlength).
5554 When the form is processed, you can retrieve the entered filename
5557 $filename = $query->param('uploaded_file');
5559 Different browsers will return slightly different things for the
5560 name. Some browsers return the filename only. Others return the full
5561 path to the file, using the path conventions of the user's machine.
5562 Regardless, the name returned is always the name of the file on the
5563 I<user's> machine, and is unrelated to the name of the temporary file
5564 that CGI.pm creates during upload spooling (see below).
5566 The filename returned is also a file handle. You can read the contents
5567 of the file using standard Perl file reading calls:
5569 # Read a text file and print it out
5570 while (<$filename>) {
5574 # Copy a binary file to somewhere safe
5575 open (OUTFILE,">>/usr/local/web/users/feedback");
5576 while ($bytesread=read($filename,$buffer,1024)) {
5577 print OUTFILE $buffer;
5580 However, there are problems with the dual nature of the upload fields.
5581 If you C<use strict>, then Perl will complain when you try to use a
5582 string as a filehandle. You can get around this by placing the file
5583 reading code in a block containing the C<no strict> pragma. More
5584 seriously, it is possible for the remote user to type garbage into the
5585 upload field, in which case what you get from param() is not a
5586 filehandle at all, but a string.
5588 To be safe, use the I<upload()> function (new in version 2.47). When
5589 called with the name of an upload field, I<upload()> returns a
5590 filehandle, or undef if the parameter is not a valid filehandle.
5592 $fh = $query->upload('uploaded_file');
5597 In an array context, upload() will return an array of filehandles.
5598 This makes it possible to create forms that use the same name for
5599 multiple upload fields.
5601 This is the recommended idiom.
5603 When a file is uploaded the browser usually sends along some
5604 information along with it in the format of headers. The information
5605 usually includes the MIME content type. Future browsers may send
5606 other information as well (such as modification date and size). To
5607 retrieve this information, call uploadInfo(). It returns a reference to
5608 an associative array containing all the document headers.
5610 $filename = $query->param('uploaded_file');
5611 $type = $query->uploadInfo($filename)->{'Content-Type'};
5612 unless ($type eq 'text/html') {
5613 die "HTML FILES ONLY!";
5616 If you are using a machine that recognizes "text" and "binary" data
5617 modes, be sure to understand when and how to use them (see the Camel book).
5618 Otherwise you may find that binary files are corrupted during file
5621 There are occasionally problems involving parsing the uploaded file.
5622 This usually happens when the user presses "Stop" before the upload is
5623 finished. In this case, CGI.pm will return undef for the name of the
5624 uploaded file and set I<cgi_error()> to the string "400 Bad request
5625 (malformed multipart POST)". This error message is designed so that
5626 you can incorporate it into a status code to be sent to the browser.
5629 $file = $query->upload('uploaded_file');
5630 if (!$file && $query->cgi_error) {
5631 print $query->header(-status=>$query->cgi_error);
5635 You are free to create a custom HTML page to complain about the error,
5638 You can set up a callback that will be called whenever a file upload
5639 is being read during the form processing. This is much like the
5640 UPLOAD_HOOK facility available in Apache::Request, with the exception
5641 that the first argument to the callback is an Apache::Upload object,
5642 here it's the remote filename.
5645 $q->upload_hook(\&hook,$data);
5649 my ($filename, $buffer, $bytes_read, $data) = @_;
5650 print "Read $bytes_read bytes of $filename\n";
5653 If using the function-oriented interface, call the CGI::upload_hook()
5654 method before calling param() or any other CGI functions:
5656 CGI::upload_hook(\&hook,$data);
5658 This method is not exported by default. You will have to import it
5659 explicitly if you wish to use it without the CGI:: prefix.
5661 If you are using CGI.pm on a Windows platform and find that binary
5662 files get slightly larger when uploaded but that text files remain the
5663 same, then you have forgotten to activate binary mode on the output
5664 filehandle. Be sure to call binmode() on any handle that you create
5665 to write the uploaded file to disk.
5667 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
5668 B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
5669 recognized. See textfield() for details.
5671 =head2 CREATING A POPUP MENU
5673 print $query->popup_menu('menu_name',
5674 ['eenie','meenie','minie'],
5679 %labels = ('eenie'=>'your first choice',
5680 'meenie'=>'your second choice',
5681 'minie'=>'your third choice');
5682 %attributes = ('eenie'=>{'class'=>'class of first choice'});
5683 print $query->popup_menu('menu_name',
5684 ['eenie','meenie','minie'],
5685 'meenie',\%labels,\%attributes);
5687 -or (named parameter style)-
5689 print $query->popup_menu(-name=>'menu_name',
5690 -values=>['eenie','meenie','minie'],
5693 -attributes=>\%attributes);
5695 popup_menu() creates a menu.
5701 The required first argument is the menu's name (-name).
5705 The required second argument (-values) is an array B<reference>
5706 containing the list of menu items in the menu. You can pass the
5707 method an anonymous array, as shown in the example, or a reference to
5708 a named array, such as "\@foo".
5712 The optional third parameter (-default) is the name of the default
5713 menu choice. If not specified, the first item will be the default.
5714 The values of the previous choice will be maintained across queries.
5718 The optional fourth parameter (-labels) is provided for people who
5719 want to use different values for the user-visible label inside the
5720 popup menu and the value returned to your script. It's a pointer to an
5721 associative array relating menu values to user-visible labels. If you
5722 leave this parameter blank, the menu values will be displayed by
5723 default. (You can also leave a label undefined if you want to).
5727 The optional fifth parameter (-attributes) is provided to assign
5728 any of the common HTML attributes to an individual menu item. It's
5729 a pointer to an associative array relating menu values to another
5730 associative array with the attribute's name as the key and the
5731 attribute's value as the value.
5735 When the form is processed, the selected value of the popup menu can
5738 $popup_menu_value = $query->param('menu_name');
5740 JAVASCRIPTING: popup_menu() recognizes the following event handlers:
5741 B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>, and
5742 B<-onBlur>. See the textfield() section for details on when these
5743 handlers are called.
5745 =head2 CREATING AN OPTION GROUP
5747 Named parameter style
5749 print $query->popup_menu(-name=>'menu_name',
5750 -values=>[qw/eenie meenie minie/,
5751 $q->optgroup(-name=>'optgroup_name',
5752 -values ['moe','catch'],
5753 -attributes=>{'catch'=>{'class'=>'red'}}),
5754 -labels=>{'eenie'=>'one',
5757 -default=>'meenie');
5760 print $query->popup_menu('menu_name',
5761 ['eenie','meenie','minie',
5762 $q->optgroup('optgroup_name', ['moe', 'catch'],
5763 {'catch'=>{'class'=>'red'}})],'meenie',
5764 {'eenie'=>'one','meenie'=>'two','minie'=>'three'});
5766 optgroup creates an option group within a popup menu.
5772 The required first argument (B<-name>) is the label attribute of the
5773 optgroup and is B<not> inserted in the parameter list of the query.
5777 The required second argument (B<-values>) is an array reference
5778 containing the list of menu items in the menu. You can pass the
5779 method an anonymous array, as shown in the example, or a reference
5780 to a named array, such as \@foo. If you pass a HASH reference,
5781 the keys will be used for the menu values, and the values will be
5782 used for the menu labels (see -labels below).
5786 The optional third parameter (B<-labels>) allows you to pass a reference
5787 to an associative array containing user-visible labels for one or more
5788 of the menu items. You can use this when you want the user to see one
5789 menu string, but have the browser return your program a different one.
5790 If you don't specify this, the value string will be used instead
5791 ("eenie", "meenie" and "minie" in this example). This is equivalent
5792 to using a hash reference for the -values parameter.
5796 An optional fourth parameter (B<-labeled>) can be set to a true value
5797 and indicates that the values should be used as the label attribute
5798 for each option element within the optgroup.
5802 An optional fifth parameter (-novals) can be set to a true value and
5803 indicates to suppress the val attribut in each option element within
5806 See the discussion on optgroup at W3C
5807 (http://www.w3.org/TR/REC-html40/interact/forms.html#edef-OPTGROUP)
5812 An optional sixth parameter (-attributes) is provided to assign
5813 any of the common HTML attributes to an individual menu item. It's
5814 a pointer to an associative array relating menu values to another
5815 associative array with the attribute's name as the key and the
5816 attribute's value as the value.
5820 =head2 CREATING A SCROLLING LIST
5822 print $query->scrolling_list('list_name',
5823 ['eenie','meenie','minie','moe'],
5824 ['eenie','moe'],5,'true',{'moe'=>{'class'=>'red'}});
5827 print $query->scrolling_list('list_name',
5828 ['eenie','meenie','minie','moe'],
5829 ['eenie','moe'],5,'true',
5830 \%labels,%attributes);
5834 print $query->scrolling_list(-name=>'list_name',
5835 -values=>['eenie','meenie','minie','moe'],
5836 -default=>['eenie','moe'],
5840 -attributes=>\%attributes);
5842 scrolling_list() creates a scrolling list.
5846 =item B<Parameters:>
5850 The first and second arguments are the list name (-name) and values
5851 (-values). As in the popup menu, the second argument should be an
5856 The optional third argument (-default) can be either a reference to a
5857 list containing the values to be selected by default, or can be a
5858 single value to select. If this argument is missing or undefined,
5859 then nothing is selected when the list first appears. In the named
5860 parameter version, you can use the synonym "-defaults" for this
5865 The optional fourth argument is the size of the list (-size).
5869 The optional fifth argument can be set to true to allow multiple
5870 simultaneous selections (-multiple). Otherwise only one selection
5871 will be allowed at a time.
5875 The optional sixth argument is a pointer to an associative array
5876 containing long user-visible labels for the list items (-labels).
5877 If not provided, the values will be displayed.
5881 The optional sixth parameter (-attributes) is provided to assign
5882 any of the common HTML attributes to an individual menu item. It's
5883 a pointer to an associative array relating menu values to another
5884 associative array with the attribute's name as the key and the
5885 attribute's value as the value.
5887 When this form is processed, all selected list items will be returned as
5888 a list under the parameter name 'list_name'. The values of the
5889 selected items can be retrieved with:
5891 @selected = $query->param('list_name');
5895 JAVASCRIPTING: scrolling_list() recognizes the following event
5896 handlers: B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>
5897 and B<-onBlur>. See textfield() for the description of when these
5898 handlers are called.
5900 =head2 CREATING A GROUP OF RELATED CHECKBOXES
5902 print $query->checkbox_group(-name=>'group_name',
5903 -values=>['eenie','meenie','minie','moe'],
5904 -default=>['eenie','moe'],
5907 -attributes=>\%attributes);
5909 print $query->checkbox_group('group_name',
5910 ['eenie','meenie','minie','moe'],
5911 ['eenie','moe'],'true',\%labels,
5912 {'moe'=>{'class'=>'red'}});
5914 HTML3-COMPATIBLE BROWSERS ONLY:
5916 print $query->checkbox_group(-name=>'group_name',
5917 -values=>['eenie','meenie','minie','moe'],
5918 -rows=2,-columns=>2);
5921 checkbox_group() creates a list of checkboxes that are related
5926 =item B<Parameters:>
5930 The first and second arguments are the checkbox name and values,
5931 respectively (-name and -values). As in the popup menu, the second
5932 argument should be an array reference. These values are used for the
5933 user-readable labels printed next to the checkboxes as well as for the
5934 values passed to your script in the query string.
5938 The optional third argument (-default) can be either a reference to a
5939 list containing the values to be checked by default, or can be a
5940 single value to checked. If this argument is missing or undefined,
5941 then nothing is selected when the list first appears.
5945 The optional fourth argument (-linebreak) can be set to true to place
5946 line breaks between the checkboxes so that they appear as a vertical
5947 list. Otherwise, they will be strung together on a horizontal line.
5951 The optional fifth argument is a pointer to an associative array
5952 relating the checkbox values to the user-visible labels that will
5953 be printed next to them (-labels). If not provided, the values will
5954 be used as the default.
5958 B<HTML3-compatible browsers> (such as Netscape) can take advantage of
5959 the optional parameters B<-rows>, and B<-columns>. These parameters
5960 cause checkbox_group() to return an HTML3 compatible table containing
5961 the checkbox group formatted with the specified number of rows and
5962 columns. You can provide just the -columns parameter if you wish;
5963 checkbox_group will calculate the correct number of rows for you.
5967 The optional sixth parameter (-attributes) is provided to assign
5968 any of the common HTML attributes to an individual menu item. It's
5969 a pointer to an associative array relating menu values to another
5970 associative array with the attribute's name as the key and the
5971 attribute's value as the value.
5973 To include row and column headings in the returned table, you
5974 can use the B<-rowheaders> and B<-colheaders> parameters. Both
5975 of these accept a pointer to an array of headings to use.
5976 The headings are just decorative. They don't reorganize the
5977 interpretation of the checkboxes -- they're still a single named
5982 When the form is processed, all checked boxes will be returned as
5983 a list under the parameter name 'group_name'. The values of the
5984 "on" checkboxes can be retrieved with:
5986 @turned_on = $query->param('group_name');
5988 The value returned by checkbox_group() is actually an array of button
5989 elements. You can capture them and use them within tables, lists,
5990 or in other creative ways:
5992 @h = $query->checkbox_group(-name=>'group_name',-values=>\@values);
5993 &use_in_creative_way(@h);
5995 JAVASCRIPTING: checkbox_group() recognizes the B<-onClick>
5996 parameter. This specifies a JavaScript code fragment or
5997 function call to be executed every time the user clicks on
5998 any of the buttons in the group. You can retrieve the identity
5999 of the particular button clicked on using the "this" variable.
6001 =head2 CREATING A STANDALONE CHECKBOX
6003 print $query->checkbox(-name=>'checkbox_name',
6006 -label=>'CLICK ME');
6010 print $query->checkbox('checkbox_name','checked','ON','CLICK ME');
6012 checkbox() is used to create an isolated checkbox that isn't logically
6013 related to any others.
6017 =item B<Parameters:>
6021 The first parameter is the required name for the checkbox (-name). It
6022 will also be used for the user-readable label printed next to the
6027 The optional second parameter (-checked) specifies that the checkbox
6028 is turned on by default. Synonyms are -selected and -on.
6032 The optional third parameter (-value) specifies the value of the
6033 checkbox when it is checked. If not provided, the word "on" is
6038 The optional fourth parameter (-label) is the user-readable label to
6039 be attached to the checkbox. If not provided, the checkbox name is
6044 The value of the checkbox can be retrieved using:
6046 $turned_on = $query->param('checkbox_name');
6048 JAVASCRIPTING: checkbox() recognizes the B<-onClick>
6049 parameter. See checkbox_group() for further details.
6051 =head2 CREATING A RADIO BUTTON GROUP
6053 print $query->radio_group(-name=>'group_name',
6054 -values=>['eenie','meenie','minie'],
6058 -attributes=>\%attributes);
6062 print $query->radio_group('group_name',['eenie','meenie','minie'],
6063 'meenie','true',\%labels,\%attributes);
6066 HTML3-COMPATIBLE BROWSERS ONLY:
6068 print $query->radio_group(-name=>'group_name',
6069 -values=>['eenie','meenie','minie','moe'],
6070 -rows=2,-columns=>2);
6072 radio_group() creates a set of logically-related radio buttons
6073 (turning one member of the group on turns the others off)
6077 =item B<Parameters:>
6081 The first argument is the name of the group and is required (-name).
6085 The second argument (-values) is the list of values for the radio
6086 buttons. The values and the labels that appear on the page are
6087 identical. Pass an array I<reference> in the second argument, either
6088 using an anonymous array, as shown, or by referencing a named array as
6093 The optional third parameter (-default) is the name of the default
6094 button to turn on. If not specified, the first item will be the
6095 default. You can provide a nonexistent button name, such as "-" to
6096 start up with no buttons selected.
6100 The optional fourth parameter (-linebreak) can be set to 'true' to put
6101 line breaks between the buttons, creating a vertical list.
6105 The optional fifth parameter (-labels) is a pointer to an associative
6106 array relating the radio button values to user-visible labels to be
6107 used in the display. If not provided, the values themselves are
6112 B<HTML3-compatible browsers> (such as Netscape) can take advantage
6114 parameters B<-rows>, and B<-columns>. These parameters cause
6115 radio_group() to return an HTML3 compatible table containing
6116 the radio group formatted with the specified number of rows
6117 and columns. You can provide just the -columns parameter if you
6118 wish; radio_group will calculate the correct number of rows
6123 The optional sixth parameter (-attributes) is provided to assign
6124 any of the common HTML attributes to an individual menu item. It's
6125 a pointer to an associative array relating menu values to another
6126 associative array with the attribute's name as the key and the
6127 attribute's value as the value.
6129 To include row and column headings in the returned table, you
6130 can use the B<-rowheader> and B<-colheader> parameters. Both
6131 of these accept a pointer to an array of headings to use.
6132 The headings are just decorative. They don't reorganize the
6133 interpretation of the radio buttons -- they're still a single named
6138 When the form is processed, the selected radio button can
6141 $which_radio_button = $query->param('group_name');
6143 The value returned by radio_group() is actually an array of button
6144 elements. You can capture them and use them within tables, lists,
6145 or in other creative ways:
6147 @h = $query->radio_group(-name=>'group_name',-values=>\@values);
6148 &use_in_creative_way(@h);
6150 =head2 CREATING A SUBMIT BUTTON
6152 print $query->submit(-name=>'button_name',
6157 print $query->submit('button_name','value');
6159 submit() will create the query submission button. Every form
6160 should have one of these.
6164 =item B<Parameters:>
6168 The first argument (-name) is optional. You can give the button a
6169 name if you have several submission buttons in your form and you want
6170 to distinguish between them. The name will also be used as the
6171 user-visible label. Be aware that a few older browsers don't deal with this correctly and
6172 B<never> send back a value from a button.
6176 The second argument (-value) is also optional. This gives the button
6177 a value that will be passed to your script in the query string.
6181 You can figure out which button was pressed by using different
6182 values for each one:
6184 $which_one = $query->param('button_name');
6186 JAVASCRIPTING: radio_group() recognizes the B<-onClick>
6187 parameter. See checkbox_group() for further details.
6189 =head2 CREATING A RESET BUTTON
6193 reset() creates the "reset" button. Note that it restores the
6194 form to its value from the last time the script was called,
6195 NOT necessarily to the defaults.
6197 Note that this conflicts with the Perl reset() built-in. Use
6198 CORE::reset() to get the original reset function.
6200 =head2 CREATING A DEFAULT BUTTON
6202 print $query->defaults('button_label')
6204 defaults() creates a button that, when invoked, will cause the
6205 form to be completely reset to its defaults, wiping out all the
6206 changes the user ever made.
6208 =head2 CREATING A HIDDEN FIELD
6210 print $query->hidden(-name=>'hidden_name',
6211 -default=>['value1','value2'...]);
6215 print $query->hidden('hidden_name','value1','value2'...);
6217 hidden() produces a text field that can't be seen by the user. It
6218 is useful for passing state variable information from one invocation
6219 of the script to the next.
6223 =item B<Parameters:>
6227 The first argument is required and specifies the name of this
6232 The second argument is also required and specifies its value
6233 (-default). In the named parameter style of calling, you can provide
6234 a single value here or a reference to a whole list
6238 Fetch the value of a hidden field this way:
6240 $hidden_value = $query->param('hidden_name');
6242 Note, that just like all the other form elements, the value of a
6243 hidden field is "sticky". If you want to replace a hidden field with
6244 some other values after the script has been called once you'll have to
6247 $query->param('hidden_name','new','values','here');
6249 =head2 CREATING A CLICKABLE IMAGE BUTTON
6251 print $query->image_button(-name=>'button_name',
6252 -src=>'/source/URL',
6257 print $query->image_button('button_name','/source/URL','MIDDLE');
6259 image_button() produces a clickable image. When it's clicked on the
6260 position of the click is returned to your script as "button_name.x"
6261 and "button_name.y", where "button_name" is the name you've assigned
6264 JAVASCRIPTING: image_button() recognizes the B<-onClick>
6265 parameter. See checkbox_group() for further details.
6269 =item B<Parameters:>
6273 The first argument (-name) is required and specifies the name of this
6278 The second argument (-src) is also required and specifies the URL
6281 The third option (-align, optional) is an alignment type, and may be
6282 TOP, BOTTOM or MIDDLE
6286 Fetch the value of the button this way:
6287 $x = $query->param('button_name.x');
6288 $y = $query->param('button_name.y');
6290 =head2 CREATING A JAVASCRIPT ACTION BUTTON
6292 print $query->button(-name=>'button_name',
6293 -value=>'user visible label',
6294 -onClick=>"do_something()");
6298 print $query->button('button_name',"do_something()");
6300 button() produces a button that is compatible with Netscape 2.0's
6301 JavaScript. When it's pressed the fragment of JavaScript code
6302 pointed to by the B<-onClick> parameter will be executed. On
6303 non-Netscape browsers this form element will probably not even
6308 Netscape browsers versions 1.1 and higher, and all versions of
6309 Internet Explorer, support a so-called "cookie" designed to help
6310 maintain state within a browser session. CGI.pm has several methods
6311 that support cookies.
6313 A cookie is a name=value pair much like the named parameters in a CGI
6314 query string. CGI scripts create one or more cookies and send
6315 them to the browser in the HTTP header. The browser maintains a list
6316 of cookies that belong to a particular Web server, and returns them
6317 to the CGI script during subsequent interactions.
6319 In addition to the required name=value pair, each cookie has several
6320 optional attributes:
6324 =item 1. an expiration time
6326 This is a time/date string (in a special GMT format) that indicates
6327 when a cookie expires. The cookie will be saved and returned to your
6328 script until this expiration date is reached if the user exits
6329 the browser and restarts it. If an expiration date isn't specified, the cookie
6330 will remain active until the user quits the browser.
6334 This is a partial or complete domain name for which the cookie is
6335 valid. The browser will return the cookie to any host that matches
6336 the partial domain name. For example, if you specify a domain name
6337 of ".capricorn.com", then the browser will return the cookie to
6338 Web servers running on any of the machines "www.capricorn.com",
6339 "www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
6340 must contain at least two periods to prevent attempts to match
6341 on top level domains like ".edu". If no domain is specified, then
6342 the browser will only return the cookie to servers on the host the
6343 cookie originated from.
6347 If you provide a cookie path attribute, the browser will check it
6348 against your script's URL before returning the cookie. For example,
6349 if you specify the path "/cgi-bin", then the cookie will be returned
6350 to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
6351 and "/cgi-bin/customer_service/complain.pl", but not to the script
6352 "/cgi-private/site_admin.pl". By default, path is set to "/", which
6353 causes the cookie to be sent to any CGI script on your site.
6355 =item 4. a "secure" flag
6357 If the "secure" attribute is set, the cookie will only be sent to your
6358 script if the CGI request is occurring on a secure channel, such as SSL.
6362 The interface to HTTP cookies is the B<cookie()> method:
6364 $cookie = $query->cookie(-name=>'sessionID',
6367 -path=>'/cgi-bin/database',
6368 -domain=>'.capricorn.org',
6370 print $query->header(-cookie=>$cookie);
6372 B<cookie()> creates a new cookie. Its parameters include:
6378 The name of the cookie (required). This can be any string at all.
6379 Although browsers limit their cookie names to non-whitespace
6380 alphanumeric characters, CGI.pm removes this restriction by escaping
6381 and unescaping cookies behind the scenes.
6385 The value of the cookie. This can be any scalar value,
6386 array reference, or even associative array reference. For example,
6387 you can store an entire associative array into a cookie this way:
6389 $cookie=$query->cookie(-name=>'family information',
6390 -value=>\%childrens_ages);
6394 The optional partial path for which this cookie will be valid, as described
6399 The optional partial domain for which this cookie will be valid, as described
6404 The optional expiration date for this cookie. The format is as described
6405 in the section on the B<header()> method:
6407 "+1h" one hour from now
6411 If set to true, this cookie will only be used within a secure
6416 The cookie created by cookie() must be incorporated into the HTTP
6417 header within the string returned by the header() method:
6419 print $query->header(-cookie=>$my_cookie);
6421 To create multiple cookies, give header() an array reference:
6423 $cookie1 = $query->cookie(-name=>'riddle_name',
6424 -value=>"The Sphynx's Question");
6425 $cookie2 = $query->cookie(-name=>'answers',
6427 print $query->header(-cookie=>[$cookie1,$cookie2]);
6429 To retrieve a cookie, request it by name by calling cookie() method
6430 without the B<-value> parameter:
6434 $riddle = $query->cookie('riddle_name');
6435 %answers = $query->cookie('answers');
6437 Cookies created with a single scalar value, such as the "riddle_name"
6438 cookie, will be returned in that form. Cookies with array and hash
6439 values can also be retrieved.
6441 The cookie and CGI namespaces are separate. If you have a parameter
6442 named 'answers' and a cookie named 'answers', the values retrieved by
6443 param() and cookie() are independent of each other. However, it's
6444 simple to turn a CGI parameter into a cookie, and vice-versa:
6446 # turn a CGI parameter into a cookie
6447 $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]);
6449 $q->param(-name=>'answers',-value=>[$q->cookie('answers')]);
6451 See the B<cookie.cgi> example script for some ideas on how to use
6452 cookies effectively.
6454 =head1 WORKING WITH FRAMES
6456 It's possible for CGI.pm scripts to write into several browser panels
6457 and windows using the HTML 4 frame mechanism. There are three
6458 techniques for defining new frames programmatically:
6462 =item 1. Create a <Frameset> document
6464 After writing out the HTTP header, instead of creating a standard
6465 HTML document using the start_html() call, create a <frameset>
6466 document that defines the frames on the page. Specify your script(s)
6467 (with appropriate parameters) as the SRC for each of the frames.
6469 There is no specific support for creating <frameset> sections
6470 in CGI.pm, but the HTML is very simple to write. See the frame
6471 documentation in Netscape's home pages for details
6473 http://home.netscape.com/assist/net_sites/frames.html
6475 =item 2. Specify the destination for the document in the HTTP header
6477 You may provide a B<-target> parameter to the header() method:
6479 print $q->header(-target=>'ResultsWindow');
6481 This will tell the browser to load the output of your script into the
6482 frame named "ResultsWindow". If a frame of that name doesn't already
6483 exist, the browser will pop up a new window and load your script's
6484 document into that. There are a number of magic names that you can
6485 use for targets. See the frame documents on Netscape's home pages for
6488 =item 3. Specify the destination for the document in the <form> tag
6490 You can specify the frame to load in the FORM tag itself. With
6491 CGI.pm it looks like this:
6493 print $q->start_form(-target=>'ResultsWindow');
6495 When your script is reinvoked by the form, its output will be loaded
6496 into the frame named "ResultsWindow". If one doesn't already exist
6497 a new window will be created.
6501 The script "frameset.cgi" in the examples directory shows one way to
6502 create pages in which the fill-out form and the response live in
6503 side-by-side frames.
6505 =head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
6507 CGI.pm has limited support for HTML3's cascading style sheets (css).
6508 To incorporate a stylesheet into your document, pass the
6509 start_html() method a B<-style> parameter. The value of this
6510 parameter may be a scalar, in which case it is treated as the source
6511 URL for the stylesheet, or it may be a hash reference. In the latter
6512 case you should provide the hash with one or more of B<-src> or
6513 B<-code>. B<-src> points to a URL where an externally-defined
6514 stylesheet can be found. B<-code> points to a scalar value to be
6515 incorporated into a <style> section. Style definitions in B<-code>
6516 override similarly-named ones in B<-src>, hence the name "cascading."
6518 You may also specify the type of the stylesheet by adding the optional
6519 B<-type> parameter to the hash pointed to by B<-style>. If not
6520 specified, the style defaults to 'text/css'.
6522 To refer to a style within the body of your document, add the
6523 B<-class> parameter to any HTML element:
6525 print h1({-class=>'Fancy'},'Welcome to the Party');
6527 Or define styles on the fly with the B<-style> parameter:
6529 print h1({-style=>'Color: red;'},'Welcome to Hell');
6531 You may also use the new B<span()> element to apply a style to a
6534 print span({-style=>'Color: red;'},
6535 h1('Welcome to Hell'),
6536 "Where did that handbasket get to?"
6539 Note that you must import the ":html3" definitions to have the
6540 B<span()> method available. Here's a quick and dirty example of using
6541 CSS's. See the CSS specification at
6542 http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
6544 use CGI qw/:standard :html3/;
6546 #here's a stylesheet incorporated directly into the page
6556 font-family: sans-serif;
6562 print start_html( -title=>'CGI with Style',
6563 -style=>{-src=>'http://www.capricorn.com/style/st1.css',
6566 print h1('CGI with Style'),
6568 "Better read the cascading style sheet spec before playing with this!"),
6569 span({-style=>'color: magenta'},
6570 "Look Mom, no hands!",
6576 Pass an array reference to B<-style> in order to incorporate multiple
6577 stylesheets into your document.
6579 Should you wish to incorporate a verbatim stylesheet that includes
6580 arbitrary formatting in the header, you may pass a -verbatim tag to
6581 the -style hash, as follows:
6583 print $q->start_html (-STYLE => {-verbatim => '@import
6584 url("/server-common/css/'.$cssFile.'");',
6585 -src => '/server-common/css/core.css'});
6589 This will generate an HTML header that contains this:
6591 <link rel="stylesheet" type="text/css" href="/server-common/css/core.css">
6592 <style type="text/css">
6593 @import url("/server-common/css/main.css");
6596 Any additional arguments passed in the -style value will be
6597 incorporated into the <link> tag. For example:
6599 start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'],
6604 <link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/>
6605 <link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/>
6609 To make more complicated <link> tags, use the Link() function
6610 and pass it to start_html() in the -head argument, as in:
6612 @h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}),
6613 Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'}));
6614 print start_html({-head=>\@h})
6618 If you are running the script from the command line or in the perl
6619 debugger, you can pass the script a list of keywords or
6620 parameter=value pairs on the command line or from standard input (you
6621 don't have to worry about tricking your script into reading from
6622 environment variables). You can pass keywords like this:
6624 your_script.pl keyword1 keyword2 keyword3
6628 your_script.pl keyword1+keyword2+keyword3
6632 your_script.pl name1=value1 name2=value2
6636 your_script.pl name1=value1&name2=value2
6638 To turn off this feature, use the -no_debug pragma.
6640 To test the POST method, you may enable full debugging with the -debug
6641 pragma. This will allow you to feed newline-delimited name=value
6642 pairs to the script on standard input.
6644 When debugging, you can use quotes and backslashes to escape
6645 characters in the familiar shell manner, letting you place
6646 spaces and other funny characters in your parameter=value
6649 your_script.pl "name1='I am a long value'" "name2=two\ words"
6651 Finally, you can set the path info for the script by prefixing the first
6652 name/value parameter with the path followed by a question mark (?):
6654 your_script.pl /your/path/here?name1=value1&name2=value2
6656 =head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
6658 The Dump() method produces a string consisting of all the query's
6659 name/value pairs formatted nicely as a nested list. This is useful
6660 for debugging purposes:
6665 Produces something that looks like:
6679 As a shortcut, you can interpolate the entire CGI object into a string
6680 and it will be replaced with the a nice HTML dump shown above:
6683 print "<h2>Current Values</h2> $query\n";
6685 =head1 FETCHING ENVIRONMENT VARIABLES
6687 Some of the more useful environment variables can be fetched
6688 through this interface. The methods are as follows:
6694 Return a list of MIME types that the remote browser accepts. If you
6695 give this method a single argument corresponding to a MIME type, as in
6696 $query->Accept('text/html'), it will return a floating point value
6697 corresponding to the browser's preference for this type from 0.0
6698 (don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept
6699 list are handled correctly.
6701 Note that the capitalization changed between version 2.43 and 2.44 in
6702 order to avoid conflict with Perl's accept() function.
6704 =item B<raw_cookie()>
6706 Returns the HTTP_COOKIE variable, an HTTP extension implemented by
6707 Netscape browsers version 1.1 and higher, and all versions of Internet
6708 Explorer. Cookies have a special format, and this method call just
6709 returns the raw form (?cookie dough). See cookie() for ways of
6710 setting and retrieving cooked cookies.
6712 Called with no parameters, raw_cookie() returns the packed cookie
6713 structure. You can separate it into individual cookies by splitting
6714 on the character sequence "; ". Called with the name of a cookie,
6715 retrieves the B<unescaped> form of the cookie. You can use the
6716 regular cookie() method to get the names, or use the raw_fetch()
6717 method from the CGI::Cookie module.
6719 =item B<user_agent()>
6721 Returns the HTTP_USER_AGENT variable. If you give
6722 this method a single argument, it will attempt to
6723 pattern match on it, allowing you to do something
6724 like $query->user_agent(netscape);
6726 =item B<path_info()>
6728 Returns additional path information from the script URL.
6729 E.G. fetching /cgi-bin/your_script/additional/stuff will result in
6730 $query->path_info() returning "/additional/stuff".
6732 NOTE: The Microsoft Internet Information Server
6733 is broken with respect to additional path information. If
6734 you use the Perl DLL library, the IIS server will attempt to
6735 execute the additional path information as a Perl script.
6736 If you use the ordinary file associations mapping, the
6737 path information will be present in the environment,
6738 but incorrect. The best thing to do is to avoid using additional
6739 path information in CGI scripts destined for use with IIS.
6741 =item B<path_translated()>
6743 As per path_info() but returns the additional
6744 path information translated into a physical path, e.g.
6745 "/usr/local/etc/httpd/htdocs/additional/stuff".
6747 The Microsoft IIS is broken with respect to the translated
6750 =item B<remote_host()>
6752 Returns either the remote host name or IP address.
6753 if the former is unavailable.
6755 =item B<script_name()>
6756 Return the script name as a partial URL, for self-refering
6761 Return the URL of the page the browser was viewing
6762 prior to fetching your script. Not available for all
6765 =item B<auth_type ()>
6767 Return the authorization/verification method in use for this
6770 =item B<server_name ()>
6772 Returns the name of the server, usually the machine's host
6775 =item B<virtual_host ()>
6777 When using virtual hosts, returns the name of the host that
6778 the browser attempted to contact
6780 =item B<server_port ()>
6782 Return the port that the server is listening on.
6784 =item B<virtual_port ()>
6786 Like server_port() except that it takes virtual hosts into account.
6787 Use this when running with virtual hosts.
6789 =item B<server_software ()>
6791 Returns the server software and version number.
6793 =item B<remote_user ()>
6795 Return the authorization/verification name used for user
6796 verification, if this script is protected.
6798 =item B<user_name ()>
6800 Attempt to obtain the remote user's name, using a variety of different
6801 techniques. This only works with older browsers such as Mosaic.
6802 Newer browsers do not report the user name for privacy reasons!
6804 =item B<request_method()>
6806 Returns the method used to access your script, usually
6807 one of 'POST', 'GET' or 'HEAD'.
6809 =item B<content_type()>
6811 Returns the content_type of data submitted in a POST, generally
6812 multipart/form-data or application/x-www-form-urlencoded
6816 Called with no arguments returns the list of HTTP environment
6817 variables, including such things as HTTP_USER_AGENT,
6818 HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the
6819 like-named HTTP header fields in the request. Called with the name of
6820 an HTTP header field, returns its value. Capitalization and the use
6821 of hyphens versus underscores are not significant.
6823 For example, all three of these examples are equivalent:
6825 $requested_language = $q->http('Accept-language');
6826 $requested_language = $q->http('Accept_language');
6827 $requested_language = $q->http('HTTP_ACCEPT_LANGUAGE');
6831 The same as I<http()>, but operates on the HTTPS environment variables
6832 present when the SSL protocol is in effect. Can be used to determine
6833 whether SSL is turned on.
6837 =head1 USING NPH SCRIPTS
6839 NPH, or "no-parsed-header", scripts bypass the server completely by
6840 sending the complete HTTP header directly to the browser. This has
6841 slight performance benefits, but is of most use for taking advantage
6842 of HTTP extensions that are not directly supported by your server,
6843 such as server push and PICS headers.
6845 Servers use a variety of conventions for designating CGI scripts as
6846 NPH. Many Unix servers look at the beginning of the script's name for
6847 the prefix "nph-". The Macintosh WebSTAR server and Microsoft's
6848 Internet Information Server, in contrast, try to decide whether a
6849 program is an NPH script by examining the first line of script output.
6852 CGI.pm supports NPH scripts with a special NPH mode. When in this
6853 mode, CGI.pm will output the necessary extra header information when
6854 the header() and redirect() methods are
6857 The Microsoft Internet Information Server requires NPH mode. As of
6858 version 2.30, CGI.pm will automatically detect when the script is
6859 running under IIS and put itself into this mode. You do not need to
6860 do this manually, although it won't hurt anything if you do. However,
6861 note that if you have applied Service Pack 6, much of the
6862 functionality of NPH scripts, including the ability to redirect while
6863 setting a cookie, b<do not work at all> on IIS without a special patch
6865 http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP:
6866 Non-Parsed Headers Stripped From CGI Applications That Have nph-
6871 =item In the B<use> statement
6873 Simply add the "-nph" pragmato the list of symbols to be imported into
6876 use CGI qw(:standard -nph)
6878 =item By calling the B<nph()> method:
6880 Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
6884 =item By using B<-nph> parameters
6886 in the B<header()> and B<redirect()> statements:
6888 print $q->header(-nph=>1);
6894 CGI.pm provides four simple functions for producing multipart
6895 documents of the type needed to implement server push. These
6896 functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To
6897 import these into your namespace, you must import the ":push" set.
6898 You are also advised to put the script into NPH mode and to set $| to
6899 1 to avoid buffering problems.
6901 Here is a simple script that demonstrates server push:
6903 #!/usr/local/bin/perl
6904 use CGI qw/:push -nph/;
6906 print multipart_init(-boundary=>'----here we go!');
6908 print multipart_start(-type=>'text/plain'),
6909 "The current time is ",scalar(localtime),"\n";
6911 print multipart_end;
6913 print multipart_final;
6918 This script initializes server push by calling B<multipart_init()>.
6919 It then enters a loop in which it begins a new multipart section by
6920 calling B<multipart_start()>, prints the current local time,
6921 and ends a multipart section with B<multipart_end()>. It then sleeps
6922 a second, and begins again. On the final iteration, it ends the
6923 multipart section with B<multipart_final()> rather than with
6928 =item multipart_init()
6930 multipart_init(-boundary=>$boundary);
6932 Initialize the multipart system. The -boundary argument specifies
6933 what MIME boundary string to use to separate parts of the document.
6934 If not provided, CGI.pm chooses a reasonable boundary for you.
6936 =item multipart_start()
6938 multipart_start(-type=>$type)
6940 Start a new part of the multipart document using the specified MIME
6941 type. If not specified, text/html is assumed.
6943 =item multipart_end()
6947 End a part. You must remember to call multipart_end() once for each
6948 multipart_start(), except at the end of the last part of the multipart
6949 document when multipart_final() should be called instead of multipart_end().
6951 =item multipart_final()
6955 End all parts. You should call multipart_final() rather than
6956 multipart_end() at the end of the last part of the multipart document.
6960 Users interested in server push applications should also have a look
6961 at the CGI::Push module.
6963 Only Netscape Navigator supports server push. Internet Explorer
6966 =head1 Avoiding Denial of Service Attacks
6968 A potential problem with CGI.pm is that, by default, it attempts to
6969 process form POSTings no matter how large they are. A wily hacker
6970 could attack your site by sending a CGI script a huge POST of many
6971 megabytes. CGI.pm will attempt to read the entire POST into a
6972 variable, growing hugely in size until it runs out of memory. While
6973 the script attempts to allocate the memory the system may slow down
6974 dramatically. This is a form of denial of service attack.
6976 Another possible attack is for the remote user to force CGI.pm to
6977 accept a huge file upload. CGI.pm will accept the upload and store it
6978 in a temporary directory even if your script doesn't expect to receive
6979 an uploaded file. CGI.pm will delete the file automatically when it
6980 terminates, but in the meantime the remote user may have filled up the
6981 server's disk space, causing problems for other programs.
6983 The best way to avoid denial of service attacks is to limit the amount
6984 of memory, CPU time and disk space that CGI scripts can use. Some Web
6985 servers come with built-in facilities to accomplish this. In other
6986 cases, you can use the shell I<limit> or I<ulimit>
6987 commands to put ceilings on CGI resource usage.
6990 CGI.pm also has some simple built-in protections against denial of
6991 service attacks, but you must activate them before you can use them.
6992 These take the form of two global variables in the CGI name space:
6996 =item B<$CGI::POST_MAX>
6998 If set to a non-negative integer, this variable puts a ceiling
6999 on the size of POSTings, in bytes. If CGI.pm detects a POST
7000 that is greater than the ceiling, it will immediately exit with an error
7001 message. This value will affect both ordinary POSTs and
7002 multipart POSTs, meaning that it limits the maximum size of file
7003 uploads as well. You should set this to a reasonably high
7004 value, such as 1 megabyte.
7006 =item B<$CGI::DISABLE_UPLOADS>
7008 If set to a non-zero value, this will disable file uploads
7009 completely. Other fill-out form values will work as usual.
7013 You can use these variables in either of two ways.
7017 =item B<1. On a script-by-script basis>
7019 Set the variable at the top of the script, right after the "use" statement:
7021 use CGI qw/:standard/;
7022 use CGI::Carp 'fatalsToBrowser';
7023 $CGI::POST_MAX=1024 * 100; # max 100K posts
7024 $CGI::DISABLE_UPLOADS = 1; # no uploads
7026 =item B<2. Globally for all scripts>
7028 Open up CGI.pm, find the definitions for $POST_MAX and
7029 $DISABLE_UPLOADS, and set them to the desired values. You'll
7030 find them towards the top of the file in a subroutine named
7031 initialize_globals().
7035 An attempt to send a POST larger than $POST_MAX bytes will cause
7036 I<param()> to return an empty CGI parameter list. You can test for
7037 this event by checking I<cgi_error()>, either after you create the CGI
7038 object or, if you are using the function-oriented interface, call
7039 <param()> for the first time. If the POST was intercepted, then
7040 cgi_error() will return the message "413 POST too large".
7042 This error message is actually defined by the HTTP protocol, and is
7043 designed to be returned to the browser as the CGI script's status
7046 $uploaded_file = param('upload');
7047 if (!$uploaded_file && cgi_error()) {
7048 print header(-status=>cgi_error());
7052 However it isn't clear that any browser currently knows what to do
7053 with this status code. It might be better just to create an
7054 HTML page that warns the user of the problem.
7056 =head1 COMPATIBILITY WITH CGI-LIB.PL
7058 To make it easier to port existing programs that use cgi-lib.pl the
7059 compatibility routine "ReadParse" is provided. Porting is simple:
7062 require "cgi-lib.pl";
7064 print "The value of the antique is $in{antique}.\n";
7069 print "The value of the antique is $in{antique}.\n";
7071 CGI.pm's ReadParse() routine creates a tied variable named %in,
7072 which can be accessed to obtain the query variables. Like
7073 ReadParse, you can also provide your own variable. Infrequently
7074 used features of ReadParse, such as the creation of @in and $in
7075 variables, are not supported.
7077 Once you use ReadParse, you can retrieve the query object itself
7081 print $q->textfield(-name=>'wow',
7082 -value=>'does this really work?');
7084 This allows you to start using the more interesting features
7085 of CGI.pm without rewriting your old scripts from scratch.
7087 =head1 AUTHOR INFORMATION
7089 Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
7091 This library is free software; you can redistribute it and/or modify
7092 it under the same terms as Perl itself.
7094 Address bug reports and comments to: lstein@cshl.org. When sending
7095 bug reports, please provide the version of CGI.pm, the version of
7096 Perl, the name and version of your Web server, and the name and
7097 version of the operating system you are using. If the problem is even
7098 remotely browser dependent, please provide information about the
7099 affected browers as well.
7103 Thanks very much to:
7107 =item Matt Heffron (heffron@falstaff.css.beckman.com)
7109 =item James Taylor (james.taylor@srs.gov)
7111 =item Scott Anguish <sanguish@digifix.com>
7113 =item Mike Jewell (mlj3u@virginia.edu)
7115 =item Timothy Shimmin (tes@kbs.citri.edu.au)
7117 =item Joergen Haegg (jh@axis.se)
7119 =item Laurent Delfosse (delfosse@delfosse.com)
7121 =item Richard Resnick (applepi1@aol.com)
7123 =item Craig Bishop (csb@barwonwater.vic.gov.au)
7125 =item Tony Curtis (tc@vcpc.univie.ac.at)
7127 =item Tim Bunce (Tim.Bunce@ig.co.uk)
7129 =item Tom Christiansen (tchrist@convex.com)
7131 =item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
7133 =item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
7135 =item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
7137 =item Stephen Dahmen (joyfire@inxpress.net)
7139 =item Ed Jordan (ed@fidalgo.net)
7141 =item David Alan Pisoni (david@cnation.com)
7143 =item Doug MacEachern (dougm@opengroup.org)
7145 =item Robin Houston (robin@oneworld.org)
7147 =item ...and many many more...
7149 for suggestions and bug fixes.
7153 =head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
7156 #!/usr/local/bin/perl
7162 print $query->header;
7163 print $query->start_html("Example CGI.pm Form");
7164 print "<h1> Example CGI.pm Form</h1>\n";
7165 &print_prompt($query);
7168 print $query->end_html;
7173 print $query->start_form;
7174 print "<em>What's your name?</em><br>";
7175 print $query->textfield('name');
7176 print $query->checkbox('Not my real name');
7178 print "<p><em>Where can you find English Sparrows?</em><br>";
7179 print $query->checkbox_group(
7180 -name=>'Sparrow locations',
7181 -values=>[England,France,Spain,Asia,Hoboken],
7183 -defaults=>[England,Asia]);
7185 print "<p><em>How far can they fly?</em><br>",
7186 $query->radio_group(
7188 -values=>['10 ft','1 mile','10 miles','real far'],
7189 -default=>'1 mile');
7191 print "<p><em>What's your favorite color?</em> ";
7192 print $query->popup_menu(-name=>'Color',
7193 -values=>['black','brown','red','yellow'],
7196 print $query->hidden('Reference','Monty Python and the Holy Grail');
7198 print "<p><em>What have you got there?</em><br>";
7199 print $query->scrolling_list(
7200 -name=>'possessions',
7201 -values=>['A Coconut','A Grail','An Icon',
7202 'A Sword','A Ticket'],
7206 print "<p><em>Any parting comments?</em><br>";
7207 print $query->textarea(-name=>'Comments',
7211 print "<p>",$query->reset;
7212 print $query->submit('Action','Shout');
7213 print $query->submit('Action','Scream');
7214 print $query->endform;
7222 print "<h2>Here are the current settings in this form</h2>";
7224 foreach $key ($query->param) {
7225 print "<strong>$key</strong> -> ";
7226 @values = $query->param($key);
7227 print join(", ",@values),"<br>\n";
7234 <address>Lincoln D. Stein</address><br>
7235 <a href="/">Home Page</a>
7245 L<CGI::Carp>, L<CGI::Fast>, L<CGI::Pretty>