4 # See the bottom of this file for the POD documentation. Search for the
7 # You can run this file through either pod2man or pod2html to produce pretty
8 # documentation in manual or html file format (these utilities are part of the
9 # Perl 5 distribution).
11 # Copyright 1995-1997 Lincoln D. Stein. All rights reserved.
12 # It may be used and modified freely, but I do request that this copyright
13 # notice remain attached to the file. You may modify this module as you
14 # wish, but if you redistribute a modified version, please attach a note
15 # listing the modifications you have made.
17 # The most recent version and complete docs are available at:
18 # http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
19 # ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
21 # Set this to 1 to enable copious autoloader debugging messages
24 # Set this to 1 to enable NPH scripts
28 # 3) print header(-nph=>1)
31 $CGI::revision = '$Id: CGI.pm,v 2.32 1997/3/19 10:10 lstein Exp $';
32 $CGI::VERSION='2.3201';
34 # OVERRIDE THE OS HERE IF CGI.pm GUESSES WRONG
41 # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
42 # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
43 # $TempFile::TMPDIRECTORY = '/usr/tmp';
45 # ------------------ START OF THE LIBRARY ------------
47 # FIGURE OUT THE OS WE'RE RUNNING UNDER
48 # Some systems support the $^O variable. If not
49 # available then require() the Config library
53 $OS = $Config::Config{'osname'};
58 } elsif ($OS=~/vms/i) {
60 } elsif ($OS=~/Mac/i) {
62 } elsif ($OS=~/os2/i) {
68 # Some OS logic. Binary mode enabled on DOS, NT and VMS
69 $needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/;
71 # This is the default class for the CGI object to use when all else fails.
72 $DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
73 # This is where to look for autoloaded routines.
74 $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
76 # The path separator is a slash, backslash or semicolon, depending
86 # Turn on NPH scripts by default when running under IIS server!
87 $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
89 # Turn on special checking for Doug MacEachern's modperl
90 if (defined($MOD_PERL = $ENV{'GATEWAY_INTERFACE'}) &&
91 $MOD_PERL =~ /^CGI-Perl/)
98 # This is really "\r\n", but the meaning of \n is different
99 # in MacPerl, so we resort to octal here.
102 if ($needs_binmode) {
103 $CGI::DefaultClass->binmode(main::STDOUT);
104 $CGI::DefaultClass->binmode(main::STDIN);
105 $CGI::DefaultClass->binmode(main::STDERR);
108 # Cute feature, but it broke when the overload mechanism changed...
109 # %OVERLOAD = ('""'=>'as_string');
112 ':html2'=>[h1..h6,qw/p br hr ol ul li dl dt dd menu code var strong em
113 tt i b blockquote pre img a address cite samp dfn html head
114 base body link nextid title meta kbd start_html end_html
115 input Select option/],
116 ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont/],
117 ':netscape'=>[qw/blink frameset frame script font fontsize center/],
118 ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
119 submit reset defaults radio_group popup_menu button autoEscape
120 scrolling_list image_button start_form end_form startform endform
121 start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
122 ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump
123 raw_cookie request_method query_string accept user_agent remote_host
124 remote_addr referer server_name server_software server_port server_protocol
125 virtual_host remote_ident auth_type http
126 remote_user user_name header redirect import_names put/],
127 ':ssl' => [qw/https/],
128 ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
129 ':html' => [qw/:html2 :html3 :netscape/],
130 ':standard' => [qw/:html2 :form :cgi/],
131 ':all' => [qw/:html2 :html3 :netscape :form :cgi/]
134 # to import symbols into caller
137 my ($callpack, $callfile, $callline) = caller;
139 $NPH++, next if $_ eq ':nph';
140 foreach (&expand_tags($_)) {
141 tr/a-zA-Z0-9_//cd; # don't allow weird function names
145 # To allow overriding, search through the packages
146 # Till we find one in which the correct subroutine is defined.
147 my @packages = ($self,@{"$self\:\:ISA"});
148 foreach $sym (keys %EXPORT) {
150 my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
151 foreach $pck (@packages) {
152 if (defined(&{"$pck\:\:$sym"})) {
157 *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
164 return ($tag) unless $EXPORT_TAGS{$tag};
165 foreach (@{$EXPORT_TAGS{$tag}}) {
166 push(@r,&expand_tags($_));
172 # The new routine. This will check the current environment
173 # for an existing query string, and initialize itself, if so.
176 my($class,$initializer) = @_;
178 bless $self,ref $class || $class || $DefaultClass;
179 $CGI::DefaultClass->_reset_globals() if $MOD_PERL;
180 $initializer = to_filehandle($initializer) if $initializer;
181 $self->init($initializer);
185 # We provide a DESTROY method so that the autoloader
186 # doesn't bother trying to find it.
190 # Returns the value(s)of a named parameter.
191 # If invoked in a list context, returns the
192 # entire list. Otherwise returns the first
193 # member of the list.
194 # If name is not provided, return a list of all
195 # the known parameters names available.
196 # If more than one argument is provided, the
197 # second and subsequent arguments are used to
198 # set the value of the parameter.
201 my($self,@p) = self_or_default(@_);
202 return $self->all_parameters unless @p;
203 my($name,$value,@other);
205 # For compatibility between old calling style and use_named_parameters() style,
206 # we have to special case for a single parameter present.
208 ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
211 if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
212 @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
214 foreach ($value,@other) {
215 push(@values,$_) if defined($_);
218 # If values is provided, then we set it.
220 $self->add_parameter($name);
221 $self->{$name}=[@values];
227 return () unless defined($name) && $self->{$name};
228 return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
232 # Deletes the named parameter entirely.
235 my($self,$name) = self_or_default(@_);
236 delete $self->{$name};
237 delete $self->{'.fieldnames'}->{$name};
238 @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
239 return wantarray ? () : undef;
242 sub self_or_default {
243 return @_ if defined($_[0]) && !ref($_[0]) && ($_[0] eq 'CGI');
244 unless (defined($_[0]) &&
246 (ref($_[0]) eq 'CGI' ||
247 eval "\$_[0]->isaCGI()")) { # optimize for the common case
248 $CGI::DefaultClass->_reset_globals()
249 if defined($Q) && $MOD_PERL && $CGI::DefaultClass->_new_request();
250 $Q = $CGI::DefaultClass->new unless defined($Q);
257 return undef unless (defined(Apache->seqno()) or eval { require Apache });
258 if (Apache->seqno() != $SEQNO) {
259 $SEQNO = Apache->seqno();
272 local $^W=0; # prevent a warning
273 if (defined($_[0]) &&
274 (substr(ref($_[0]),0,3) eq 'CGI'
275 || eval "\$_[0]->isaCGI()")) {
278 return ($DefaultClass,@_);
286 #### Method: import_names
287 # Import all parameters into the given namespace.
288 # Assumes namespace 'Q' if not specified
291 my($self,$namespace) = self_or_default(@_);
292 $namespace = 'Q' unless defined($namespace);
293 die "Can't import names into 'main'\n"
294 if $namespace eq 'main';
295 my($param,@value,$var);
296 foreach $param ($self->param) {
297 # protect against silly names
298 ($var = $param)=~tr/a-zA-Z0-9_/_/c;
299 $var = "${namespace}::$var";
300 @value = $self->param($param);
306 #### Method: use_named_parameters
307 # Force CGI.pm to use named parameter-style method calls
308 # rather than positional parameters. The same effect
309 # will happen automatically if the first parameter
311 sub use_named_parameters {
312 my($self,$use_named) = self_or_default(@_);
313 return $self->{'.named'} unless defined ($use_named);
315 # stupidity to avoid annoying warnings
316 return $self->{'.named'}=$use_named;
319 ########################################
320 # THESE METHODS ARE MORE OR LESS PRIVATE
321 # GO TO THE __DATA__ SECTION TO SEE MORE
323 ########################################
325 # Initialize the query object from the environment.
326 # If a parameter list is found, this object will be set
327 # to an associative array in which parameter names are keys
328 # and the values are stored as lists
329 # If a keyword list is found, this method creates a bogus
330 # parameter list with the single parameter 'keywords'.
333 my($self,$initializer) = @_;
334 my($query_string,@lines);
337 # if we get called more than once, we want to initialize
338 # ourselves from the original query (which may be gone
339 # if it was read from STDIN originally.)
340 if (defined(@QUERY_PARAM) && !defined($initializer)) {
342 foreach (@QUERY_PARAM) {
343 $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
348 $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
350 # If initializer is defined, then read parameters
353 if (defined($initializer)) {
355 if (ref($initializer) && ref($initializer) eq 'HASH') {
356 foreach (keys %$initializer) {
357 $self->param('-name'=>$_,'-value'=>$initializer->{$_});
362 $initializer = $$initializer if ref($initializer);
363 if (defined(fileno($initializer))) {
364 while (<$initializer>) {
369 # massage back into standard format
370 if ("@lines" =~ /=/) {
371 $query_string=join("&",@lines);
373 $query_string=join("+",@lines);
377 $query_string = $initializer;
380 # If method is GET or HEAD, fetch the query from
382 if ($meth=~/^(GET|HEAD)$/) {
383 $query_string = $ENV{'QUERY_STRING'};
387 # If the method is POST, fetch the query from standard
389 if ($meth eq 'POST') {
391 if (defined($ENV{'CONTENT_TYPE'})
393 $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|) {
394 my($boundary) = $ENV{'CONTENT_TYPE'}=~/boundary=(\S+)/;
395 $self->read_multipart($boundary,$ENV{'CONTENT_LENGTH'});
399 $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0)
400 if $ENV{'CONTENT_LENGTH'} > 0;
403 # Some people want to have their cake and eat it too!
404 # Uncomment this line to have the contents of the query string
405 # APPENDED to the POST data.
406 # $query_string .= ($query_string ? '&' : '') . $ENV{'QUERY_STRING'} if $ENV{'QUERY_STRING'};
410 # If neither is set, assume we're being debugged offline.
411 # Check the command line and then the standard input for data.
412 # We use the shellwords package in order to behave the way that
413 # UN*X programmers expect.
414 $query_string = &read_from_cmdline;
417 # We now have the query string in hand. We do slightly
418 # different things for keyword lists and parameter lists.
420 if ($query_string =~ /=/) {
421 $self->parse_params($query_string);
423 $self->add_parameter('keywords');
424 $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
428 # Special case. Erase everything if there is a field named
430 if ($self->param('.defaults')) {
434 # Associative array containing our defined fieldnames
435 $self->{'.fieldnames'} = {};
436 foreach ($self->param('.cgifields')) {
437 $self->{'.fieldnames'}->{$_}++;
440 # Clear out our default submission button flag if present
441 $self->delete('.submit');
442 $self->delete('.cgifields');
443 $self->save_request unless $initializer;
448 # FUNCTIONS TO OVERRIDE:
450 # Turn a string into a filehandle
453 if ($string && !ref($string)) {
454 my($package) = caller(1);
455 my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string";
456 return $tmp if defined(fileno($tmp));
461 # Create a new multipart buffer
462 sub new_MultipartBuffer {
463 my($self,$boundary,$length,$filehandle) = @_;
464 return MultipartBuffer->new($self,$boundary,$length,$filehandle);
467 # Read data from a file handle
468 sub read_from_client {
469 my($self, $fh, $buff, $len, $offset) = @_;
470 local $^W=0; # prevent a warning
471 return read($fh, $$buff, $len, $offset);
474 # put a filehandle into binary mode (DOS)
479 # send output to the browser
481 my($self,@p) = self_or_default(@_);
485 # print to standard output (for overriding in mod_perl)
491 # unescape URL-encoded data
494 $todecode =~ tr/+/ /; # pluses become spaces
495 $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
502 $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
508 # We're going to play with the package globals now so that if we get called
509 # again, we initialize ourselves in exactly the same way. This allows
510 # us to have several of these objects.
511 @QUERY_PARAM = $self->param; # save list of parameters
512 foreach (@QUERY_PARAM) {
513 $QUERY_PARAM{$_}=$self->{$_};
517 sub parse_keywordlist {
518 my($self,$tosplit) = @_;
519 $tosplit = &unescape($tosplit); # unescape the keywords
520 $tosplit=~tr/+/ /; # pluses to spaces
521 my(@keywords) = split(/\s+/,$tosplit);
526 my($self,$tosplit) = @_;
527 my(@pairs) = split('&',$tosplit);
530 ($param,$value) = split('=');
531 $param = &unescape($param);
532 $value = &unescape($value);
533 $self->add_parameter($param);
534 push (@{$self->{$param}},$value);
540 push (@{$self->{'.parameters'}},$param)
541 unless defined($self->{$param});
546 return () unless defined($self) && $self->{'.parameters'};
547 return () unless @{$self->{'.parameters'}};
548 return @{$self->{'.parameters'}};
553 #### Method as_string
562 print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
563 my($func) = $AUTOLOAD;
564 my($pack,$func_name) = $func=~/(.+)::([^:]+)$/;
565 $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
566 unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
568 my($sub) = \%{"$pack\:\:SUBS"};
570 my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
571 eval "package $pack; $$auto";
574 my($code) = $sub->{$func_name};
576 $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
578 if ($EXPORT{':any'} ||
579 $EXPORT{$func_name} ||
580 (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
581 && $EXPORT_OK{$func_name}) {
582 $code = $sub->{'HTML_FUNC'};
583 $code=~s/func_name/$func_name/mg;
586 die "Undefined subroutine $AUTOLOAD\n" unless $code;
587 eval "package $pack; $code";
592 goto &{"$pack\:\:$func_name"};
596 # Smart rearrangement of parameters to allow named parameter
597 # calling. We do the rearangement if:
598 # 1. The first parameter begins with a -
599 # 2. The use_named_parameters() method returns true
601 my($self,$order,@param) = @_;
602 return () unless @param;
604 return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-')
605 || $self->use_named_parameters;
608 for ($i=0;$i<@param;$i+=2) {
609 $param[$i]=~s/^\-//; # get rid of initial - if present
610 $param[$i]=~tr/a-z/A-Z/; # parameters are upper case
613 my(%param) = @param; # convert into associative array
617 foreach $key (@$order) {
619 # this is an awful hack to fix spurious warnings when the
621 if (ref($key) && ref($key) eq 'ARRAY') {
623 last if defined($value);
628 $value = $param{$key};
631 push(@return_array,$value);
633 push (@return_array,$self->make_attributes(\%param)) if %param;
634 return (@return_array);
637 ###############################################################################
638 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
639 ###############################################################################
640 $AUTOLOADED_ROUTINES = ''; # get rid of -w warning
641 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
645 'URL_ENCODED'=> <<'END_OF_FUNC',
646 sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
649 'MULTIPART' => <<'END_OF_FUNC',
650 sub MULTIPART { 'multipart/form-data'; }
653 'HTML_FUNC' => <<'END_OF_FUNC',
656 # handle various cases in which we're called
657 # most of this bizarre stuff is to avoid -w errors
659 (!ref($_[0]) && $_[0] eq $CGI::DefaultClass) ||
661 (substr(ref($_[0]),0,3) eq 'CGI' ||
662 eval "\$_[0]->isaCGI()"));
665 if (ref($_[0]) && ref($_[0]) eq 'HASH') {
666 my(@attr) = CGI::make_attributes('',shift);
667 $attr = " @attr" if @attr;
669 my($tag,$untag) = ("\U<func_name\E$attr>","\U</func_name>\E");
670 return $tag unless @_;
671 if (ref($_[0]) eq 'ARRAY') {
674 push(@r,"$tag$_$untag");
678 return "$tag@_$untag";
683 #### Method: keywords
684 # Keywords acts a bit differently. Calling it in a list context
685 # returns the list of keywords.
686 # Calling it in a scalar context gives you the size of the list.
688 'keywords' => <<'END_OF_FUNC',
690 my($self,@values) = self_or_default(@_);
691 # If values is provided, then we set it.
692 $self->{'keywords'}=[@values] if @values;
693 my(@result) = @{$self->{'keywords'}};
698 # These are some tie() interfaces for compatibility
699 # with Steve Brenner's cgi-lib.pl routines
700 'ReadParse' => <<'END_OF_FUNC',
713 'PrintHeader' => <<'END_OF_FUNC',
715 my($self) = self_or_default(@_);
716 return $self->header();
720 'HtmlTop' => <<'END_OF_FUNC',
722 my($self,@p) = self_or_default(@_);
723 return $self->start_html(@p);
727 'HtmlBot' => <<'END_OF_FUNC',
729 my($self,@p) = self_or_default(@_);
730 return $self->end_html(@p);
734 'SplitParam' => <<'END_OF_FUNC',
737 my (@params) = split ("\0", $param);
738 return (wantarray ? @params : $params[0]);
742 'MethGet' => <<'END_OF_FUNC',
744 return request_method() eq 'GET';
748 'MethPost' => <<'END_OF_FUNC',
750 return request_method() eq 'POST';
754 'TIEHASH' => <<'END_OF_FUNC',
760 'STORE' => <<'END_OF_FUNC',
762 $_[0]->param($_[1],split("\0",$_[2]));
766 'FETCH' => <<'END_OF_FUNC',
768 return $_[0] if $_[1] eq 'CGI';
769 return undef unless defined $_[0]->param($_[1]);
770 return join("\0",$_[0]->param($_[1]));
774 'FIRSTKEY' => <<'END_OF_FUNC',
776 $_[0]->{'.iterator'}=0;
777 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
781 'NEXTKEY' => <<'END_OF_FUNC',
783 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
787 'EXISTS' => <<'END_OF_FUNC',
789 exists $_[0]->{$_[1]};
793 'DELETE' => <<'END_OF_FUNC',
795 $_[0]->delete($_[1]);
799 'CLEAR' => <<'END_OF_FUNC',
807 # Append a new value to an existing query
812 my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
813 my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
815 $self->add_parameter($name);
816 push(@{$self->{$name}},@values);
818 return $self->param($name);
822 #### Method: delete_all
823 # Delete all parameters
825 'delete_all' => <<'EOF',
827 my($self) = self_or_default(@_);
832 #### Method: autoescape
833 # If you want to turn off the autoescaping features,
834 # call this method with undef as the argument
835 'autoEscape' => <<'END_OF_FUNC',
837 my($self,$escape) = self_or_default(@_);
838 $self->{'dontescape'}=!$escape;
844 # Return the current version
846 'version' => <<'END_OF_FUNC',
852 'make_attributes' => <<'END_OF_FUNC',
853 sub make_attributes {
854 my($self,$attr) = @_;
855 return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
857 foreach (keys %{$attr}) {
859 $key=~s/^\-//; # get rid of initial - if present
860 $key=~tr/a-z/A-Z/; # parameters are upper case
861 push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/);
868 # Returns a string in which all the known parameter/value
869 # pairs are represented as nested lists, mainly for the purposes
872 'dump' => <<'END_OF_FUNC',
874 my($self) = self_or_default(@_);
875 my($param,$value,@result);
876 return '<UL></UL>' unless $self->param;
877 push(@result,"<UL>");
878 foreach $param ($self->param) {
879 my($name)=$self->escapeHTML($param);
880 push(@result,"<LI><STRONG>$param</STRONG>");
881 push(@result,"<UL>");
882 foreach $value ($self->param($param)) {
883 $value = $self->escapeHTML($value);
884 push(@result,"<LI>$value");
886 push(@result,"</UL>");
888 push(@result,"</UL>\n");
889 return join("\n",@result);
895 # Write values out to a filehandle in such a way that they can
896 # be reinitialized by the filehandle form of the new() method
898 'save' => <<'END_OF_FUNC',
900 my($self,$filehandle) = self_or_default(@_);
902 my($package) = caller;
903 # Check that this still works!
904 # $filehandle = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
905 $filehandle = to_filehandle($filehandle);
906 foreach $param ($self->param) {
907 my($escaped_param) = &escape($param);
909 foreach $value ($self->param($param)) {
910 print $filehandle "$escaped_param=",escape($value),"\n";
913 print $filehandle "=\n"; # end of record
919 # Return a Content-Type: style header
922 'header' => <<'END_OF_FUNC',
924 my($self,@p) = self_or_default(@_);
927 my($type,$status,$cookie,$target,$expires,$nph,@other) =
928 $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
930 # rearrange() was designed for the HTML portion, so we
931 # need to fix it up a little.
933 next unless my($header,$value) = /([^\s=]+)=(.+)/;
934 substr($header,1,1000)=~tr/A-Z/a-z/;
935 ($value)=$value=~/^"(.*)"$/;
936 $_ = "$header: $value";
939 $type = $type || 'text/html';
941 push(@header,'HTTP/1.0 ' . ($status || '200 OK')) if $nph || $NPH;
942 push(@header,"Status: $status") if $status;
943 push(@header,"Window-target: $target") if $target;
944 # push all the cookies -- there may be several
946 my(@cookie) = ref($cookie) ? @{$cookie} : $cookie;
948 push(@header,"Set-cookie: $_");
951 # if the user indicates an expiration time, then we need
952 # both an Expires and a Date header (so that the browser is
954 push(@header,"Expires: " . &expires($expires)) if $expires;
955 push(@header,"Date: " . &expires(0)) if $expires;
956 push(@header,"Pragma: no-cache") if $self->cache();
957 push(@header,@other);
958 push(@header,"Content-type: $type");
960 my $header = join($CRLF,@header);
961 return $header . "${CRLF}${CRLF}";
967 # Control whether header() will produce the no-cache
970 'cache' => <<'END_OF_FUNC',
972 my($self,$new_value) = self_or_default(@_);
973 $new_value = '' unless $new_value;
974 if ($new_value ne '') {
975 $self->{'cache'} = $new_value;
977 return $self->{'cache'};
982 #### Method: redirect
983 # Return a Location: style header
986 'redirect' => <<'END_OF_FUNC',
988 my($self,@p) = self_or_default(@_);
989 my($url,$target,$cookie,$nph,@other) = $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p);
990 $url = $url || $self->self_url;
992 foreach (@other) { push(@o,split("=")); }
994 '-Status'=>'302 Found',
997 '-nph'=>($nph||$NPH));
998 push(@o,'-Target'=>$target) if $target;
999 push(@o,'-Cookie'=>$cookie) if $cookie;
1000 return $self->header(@o);
1005 #### Method: start_html
1006 # Canned HTML header
1009 # $title -> (optional) The title for this HTML document (-title)
1010 # $author -> (optional) e-mail address of the author (-author)
1011 # $base -> (optional) if set to true, will enter the BASE address of this document
1012 # for resolving relative references (-base)
1013 # $xbase -> (optional) alternative base at some remote location (-xbase)
1014 # $target -> (optional) target window to load all links into (-target)
1015 # $script -> (option) Javascript code (-script)
1016 # $meta -> (optional) Meta information tags
1017 # @other -> (optional) any other named parameters you'd like to incorporate into
1020 'start_html' => <<'END_OF_FUNC',
1022 my($self,@p) = &self_or_default(@_);
1023 my($title,$author,$base,$xbase,$script,$target,$meta,@other) =
1024 $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,TARGET,META],@p);
1026 # strangely enough, the title needs to be escaped as HTML
1027 # while the author needs to be escaped as a URL
1028 $title = $self->escapeHTML($title || 'Untitled Document');
1029 $author = $self->escapeHTML($author);
1031 push(@result,'<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">');
1032 push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
1033 push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if $author;
1035 if ($base || $xbase || $target) {
1036 my $href = $xbase || $self->url();
1037 my $t = $target ? qq/ TARGET="$target"/ : '';
1038 push(@result,qq/<BASE HREF="$href"$t>/);
1041 if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
1042 foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
1044 push(@result,<<END) if $script;
1046 <!-- Hide script from HTML-compliant browsers
1048 // End script hiding. -->
1052 my($other) = @other ? " @other" : '';
1053 push(@result,"</HEAD><BODY$other>");
1054 return join("\n",@result);
1059 #### Method: end_html
1060 # End an HTML document.
1061 # Trivial method for completeness. Just returns "</BODY>"
1063 'end_html' => <<'END_OF_FUNC',
1065 return "</BODY></HTML>";
1070 ################################
1071 # METHODS USED IN BUILDING FORMS
1072 ################################
1074 #### Method: isindex
1075 # Just prints out the isindex tag.
1077 # $action -> optional URL of script to run
1079 # A string containing a <ISINDEX> tag
1080 'isindex' => <<'END_OF_FUNC',
1082 my($self,@p) = self_or_default(@_);
1083 my($action,@other) = $self->rearrange([ACTION],@p);
1084 $action = qq/ACTION="$action"/ if $action;
1085 my($other) = @other ? " @other" : '';
1086 return "<ISINDEX $action$other>";
1091 #### Method: startform
1094 # $method -> optional submission method to use (GET or POST)
1095 # $action -> optional URL of script to run
1096 # $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1097 'startform' => <<'END_OF_FUNC',
1099 my($self,@p) = self_or_default(@_);
1101 my($method,$action,$enctype,@other) =
1102 $self->rearrange([METHOD,ACTION,ENCTYPE],@p);
1104 $method = $method || 'POST';
1105 $enctype = $enctype || &URL_ENCODED;
1106 $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
1107 'ACTION="'.$self->script_name.'"' : '';
1108 my($other) = @other ? " @other" : '';
1109 $self->{'.parametersToAdd'}={};
1110 return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
1115 #### Method: start_form
1116 # synonym for startform
1117 'start_form' => <<'END_OF_FUNC',
1124 #### Method: start_multipart_form
1125 # synonym for startform
1126 'start_multipart_form' => <<'END_OF_FUNC',
1127 sub start_multipart_form {
1128 my($self,@p) = self_or_default(@_);
1129 if ($self->use_named_parameters ||
1130 (defined($param[0]) && substr($param[0],0,1) eq '-')) {
1132 $p{'-enctype'}=&MULTIPART;
1133 return $self->startform(%p);
1135 my($method,$action,@other) =
1136 $self->rearrange([METHOD,ACTION],@p);
1137 return $self->startform($method,$action,&MULTIPART,@other);
1143 #### Method: endform
1145 'endform' => <<'END_OF_FUNC',
1147 my($self,@p) = self_or_default(@_);
1148 return ($self->get_fields,"</FORM>");
1153 #### Method: end_form
1154 # synonym for endform
1155 'end_form' => <<'END_OF_FUNC',
1162 #### Method: textfield
1164 # $name -> Name of the text field
1165 # $default -> Optional default value of the field if not
1167 # $size -> Optional width of field in characaters.
1168 # $maxlength -> Optional maximum number of characters.
1170 # A string containing a <INPUT TYPE="text"> field
1172 'textfield' => <<'END_OF_FUNC',
1174 my($self,@p) = self_or_default(@_);
1175 my($name,$default,$size,$maxlength,$override,@other) =
1176 $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1178 my $current = $override ? $default :
1179 (defined($self->param($name)) ? $self->param($name) : $default);
1181 $current = defined($current) ? $self->escapeHTML($current) : '';
1182 $name = defined($name) ? $self->escapeHTML($name) : '';
1183 my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1184 my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
1185 my($other) = @other ? " @other" : '';
1186 return qq/<INPUT TYPE="text" NAME="$name" VALUE="$current"$s$m$other>/;
1191 #### Method: filefield
1193 # $name -> Name of the file upload field
1194 # $size -> Optional width of field in characaters.
1195 # $maxlength -> Optional maximum number of characters.
1197 # A string containing a <INPUT TYPE="text"> field
1199 'filefield' => <<'END_OF_FUNC',
1201 my($self,@p) = self_or_default(@_);
1203 my($name,$default,$size,$maxlength,$override,@other) =
1204 $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1206 $current = $override ? $default :
1207 (defined($self->param($name)) ? $self->param($name) : $default);
1209 $name = defined($name) ? $self->escapeHTML($name) : '';
1210 my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1211 my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
1212 $current = defined($current) ? $self->escapeHTML($current) : '';
1213 $other = ' ' . join(" ",@other);
1214 return qq/<INPUT TYPE="file" NAME="$name" VALUE="$current"$s$m$other>/;
1219 #### Method: password
1220 # Create a "secret password" entry field
1222 # $name -> Name of the field
1223 # $default -> Optional default value of the field if not
1225 # $size -> Optional width of field in characters.
1226 # $maxlength -> Optional maximum characters that can be entered.
1228 # A string containing a <INPUT TYPE="password"> field
1230 'password_field' => <<'END_OF_FUNC',
1231 sub password_field {
1232 my ($self,@p) = self_or_default(@_);
1234 my($name,$default,$size,$maxlength,$override,@other) =
1235 $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1237 my($current) = $override ? $default :
1238 (defined($self->param($name)) ? $self->param($name) : $default);
1240 $name = defined($name) ? $self->escapeHTML($name) : '';
1241 $current = defined($current) ? $self->escapeHTML($current) : '';
1242 my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1243 my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
1244 my($other) = @other ? " @other" : '';
1245 return qq/<INPUT TYPE="password" NAME="$name" VALUE="$current"$s$m$other>/;
1250 #### Method: textarea
1252 # $name -> Name of the text field
1253 # $default -> Optional default value of the field if not
1255 # $rows -> Optional number of rows in text area
1256 # $columns -> Optional number of columns in text area
1258 # A string containing a <TEXTAREA></TEXTAREA> tag
1260 'textarea' => <<'END_OF_FUNC',
1262 my($self,@p) = self_or_default(@_);
1264 my($name,$default,$rows,$cols,$override,@other) =
1265 $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
1267 my($current)= $override ? $default :
1268 (defined($self->param($name)) ? $self->param($name) : $default);
1270 $name = defined($name) ? $self->escapeHTML($name) : '';
1271 $current = defined($current) ? $self->escapeHTML($current) : '';
1272 my($r) = $rows ? " ROWS=$rows" : '';
1273 my($c) = $cols ? " COLS=$cols" : '';
1274 my($other) = @other ? " @other" : '';
1275 return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
1281 # Create a javascript button.
1283 # $name -> (optional) Name for the button. (-name)
1284 # $value -> (optional) Value of the button when selected (and visible name) (-value)
1285 # $onclick -> (optional) Text of the JavaScript to run when the button is
1288 # A string containing a <INPUT TYPE="button"> tag
1290 'button' => <<'END_OF_FUNC',
1292 my($self,@p) = self_or_default(@_);
1294 my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
1295 [ONCLICK,SCRIPT]],@p);
1297 $label=$self->escapeHTML($label);
1298 $value=$self->escapeHTML($value);
1299 $script=$self->escapeHTML($script);
1302 $name = qq/ NAME="$label"/ if $label;
1303 $value = $value || $label;
1305 $val = qq/ VALUE="$value"/ if $value;
1306 $script = qq/ ONCLICK="$script"/ if $script;
1307 my($other) = @other ? " @other" : '';
1308 return qq/<INPUT TYPE="button"$name$val$script$other>/;
1314 # Create a "submit query" button.
1316 # $name -> (optional) Name for the button.
1317 # $value -> (optional) Value of the button when selected (also doubles as label).
1318 # $label -> (optional) Label printed on the button(also doubles as the value).
1320 # A string containing a <INPUT TYPE="submit"> tag
1322 'submit' => <<'END_OF_FUNC',
1324 my($self,@p) = self_or_default(@_);
1326 my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p);
1328 $label=$self->escapeHTML($label);
1329 $value=$self->escapeHTML($value);
1331 my($name) = ' NAME=".submit"';
1332 $name = qq/ NAME="$label"/ if $label;
1333 $value = $value || $label;
1335 $val = qq/ VALUE="$value"/ if defined($value);
1336 my($other) = @other ? " @other" : '';
1337 return qq/<INPUT TYPE="submit"$name$val$other>/;
1343 # Create a "reset" button.
1345 # $name -> (optional) Name for the button.
1347 # A string containing a <INPUT TYPE="reset"> tag
1349 'reset' => <<'END_OF_FUNC',
1351 my($self,@p) = self_or_default(@_);
1352 my($label,@other) = $self->rearrange([NAME],@p);
1353 $label=$self->escapeHTML($label);
1354 my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
1355 my($other) = @other ? " @other" : '';
1356 return qq/<INPUT TYPE="reset"$value$other>/;
1361 #### Method: defaults
1362 # Create a "defaults" button.
1364 # $name -> (optional) Name for the button.
1366 # A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
1368 # Note: this button has a special meaning to the initialization script,
1369 # and tells it to ERASE the current query string so that your defaults
1372 'defaults' => <<'END_OF_FUNC',
1374 my($self,@p) = self_or_default(@_);
1376 my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
1378 $label=$self->escapeHTML($label);
1379 $label = $label || "Defaults";
1380 my($value) = qq/ VALUE="$label"/;
1381 my($other) = @other ? " @other" : '';
1382 return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
1387 #### Method: checkbox
1388 # Create a checkbox that is not logically linked to any others.
1389 # The field value is "on" when the button is checked.
1391 # $name -> Name of the checkbox
1392 # $checked -> (optional) turned on by default if true
1393 # $value -> (optional) value of the checkbox, 'on' by default
1394 # $label -> (optional) a user-readable label printed next to the box.
1395 # Otherwise the checkbox name is used.
1397 # A string containing a <INPUT TYPE="checkbox"> field
1399 'checkbox' => <<'END_OF_FUNC',
1401 my($self,@p) = self_or_default(@_);
1403 my($name,$checked,$value,$label,$override,@other) =
1404 $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
1406 if (!$override && defined($self->param($name))) {
1407 $value = $self->param($name) unless defined $value;
1408 $checked = $self->param($name) eq $value ? ' CHECKED' : '';
1410 $checked = $checked ? ' CHECKED' : '';
1411 $value = defined $value ? $value : 'on';
1413 my($the_label) = defined $label ? $label : $name;
1414 $name = $self->escapeHTML($name);
1415 $value = $self->escapeHTML($value);
1416 $the_label = $self->escapeHTML($the_label);
1417 my($other) = @other ? " @other" : '';
1418 $self->register_parameter($name);
1420 <INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label
1426 #### Method: checkbox_group
1427 # Create a list of logically-linked checkboxes.
1429 # $name -> Common name for all the check boxes
1430 # $values -> A pointer to a regular array containing the
1431 # values for each checkbox in the group.
1432 # $defaults -> (optional)
1433 # 1. If a pointer to a regular array of checkbox values,
1434 # then this will be used to decide which
1435 # checkboxes to turn on by default.
1436 # 2. If a scalar, will be assumed to hold the
1437 # value of a single checkbox in the group to turn on.
1438 # $linebreak -> (optional) Set to true to place linebreaks
1439 # between the buttons.
1440 # $labels -> (optional)
1441 # A pointer to an associative array of labels to print next to each checkbox
1442 # in the form $label{'value'}="Long explanatory label".
1443 # Otherwise the provided values are used as the labels.
1445 # An ARRAY containing a series of <INPUT TYPE="checkbox"> fields
1447 'checkbox_group' => <<'END_OF_FUNC',
1448 sub checkbox_group {
1449 my($self,@p) = self_or_default(@_);
1451 my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
1452 $rowheaders,$colheaders,$override,$nolabels,@other) =
1453 $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1454 LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
1455 ROWHEADERS,COLHEADERS,
1456 [OVERRIDE,FORCE],NOLABELS],@p);
1458 my($checked,$break,$result,$label);
1460 my(%checked) = $self->previous_or_default($name,$defaults,$override);
1462 $break = $linebreak ? "<BR>" : '';
1463 $name=$self->escapeHTML($name);
1465 # Create the elements
1467 my(@values) = $values ? @$values : $self->param($name);
1468 my($other) = @other ? " @other" : '';
1470 $checked = $checked{$_} ? ' CHECKED' : '';
1472 unless (defined($nolabels) && $nolabels) {
1474 $label = $labels->{$_} if defined($labels) && $labels->{$_};
1475 $label = $self->escapeHTML($label);
1477 $_ = $self->escapeHTML($_);
1478 push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label} ${break}/);
1480 $self->register_parameter($name);
1481 return wantarray ? @elements : join('',@elements) unless $columns;
1482 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1487 # Escape HTML -- used internally
1488 'escapeHTML' => <<'END_OF_FUNC',
1490 my($self,$toencode) = @_;
1491 return undef unless defined($toencode);
1492 return $toencode if $self->{'dontescape'};
1493 $toencode=~s/&/&/g;
1494 $toencode=~s/\"/"/g;
1495 $toencode=~s/>/>/g;
1496 $toencode=~s/</</g;
1502 # Internal procedure - don't use
1503 '_tableize' => <<'END_OF_FUNC',
1505 my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
1508 $rows = int(0.99 + @elements/$columns) unless $rows;
1509 # rearrange into a pretty table
1510 $result = "<TABLE>";
1512 unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
1513 $result .= "<TR>" if @{$colheaders};
1514 foreach (@{$colheaders}) {
1515 $result .= "<TH>$_</TH>";
1517 for ($row=0;$row<$rows;$row++) {
1519 $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
1520 for ($column=0;$column<$columns;$column++) {
1521 $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>";
1525 $result .= "</TABLE>";
1531 #### Method: radio_group
1532 # Create a list of logically-linked radio buttons.
1534 # $name -> Common name for all the buttons.
1535 # $values -> A pointer to a regular array containing the
1536 # values for each button in the group.
1537 # $default -> (optional) Value of the button to turn on by default. Pass '-'
1538 # to turn _nothing_ on.
1539 # $linebreak -> (optional) Set to true to place linebreaks
1540 # between the buttons.
1541 # $labels -> (optional)
1542 # A pointer to an associative array of labels to print next to each checkbox
1543 # in the form $label{'value'}="Long explanatory label".
1544 # Otherwise the provided values are used as the labels.
1546 # An ARRAY containing a series of <INPUT TYPE="radio"> fields
1548 'radio_group' => <<'END_OF_FUNC',
1550 my($self,@p) = self_or_default(@_);
1552 my($name,$values,$default,$linebreak,$labels,
1553 $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
1554 $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
1555 ROWS,[COLUMNS,COLS],
1556 ROWHEADERS,COLHEADERS,
1557 [OVERRIDE,FORCE],NOLABELS],@p);
1558 my($result,$checked);
1560 if (!$override && defined($self->param($name))) {
1561 $checked = $self->param($name);
1563 $checked = $default;
1565 # If no check array is specified, check the first by default
1566 $checked = $values->[0] unless $checked;
1567 $name=$self->escapeHTML($name);
1570 my(@values) = $values ? @$values : $self->param($name);
1571 my($other) = @other ? " @other" : '';
1573 my($checkit) = $checked eq $_ ? ' CHECKED' : '';
1574 my($break) = $linebreak ? '<BR>' : '';
1576 unless (defined($nolabels) && $nolabels) {
1578 $label = $labels->{$_} if defined($labels) && $labels->{$_};
1579 $label = $self->escapeHTML($label);
1581 $_=$self->escapeHTML($_);
1582 push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label} ${break}/);
1584 $self->register_parameter($name);
1585 return wantarray ? @elements : join('',@elements) unless $columns;
1586 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1591 #### Method: popup_menu
1592 # Create a popup menu.
1594 # $name -> Name for all the menu
1595 # $values -> A pointer to a regular array containing the
1596 # text of each menu item.
1597 # $default -> (optional) Default item to display
1598 # $labels -> (optional)
1599 # A pointer to an associative array of labels to print next to each checkbox
1600 # in the form $label{'value'}="Long explanatory label".
1601 # Otherwise the provided values are used as the labels.
1603 # A string containing the definition of a popup menu.
1605 'popup_menu' => <<'END_OF_FUNC',
1607 my($self,@p) = self_or_default(@_);
1609 my($name,$values,$default,$labels,$override,@other) =
1610 $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
1611 my($result,$selected);
1613 if (!$override && defined($self->param($name))) {
1614 $selected = $self->param($name);
1616 $selected = $default;
1618 $name=$self->escapeHTML($name);
1619 my($other) = @other ? " @other" : '';
1621 my(@values) = $values ? @$values : $self->param($name);
1622 $result = qq/<SELECT NAME="$name"$other>\n/;
1624 my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
1626 $label = $labels->{$_} if defined($labels) && $labels->{$_};
1627 my($value) = $self->escapeHTML($_);
1628 $label=$self->escapeHTML($label);
1629 $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
1632 $result .= "</SELECT>\n";
1638 #### Method: scrolling_list
1639 # Create a scrolling list.
1641 # $name -> name for the list
1642 # $values -> A pointer to a regular array containing the
1643 # values for each option line in the list.
1644 # $defaults -> (optional)
1645 # 1. If a pointer to a regular array of options,
1646 # then this will be used to decide which
1647 # lines to turn on by default.
1648 # 2. Otherwise holds the value of the single line to turn on.
1649 # $size -> (optional) Size of the list.
1650 # $multiple -> (optional) If set, allow multiple selections.
1651 # $labels -> (optional)
1652 # A pointer to an associative array of labels to print next to each checkbox
1653 # in the form $label{'value'}="Long explanatory label".
1654 # Otherwise the provided values are used as the labels.
1656 # A string containing the definition of a scrolling list.
1658 'scrolling_list' => <<'END_OF_FUNC',
1659 sub scrolling_list {
1660 my($self,@p) = self_or_default(@_);
1661 my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
1662 = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1663 SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
1666 my(@values) = $values ? @$values : $self->param($name);
1667 $size = $size || scalar(@values);
1669 my(%selected) = $self->previous_or_default($name,$defaults,$override);
1670 my($is_multiple) = $multiple ? ' MULTIPLE' : '';
1671 my($has_size) = $size ? " SIZE=$size" : '';
1672 my($other) = @other ? " @other" : '';
1674 $name=$self->escapeHTML($name);
1675 $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
1677 my($selectit) = $selected{$_} ? 'SELECTED' : '';
1679 $label = $labels->{$_} if defined($labels) && $labels->{$_};
1680 $label=$self->escapeHTML($label);
1681 my($value)=$self->escapeHTML($_);
1682 $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
1684 $result .= "</SELECT>\n";
1685 $self->register_parameter($name);
1693 # $name -> Name of the hidden field
1694 # @default -> (optional) Initial values of field (may be an array)
1696 # $default->[initial values of field]
1698 # A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
1700 'hidden' => <<'END_OF_FUNC',
1702 my($self,@p) = self_or_default(@_);
1704 # this is the one place where we departed from our standard
1705 # calling scheme, so we have to special-case (darn)
1707 my($name,$default,$override,@other) =
1708 $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
1710 my $do_override = 0;
1711 if ( substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
1712 @value = ref($default) ? @{$default} : $default;
1713 $do_override = $override;
1715 foreach ($default,$override,@other) {
1716 push(@value,$_) if defined($_);
1720 # use previous values if override is not set
1721 my @prev = $self->param($name);
1722 @value = @prev if !$do_override && @prev;
1724 $name=$self->escapeHTML($name);
1726 $_=$self->escapeHTML($_);
1727 push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
1729 return wantarray ? @result : join('',@result);
1734 #### Method: image_button
1736 # $name -> Name of the button
1737 # $src -> URL of the image source
1738 # $align -> Alignment style (TOP, BOTTOM or MIDDLE)
1740 # A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment">
1742 'image_button' => <<'END_OF_FUNC',
1744 my($self,@p) = self_or_default(@_);
1746 my($name,$src,$alignment,@other) =
1747 $self->rearrange([NAME,SRC,ALIGN],@p);
1749 my($align) = $alignment ? " ALIGN=\U$alignment" : '';
1750 my($other) = @other ? " @other" : '';
1751 $name=$self->escapeHTML($name);
1752 return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/;
1757 #### Method: self_url
1758 # Returns a URL containing the current script and all its
1759 # param/value pairs arranged as a query. You can use this
1760 # to create a link that, when selected, will reinvoke the
1761 # script with all its state information preserved.
1763 'self_url' => <<'END_OF_FUNC',
1765 my($self) = self_or_default(@_);
1766 my($query_string) = $self->query_string;
1767 my $protocol = $self->protocol();
1768 my $name = "$protocol://" . $self->server_name;
1769 $name .= ":" . $self->server_port
1770 unless $self->server_port == 80;
1771 $name .= $self->script_name;
1772 $name .= $self->path_info if $self->path_info;
1773 return $name unless $query_string;
1774 return "$name?$query_string";
1779 # This is provided as a synonym to self_url() for people unfortunate
1780 # enough to have incorporated it into their programs already!
1781 'state' => <<'END_OF_FUNC',
1789 # Like self_url, but doesn't return the query string part of
1792 'url' => <<'END_OF_FUNC',
1794 my($self) = self_or_default(@_);
1795 my $protocol = $self->protocol();
1796 my $name = "$protocol://" . $self->server_name;
1797 $name .= ":" . $self->server_port
1798 unless $self->server_port == 80;
1799 $name .= $self->script_name;
1806 # Set or read a cookie from the specified name.
1807 # Cookie can then be passed to header().
1808 # Usual rules apply to the stickiness of -value.
1810 # -name -> name for this cookie (optional)
1811 # -value -> value of this cookie (scalar, array or hash)
1812 # -path -> paths for which this cookie is valid (optional)
1813 # -domain -> internet domain in which this cookie is valid (optional)
1814 # -secure -> if true, cookie only passed through secure channel (optional)
1815 # -expires -> expiry date in format Wdy, DD-Mon-YY HH:MM:SS GMT (optional)
1817 'cookie' => <<'END_OF_FUNC',
1818 # temporary, for debugging.
1820 my($self,@p) = self_or_default(@_);
1821 my($name,$value,$path,$domain,$secure,$expires) =
1822 $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
1825 # if no value is supplied, then we retrieve the
1826 # value of the cookie, if any. For efficiency, we cache the parsed
1827 # cookie in our state variables.
1828 unless (defined($value)) {
1829 unless ($self->{'.cookies'}) {
1830 my(@pairs) = split("; ",$self->raw_cookie);
1832 my($key,$value) = split("=");
1833 my(@values) = map unescape($_),split('&',$value);
1834 $self->{'.cookies'}->{unescape($key)} = [@values];
1838 # If no name is supplied, then retrieve the names of all our cookies.
1839 return () unless $self->{'.cookies'};
1840 return wantarray ? @{$self->{'.cookies'}->{$name}} : $self->{'.cookies'}->{$name}->[0]
1841 if defined($name) && $name ne '';
1842 return keys %{$self->{'.cookies'}};
1846 # Pull out our parameters.
1848 if (ref($value) eq 'ARRAY') {
1850 } elsif (ref($value) eq 'HASH') {
1856 @values = map escape($_),@values;
1858 # I.E. requires the path to be present.
1859 ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $path;
1861 my(@constant_values);
1862 push(@constant_values,"domain=$domain") if $domain;
1863 push(@constant_values,"path=$path") if $path;
1864 push(@constant_values,"expires=".&expires($expires)) if $expires;
1865 push(@constant_values,'secure') if $secure;
1867 my($key) = &escape($name);
1868 my($cookie) = join("=",$key,join("&",@values));
1869 return join("; ",$cookie,@constant_values);
1874 # This internal routine creates an expires string exactly some number of
1875 # hours from the current time in GMT. This is the format
1876 # required by Netscape cookies, and I think it works for the HTTP
1877 # Expires: header as well.
1878 'expires' => <<'END_OF_FUNC',
1881 my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
1882 my(@WDAY) = qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/;
1883 my(%mult) = ('s'=>1,
1889 # format for time can be in any of the forms...
1890 # "now" -- expire immediately
1891 # "+180s" -- in 180 seconds
1892 # "+2m" -- in 2 minutes
1893 # "+12h" -- in 12 hours
1895 # "+3M" -- in 3 months
1896 # "+2y" -- in 2 years
1897 # "-3m" -- 3 minutes ago(!)
1898 # If you don't supply one of these forms, we assume you are
1899 # specifying the date yourself
1901 if (!$time || ($time eq 'now')) {
1903 } elsif ($time=~/^([+-]?\d+)([mhdMy]?)/) {
1904 $offset = ($mult{$2} || 1)*$1;
1908 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime(time+$offset);
1909 $year += 1900 unless $year < 100;
1910 return sprintf("%s, %02d-%s-%02d %02d:%02d:%02d GMT",
1911 $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
1916 ###############################################
1917 # OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
1918 ###############################################
1920 #### Method: path_info
1921 # Return the extra virtual path information provided
1922 # after the URL (if any)
1924 'path_info' => <<'END_OF_FUNC',
1926 return $ENV{'PATH_INFO'};
1931 #### Method: request_method
1932 # Returns 'POST', 'GET', 'PUT' or 'HEAD'
1934 'request_method' => <<'END_OF_FUNC',
1935 sub request_method {
1936 return $ENV{'REQUEST_METHOD'};
1940 #### Method: path_translated
1941 # Return the physical path information provided
1942 # by the URL (if any)
1944 'path_translated' => <<'END_OF_FUNC',
1945 sub path_translated {
1946 return $ENV{'PATH_TRANSLATED'};
1951 #### Method: query_string
1952 # Synthesize a query string from our current
1955 'query_string' => <<'END_OF_FUNC',
1957 my($self) = self_or_default(@_);
1958 my($param,$value,@pairs);
1959 foreach $param ($self->param) {
1960 my($eparam) = &escape($param);
1961 foreach $value ($self->param($param)) {
1962 $value = &escape($value);
1963 push(@pairs,"$eparam=$value");
1966 return join("&",@pairs);
1972 # Without parameters, returns an array of the
1973 # MIME types the browser accepts.
1974 # With a single parameter equal to a MIME
1975 # type, will return undef if the browser won't
1976 # accept it, 1 if the browser accepts it but
1977 # doesn't give a preference, or a floating point
1978 # value between 0.0 and 1.0 if the browser
1979 # declares a quantitative score for it.
1980 # This handles MIME type globs correctly.
1982 'accept' => <<'END_OF_FUNC',
1984 my($self,$search) = self_or_CGI(@_);
1985 my(%prefs,$type,$pref,$pat);
1987 my(@accept) = split(',',$self->http('accept'));
1990 ($pref) = /q=(\d\.\d+|\d+)/;
1991 ($type) = m#(\S+/[^;]+)#;
1993 $prefs{$type}=$pref || 1;
1996 return keys %prefs unless $search;
1998 # if a search type is provided, we may need to
1999 # perform a pattern matching operation.
2000 # The MIME types use a glob mechanism, which
2001 # is easily translated into a perl pattern match
2003 # First return the preference for directly supported
2005 return $prefs{$search} if $prefs{$search};
2007 # Didn't get it, so try pattern matching.
2008 foreach (keys %prefs) {
2009 next unless /\*/; # not a pattern match
2010 ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2011 $pat =~ s/\*/.*/g; # turn it into a pattern
2012 return $prefs{$_} if $search=~/$pat/;
2018 #### Method: user_agent
2019 # If called with no parameters, returns the user agent.
2020 # If called with one parameter, does a pattern match (case
2021 # insensitive) on the user agent.
2023 'user_agent' => <<'END_OF_FUNC',
2025 my($self,$match)=self_or_CGI(@_);
2026 return $self->http('user_agent') unless $match;
2027 return $self->http('user_agent') =~ /$match/i;
2033 # Returns the magic cookie for the session.
2034 # To set the magic cookie for new transations,
2035 # try print $q->header('-Set-cookie'=>'my cookie')
2037 'raw_cookie' => <<'END_OF_FUNC',
2039 my($self) = self_or_CGI(@_);
2040 return $self->http('cookie') || $ENV{'COOKIE'} || '';
2044 #### Method: virtual_host
2045 # Return the name of the virtual_host, which
2046 # is not always the same as the server
2048 'virtual_host' => <<'END_OF_FUNC',
2050 return http('host') || server_name();
2054 #### Method: remote_host
2055 # Return the name of the remote host, or its IP
2056 # address if unavailable. If this variable isn't
2057 # defined, it returns "localhost" for debugging
2060 'remote_host' => <<'END_OF_FUNC',
2062 return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
2068 #### Method: remote_addr
2069 # Return the IP addr of the remote host.
2071 'remote_addr' => <<'END_OF_FUNC',
2073 return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
2078 #### Method: script_name
2079 # Return the partial URL to this script for
2080 # self-referencing scripts. Also see
2081 # self_url(), which returns a URL with all state information
2084 'script_name' => <<'END_OF_FUNC',
2086 return $ENV{'SCRIPT_NAME'} if $ENV{'SCRIPT_NAME'};
2087 # These are for debugging
2088 return "/$0" unless $0=~/^\//;
2094 #### Method: referer
2095 # Return the HTTP_REFERER: useful for generating
2098 'referer' => <<'END_OF_FUNC',
2100 my($self) = self_or_CGI(@_);
2101 return $self->http('referer');
2106 #### Method: server_name
2107 # Return the name of the server
2109 'server_name' => <<'END_OF_FUNC',
2111 return $ENV{'SERVER_NAME'} || 'localhost';
2115 #### Method: server_software
2116 # Return the name of the server software
2118 'server_software' => <<'END_OF_FUNC',
2119 sub server_software {
2120 return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
2124 #### Method: server_port
2125 # Return the tcp/ip port the server is running on
2127 'server_port' => <<'END_OF_FUNC',
2129 return $ENV{'SERVER_PORT'} || 80; # for debugging
2133 #### Method: server_protocol
2134 # Return the protocol (usually HTTP/1.0)
2136 'server_protocol' => <<'END_OF_FUNC',
2137 sub server_protocol {
2138 return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
2143 # Return the value of an HTTP variable, or
2144 # the list of variables if none provided
2146 'http' => <<'END_OF_FUNC',
2148 my ($self,$parameter) = self_or_CGI(@_);
2149 return $ENV{$parameter} if $parameter=~/^HTTP/;
2150 return $ENV{"HTTP_\U$parameter\E"} if $parameter;
2152 foreach (keys %ENV) {
2153 push(@p,$_) if /^HTTP/;
2160 # Return the value of HTTPS
2162 'https' => <<'END_OF_FUNC',
2165 my ($self,$parameter) = self_or_CGI(@_);
2166 return $ENV{HTTPS} unless $parameter;
2167 return $ENV{$parameter} if $parameter=~/^HTTPS/;
2168 return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
2170 foreach (keys %ENV) {
2171 push(@p,$_) if /^HTTPS/;
2177 #### Method: protocol
2178 # Return the protocol (http or https currently)
2180 'protocol' => <<'END_OF_FUNC',
2184 return 'https' if $self->https() eq 'ON';
2185 return 'https' if $self->server_port == 443;
2186 my $prot = $self->server_protocol;
2187 my($protocol,$version) = split('/',$prot);
2188 return "\L$protocol\E";
2192 #### Method: remote_ident
2193 # Return the identity of the remote user
2194 # (but only if his host is running identd)
2196 'remote_ident' => <<'END_OF_FUNC',
2198 return $ENV{'REMOTE_IDENT'};
2203 #### Method: auth_type
2204 # Return the type of use verification/authorization in use, if any.
2206 'auth_type' => <<'END_OF_FUNC',
2208 return $ENV{'AUTH_TYPE'};
2213 #### Method: remote_user
2214 # Return the authorization name used for user
2217 'remote_user' => <<'END_OF_FUNC',
2219 return $ENV{'REMOTE_USER'};
2224 #### Method: user_name
2225 # Try to return the remote user's name by hook or by
2228 'user_name' => <<'END_OF_FUNC',
2230 my ($self) = self_or_CGI(@_);
2231 return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
2236 # Set or return the NPH global flag
2238 'nph' => <<'END_OF_FUNC',
2240 my ($self,$param) = self_or_CGI(@_);
2241 $CGI::nph = $param if defined($param);
2246 # -------------- really private subroutines -----------------
2247 'previous_or_default' => <<'END_OF_FUNC',
2248 sub previous_or_default {
2249 my($self,$name,$defaults,$override) = @_;
2252 if (!$override && ($self->{'.fieldnames'}->{$name} ||
2253 defined($self->param($name)) ) ) {
2254 grep($selected{$_}++,$self->param($name));
2255 } elsif (defined($defaults) && ref($defaults) &&
2256 (ref($defaults) eq 'ARRAY')) {
2257 grep($selected{$_}++,@{$defaults});
2259 $selected{$defaults}++ if defined($defaults);
2266 'register_parameter' => <<'END_OF_FUNC',
2267 sub register_parameter {
2268 my($self,$param) = @_;
2269 $self->{'.parametersToAdd'}->{$param}++;
2273 'get_fields' => <<'END_OF_FUNC',
2276 return $self->hidden('-name'=>'.cgifields',
2277 '-values'=>[keys %{$self->{'.parametersToAdd'}}],
2282 'read_from_cmdline' => <<'END_OF_FUNC',
2283 sub read_from_cmdline {
2284 require "shellwords.pl";
2288 $input = join(" ",@ARGV);
2290 print STDERR "(offline mode: enter name=value pairs on standard input)\n";
2291 chomp(@lines = <>); # remove newlines
2292 $input = join(" ",@lines);
2295 # minimal handling of escape characters
2296 $input=~s/\\=/%3D/g;
2297 $input=~s/\\&/%26/g;
2299 @words = &shellwords($input);
2300 if ("@words"=~/=/) {
2301 $query_string = join('&',@words);
2303 $query_string = join('+',@words);
2305 return $query_string;
2310 # subroutine: read_multipart
2312 # Read multipart data and store it into our parameters.
2313 # An interesting feature is that if any of the parts is a file, we
2314 # create a temporary file and open up a filehandle on it so that the
2315 # caller can read from it if necessary.
2317 'read_multipart' => <<'END_OF_FUNC',
2318 sub read_multipart {
2319 my($self,$boundary,$length) = @_;
2320 my($buffer) = $self->new_MultipartBuffer($boundary,$length);
2321 return unless $buffer;
2323 while (!$buffer->eof) {
2324 %header = $buffer->readHeader;
2326 # In beta1 it was "Content-disposition". In beta2 it's "Content-Disposition"
2328 my($key) = $header{'Content-disposition'} ? 'Content-disposition' : 'Content-Disposition';
2329 my($param)= $header{$key}=~/ name="([^\"]*)"/;
2331 # possible bug: our regular expression expects the filename= part to fall
2332 # at the end of the line. Netscape doesn't escape quotation marks in file names!!!
2333 my($filename) = $header{$key}=~/ filename="(.*)"$/;
2335 # add this parameter to our list
2336 $self->add_parameter($param);
2338 # If no filename specified, then just read the data and assign it
2339 # to our parameter list.
2340 unless ($filename) {
2341 my($value) = $buffer->readBody;
2342 push(@{$self->{$param}},$value);
2346 # If we get here, then we are dealing with a potentially large
2347 # uploaded form. Save the data to a temporary file, then open
2348 # the file for reading.
2349 my($tmpfile) = new TempFile;
2350 my $tmp = $tmpfile->as_string;
2352 open (OUT,">$tmp") || die "CGI open of $tmpfile: $!\n";
2353 $CGI::DefaultClass->binmode(OUT) if $CGI::needs_binmode;
2354 chmod 0666,$tmp; # make sure anyone can delete it.
2356 while ($data = $buffer->read) {
2361 # Now create a new filehandle in the caller's namespace.
2362 # The name of this filehandle just happens to be identical
2363 # to the original filename (NOT the name of the temporary
2364 # file, which is hidden!)
2366 if ($filename=~/^[a-zA-Z_]/) {
2368 do { $cp = caller($frame++); } until !eval("'$cp'->isaCGI()");
2369 $filehandle = "$cp\:\:$filename";
2371 $filehandle = "\:\:$filename";
2374 open($filehandle,$tmp) || die "CGI open of $tmp: $!\n";
2375 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2377 push(@{$self->{$param}},$filename);
2379 # Under Unix, it would be safe to let the temporary file
2380 # be deleted immediately. However, I fear that other operating
2381 # systems are not so forgiving. Therefore we save a reference
2382 # to the temporary file in the CGI object so that the file
2383 # isn't unlinked until the CGI object itself goes out of
2384 # scope. This is a bit hacky, but it has the interesting side
2385 # effect that one can access the name of the tmpfile by
2386 # asking for $query->{$query->param('foo')}, where 'foo'
2387 # is the name of the file upload field.
2388 $self->{'.tmpfiles'}->{$filename}= {
2396 'tmpFileName' => <<'END_OF_FUNC',
2398 my($self,$filename) = self_or_default(@_);
2399 return $self->{'.tmpfiles'}->{$filename}->{name}->as_string;
2403 'uploadInfo' => <<'END_OF_FUNC'
2405 my($self,$filename) = self_or_default(@_);
2406 return $self->{'.tmpfiles'}->{$filename}->{info};
2414 # Globals and stubs for other packages that we use
2415 package MultipartBuffer;
2417 # how many bytes to read at a time. We use
2418 # a 5K buffer by default.
2419 $FILLUNIT = 1024 * 5;
2420 $TIMEOUT = 10*60; # 10 minute timeout
2421 $SPIN_LOOP_MAX = 1000; # bug fix for some Netscape servers
2424 #reuse the autoload function
2425 *MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
2427 ###############################################################################
2428 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
2429 ###############################################################################
2430 $AUTOLOADED_ROUTINES = ''; # prevent -w error
2431 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
2434 'new' => <<'END_OF_FUNC',
2436 my($package,$interface,$boundary,$length,$filehandle) = @_;
2439 my($package) = caller;
2440 # force into caller's package if necessary
2441 $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
2443 $IN = "main::STDIN" unless $IN;
2445 $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
2447 # If the user types garbage into the file upload field,
2448 # then Netscape passes NOTHING to the server (not good).
2449 # We may hang on this read in that case. So we implement
2450 # a read timeout. If nothing is ready to read
2451 # by then, we return.
2453 # Netscape seems to be a little bit unreliable
2454 # about providing boundary strings.
2457 # Under the MIME spec, the boundary consists of the
2458 # characters "--" PLUS the Boundary string
2459 $boundary = "--$boundary";
2460 # Read the topmost (boundary) line plus the CRLF
2462 $length -= $interface->read_from_client($IN,\$null,length($boundary)+2,0);
2464 } else { # otherwise we find it ourselves
2466 ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
2467 $boundary = <$IN>; # BUG: This won't work correctly under mod_perl
2468 $length -= length($boundary);
2469 chomp($boundary); # remove the CRLF
2470 $/ = $old; # restore old line separator
2473 my $self = {LENGTH=>$length,
2474 BOUNDARY=>$boundary,
2476 INTERFACE=>$interface,
2480 $FILLUNIT = length($boundary)
2481 if length($boundary) > $FILLUNIT;
2483 return bless $self,ref $package || $package;
2487 'readHeader' => <<'END_OF_FUNC',
2493 $self->fillBuffer($FILLUNIT);
2494 $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
2495 $ok++ if $self->{BUFFER} eq '';
2496 $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
2499 my($header) = substr($self->{BUFFER},0,$end+2);
2500 substr($self->{BUFFER},0,$end+4) = '';
2502 while ($header=~/^([\w-]+): (.*)$CRLF/mog) {
2509 # This reads and returns the body as a single scalar value.
2510 'readBody' => <<'END_OF_FUNC',
2515 while (defined($data = $self->read)) {
2516 $returnval .= $data;
2522 # This will read $bytes or until the boundary is hit, whichever happens
2523 # first. After the boundary is hit, we return undef. The next read will
2524 # skip over the boundary and begin reading again;
2525 'read' => <<'END_OF_FUNC',
2527 my($self,$bytes) = @_;
2529 # default number of bytes to read
2530 $bytes = $bytes || $FILLUNIT;
2532 # Fill up our internal buffer in such a way that the boundary
2533 # is never split between reads.
2534 $self->fillBuffer($bytes);
2536 # Find the boundary in the buffer (it may not be there).
2537 my $start = index($self->{BUFFER},$self->{BOUNDARY});
2539 # If the boundary begins the data, then skip past it
2540 # and return undef. The +2 here is a fiendish plot to
2541 # remove the CR/LF pair at the end of the boundary.
2544 # clear us out completely if we've hit the last boundary.
2545 if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
2551 # just remove the boundary.
2552 substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
2557 if ($start > 0) { # read up to the boundary
2558 $bytesToReturn = $start > $bytes ? $bytes : $start;
2559 } else { # read the requested number of bytes
2560 # leave enough bytes in the buffer to allow us to read
2561 # the boundary. Thanks to Kevin Hendrick for finding
2563 $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
2566 my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
2567 substr($self->{BUFFER},0,$bytesToReturn)='';
2569 # If we hit the boundary, remove the CRLF from the end.
2570 return ($start > 0) ? substr($returnval,0,-2) : $returnval;
2575 # This fills up our internal buffer in such a way that the
2576 # boundary is never split between reads
2577 'fillBuffer' => <<'END_OF_FUNC',
2579 my($self,$bytes) = @_;
2580 return unless $self->{LENGTH};
2582 my($boundaryLength) = length($self->{BOUNDARY});
2583 my($bufferLength) = length($self->{BUFFER});
2584 my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
2585 $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
2587 # Try to read some data. We may hang here if the browser is screwed up.
2588 my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN},
2593 # An apparent bug in the Netscape Commerce server causes the read()
2594 # to return zero bytes repeatedly without blocking if the
2595 # remote user aborts during a file transfer. I don't know how
2596 # they manage this, but the workaround is to abort if we get
2597 # more than SPIN_LOOP_MAX consecutive zero reads.
2598 if ($bytesRead == 0) {
2599 die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
2600 if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
2602 $self->{ZERO_LOOP_COUNTER}=0;
2605 $self->{LENGTH} -= $bytesRead;
2610 # Return true when we've finished reading
2611 'eof' => <<'END_OF_FUNC'
2614 return 1 if (length($self->{BUFFER}) == 0)
2615 && ($self->{LENGTH} <= 0);
2623 ####################################################################################
2624 ################################## TEMPORARY FILES #################################
2625 ####################################################################################
2629 unless ($TMPDIRECTORY) {
2630 @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp","${SL}tmp","${SL}temp","${SL}Temporary Items");
2632 do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
2636 $TMPDIRECTORY = "." unless $TMPDIRECTORY;
2637 $SEQUENCE="CGItemp${$}0000";
2639 # cute feature, but overload implementation broke it
2640 # %OVERLOAD = ('""'=>'as_string');
2641 *TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
2643 ###############################################################################
2644 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
2645 ###############################################################################
2646 $AUTOLOADED_ROUTINES = ''; # prevent -w error
2647 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
2650 'new' => <<'END_OF_FUNC',
2654 my $directory = "${TMPDIRECTORY}${SL}${SEQUENCE}";
2655 return bless \$directory;
2659 'DESTROY' => <<'END_OF_FUNC',
2662 unlink $$self; # get rid of the file
2666 'as_string' => <<'END_OF_FUNC'
2678 # We get a whole bunch of warnings about "possibly uninitialized variables"
2679 # when running with the -w switch. Touch them all once to get rid of the
2680 # warnings. This is ugly and I hate it.
2685 $MultipartBuffer::SPIN_LOOP_MAX;
2686 $MultipartBuffer::CRLF;
2687 $MultipartBuffer::TIMEOUT;
2688 $MultipartBuffer::FILLUNIT;
2689 $TempFile::SEQUENCE;
2700 CGI - Simple Common Gateway Interface Class
2705 # the rest is too complicated for a synopsis; keep reading
2709 This perl library uses perl5 objects to make it easy to create
2710 Web fill-out forms and parse their contents. This package
2711 defines CGI objects, entities that contain the values of the
2712 current query string and other state variables.
2713 Using a CGI object's methods, you can examine keywords and parameters
2714 passed to your script, and create forms whose initial values
2715 are taken from the current query (thereby preserving state
2718 The current version of CGI.pm is available at
2720 http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
2721 ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
2723 =head1 INSTALLATION:
2725 To install this package, just change to the directory in which this
2726 file is found and type the following:
2732 This will copy CGI.pm to your perl library directory for use by all
2733 perl scripts. You probably must be root to do this. Now you can
2734 load the CGI routines in your Perl scripts with the line:
2738 If you don't have sufficient privileges to install CGI.pm in the Perl
2739 library directory, you can put CGI.pm into some convenient spot, such
2740 as your home directory, or in cgi-bin itself and prefix all Perl
2741 scripts that call it with something along the lines of the following
2744 use lib '/home/davis/lib';
2747 If you are using a version of perl earlier than 5.002 (such as NT perl), use
2751 unshift(@INC,'/home/davis/lib');
2755 The CGI distribution also comes with a cute module called L<CGI::Carp>.
2756 It redefines the die(), warn(), confess() and croak() error routines
2757 so that they write nicely formatted error messages into the server's
2758 error log (or to the output stream of your choice). This avoids long
2759 hours of groping through the error and access logs, trying to figure
2760 out which CGI script is generating error messages. If you choose,
2761 you can even have fatal error messages echoed to the browser to avoid
2762 the annoying and uninformative "Server Error" message.
2766 =head2 CREATING A NEW QUERY OBJECT:
2770 This will parse the input (from both POST and GET methods) and store
2771 it into a perl5 object called $query.
2773 =head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
2775 $query = new CGI(INPUTFILE);
2777 If you provide a file handle to the new() method, it
2778 will read parameters from the file (or STDIN, or whatever). The
2779 file can be in any of the forms describing below under debugging
2780 (i.e. a series of newline delimited TAG=VALUE pairs will work).
2781 Conveniently, this type of file is created by the save() method
2782 (see below). Multiple records can be saved and restored.
2784 Perl purists will be pleased to know that this syntax accepts
2785 references to file handles, or even references to filehandle globs,
2786 which is the "official" way to pass a filehandle:
2788 $query = new CGI(\*STDIN);
2790 You can also initialize the query object from an associative array
2793 $query = new CGI( {'dinosaur'=>'barney',
2794 'song'=>'I love you',
2795 'friends'=>[qw/Jessica George Nancy/]}
2798 or from a properly formatted, URL-escaped query string:
2800 $query = new CGI('dinosaur=barney&color=purple');
2802 To create an empty query, initialize it from an empty string or hash:
2804 $empty_query = new CGI("");
2806 $empty_query = new CGI({});
2808 =head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
2810 @keywords = $query->keywords
2812 If the script was invoked as the result of an <ISINDEX> search, the
2813 parsed keywords can be obtained as an array using the keywords() method.
2815 =head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
2817 @names = $query->param
2819 If the script was invoked with a parameter list
2820 (e.g. "name1=value1&name2=value2&name3=value3"), the param()
2821 method will return the parameter names as a list. If the
2822 script was invoked as an <ISINDEX> script, there will be a
2823 single parameter named 'keywords'.
2825 NOTE: As of version 1.5, the array of parameter names returned will
2826 be in the same order as they were submitted by the browser.
2827 Usually this order is the same as the order in which the
2828 parameters are defined in the form (however, this isn't part
2829 of the spec, and so isn't guaranteed).
2831 =head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
2833 @values = $query->param('foo');
2837 $value = $query->param('foo');
2839 Pass the param() method a single argument to fetch the value of the
2840 named parameter. If the parameter is multivalued (e.g. from multiple
2841 selections in a scrolling list), you can ask to receive an array. Otherwise
2842 the method will return a single value.
2844 =head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
2846 $query->param('foo','an','array','of','values');
2848 This sets the value for the named parameter 'foo' to an array of
2849 values. This is one way to change the value of a field AFTER
2850 the script has been invoked once before. (Another way is with
2851 the -override parameter accepted by all methods that generate
2854 param() also recognizes a named parameter style of calling described
2855 in more detail later:
2857 $query->param(-name=>'foo',-values=>['an','array','of','values']);
2861 $query->param(-name=>'foo',-value=>'the value');
2863 =head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
2865 $query->append(-name=>;'foo',-values=>['yet','more','values']);
2867 This adds a value or list of values to the named parameter. The
2868 values are appended to the end of the parameter if it already exists.
2869 Otherwise the parameter is created. Note that this method only
2870 recognizes the named argument calling syntax.
2872 =head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
2874 $query->import_names('R');
2876 This creates a series of variables in the 'R' namespace. For example,
2877 $R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
2878 If no namespace is given, this method will assume 'Q'.
2879 WARNING: don't import anything into 'main'; this is a major security
2882 In older versions, this method was called B<import()>. As of version 2.20,
2883 this name has been removed completely to avoid conflict with the built-in
2884 Perl module B<import> operator.
2886 =head2 DELETING A PARAMETER COMPLETELY:
2888 $query->delete('foo');
2890 This completely clears a parameter. It sometimes useful for
2891 resetting parameters that you don't want passed down between
2894 =head2 DELETING ALL PARAMETERS:
2896 $query->delete_all();
2898 This clears the CGI object completely. It might be useful to ensure
2899 that all the defaults are taken when you create a fill-out form.
2901 =head2 SAVING THE STATE OF THE FORM TO A FILE:
2903 $query->save(FILEHANDLE)
2905 This will write the current state of the form to the provided
2906 filehandle. You can read it back in by providing a filehandle
2907 to the new() method. Note that the filehandle can be a file, a pipe,
2910 The format of the saved file is:
2918 Both name and value are URL escaped. Multi-valued CGI parameters are
2919 represented as repeated names. A session record is delimited by a
2920 single = symbol. You can write out multiple records and read them
2921 back in with several calls to B<new>. You can do this across several
2922 sessions by opening the file in append mode, allowing you to create
2923 primitive guest books, or to keep a history of users' queries. Here's
2924 a short example of creating multiple session records:
2928 open (OUT,">>test.out") || die;
2930 foreach (0..$records) {
2932 $q->param(-name=>'counter',-value=>$_);
2937 # reopen for reading
2938 open (IN,"test.out") || die;
2940 my $q = new CGI(IN);
2941 print $q->param('counter'),"\n";
2944 The file format used for save/restore is identical to that used by the
2945 Whitehead Genome Center's data exchange format "Boulderio", and can be
2946 manipulated and even databased using Boulderio utilities. See
2948 http://www.genome.wi.mit.edu/genome_software/other/boulder.html
2950 for further details.
2952 =head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
2954 $myself = $query->self_url;
2955 print "<A HREF=$myself>I'm talking to myself.</A>";
2957 self_url() will return a URL, that, when selected, will reinvoke
2958 this script with all its state information intact. This is most
2959 useful when you want to jump around within the document using
2960 internal anchors but you don't want to disrupt the current contents
2961 of the form(s). Something like this will do the trick.
2963 $myself = $query->self_url;
2964 print "<A HREF=$myself#table1>See table 1</A>";
2965 print "<A HREF=$myself#table2>See table 2</A>";
2966 print "<A HREF=$myself#yourself>See for yourself</A>";
2968 If you don't want to get the whole query string, call
2969 the method url() to return just the URL for the script:
2971 $myself = $query->url;
2972 print "<A HREF=$myself>No query string in this baby!</A>\n";
2974 You can also retrieve the unprocessed query string with query_string():
2976 $the_string = $query->query_string;
2978 =head2 COMPATIBILITY WITH CGI-LIB.PL
2980 To make it easier to port existing programs that use cgi-lib.pl
2981 the compatibility routine "ReadParse" is provided. Porting is
2985 require "cgi-lib.pl";
2987 print "The value of the antique is $in{antique}.\n";
2992 print "The value of the antique is $in{antique}.\n";
2994 CGI.pm's ReadParse() routine creates a tied variable named %in,
2995 which can be accessed to obtain the query variables. Like
2996 ReadParse, you can also provide your own variable. Infrequently
2997 used features of ReadParse, such as the creation of @in and $in
2998 variables, are not supported.
3000 Once you use ReadParse, you can retrieve the query object itself
3004 print $q->textfield(-name=>'wow',
3005 -value=>'does this really work?');
3007 This allows you to start using the more interesting features
3008 of CGI.pm without rewriting your old scripts from scratch.
3010 =head2 CALLING CGI FUNCTIONS THAT TAKE MULTIPLE ARGUMENTS
3012 In versions of CGI.pm prior to 2.0, it could get difficult to remember
3013 the proper order of arguments in CGI function calls that accepted five
3014 or six different arguments. As of 2.0, there's a better way to pass
3015 arguments to the various CGI functions. In this style, you pass a
3016 series of name=>argument pairs, like this:
3018 $field = $query->radio_group(-name=>'OS',
3019 -values=>[Unix,Windows,Macintosh],
3022 The advantages of this style are that you don't have to remember the
3023 exact order of the arguments, and if you leave out a parameter, in
3024 most cases it will default to some reasonable value. If you provide
3025 a parameter that the method doesn't recognize, it will usually do
3026 something useful with it, such as incorporating it into the HTML form
3027 tag. For example if Netscape decides next week to add a new
3028 JUSTIFICATION parameter to the text field tags, you can start using
3029 the feature without waiting for a new version of CGI.pm:
3031 $field = $query->textfield(-name=>'State',
3032 -default=>'gaseous',
3033 -justification=>'RIGHT');
3035 This will result in an HTML tag that looks like this:
3037 <INPUT TYPE="textfield" NAME="State" VALUE="gaseous"
3038 JUSTIFICATION="RIGHT">
3040 Parameter names are case insensitive: you can use -name, or -Name or
3041 -NAME. You don't have to use the hyphen if you don't want to. After
3042 creating a CGI object, call the B<use_named_parameters()> method with
3043 a nonzero value. This will tell CGI.pm that you intend to use named
3044 parameters exclusively:
3047 $query->use_named_parameters(1);
3048 $field = $query->radio_group('name'=>'OS',
3049 'values'=>['Unix','Windows','Macintosh'],
3052 Actually, CGI.pm only looks for a hyphen in the first parameter. So
3053 you can leave it off subsequent parameters if you like. Something to
3054 be wary of is the potential that a string constant like "values" will
3055 collide with a keyword (and in fact it does!) While Perl usually
3056 figures out when you're referring to a function and when you're
3057 referring to a string, you probably should put quotation marks around
3058 all string constants just to play it safe.
3060 =head2 CREATING THE HTTP HEADER:
3062 print $query->header;
3066 print $query->header('image/gif');
3070 print $query->header('text/html','204 No response');
3074 print $query->header(-type=>'image/gif',
3076 -status=>'402 Payment required',
3081 header() returns the Content-type: header. You can provide your own
3082 MIME type if you choose, otherwise it defaults to text/html. An
3083 optional second parameter specifies the status code and a human-readable
3084 message. For example, you can specify 204, "No response" to create a
3085 script that tells the browser to do nothing at all. If you want to
3086 add additional fields to the header, just tack them on to the end:
3088 print $query->header('text/html','200 OK','Content-Length: 3002');
3090 The last example shows the named argument style for passing arguments
3091 to the CGI methods using named parameters. Recognized parameters are
3092 B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other
3093 parameters will be stripped of their initial hyphens and turned into
3094 header fields, allowing you to specify any HTTP header you desire.
3096 Most browsers will not cache the output from CGI scripts. Every time
3097 the browser reloads the page, the script is invoked anew. You can
3098 change this behavior with the B<-expires> parameter. When you specify
3099 an absolute or relative expiration interval with this parameter, some
3100 browsers and proxy servers will cache the script's output until the
3101 indicated expiration date. The following forms are all valid for the
3104 +30s 30 seconds from now
3105 +10m ten minutes from now
3106 +1h one hour from now
3107 -1d yesterday (i.e. "ASAP!")
3110 +10y in ten years time
3111 Thursday, 25-Apr-96 00:40:33 GMT at the indicated time & date
3113 (CGI::expires() is the static function call used internally that turns
3114 relative time intervals into HTTP dates. You can call it directly if
3117 The B<-cookie> parameter generates a header that tells the browser to provide
3118 a "magic cookie" during all subsequent transactions with your script.
3119 Netscape cookies have a special format that includes interesting attributes
3120 such as expiration time. Use the cookie() method to create and retrieve
3123 The B<-nph> parameter, if set to a true value, will issue the correct
3124 headers to work with a NPH (no-parse-header) script. This is important
3125 to use with certain servers, such as Microsoft Internet Explorer, which
3126 expect all their scripts to be NPH.
3128 =head2 GENERATING A REDIRECTION INSTRUCTION
3130 print $query->redirect('http://somewhere.else/in/movie/land');
3132 redirects the browser elsewhere. If you use redirection like this,
3133 you should B<not> print out a header as well. As of version 2.0, we
3134 produce both the unofficial Location: header and the official URI:
3135 header. This should satisfy most servers and browsers.
3137 One hint I can offer is that relative links may not work correctly
3138 when when you generate a redirection to another document on your site.
3139 This is due to a well-intentioned optimization that some servers use.
3140 The solution to this is to use the full URL (including the http: part)
3141 of the document you are redirecting to.
3143 You can use named parameters:
3145 print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
3148 The B<-nph> parameter, if set to a true value, will issue the correct
3149 headers to work with a NPH (no-parse-header) script. This is important
3150 to use with certain servers, such as Microsoft Internet Explorer, which
3151 expect all their scripts to be NPH.
3154 =head2 CREATING THE HTML HEADER:
3156 print $query->start_html(-title=>'Secrets of the Pyramids',
3157 -author=>'fred@capricorn.org',
3160 -meta=>{'keywords'=>'pharaoh secret mummy',
3161 'copyright'=>'copyright 1996 King Tut'},
3166 print $query->start_html('Secrets of the Pyramids',
3167 'fred@capricorn.org','true',
3170 This will return a canned HTML header and the opening <BODY> tag.
3171 All parameters are optional. In the named parameter form, recognized
3172 parameters are -title, -author, -base, -xbase and -target (see below for the
3173 explanation). Any additional parameters you provide, such as the
3174 Netscape unofficial BGCOLOR attribute, are added to the <BODY> tag.
3176 The argument B<-xbase> allows you to provide an HREF for the <BASE> tag
3177 different from the current location, as in
3179 -xbase=>"http://home.mcom.com/"
3181 All relative links will be interpreted relative to this tag.
3183 The argument B<-target> allows you to provide a default target frame
3184 for all the links and fill-out forms on the page. See the Netscape
3185 documentation on frames for details of how to manipulate this.
3187 -target=>"answer_window"
3189 All relative links will be interpreted relative to this tag.
3190 You add arbitrary meta information to the header with the B<-meta>
3191 argument. This argument expects a reference to an associative array
3192 containing name/value pairs of meta information. These will be turned
3193 into a series of header <META> tags that look something like this:
3195 <META NAME="keywords" CONTENT="pharaoh secret mummy">
3196 <META NAME="description" CONTENT="copyright 1996 King Tut">
3198 There is no support for the HTTP-EQUIV type of <META> tag. This is
3199 because you can modify the HTTP header directly with the B<header()>
3202 JAVASCRIPTING: The B<-script>, B<-onLoad> and B<-onUnload> parameters
3203 are used to add Netscape JavaScript calls to your pages. B<-script>
3204 should point to a block of text containing JavaScript function
3205 definitions. This block will be placed within a <SCRIPT> block inside
3206 the HTML (not HTTP) header. The block is placed in the header in
3207 order to give your page a fighting chance of having all its JavaScript
3208 functions in place even if the user presses the stop button before the
3209 page has loaded completely. CGI.pm attempts to format the script in
3210 such a way that JavaScript-naive browsers will not choke on the code:
3211 unfortunately there are some browsers, such as Chimera for Unix, that
3212 get confused by it nevertheless.
3214 The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
3215 code to execute when the page is respectively opened and closed by the
3216 browser. Usually these parameters are calls to functions defined in the
3220 print $query->header;
3222 // Ask a silly question
3223 function riddle_me_this() {
3224 var r = prompt("What walks on four legs in the morning, " +
3225 "two legs in the afternoon, " +
3226 "and three legs in the evening?");
3229 // Get a silly answer
3230 function response(answer) {
3231 if (answer == "man")
3232 alert("Right you are!");
3234 alert("Wrong! Guess again.");
3237 print $query->start_html(-title=>'The Riddle of the Sphinx',
3242 http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
3244 for more information about JavaScript.
3246 The old-style positional parameters are as follows:
3250 =item B<Parameters:>
3258 The author's e-mail address (will create a <LINK REV="MADE"> tag if present
3262 A 'true' flag if you want to include a <BASE> tag in the header. This
3263 helps resolve relative addresses to absolute ones when the document is moved,
3264 but makes the document hierarchy non-portable. Use with care!
3268 Any other parameters you want to include in the <BODY> tag. This is a good
3269 place to put Netscape extensions, such as colors and wallpaper patterns.
3273 =head2 ENDING THE HTML DOCUMENT:
3275 print $query->end_html
3277 This ends an HTML document by printing the </BODY></HTML> tags.
3279 =head1 CREATING FORMS:
3281 I<General note> The various form-creating methods all return strings
3282 to the caller, containing the tag or tags that will create the requested
3283 form element. You are responsible for actually printing out these strings.
3284 It's set up this way so that you can place formatting tags
3285 around the form elements.
3287 I<Another note> The default values that you specify for the forms are only
3288 used the B<first> time the script is invoked (when there is no query
3289 string). On subsequent invocations of the script (when there is a query
3290 string), the former values are used even if they are blank.
3292 If you want to change the value of a field from its previous value, you have two
3295 (1) call the param() method to set it.
3297 (2) use the -override (alias -force) parameter (a new feature in version 2.15).
3298 This forces the default value to be used, regardless of the previous value:
3300 print $query->textfield(-name=>'field_name',
3301 -default=>'starting value',
3306 I<Yet another note> By default, the text and labels of form elements are
3307 escaped according to HTML rules. This means that you can safely use
3308 "<CLICK ME>" as the label for a button. However, it also interferes with
3309 your ability to incorporate special HTML character sequences, such as Á,
3310 into your fields. If you wish to turn off automatic escaping, call the
3311 autoEscape() method with a false value immediately after creating the CGI object:
3314 $query->autoEscape(undef);
3317 =head2 CREATING AN ISINDEX TAG
3319 print $query->isindex(-action=>$action);
3323 print $query->isindex($action);
3325 Prints out an <ISINDEX> tag. Not very exciting. The parameter
3326 -action specifies the URL of the script to process the query. The
3327 default is to process the query with the current script.
3329 =head2 STARTING AND ENDING A FORM
3331 print $query->startform(-method=>$method,
3333 -encoding=>$encoding);
3334 <... various form stuff ...>
3335 print $query->endform;
3339 print $query->startform($method,$action,$encoding);
3340 <... various form stuff ...>
3341 print $query->endform;
3343 startform() will return a <FORM> tag with the optional method,
3344 action and form encoding that you specify. The defaults are:
3348 encoding: application/x-www-form-urlencoded
3350 endform() returns the closing </FORM> tag.
3352 Startform()'s encoding method tells the browser how to package the various
3353 fields of the form before sending the form to the server. Two
3354 values are possible:
3358 =item B<application/x-www-form-urlencoded>
3360 This is the older type of encoding used by all browsers prior to
3361 Netscape 2.0. It is compatible with many CGI scripts and is
3362 suitable for short fields containing text data. For your
3363 convenience, CGI.pm stores the name of this encoding
3364 type in B<$CGI::URL_ENCODED>.
3366 =item B<multipart/form-data>
3368 This is the newer type of encoding introduced by Netscape 2.0.
3369 It is suitable for forms that contain very large fields or that
3370 are intended for transferring binary data. Most importantly,
3371 it enables the "file upload" feature of Netscape 2.0 forms. For
3372 your convenience, CGI.pm stores the name of this encoding type
3373 in B<$CGI::MULTIPART>
3375 Forms that use this type of encoding are not easily interpreted
3376 by CGI scripts unless they use CGI.pm or another library designed
3381 For compatibility, the startform() method uses the older form of
3382 encoding by default. If you want to use the newer form of encoding
3383 by default, you can call B<start_multipart_form()> instead of
3386 JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
3387 for use with JavaScript. The -name parameter gives the
3388 form a name so that it can be identified and manipulated by
3389 JavaScript functions. -onSubmit should point to a JavaScript
3390 function that will be executed just before the form is submitted to your
3391 server. You can use this opportunity to check the contents of the form
3392 for consistency and completeness. If you find something wrong, you
3393 can put up an alert box or maybe fix things up yourself. You can
3394 abort the submission by returning false from this function.
3396 Usually the bulk of JavaScript functions are defined in a <SCRIPT>
3397 block in the HTML header and -onSubmit points to one of these function
3398 call. See start_html() for details.
3400 =head2 CREATING A TEXT FIELD
3402 print $query->textfield(-name=>'field_name',
3403 -default=>'starting value',
3408 print $query->textfield('field_name','starting value',50,80);
3410 textfield() will return a text input field.
3418 The first parameter is the required name for the field (-name).
3422 The optional second parameter is the default starting value for the field
3423 contents (-default).
3427 The optional third parameter is the size of the field in
3432 The optional fourth parameter is the maximum number of characters the
3433 field will accept (-maxlength).
3437 As with all these methods, the field will be initialized with its
3438 previous contents from earlier invocations of the script.
3439 When the form is processed, the value of the text field can be
3442 $value = $query->param('foo');
3444 If you want to reset it from its initial value after the script has been
3445 called once, you can do so like this:
3447 $query->param('foo',"I'm taking over this value!");
3449 NEW AS OF VERSION 2.15: If you don't want the field to take on its previous
3450 value, you can force its current value by using the -override (alias -force)
3453 print $query->textfield(-name=>'field_name',
3454 -default=>'starting value',
3459 JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>, B<-onBlur>
3460 and B<-onSelect> parameters to register JavaScript event handlers.
3461 The onChange handler will be called whenever the user changes the
3462 contents of the text field. You can do text validation if you like.
3463 onFocus and onBlur are called respectively when the insertion point
3464 moves into and out of the text field. onSelect is called when the
3465 user changes the portion of the text that is selected.
3467 =head2 CREATING A BIG TEXT FIELD
3469 print $query->textarea(-name=>'foo',
3470 -default=>'starting value',
3476 print $query->textarea('foo','starting value',10,50);
3478 textarea() is just like textfield, but it allows you to specify
3479 rows and columns for a multiline text entry box. You can provide
3480 a starting value for the field, which can be long and contain
3483 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
3484 and B<-onSelect> parameters are recognized. See textfield().
3486 =head2 CREATING A PASSWORD FIELD
3488 print $query->password_field(-name=>'secret',
3489 -value=>'starting value',
3494 print $query->password_field('secret','starting value',50,80);
3496 password_field() is identical to textfield(), except that its contents
3497 will be starred out on the web page.
3499 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
3500 and B<-onSelect> parameters are recognized. See textfield().
3502 =head2 CREATING A FILE UPLOAD FIELD
3504 print $query->filefield(-name=>'uploaded_file',
3505 -default=>'starting value',
3510 print $query->filefield('uploaded_file','starting value',50,80);
3512 filefield() will return a file upload field for Netscape 2.0 browsers.
3513 In order to take full advantage of this I<you must use the new
3514 multipart encoding scheme> for the form. You can do this either
3515 by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>,
3516 or by calling the new method B<start_multipart_form()> instead of
3517 vanilla B<startform()>.
3525 The first parameter is the required name for the field (-name).
3529 The optional second parameter is the starting value for the field contents
3530 to be used as the default file name (-default).
3532 The beta2 version of Netscape 2.0 currently doesn't pay any attention
3533 to this field, and so the starting value will always be blank. Worse,
3534 the field loses its "sticky" behavior and forgets its previous
3535 contents. The starting value field is called for in the HTML
3536 specification, however, and possibly later versions of Netscape will
3541 The optional third parameter is the size of the field in
3546 The optional fourth parameter is the maximum number of characters the
3547 field will accept (-maxlength).
3551 When the form is processed, you can retrieve the entered filename
3554 $filename = $query->param('uploaded_file');
3556 In Netscape Gold, the filename that gets returned is the full local filename
3557 on the B<remote user's> machine. If the remote user is on a Unix
3558 machine, the filename will follow Unix conventions:
3562 On an MS-DOS/Windows and OS/2 machines, the filename will follow DOS conventions:
3564 C:\PATH\TO\THE\FILE.MSW
3566 On a Macintosh machine, the filename will follow Mac conventions:
3568 HD 40:Desktop Folder:Sort Through:Reminders
3570 The filename returned is also a file handle. You can read the contents
3571 of the file using standard Perl file reading calls:
3573 # Read a text file and print it out
3574 while (<$filename>) {
3578 # Copy a binary file to somewhere safe
3579 open (OUTFILE,">>/usr/local/web/users/feedback");
3580 while ($bytesread=read($filename,$buffer,1024)) {
3581 print OUTFILE $buffer;
3584 When a file is uploaded the browser usually sends along some
3585 information along with it in the format of headers. The information
3586 usually includes the MIME content type. Future browsers may send
3587 other information as well (such as modification date and size). To
3588 retrieve this information, call uploadInfo(). It returns a reference to
3589 an associative array containing all the document headers.
3591 $filename = $query->param('uploaded_file');
3592 $type = $query->uploadInfo($filename)->{'Content-Type'};
3593 unless ($type eq 'text/html') {
3594 die "HTML FILES ONLY!";
3597 If you are using a machine that recognizes "text" and "binary" data
3598 modes, be sure to understand when and how to use them (see the Camel book).
3599 Otherwise you may find that binary files are corrupted during file uploads.
3601 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
3602 and B<-onSelect> parameters are recognized. See textfield()
3605 =head2 CREATING A POPUP MENU
3607 print $query->popup_menu('menu_name',
3608 ['eenie','meenie','minie'],
3613 %labels = ('eenie'=>'your first choice',
3614 'meenie'=>'your second choice',
3615 'minie'=>'your third choice');
3616 print $query->popup_menu('menu_name',
3617 ['eenie','meenie','minie'],
3620 -or (named parameter style)-
3622 print $query->popup_menu(-name=>'menu_name',
3623 -values=>['eenie','meenie','minie'],
3627 popup_menu() creates a menu.
3633 The required first argument is the menu's name (-name).
3637 The required second argument (-values) is an array B<reference>
3638 containing the list of menu items in the menu. You can pass the
3639 method an anonymous array, as shown in the example, or a reference to
3640 a named array, such as "\@foo".
3644 The optional third parameter (-default) is the name of the default
3645 menu choice. If not specified, the first item will be the default.
3646 The values of the previous choice will be maintained across queries.
3650 The optional fourth parameter (-labels) is provided for people who
3651 want to use different values for the user-visible label inside the
3652 popup menu nd the value returned to your script. It's a pointer to an
3653 associative array relating menu values to user-visible labels. If you
3654 leave this parameter blank, the menu values will be displayed by
3655 default. (You can also leave a label undefined if you want to).
3659 When the form is processed, the selected value of the popup menu can
3662 $popup_menu_value = $query->param('menu_name');
3664 JAVASCRIPTING: popup_menu() recognizes the following event handlers:
3665 B<-onChange>, B<-onFocus>, and B<-onBlur>. See the textfield()
3666 section for details on when these handlers are called.
3668 =head2 CREATING A SCROLLING LIST
3670 print $query->scrolling_list('list_name',
3671 ['eenie','meenie','minie','moe'],
3672 ['eenie','moe'],5,'true');
3675 print $query->scrolling_list('list_name',
3676 ['eenie','meenie','minie','moe'],
3677 ['eenie','moe'],5,'true',
3682 print $query->scrolling_list(-name=>'list_name',
3683 -values=>['eenie','meenie','minie','moe'],
3684 -default=>['eenie','moe'],
3689 scrolling_list() creates a scrolling list.
3693 =item B<Parameters:>
3697 The first and second arguments are the list name (-name) and values
3698 (-values). As in the popup menu, the second argument should be an
3703 The optional third argument (-default) can be either a reference to a
3704 list containing the values to be selected by default, or can be a
3705 single value to select. If this argument is missing or undefined,
3706 then nothing is selected when the list first appears. In the named
3707 parameter version, you can use the synonym "-defaults" for this
3712 The optional fourth argument is the size of the list (-size).
3716 The optional fifth argument can be set to true to allow multiple
3717 simultaneous selections (-multiple). Otherwise only one selection
3718 will be allowed at a time.
3722 The optional sixth argument is a pointer to an associative array
3723 containing long user-visible labels for the list items (-labels).
3724 If not provided, the values will be displayed.
3726 When this form is processed, all selected list items will be returned as
3727 a list under the parameter name 'list_name'. The values of the
3728 selected items can be retrieved with:
3730 @selected = $query->param('list_name');
3734 JAVASCRIPTING: scrolling_list() recognizes the following event handlers:
3735 B<-onChange>, B<-onFocus>, and B<-onBlur>. See textfield() for
3736 the description of when these handlers are called.
3738 =head2 CREATING A GROUP OF RELATED CHECKBOXES
3740 print $query->checkbox_group(-name=>'group_name',
3741 -values=>['eenie','meenie','minie','moe'],
3742 -default=>['eenie','moe'],
3746 print $query->checkbox_group('group_name',
3747 ['eenie','meenie','minie','moe'],
3748 ['eenie','moe'],'true',\%labels);
3750 HTML3-COMPATIBLE BROWSERS ONLY:
3752 print $query->checkbox_group(-name=>'group_name',
3753 -values=>['eenie','meenie','minie','moe'],
3754 -rows=2,-columns=>2);
3757 checkbox_group() creates a list of checkboxes that are related
3762 =item B<Parameters:>
3766 The first and second arguments are the checkbox name and values,
3767 respectively (-name and -values). As in the popup menu, the second
3768 argument should be an array reference. These values are used for the
3769 user-readable labels printed next to the checkboxes as well as for the
3770 values passed to your script in the query string.
3774 The optional third argument (-default) can be either a reference to a
3775 list containing the values to be checked by default, or can be a
3776 single value to checked. If this argument is missing or undefined,
3777 then nothing is selected when the list first appears.
3781 The optional fourth argument (-linebreak) can be set to true to place
3782 line breaks between the checkboxes so that they appear as a vertical
3783 list. Otherwise, they will be strung together on a horizontal line.
3787 The optional fifth argument is a pointer to an associative array
3788 relating the checkbox values to the user-visible labels that will will
3789 be printed next to them (-labels). If not provided, the values will
3790 be used as the default.
3794 B<HTML3-compatible browsers> (such as Netscape) can take advantage
3796 parameters B<-rows>, and B<-columns>. These parameters cause
3797 checkbox_group() to return an HTML3 compatible table containing
3798 the checkbox group formatted with the specified number of rows
3799 and columns. You can provide just the -columns parameter if you
3800 wish; checkbox_group will calculate the correct number of rows
3803 To include row and column headings in the returned table, you
3804 can use the B<-rowheader> and B<-colheader> parameters. Both
3805 of these accept a pointer to an array of headings to use.
3806 The headings are just decorative. They don't reorganize the
3807 interpretation of the checkboxes -- they're still a single named
3812 When the form is processed, all checked boxes will be returned as
3813 a list under the parameter name 'group_name'. The values of the
3814 "on" checkboxes can be retrieved with:
3816 @turned_on = $query->param('group_name');
3818 The value returned by checkbox_group() is actually an array of button
3819 elements. You can capture them and use them within tables, lists,
3820 or in other creative ways:
3822 @h = $query->checkbox_group(-name=>'group_name',-values=>\@values);
3823 &use_in_creative_way(@h);
3825 JAVASCRIPTING: checkbox_group() recognizes the B<-onClick>
3826 parameter. This specifies a JavaScript code fragment or
3827 function call to be executed every time the user clicks on
3828 any of the buttons in the group. You can retrieve the identity
3829 of the particular button clicked on using the "this" variable.
3831 =head2 CREATING A STANDALONE CHECKBOX
3833 print $query->checkbox(-name=>'checkbox_name',
3834 -checked=>'checked',
3836 -label=>'CLICK ME');
3840 print $query->checkbox('checkbox_name','checked','ON','CLICK ME');
3842 checkbox() is used to create an isolated checkbox that isn't logically
3843 related to any others.
3847 =item B<Parameters:>
3851 The first parameter is the required name for the checkbox (-name). It
3852 will also be used for the user-readable label printed next to the
3857 The optional second parameter (-checked) specifies that the checkbox
3858 is turned on by default. Synonyms are -selected and -on.
3862 The optional third parameter (-value) specifies the value of the
3863 checkbox when it is checked. If not provided, the word "on" is
3868 The optional fourth parameter (-label) is the user-readable label to
3869 be attached to the checkbox. If not provided, the checkbox name is
3874 The value of the checkbox can be retrieved using:
3876 $turned_on = $query->param('checkbox_name');
3878 JAVASCRIPTING: checkbox() recognizes the B<-onClick>
3879 parameter. See checkbox_group() for further details.
3881 =head2 CREATING A RADIO BUTTON GROUP
3883 print $query->radio_group(-name=>'group_name',
3884 -values=>['eenie','meenie','minie'],
3891 print $query->radio_group('group_name',['eenie','meenie','minie'],
3892 'meenie','true',\%labels);
3895 HTML3-COMPATIBLE BROWSERS ONLY:
3897 print $query->radio_group(-name=>'group_name',
3898 -values=>['eenie','meenie','minie','moe'],
3899 -rows=2,-columns=>2);
3901 radio_group() creates a set of logically-related radio buttons
3902 (turning one member of the group on turns the others off)
3906 =item B<Parameters:>
3910 The first argument is the name of the group and is required (-name).
3914 The second argument (-values) is the list of values for the radio
3915 buttons. The values and the labels that appear on the page are
3916 identical. Pass an array I<reference> in the second argument, either
3917 using an anonymous array, as shown, or by referencing a named array as
3922 The optional third parameter (-default) is the name of the default
3923 button to turn on. If not specified, the first item will be the
3924 default. You can provide a nonexistent button name, such as "-" to
3925 start up with no buttons selected.
3929 The optional fourth parameter (-linebreak) can be set to 'true' to put
3930 line breaks between the buttons, creating a vertical list.
3934 The optional fifth parameter (-labels) is a pointer to an associative
3935 array relating the radio button values to user-visible labels to be
3936 used in the display. If not provided, the values themselves are
3941 B<HTML3-compatible browsers> (such as Netscape) can take advantage
3943 parameters B<-rows>, and B<-columns>. These parameters cause
3944 radio_group() to return an HTML3 compatible table containing
3945 the radio group formatted with the specified number of rows
3946 and columns. You can provide just the -columns parameter if you
3947 wish; radio_group will calculate the correct number of rows
3950 To include row and column headings in the returned table, you
3951 can use the B<-rowheader> and B<-colheader> parameters. Both
3952 of these accept a pointer to an array of headings to use.
3953 The headings are just decorative. They don't reorganize the
3954 interpetation of the radio buttons -- they're still a single named
3959 When the form is processed, the selected radio button can
3962 $which_radio_button = $query->param('group_name');
3964 The value returned by radio_group() is actually an array of button
3965 elements. You can capture them and use them within tables, lists,
3966 or in other creative ways:
3968 @h = $query->radio_group(-name=>'group_name',-values=>\@values);
3969 &use_in_creative_way(@h);
3971 =head2 CREATING A SUBMIT BUTTON
3973 print $query->submit(-name=>'button_name',
3978 print $query->submit('button_name','value');
3980 submit() will create the query submission button. Every form
3981 should have one of these.
3985 =item B<Parameters:>
3989 The first argument (-name) is optional. You can give the button a
3990 name if you have several submission buttons in your form and you want
3991 to distinguish between them. The name will also be used as the
3992 user-visible label. Be aware that a few older browsers don't deal with this correctly and
3993 B<never> send back a value from a button.
3997 The second argument (-value) is also optional. This gives the button
3998 a value that will be passed to your script in the query string.
4002 You can figure out which button was pressed by using different
4003 values for each one:
4005 $which_one = $query->param('button_name');
4007 JAVASCRIPTING: radio_group() recognizes the B<-onClick>
4008 parameter. See checkbox_group() for further details.
4010 =head2 CREATING A RESET BUTTON
4014 reset() creates the "reset" button. Note that it restores the
4015 form to its value from the last time the script was called,
4016 NOT necessarily to the defaults.
4018 =head2 CREATING A DEFAULT BUTTON
4020 print $query->defaults('button_label')
4022 defaults() creates a button that, when invoked, will cause the
4023 form to be completely reset to its defaults, wiping out all the
4024 changes the user ever made.
4026 =head2 CREATING A HIDDEN FIELD
4028 print $query->hidden(-name=>'hidden_name',
4029 -default=>['value1','value2'...]);
4033 print $query->hidden('hidden_name','value1','value2'...);
4035 hidden() produces a text field that can't be seen by the user. It
4036 is useful for passing state variable information from one invocation
4037 of the script to the next.
4041 =item B<Parameters:>
4045 The first argument is required and specifies the name of this
4050 The second argument is also required and specifies its value
4051 (-default). In the named parameter style of calling, you can provide
4052 a single value here or a reference to a whole list
4056 Fetch the value of a hidden field this way:
4058 $hidden_value = $query->param('hidden_name');
4060 Note, that just like all the other form elements, the value of a
4061 hidden field is "sticky". If you want to replace a hidden field with
4062 some other values after the script has been called once you'll have to
4065 $query->param('hidden_name','new','values','here');
4067 =head2 CREATING A CLICKABLE IMAGE BUTTON
4069 print $query->image_button(-name=>'button_name',
4070 -src=>'/source/URL',
4075 print $query->image_button('button_name','/source/URL','MIDDLE');
4077 image_button() produces a clickable image. When it's clicked on the
4078 position of the click is returned to your script as "button_name.x"
4079 and "button_name.y", where "button_name" is the name you've assigned
4082 JAVASCRIPTING: image_button() recognizes the B<-onClick>
4083 parameter. See checkbox_group() for further details.
4087 =item B<Parameters:>
4091 The first argument (-name) is required and specifies the name of this
4096 The second argument (-src) is also required and specifies the URL
4099 The third option (-align, optional) is an alignment type, and may be
4100 TOP, BOTTOM or MIDDLE
4104 Fetch the value of the button this way:
4105 $x = $query->param('button_name.x');
4106 $y = $query->param('button_name.y');
4108 =head2 CREATING A JAVASCRIPT ACTION BUTTON
4110 print $query->button(-name=>'button_name',
4111 -value=>'user visible label',
4112 -onClick=>"do_something()");
4116 print $query->button('button_name',"do_something()");
4118 button() produces a button that is compatible with Netscape 2.0's
4119 JavaScript. When it's pressed the fragment of JavaScript code
4120 pointed to by the B<-onClick> parameter will be executed. On
4121 non-Netscape browsers this form element will probably not even
4124 =head1 NETSCAPE COOKIES
4126 Netscape browsers versions 1.1 and higher support a so-called
4127 "cookie" designed to help maintain state within a browser session.
4128 CGI.pm has several methods that support cookies.
4130 A cookie is a name=value pair much like the named parameters in a CGI
4131 query string. CGI scripts create one or more cookies and send
4132 them to the browser in the HTTP header. The browser maintains a list
4133 of cookies that belong to a particular Web server, and returns them
4134 to the CGI script during subsequent interactions.
4136 In addition to the required name=value pair, each cookie has several
4137 optional attributes:
4141 =item 1. an expiration time
4143 This is a time/date string (in a special GMT format) that indicates
4144 when a cookie expires. The cookie will be saved and returned to your
4145 script until this expiration date is reached if the user exits
4146 Netscape and restarts it. If an expiration date isn't specified, the cookie
4147 will remain active until the user quits Netscape.
4151 This is a partial or complete domain name for which the cookie is
4152 valid. The browser will return the cookie to any host that matches
4153 the partial domain name. For example, if you specify a domain name
4154 of ".capricorn.com", then Netscape will return the cookie to
4155 Web servers running on any of the machines "www.capricorn.com",
4156 "www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
4157 must contain at least two periods to prevent attempts to match
4158 on top level domains like ".edu". If no domain is specified, then
4159 the browser will only return the cookie to servers on the host the
4160 cookie originated from.
4164 If you provide a cookie path attribute, the browser will check it
4165 against your script's URL before returning the cookie. For example,
4166 if you specify the path "/cgi-bin", then the cookie will be returned
4167 to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
4168 and "/cgi-bin/customer_service/complain.pl", but not to the script
4169 "/cgi-private/site_admin.pl". By default, path is set to "/", which
4170 causes the cookie to be sent to any CGI script on your site.
4172 =item 4. a "secure" flag
4174 If the "secure" attribute is set, the cookie will only be sent to your
4175 script if the CGI request is occurring on a secure channel, such as SSL.
4179 The interface to Netscape cookies is the B<cookie()> method:
4181 $cookie = $query->cookie(-name=>'sessionID',
4184 -path=>'/cgi-bin/database',
4185 -domain=>'.capricorn.org',
4187 print $query->header(-cookie=>$cookie);
4189 B<cookie()> creates a new cookie. Its parameters include:
4195 The name of the cookie (required). This can be any string at all.
4196 Although Netscape limits its cookie names to non-whitespace
4197 alphanumeric characters, CGI.pm removes this restriction by escaping
4198 and unescaping cookies behind the scenes.
4202 The value of the cookie. This can be any scalar value,
4203 array reference, or even associative array reference. For example,
4204 you can store an entire associative array into a cookie this way:
4206 $cookie=$query->cookie(-name=>'family information',
4207 -value=>\%childrens_ages);
4211 The optional partial path for which this cookie will be valid, as described
4216 The optional partial domain for which this cookie will be valid, as described
4221 The optional expiration date for this cookie. The format is as described
4222 in the section on the B<header()> method:
4224 "+1h" one hour from now
4228 If set to true, this cookie will only be used within a secure
4233 The cookie created by cookie() must be incorporated into the HTTP
4234 header within the string returned by the header() method:
4236 print $query->header(-cookie=>$my_cookie);
4238 To create multiple cookies, give header() an array reference:
4240 $cookie1 = $query->cookie(-name=>'riddle_name',
4241 -value=>"The Sphynx's Question");
4242 $cookie2 = $query->cookie(-name=>'answers',
4244 print $query->header(-cookie=>[$cookie1,$cookie2]);
4246 To retrieve a cookie, request it by name by calling cookie()
4247 method without the B<-value> parameter:
4251 %answers = $query->cookie(-name=>'answers');
4252 # $query->cookie('answers') will work too!
4254 The cookie and CGI namespaces are separate. If you have a parameter
4255 named 'answers' and a cookie named 'answers', the values retrieved by
4256 param() and cookie() are independent of each other. However, it's
4257 simple to turn a CGI parameter into a cookie, and vice-versa:
4259 # turn a CGI parameter into a cookie
4260 $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]);
4262 $q->param(-name=>'answers',-value=>[$q->cookie('answers')]);
4264 See the B<cookie.cgi> example script for some ideas on how to use
4265 cookies effectively.
4267 B<NOTE:> There appear to be some (undocumented) restrictions on
4268 Netscape cookies. In Netscape 2.01, at least, I haven't been able to
4269 set more than three cookies at a time. There may also be limits on
4270 the length of cookies. If you need to store a lot of information,
4271 it's probably better to create a unique session ID, store it in a
4272 cookie, and use the session ID to locate an external file/database
4273 saved on the server's side of the connection.
4275 =head1 WORKING WITH NETSCAPE FRAMES
4277 It's possible for CGI.pm scripts to write into several browser
4278 panels and windows using Netscape's frame mechanism.
4279 There are three techniques for defining new frames programmatically:
4283 =item 1. Create a <Frameset> document
4285 After writing out the HTTP header, instead of creating a standard
4286 HTML document using the start_html() call, create a <FRAMESET>
4287 document that defines the frames on the page. Specify your script(s)
4288 (with appropriate parameters) as the SRC for each of the frames.
4290 There is no specific support for creating <FRAMESET> sections
4291 in CGI.pm, but the HTML is very simple to write. See the frame
4292 documentation in Netscape's home pages for details
4294 http://home.netscape.com/assist/net_sites/frames.html
4296 =item 2. Specify the destination for the document in the HTTP header
4298 You may provide a B<-target> parameter to the header() method:
4300 print $q->header(-target=>'ResultsWindow');
4302 This will tell Netscape to load the output of your script into the
4303 frame named "ResultsWindow". If a frame of that name doesn't
4304 already exist, Netscape will pop up a new window and load your
4305 script's document into that. There are a number of magic names
4306 that you can use for targets. See the frame documents on Netscape's
4307 home pages for details.
4309 =item 3. Specify the destination for the document in the <FORM> tag
4311 You can specify the frame to load in the FORM tag itself. With
4312 CGI.pm it looks like this:
4314 print $q->startform(-target=>'ResultsWindow');
4316 When your script is reinvoked by the form, its output will be loaded
4317 into the frame named "ResultsWindow". If one doesn't already exist
4318 a new window will be created.
4322 The script "frameset.cgi" in the examples directory shows one way to
4323 create pages in which the fill-out form and the response live in
4324 side-by-side frames.
4328 If you are running the script
4329 from the command line or in the perl debugger, you can pass the script
4330 a list of keywords or parameter=value pairs on the command line or
4331 from standard input (you don't have to worry about tricking your
4332 script into reading from environment variables).
4333 You can pass keywords like this:
4335 your_script.pl keyword1 keyword2 keyword3
4339 your_script.pl keyword1+keyword2+keyword3
4343 your_script.pl name1=value1 name2=value2
4347 your_script.pl name1=value1&name2=value2
4349 or even as newline-delimited parameters on standard input.
4351 When debugging, you can use quotes and backslashes to escape
4352 characters in the familiar shell manner, letting you place
4353 spaces and other funny characters in your parameter=value
4356 your_script.pl "name1='I am a long value'" "name2=two\ words"
4358 =head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
4360 The dump() method produces a string consisting of all the query's
4361 name/value pairs formatted nicely as a nested list. This is useful
4362 for debugging purposes:
4367 Produces something that looks like:
4381 You can pass a value of 'true' to dump() in order to get it to
4382 print the results out as plain text, suitable for incorporating
4383 into a <PRE> section.
4385 As a shortcut, as of version 1.56 you can interpolate the entire
4386 CGI object into a string and it will be replaced with the
4387 the a nice HTML dump shown above:
4390 print "<H2>Current Values</H2> $query\n";
4392 =head1 FETCHING ENVIRONMENT VARIABLES
4394 Some of the more useful environment variables can be fetched
4395 through this interface. The methods are as follows:
4401 Return a list of MIME types that the remote browser
4402 accepts. If you give this method a single argument
4403 corresponding to a MIME type, as in
4404 $query->accept('text/html'), it will return a
4405 floating point value corresponding to the browser's
4406 preference for this type from 0.0 (don't want) to 1.0.
4407 Glob types (e.g. text/*) in the browser's accept list
4408 are handled correctly.
4410 =item B<raw_cookie()>
4412 Returns the HTTP_COOKIE variable, an HTTP extension
4413 implemented by Netscape browsers version 1.1
4414 and higher. Cookies have a special format, and this
4415 method call just returns the raw form (?cookie dough).
4416 See cookie() for ways of setting and retrieving
4419 =item B<user_agent()>
4421 Returns the HTTP_USER_AGENT variable. If you give
4422 this method a single argument, it will attempt to
4423 pattern match on it, allowing you to do something
4424 like $query->user_agent(netscape);
4426 =item B<path_info()>
4428 Returns additional path information from the script URL.
4429 E.G. fetching /cgi-bin/your_script/additional/stuff will
4430 result in $query->path_info() returning
4433 NOTE: The Microsoft Internet Information Server
4434 is broken with respect to additional path information. If
4435 you use the Perl DLL library, the IIS server will attempt to
4436 execute the additional path information as a Perl script.
4437 If you use the ordinary file associations mapping, the
4438 path information will be present in the environment,
4439 but incorrect. The best thing to do is to avoid using additional
4440 path information in CGI scripts destined for use with IIS.
4442 =item B<path_translated()>
4444 As per path_info() but returns the additional
4445 path information translated into a physical path, e.g.
4446 "/usr/local/etc/httpd/htdocs/additional/stuff".
4448 The Microsoft IIS is broken with respect to the translated
4451 =item B<remote_host()>
4453 Returns either the remote host name or IP address.
4454 if the former is unavailable.
4456 =item B<script_name()>
4457 Return the script name as a partial URL, for self-refering
4462 Return the URL of the page the browser was viewing
4463 prior to fetching your script. Not available for all
4466 =item B<auth_type ()>
4468 Return the authorization/verification method in use for this
4471 =item B<server_name ()>
4473 Returns the name of the server, usually the machine's host
4476 =item B<virtual_host ()>
4478 When using virtual hosts, returns the name of the host that
4479 the browser attempted to contact
4481 =item B<server_software ()>
4483 Returns the server software and version number.
4485 =item B<remote_user ()>
4487 Return the authorization/verification name used for user
4488 verification, if this script is protected.
4490 =item B<user_name ()>
4492 Attempt to obtain the remote user's name, using a variety
4493 of different techniques. This only works with older browsers
4494 such as Mosaic. Netscape does not reliably report the user
4497 =item B<request_method()>
4499 Returns the method used to access your script, usually
4500 one of 'POST', 'GET' or 'HEAD'.
4504 =head1 CREATING HTML ELEMENTS:
4506 In addition to its shortcuts for creating form elements, CGI.pm
4507 defines general HTML shortcut methods as well. HTML shortcuts are
4508 named after a single HTML element and return a fragment of HTML text
4509 that you can then print or manipulate as you like.
4511 This example shows how to use the HTML methods:
4514 print $q->blockquote(
4515 "Many years ago on the island of",
4516 $q->a({href=>"http://crete.org/"},"Crete"),
4517 "there lived a minotaur named",
4518 $q->strong("Fred."),
4522 This results in the following HTML code (extra newlines have been
4523 added for readability):
4526 Many years ago on the island of
4527 <a HREF="http://crete.org/">Crete</a> there lived
4528 a minotaur named <strong>Fred.</strong>
4532 If you find the syntax for calling the HTML shortcuts awkward, you can
4533 import them into your namespace and dispense with the object syntax
4534 completely (see the next section for more details):
4536 use CGI shortcuts; # IMPORT HTML SHORTCUTS
4538 "Many years ago on the island of",
4539 a({href=>"http://crete.org/"},"Crete"),
4540 "there lived a minotaur named",
4545 =head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
4547 The HTML methods will accept zero, one or multiple arguments. If you
4548 provide no arguments, you get a single tag:
4553 If you provide one or more string arguments, they are concatenated
4554 together with spaces and placed between opening and closing tags:
4556 print h1("Chapter","1");
4557 # gives "<h1>Chapter 1</h1>"
4559 If the first argument is an associative array reference, then the keys
4560 and values of the associative array become the HTML tag's attributes:
4562 print a({href=>'fred.html',target=>'_new'},
4563 "Open a new frame");
4564 # gives <a href="fred.html",target="_new">Open a new frame</a>
4566 You are free to use CGI.pm-style dashes in front of the attribute
4567 names if you prefer:
4569 print img {-src=>'fred.gif',-align=>'LEFT'};
4570 # gives <img ALIGN="LEFT" SRC="fred.gif">
4572 =head2 Generating new HTML tags
4574 Since no mere mortal can keep up with Netscape and Microsoft as they
4575 battle it out for control of HTML, the code that generates HTML tags
4576 is general and extensible. You can create new HTML tags freely just
4577 by referring to them on the import line:
4579 use CGI shortcuts,winkin,blinkin,nod;
4581 Now, in addition to the standard CGI shortcuts, you've created HTML
4582 tags named "winkin", "blinkin" and "nod". You can use them like this:
4584 print blinkin {color=>'blue',rate=>'fast'},"Yahoo!";
4585 # <blinkin COLOR="blue" RATE="fast">Yahoo!</blinkin>
4587 =head1 IMPORTING CGI METHOD CALLS INTO YOUR NAME SPACE
4589 As a convenience, you can import most of the CGI method calls directly
4590 into your name space. The syntax for doing this is:
4592 use CGI <list of methods>;
4594 The listed methods will be imported into the current package; you can
4595 call them directly without creating a CGI object first. This example
4596 shows how to import the B<param()> and B<header()>
4597 methods, and then use them directly:
4599 use CGI param,header;
4600 print header('text/plain');
4601 $zipcode = param('zipcode');
4603 You can import groups of methods by referring to a number of special
4610 Import all CGI-handling methods, such as B<param()>, B<path_info()>
4615 Import all fill-out form generating methods, such as B<textfield()>.
4619 Import all methods that generate HTML 2.0 standard elements.
4623 Import all methods that generate HTML 3.0 proposed elements (such as
4624 <table>, <super> and <sub>).
4628 Import all methods that generate Netscape-specific HTML extensions.
4632 Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
4637 Import "standard" features, 'html2', 'form' and 'cgi'.
4641 Import all the available methods. For the full list, see the CGI.pm
4642 code, where the variable %TAGS is defined.
4646 Note that in the interests of execution speed CGI.pm does B<not> use
4647 the standard L<Exporter> syntax for specifying load symbols. This may
4648 change in the future.
4650 If you import any of the state-maintaining CGI or form-generating
4651 methods, a default CGI object will be created and initialized
4652 automatically the first time you use any of the methods that require
4653 one to be present. This includes B<param()>, B<textfield()>,
4654 B<submit()> and the like. (If you need direct access to the CGI
4655 object, you can find it in the global variable B<$CGI::Q>). By
4656 importing CGI.pm methods, you can create visually elegant scripts:
4658 use CGI standard,html2;
4661 start_html('Simple Script'),
4662 h1('Simple Script'),
4664 "What's your name? ",textfield('name'),p,
4665 "What's the combination?",
4666 checkbox_group(-name=>'words',
4667 -values=>['eenie','meenie','minie','moe'],
4668 -defaults=>['eenie','moe']),p,
4669 "What's your favorite color?",
4670 popup_menu(-name=>'color',
4671 -values=>['red','green','blue','chartreuse']),p,
4678 "Your name is ",em(param('name')),p,
4679 "The keywords are: ",em(join(", ",param('words'))),p,
4680 "Your favorite color is ",em(param('color')),".\n";
4684 =head1 USING NPH SCRIPTS
4686 NPH, or "no-parsed-header", scripts bypass the server completely by
4687 sending the complete HTTP header directly to the browser. This has
4688 slight performance benefits, but is of most use for taking advantage
4689 of HTTP extensions that are not directly supported by your server,
4690 such as server push and PICS headers.
4692 Servers use a variety of conventions for designating CGI scripts as
4693 NPH. Many Unix servers look at the beginning of the script's name for
4694 the prefix "nph-". The Macintosh WebSTAR server and Microsoft's
4695 Internet Information Server, in contrast, try to decide whether a
4696 program is an NPH script by examining the first line of script output.
4699 CGI.pm supports NPH scripts with a special NPH mode. When in this
4700 mode, CGI.pm will output the necessary extra header information when
4701 the header() and redirect() methods are
4704 The Microsoft Internet Information Server requires NPH mode. As of version
4705 2.30, CGI.pm will automatically detect when the script is running under IIS
4706 and put itself into this mode. You do not need to do this manually, although
4707 it won't hurt anything if you do.
4709 There are a number of ways to put CGI.pm into NPH mode:
4713 =item In the B<use> statement
4714 Simply add ":nph" to the list of symbols to be imported into your script:
4716 use CGI qw(:standard :nph)
4718 =item By calling the B<nph()> method:
4720 Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
4724 =item By using B<-nph> parameters in the B<header()> and B<redirect()> statements:
4726 print $q->header(-nph=>1);
4730 =head1 AUTHOR INFORMATION
4732 Copyright 1995,1996, Lincoln D. Stein. All rights reserved. It may
4733 be used and modified freely, but I do request that this copyright
4734 notice remain attached to the file. You may modify this module as you
4735 wish, but if you redistribute a modified version, please attach a note
4736 listing the modifications you have made.
4738 Address bug reports and comments to:
4739 lstein@genome.wi.mit.edu
4743 Thanks very much to:
4747 =item Matt Heffron (heffron@falstaff.css.beckman.com)
4749 =item James Taylor (james.taylor@srs.gov)
4751 =item Scott Anguish <sanguish@digifix.com>
4753 =item Mike Jewell (mlj3u@virginia.edu)
4755 =item Timothy Shimmin (tes@kbs.citri.edu.au)
4757 =item Joergen Haegg (jh@axis.se)
4759 =item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu)
4761 =item Richard Resnick (applepi1@aol.com)
4763 =item Craig Bishop (csb@barwonwater.vic.gov.au)
4765 =item Tony Curtis (tc@vcpc.univie.ac.at)
4767 =item Tim Bunce (Tim.Bunce@ig.co.uk)
4769 =item Tom Christiansen (tchrist@convex.com)
4771 =item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
4773 =item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
4775 =item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
4777 =item Stephen Dahmen (joyfire@inxpress.net)
4779 =item Ed Jordan (ed@fidalgo.net)
4781 =item David Alan Pisoni (david@cnation.com)
4783 =item ...and many many more...
4785 for suggestions and bug fixes.
4789 =head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
4792 #!/usr/local/bin/perl
4798 print $query->header;
4799 print $query->start_html("Example CGI.pm Form");
4800 print "<H1> Example CGI.pm Form</H1>\n";
4801 &print_prompt($query);
4804 print $query->end_html;
4809 print $query->startform;
4810 print "<EM>What's your name?</EM><BR>";
4811 print $query->textfield('name');
4812 print $query->checkbox('Not my real name');
4814 print "<P><EM>Where can you find English Sparrows?</EM><BR>";
4815 print $query->checkbox_group(
4816 -name=>'Sparrow locations',
4817 -values=>[England,France,Spain,Asia,Hoboken],
4819 -defaults=>[England,Asia]);
4821 print "<P><EM>How far can they fly?</EM><BR>",
4822 $query->radio_group(
4824 -values=>['10 ft','1 mile','10 miles','real far'],
4825 -default=>'1 mile');
4827 print "<P><EM>What's your favorite color?</EM> ";
4828 print $query->popup_menu(-name=>'Color',
4829 -values=>['black','brown','red','yellow'],
4832 print $query->hidden('Reference','Monty Python and the Holy Grail');
4834 print "<P><EM>What have you got there?</EM><BR>";
4835 print $query->scrolling_list(
4836 -name=>'possessions',
4837 -values=>['A Coconut','A Grail','An Icon',
4838 'A Sword','A Ticket'],
4842 print "<P><EM>Any parting comments?</EM><BR>";
4843 print $query->textarea(-name=>'Comments',
4847 print "<P>",$query->reset;
4848 print $query->submit('Action','Shout');
4849 print $query->submit('Action','Scream');
4850 print $query->endform;
4858 print "<H2>Here are the current settings in this form</H2>";
4860 foreach $key ($query->param) {
4861 print "<STRONG>$key</STRONG> -> ";
4862 @values = $query->param($key);
4863 print join(", ",@values),"<BR>\n";
4870 <ADDRESS>Lincoln D. Stein</ADDRESS><BR>
4871 <A HREF="/">Home Page</A>
4877 This module has grown large and monolithic. Furthermore it's doing many
4878 things, such as handling URLs, parsing CGI input, writing HTML, etc., that
4879 are also done in the LWP modules. It should be discarded in favor of
4880 the CGI::* modules, but somehow I continue to work on it.
4882 Note that the code is truly contorted in order to avoid spurious
4883 warnings when programs are run with the B<-w> switch.
4887 L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>,
4888 L<CGI::Base>, L<CGI::Form>, L<CGI::Apache>, L<CGI::Switch>,
4889 L<CGI::Push>, L<CGI::Fast>