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 $';
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 ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/) {
96 # This is really "\r\n", but the meaning of \n is different
97 # in MacPerl, so we resort to octal here.
100 if ($needs_binmode) {
101 $CGI::DefaultClass->binmode(main::STDOUT);
102 $CGI::DefaultClass->binmode(main::STDIN);
103 $CGI::DefaultClass->binmode(main::STDERR);
106 # Cute feature, but it broke when the overload mechanism changed...
107 # %OVERLOAD = ('""'=>'as_string');
110 ':html2'=>[h1..h6,qw/p br hr ol ul li dl dt dd menu code var strong em
111 tt i b blockquote pre img a address cite samp dfn html head
112 base body link nextid title meta kbd start_html end_html
113 input Select option/],
114 ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont/],
115 ':netscape'=>[qw/blink frameset frame script font fontsize center/],
116 ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
117 submit reset defaults radio_group popup_menu button autoEscape
118 scrolling_list image_button start_form end_form startform endform
119 start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
120 ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump
121 raw_cookie request_method query_string accept user_agent remote_host
122 remote_addr referer server_name server_software server_port server_protocol
123 virtual_host remote_ident auth_type http
124 remote_user user_name header redirect import_names put/],
125 ':ssl' => [qw/https/],
126 ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
127 ':html' => [qw/:html2 :html3 :netscape/],
128 ':standard' => [qw/:html2 :form :cgi/],
129 ':all' => [qw/:html2 :html3 :netscape :form :cgi/]
132 # to import symbols into caller
135 my ($callpack, $callfile, $callline) = caller;
137 $NPH++, next if $_ eq ':nph';
138 foreach (&expand_tags($_)) {
139 tr/a-zA-Z0-9_//cd; # don't allow weird function names
143 # To allow overriding, search through the packages
144 # Till we find one in which the correct subroutine is defined.
145 my @packages = ($self,@{"$self\:\:ISA"});
146 foreach $sym (keys %EXPORT) {
148 my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
149 foreach $pck (@packages) {
150 if (defined(&{"$pck\:\:$sym"})) {
155 *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
162 return ($tag) unless $EXPORT_TAGS{$tag};
163 foreach (@{$EXPORT_TAGS{$tag}}) {
164 push(@r,&expand_tags($_));
170 # The new routine. This will check the current environment
171 # for an existing query string, and initialize itself, if so.
174 my($class,$initializer) = @_;
176 bless $self,ref $class || $class || $DefaultClass;
177 $CGI::DefaultClass->_reset_globals() if $MOD_PERL;
178 $initializer = to_filehandle($initializer) if $initializer;
179 $self->init($initializer);
183 # We provide a DESTROY method so that the autoloader
184 # doesn't bother trying to find it.
188 # Returns the value(s)of a named parameter.
189 # If invoked in a list context, returns the
190 # entire list. Otherwise returns the first
191 # member of the list.
192 # If name is not provided, return a list of all
193 # the known parameters names available.
194 # If more than one argument is provided, the
195 # second and subsequent arguments are used to
196 # set the value of the parameter.
199 my($self,@p) = self_or_default(@_);
200 return $self->all_parameters unless @p;
201 my($name,$value,@other);
203 # For compatibility between old calling style and use_named_parameters() style,
204 # we have to special case for a single parameter present.
206 ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
209 if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
210 @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
212 foreach ($value,@other) {
213 push(@values,$_) if defined($_);
216 # If values is provided, then we set it.
218 $self->add_parameter($name);
219 $self->{$name}=[@values];
225 return () unless defined($name) && $self->{$name};
226 return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
230 # Deletes the named parameter entirely.
233 my($self,$name) = self_or_default(@_);
234 delete $self->{$name};
235 delete $self->{'.fieldnames'}->{$name};
236 @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
237 return wantarray ? () : undef;
240 sub self_or_default {
241 return @_ if defined($_[0]) && !ref($_[0]) && ($_[0] eq 'CGI');
242 unless (defined($_[0]) &&
244 (ref($_[0]) eq 'CGI' ||
245 eval "\$_[0]->isaCGI()")) { # optimize for the common case
246 $CGI::DefaultClass->_reset_globals()
247 if defined($Q) && $MOD_PERL && $CGI::DefaultClass->_new_request();
248 $Q = $CGI::DefaultClass->new unless defined($Q);
255 return undef unless (defined(Apache->seqno()) or eval { require Apache });
256 if (Apache->seqno() != $SEQNO) {
257 $SEQNO = Apache->seqno();
270 local $^W=0; # prevent a warning
271 if (defined($_[0]) &&
272 (substr(ref($_[0]),0,3) eq 'CGI'
273 || eval "\$_[0]->isaCGI()")) {
276 return ($DefaultClass,@_);
284 #### Method: import_names
285 # Import all parameters into the given namespace.
286 # Assumes namespace 'Q' if not specified
289 my($self,$namespace) = self_or_default(@_);
290 $namespace = 'Q' unless defined($namespace);
291 die "Can't import names into 'main'\n"
292 if $namespace eq 'main';
293 my($param,@value,$var);
294 foreach $param ($self->param) {
295 # protect against silly names
296 ($var = $param)=~tr/a-zA-Z0-9_/_/c;
297 $var = "${namespace}::$var";
298 @value = $self->param($param);
304 #### Method: use_named_parameters
305 # Force CGI.pm to use named parameter-style method calls
306 # rather than positional parameters. The same effect
307 # will happen automatically if the first parameter
309 sub use_named_parameters {
310 my($self,$use_named) = self_or_default(@_);
311 return $self->{'.named'} unless defined ($use_named);
313 # stupidity to avoid annoying warnings
314 return $self->{'.named'}=$use_named;
317 ########################################
318 # THESE METHODS ARE MORE OR LESS PRIVATE
319 # GO TO THE __DATA__ SECTION TO SEE MORE
321 ########################################
323 # Initialize the query object from the environment.
324 # If a parameter list is found, this object will be set
325 # to an associative array in which parameter names are keys
326 # and the values are stored as lists
327 # If a keyword list is found, this method creates a bogus
328 # parameter list with the single parameter 'keywords'.
331 my($self,$initializer) = @_;
332 my($query_string,@lines);
335 # if we get called more than once, we want to initialize
336 # ourselves from the original query (which may be gone
337 # if it was read from STDIN originally.)
338 if (defined(@QUERY_PARAM) && !defined($initializer)) {
340 foreach (@QUERY_PARAM) {
341 $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
346 $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
348 # If initializer is defined, then read parameters
351 if (defined($initializer)) {
353 if (ref($initializer) && ref($initializer) eq 'HASH') {
354 foreach (keys %$initializer) {
355 $self->param('-name'=>$_,'-value'=>$initializer->{$_});
360 $initializer = $$initializer if ref($initializer);
361 if (defined(fileno($initializer))) {
362 while (<$initializer>) {
367 # massage back into standard format
368 if ("@lines" =~ /=/) {
369 $query_string=join("&",@lines);
371 $query_string=join("+",@lines);
375 $query_string = $initializer;
378 # If method is GET or HEAD, fetch the query from
380 if ($meth=~/^(GET|HEAD)$/) {
381 $query_string = $ENV{'QUERY_STRING'};
385 # If the method is POST, fetch the query from standard
387 if ($meth eq 'POST') {
389 if (defined($ENV{'CONTENT_TYPE'})
391 $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|) {
392 my($boundary) = $ENV{'CONTENT_TYPE'}=~/boundary=(\S+)/;
393 $self->read_multipart($boundary,$ENV{'CONTENT_LENGTH'});
397 $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0)
398 if $ENV{'CONTENT_LENGTH'} > 0;
401 # Some people want to have their cake and eat it too!
402 # Uncomment this line to have the contents of the query string
403 # APPENDED to the POST data.
404 # $query_string .= ($query_string ? '&' : '') . $ENV{'QUERY_STRING'} if $ENV{'QUERY_STRING'};
408 # If neither is set, assume we're being debugged offline.
409 # Check the command line and then the standard input for data.
410 # We use the shellwords package in order to behave the way that
411 # UN*X programmers expect.
412 $query_string = &read_from_cmdline;
415 # We now have the query string in hand. We do slightly
416 # different things for keyword lists and parameter lists.
418 if ($query_string =~ /=/) {
419 $self->parse_params($query_string);
421 $self->add_parameter('keywords');
422 $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
426 # Special case. Erase everything if there is a field named
428 if ($self->param('.defaults')) {
432 # Associative array containing our defined fieldnames
433 $self->{'.fieldnames'} = {};
434 foreach ($self->param('.cgifields')) {
435 $self->{'.fieldnames'}->{$_}++;
438 # Clear out our default submission button flag if present
439 $self->delete('.submit');
440 $self->delete('.cgifields');
441 $self->save_request unless $initializer;
446 # FUNCTIONS TO OVERRIDE:
448 # Turn a string into a filehandle
451 if ($string && !ref($string)) {
452 my($package) = caller(1);
453 my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string";
454 return $tmp if defined(fileno($tmp));
459 # Create a new multipart buffer
460 sub new_MultipartBuffer {
461 my($self,$boundary,$length,$filehandle) = @_;
462 return MultipartBuffer->new($self,$boundary,$length,$filehandle);
465 # Read data from a file handle
466 sub read_from_client {
467 my($self, $fh, $buff, $len, $offset) = @_;
468 local $^W=0; # prevent a warning
469 return read($fh, $$buff, $len, $offset);
472 # put a filehandle into binary mode (DOS)
477 # send output to the browser
479 my($self,@p) = self_or_default(@_);
483 # print to standard output (for overriding in mod_perl)
489 # unescape URL-encoded data
492 $todecode =~ tr/+/ /; # pluses become spaces
493 $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
500 $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
506 # We're going to play with the package globals now so that if we get called
507 # again, we initialize ourselves in exactly the same way. This allows
508 # us to have several of these objects.
509 @QUERY_PARAM = $self->param; # save list of parameters
510 foreach (@QUERY_PARAM) {
511 $QUERY_PARAM{$_}=$self->{$_};
515 sub parse_keywordlist {
516 my($self,$tosplit) = @_;
517 $tosplit = &unescape($tosplit); # unescape the keywords
518 $tosplit=~tr/+/ /; # pluses to spaces
519 my(@keywords) = split(/\s+/,$tosplit);
524 my($self,$tosplit) = @_;
525 my(@pairs) = split('&',$tosplit);
528 ($param,$value) = split('=');
529 $param = &unescape($param);
530 $value = &unescape($value);
531 $self->add_parameter($param);
532 push (@{$self->{$param}},$value);
538 push (@{$self->{'.parameters'}},$param)
539 unless defined($self->{$param});
544 return () unless defined($self) && $self->{'.parameters'};
545 return () unless @{$self->{'.parameters'}};
546 return @{$self->{'.parameters'}};
551 #### Method as_string
560 print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
561 my($func) = $AUTOLOAD;
562 my($pack,$func_name) = $func=~/(.+)::([^:]+)$/;
563 $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
564 unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
566 my($sub) = \%{"$pack\:\:SUBS"};
568 my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
569 eval "package $pack; $$auto";
572 my($code) = $sub->{$func_name};
574 $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
576 if ($EXPORT{':any'} ||
577 $EXPORT{$func_name} ||
578 (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
579 && $EXPORT_OK{$func_name}) {
580 $code = $sub->{'HTML_FUNC'};
581 $code=~s/func_name/$func_name/mg;
584 die "Undefined subroutine $AUTOLOAD\n" unless $code;
585 eval "package $pack; $code";
590 goto &{"$pack\:\:$func_name"};
594 # Smart rearrangement of parameters to allow named parameter
595 # calling. We do the rearangement if:
596 # 1. The first parameter begins with a -
597 # 2. The use_named_parameters() method returns true
599 my($self,$order,@param) = @_;
600 return () unless @param;
602 return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-')
603 || $self->use_named_parameters;
606 for ($i=0;$i<@param;$i+=2) {
607 $param[$i]=~s/^\-//; # get rid of initial - if present
608 $param[$i]=~tr/a-z/A-Z/; # parameters are upper case
611 my(%param) = @param; # convert into associative array
615 foreach $key (@$order) {
617 # this is an awful hack to fix spurious warnings when the
619 if (ref($key) && ref($key) eq 'ARRAY') {
621 last if defined($value);
626 $value = $param{$key};
629 push(@return_array,$value);
631 push (@return_array,$self->make_attributes(\%param)) if %param;
632 return (@return_array);
635 ###############################################################################
636 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
637 ###############################################################################
638 $AUTOLOADED_ROUTINES = ''; # get rid of -w warning
639 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
643 'URL_ENCODED'=> <<'END_OF_FUNC',
644 sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
647 'MULTIPART' => <<'END_OF_FUNC',
648 sub MULTIPART { 'multipart/form-data'; }
651 'HTML_FUNC' => <<'END_OF_FUNC',
654 # handle various cases in which we're called
655 # most of this bizarre stuff is to avoid -w errors
657 (!ref($_[0]) && $_[0] eq $CGI::DefaultClass) ||
659 (substr(ref($_[0]),0,3) eq 'CGI' ||
660 eval "\$_[0]->isaCGI()"));
663 if (ref($_[0]) && ref($_[0]) eq 'HASH') {
664 my(@attr) = CGI::make_attributes('',shift);
665 $attr = " @attr" if @attr;
667 my($tag,$untag) = ("\U<func_name\E$attr>","\U</func_name>\E");
668 return $tag unless @_;
669 if (ref($_[0]) eq 'ARRAY') {
672 push(@r,"$tag$_$untag");
676 return "$tag@_$untag";
681 #### Method: keywords
682 # Keywords acts a bit differently. Calling it in a list context
683 # returns the list of keywords.
684 # Calling it in a scalar context gives you the size of the list.
686 'keywords' => <<'END_OF_FUNC',
688 my($self,@values) = self_or_default(@_);
689 # If values is provided, then we set it.
690 $self->{'keywords'}=[@values] if @values;
691 my(@result) = @{$self->{'keywords'}};
696 # These are some tie() interfaces for compatibility
697 # with Steve Brenner's cgi-lib.pl routines
698 'ReadParse' => <<'END_OF_FUNC',
711 'PrintHeader' => <<'END_OF_FUNC',
713 my($self) = self_or_default(@_);
714 return $self->header();
718 'HtmlTop' => <<'END_OF_FUNC',
720 my($self,@p) = self_or_default(@_);
721 return $self->start_html(@p);
725 'HtmlBot' => <<'END_OF_FUNC',
727 my($self,@p) = self_or_default(@_);
728 return $self->end_html(@p);
732 'SplitParam' => <<'END_OF_FUNC',
735 my (@params) = split ("\0", $param);
736 return (wantarray ? @params : $params[0]);
740 'MethGet' => <<'END_OF_FUNC',
742 return request_method() eq 'GET';
746 'MethPost' => <<'END_OF_FUNC',
748 return request_method() eq 'POST';
752 'TIEHASH' => <<'END_OF_FUNC',
758 'STORE' => <<'END_OF_FUNC',
760 $_[0]->param($_[1],split("\0",$_[2]));
764 'FETCH' => <<'END_OF_FUNC',
766 return $_[0] if $_[1] eq 'CGI';
767 return undef unless defined $_[0]->param($_[1]);
768 return join("\0",$_[0]->param($_[1]));
772 'FIRSTKEY' => <<'END_OF_FUNC',
774 $_[0]->{'.iterator'}=0;
775 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
779 'NEXTKEY' => <<'END_OF_FUNC',
781 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
785 'EXISTS' => <<'END_OF_FUNC',
787 exists $_[0]->{$_[1]};
791 'DELETE' => <<'END_OF_FUNC',
793 $_[0]->delete($_[1]);
797 'CLEAR' => <<'END_OF_FUNC',
805 # Append a new value to an existing query
810 my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
811 my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
813 $self->add_parameter($name);
814 push(@{$self->{$name}},@values);
816 return $self->param($name);
820 #### Method: delete_all
821 # Delete all parameters
823 'delete_all' => <<'EOF',
825 my($self) = self_or_default(@_);
830 #### Method: autoescape
831 # If you want to turn off the autoescaping features,
832 # call this method with undef as the argument
833 'autoEscape' => <<'END_OF_FUNC',
835 my($self,$escape) = self_or_default(@_);
836 $self->{'dontescape'}=!$escape;
842 # Return the current version
844 'version' => <<'END_OF_FUNC',
850 'make_attributes' => <<'END_OF_FUNC',
851 sub make_attributes {
852 my($self,$attr) = @_;
853 return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
855 foreach (keys %{$attr}) {
857 $key=~s/^\-//; # get rid of initial - if present
858 $key=~tr/a-z/A-Z/; # parameters are upper case
859 push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/);
866 # Returns a string in which all the known parameter/value
867 # pairs are represented as nested lists, mainly for the purposes
870 'dump' => <<'END_OF_FUNC',
872 my($self) = self_or_default(@_);
873 my($param,$value,@result);
874 return '<UL></UL>' unless $self->param;
875 push(@result,"<UL>");
876 foreach $param ($self->param) {
877 my($name)=$self->escapeHTML($param);
878 push(@result,"<LI><STRONG>$param</STRONG>");
879 push(@result,"<UL>");
880 foreach $value ($self->param($param)) {
881 $value = $self->escapeHTML($value);
882 push(@result,"<LI>$value");
884 push(@result,"</UL>");
886 push(@result,"</UL>\n");
887 return join("\n",@result);
893 # Write values out to a filehandle in such a way that they can
894 # be reinitialized by the filehandle form of the new() method
896 'save' => <<'END_OF_FUNC',
898 my($self,$filehandle) = self_or_default(@_);
900 my($package) = caller;
901 # Check that this still works!
902 # $filehandle = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
903 $filehandle = to_filehandle($filehandle);
904 foreach $param ($self->param) {
905 my($escaped_param) = &escape($param);
907 foreach $value ($self->param($param)) {
908 print $filehandle "$escaped_param=",escape($value),"\n";
911 print $filehandle "=\n"; # end of record
917 # Return a Content-Type: style header
920 'header' => <<'END_OF_FUNC',
922 my($self,@p) = self_or_default(@_);
925 my($type,$status,$cookie,$target,$expires,$nph,@other) =
926 $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
928 # rearrange() was designed for the HTML portion, so we
929 # need to fix it up a little.
931 next unless my($header,$value) = /([^\s=]+)=(.+)/;
932 substr($header,1,1000)=~tr/A-Z/a-z/;
933 ($value)=$value=~/^"(.*)"$/;
934 $_ = "$header: $value";
937 $type = $type || 'text/html';
939 push(@header,'HTTP/1.0 ' . ($status || '200 OK')) if $nph || $NPH;
940 push(@header,"Status: $status") if $status;
941 push(@header,"Window-target: $target") if $target;
942 # push all the cookies -- there may be several
944 my(@cookie) = ref($cookie) ? @{$cookie} : $cookie;
946 push(@header,"Set-cookie: $_");
949 # if the user indicates an expiration time, then we need
950 # both an Expires and a Date header (so that the browser is
952 push(@header,"Expires: " . &expires($expires)) if $expires;
953 push(@header,"Date: " . &expires(0)) if $expires;
954 push(@header,"Pragma: no-cache") if $self->cache();
955 push(@header,@other);
956 push(@header,"Content-type: $type");
958 my $header = join($CRLF,@header);
959 return $header . "${CRLF}${CRLF}";
965 # Control whether header() will produce the no-cache
968 'cache' => <<'END_OF_FUNC',
970 my($self,$new_value) = self_or_default(@_);
971 $new_value = '' unless $new_value;
972 if ($new_value ne '') {
973 $self->{'cache'} = $new_value;
975 return $self->{'cache'};
980 #### Method: redirect
981 # Return a Location: style header
984 'redirect' => <<'END_OF_FUNC',
986 my($self,@p) = self_or_default(@_);
987 my($url,$target,$cookie,$nph,@other) = $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p);
988 $url = $url || $self->self_url;
990 foreach (@other) { push(@o,split("=")); }
992 '-Status'=>'302 Found',
995 '-nph'=>($nph||$NPH));
996 push(@o,'-Target'=>$target) if $target;
997 push(@o,'-Cookie'=>$cookie) if $cookie;
998 return $self->header(@o);
1003 #### Method: start_html
1004 # Canned HTML header
1007 # $title -> (optional) The title for this HTML document (-title)
1008 # $author -> (optional) e-mail address of the author (-author)
1009 # $base -> (optional) if set to true, will enter the BASE address of this document
1010 # for resolving relative references (-base)
1011 # $xbase -> (optional) alternative base at some remote location (-xbase)
1012 # $target -> (optional) target window to load all links into (-target)
1013 # $script -> (option) Javascript code (-script)
1014 # $meta -> (optional) Meta information tags
1015 # @other -> (optional) any other named parameters you'd like to incorporate into
1018 'start_html' => <<'END_OF_FUNC',
1020 my($self,@p) = &self_or_default(@_);
1021 my($title,$author,$base,$xbase,$script,$target,$meta,@other) =
1022 $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,TARGET,META],@p);
1024 # strangely enough, the title needs to be escaped as HTML
1025 # while the author needs to be escaped as a URL
1026 $title = $self->escapeHTML($title || 'Untitled Document');
1027 $author = $self->escapeHTML($author);
1029 push(@result,'<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">');
1030 push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
1031 push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if $author;
1033 if ($base || $xbase || $target) {
1034 my $href = $xbase || $self->url();
1035 my $t = $target ? qq/ TARGET="$target"/ : '';
1036 push(@result,qq/<BASE HREF="$href"$t>/);
1039 if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
1040 foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
1042 push(@result,<<END) if $script;
1044 <!-- Hide script from HTML-compliant browsers
1046 // End script hiding. -->
1050 my($other) = @other ? " @other" : '';
1051 push(@result,"</HEAD><BODY$other>");
1052 return join("\n",@result);
1057 #### Method: end_html
1058 # End an HTML document.
1059 # Trivial method for completeness. Just returns "</BODY>"
1061 'end_html' => <<'END_OF_FUNC',
1063 return "</BODY></HTML>";
1068 ################################
1069 # METHODS USED IN BUILDING FORMS
1070 ################################
1072 #### Method: isindex
1073 # Just prints out the isindex tag.
1075 # $action -> optional URL of script to run
1077 # A string containing a <ISINDEX> tag
1078 'isindex' => <<'END_OF_FUNC',
1080 my($self,@p) = self_or_default(@_);
1081 my($action,@other) = $self->rearrange([ACTION],@p);
1082 $action = qq/ACTION="$action"/ if $action;
1083 my($other) = @other ? " @other" : '';
1084 return "<ISINDEX $action$other>";
1089 #### Method: startform
1092 # $method -> optional submission method to use (GET or POST)
1093 # $action -> optional URL of script to run
1094 # $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1095 'startform' => <<'END_OF_FUNC',
1097 my($self,@p) = self_or_default(@_);
1099 my($method,$action,$enctype,@other) =
1100 $self->rearrange([METHOD,ACTION,ENCTYPE],@p);
1102 $method = $method || 'POST';
1103 $enctype = $enctype || &URL_ENCODED;
1104 $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
1105 'ACTION="'.$self->script_name.'"' : '';
1106 my($other) = @other ? " @other" : '';
1107 $self->{'.parametersToAdd'}={};
1108 return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
1113 #### Method: start_form
1114 # synonym for startform
1115 'start_form' => <<'END_OF_FUNC',
1122 #### Method: start_multipart_form
1123 # synonym for startform
1124 'start_multipart_form' => <<'END_OF_FUNC',
1125 sub start_multipart_form {
1126 my($self,@p) = self_or_default(@_);
1127 if ($self->use_named_parameters ||
1128 (defined($param[0]) && substr($param[0],0,1) eq '-')) {
1130 $p{'-enctype'}=&MULTIPART;
1131 return $self->startform(%p);
1133 my($method,$action,@other) =
1134 $self->rearrange([METHOD,ACTION],@p);
1135 return $self->startform($method,$action,&MULTIPART,@other);
1141 #### Method: endform
1143 'endform' => <<'END_OF_FUNC',
1145 my($self,@p) = self_or_default(@_);
1146 return ($self->get_fields,"</FORM>");
1151 #### Method: end_form
1152 # synonym for endform
1153 'end_form' => <<'END_OF_FUNC',
1160 #### Method: textfield
1162 # $name -> Name of the text field
1163 # $default -> Optional default value of the field if not
1165 # $size -> Optional width of field in characaters.
1166 # $maxlength -> Optional maximum number of characters.
1168 # A string containing a <INPUT TYPE="text"> field
1170 'textfield' => <<'END_OF_FUNC',
1172 my($self,@p) = self_or_default(@_);
1173 my($name,$default,$size,$maxlength,$override,@other) =
1174 $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1176 my $current = $override ? $default :
1177 (defined($self->param($name)) ? $self->param($name) : $default);
1179 $current = defined($current) ? $self->escapeHTML($current) : '';
1180 $name = defined($name) ? $self->escapeHTML($name) : '';
1181 my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1182 my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
1183 my($other) = @other ? " @other" : '';
1184 return qq/<INPUT TYPE="text" NAME="$name" VALUE="$current"$s$m$other>/;
1189 #### Method: filefield
1191 # $name -> Name of the file upload field
1192 # $size -> Optional width of field in characaters.
1193 # $maxlength -> Optional maximum number of characters.
1195 # A string containing a <INPUT TYPE="text"> field
1197 'filefield' => <<'END_OF_FUNC',
1199 my($self,@p) = self_or_default(@_);
1201 my($name,$default,$size,$maxlength,$override,@other) =
1202 $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1204 $current = $override ? $default :
1205 (defined($self->param($name)) ? $self->param($name) : $default);
1207 $name = defined($name) ? $self->escapeHTML($name) : '';
1208 my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1209 my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
1210 $current = defined($current) ? $self->escapeHTML($current) : '';
1211 $other = ' ' . join(" ",@other);
1212 return qq/<INPUT TYPE="file" NAME="$name" VALUE="$current"$s$m$other>/;
1217 #### Method: password
1218 # Create a "secret password" entry field
1220 # $name -> Name of the field
1221 # $default -> Optional default value of the field if not
1223 # $size -> Optional width of field in characters.
1224 # $maxlength -> Optional maximum characters that can be entered.
1226 # A string containing a <INPUT TYPE="password"> field
1228 'password_field' => <<'END_OF_FUNC',
1229 sub password_field {
1230 my ($self,@p) = self_or_default(@_);
1232 my($name,$default,$size,$maxlength,$override,@other) =
1233 $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1235 my($current) = $override ? $default :
1236 (defined($self->param($name)) ? $self->param($name) : $default);
1238 $name = defined($name) ? $self->escapeHTML($name) : '';
1239 $current = defined($current) ? $self->escapeHTML($current) : '';
1240 my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1241 my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
1242 my($other) = @other ? " @other" : '';
1243 return qq/<INPUT TYPE="password" NAME="$name" VALUE="$current"$s$m$other>/;
1248 #### Method: textarea
1250 # $name -> Name of the text field
1251 # $default -> Optional default value of the field if not
1253 # $rows -> Optional number of rows in text area
1254 # $columns -> Optional number of columns in text area
1256 # A string containing a <TEXTAREA></TEXTAREA> tag
1258 'textarea' => <<'END_OF_FUNC',
1260 my($self,@p) = self_or_default(@_);
1262 my($name,$default,$rows,$cols,$override,@other) =
1263 $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
1265 my($current)= $override ? $default :
1266 (defined($self->param($name)) ? $self->param($name) : $default);
1268 $name = defined($name) ? $self->escapeHTML($name) : '';
1269 $current = defined($current) ? $self->escapeHTML($current) : '';
1270 my($r) = $rows ? " ROWS=$rows" : '';
1271 my($c) = $cols ? " COLS=$cols" : '';
1272 my($other) = @other ? " @other" : '';
1273 return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
1279 # Create a javascript button.
1281 # $name -> (optional) Name for the button. (-name)
1282 # $value -> (optional) Value of the button when selected (and visible name) (-value)
1283 # $onclick -> (optional) Text of the JavaScript to run when the button is
1286 # A string containing a <INPUT TYPE="button"> tag
1288 'button' => <<'END_OF_FUNC',
1290 my($self,@p) = self_or_default(@_);
1292 my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
1293 [ONCLICK,SCRIPT]],@p);
1295 $label=$self->escapeHTML($label);
1296 $value=$self->escapeHTML($value);
1297 $script=$self->escapeHTML($script);
1300 $name = qq/ NAME="$label"/ if $label;
1301 $value = $value || $label;
1303 $val = qq/ VALUE="$value"/ if $value;
1304 $script = qq/ ONCLICK="$script"/ if $script;
1305 my($other) = @other ? " @other" : '';
1306 return qq/<INPUT TYPE="button"$name$val$script$other>/;
1312 # Create a "submit query" button.
1314 # $name -> (optional) Name for the button.
1315 # $value -> (optional) Value of the button when selected (also doubles as label).
1316 # $label -> (optional) Label printed on the button(also doubles as the value).
1318 # A string containing a <INPUT TYPE="submit"> tag
1320 'submit' => <<'END_OF_FUNC',
1322 my($self,@p) = self_or_default(@_);
1324 my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p);
1326 $label=$self->escapeHTML($label);
1327 $value=$self->escapeHTML($value);
1329 my($name) = ' NAME=".submit"';
1330 $name = qq/ NAME="$label"/ if $label;
1331 $value = $value || $label;
1333 $val = qq/ VALUE="$value"/ if defined($value);
1334 my($other) = @other ? " @other" : '';
1335 return qq/<INPUT TYPE="submit"$name$val$other>/;
1341 # Create a "reset" button.
1343 # $name -> (optional) Name for the button.
1345 # A string containing a <INPUT TYPE="reset"> tag
1347 'reset' => <<'END_OF_FUNC',
1349 my($self,@p) = self_or_default(@_);
1350 my($label,@other) = $self->rearrange([NAME],@p);
1351 $label=$self->escapeHTML($label);
1352 my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
1353 my($other) = @other ? " @other" : '';
1354 return qq/<INPUT TYPE="reset"$value$other>/;
1359 #### Method: defaults
1360 # Create a "defaults" button.
1362 # $name -> (optional) Name for the button.
1364 # A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
1366 # Note: this button has a special meaning to the initialization script,
1367 # and tells it to ERASE the current query string so that your defaults
1370 'defaults' => <<'END_OF_FUNC',
1372 my($self,@p) = self_or_default(@_);
1374 my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
1376 $label=$self->escapeHTML($label);
1377 $label = $label || "Defaults";
1378 my($value) = qq/ VALUE="$label"/;
1379 my($other) = @other ? " @other" : '';
1380 return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
1385 #### Method: checkbox
1386 # Create a checkbox that is not logically linked to any others.
1387 # The field value is "on" when the button is checked.
1389 # $name -> Name of the checkbox
1390 # $checked -> (optional) turned on by default if true
1391 # $value -> (optional) value of the checkbox, 'on' by default
1392 # $label -> (optional) a user-readable label printed next to the box.
1393 # Otherwise the checkbox name is used.
1395 # A string containing a <INPUT TYPE="checkbox"> field
1397 'checkbox' => <<'END_OF_FUNC',
1399 my($self,@p) = self_or_default(@_);
1401 my($name,$checked,$value,$label,$override,@other) =
1402 $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
1404 if (!$override && defined($self->param($name))) {
1405 $value = $self->param($name) unless defined $value;
1406 $checked = $self->param($name) eq $value ? ' CHECKED' : '';
1408 $checked = $checked ? ' CHECKED' : '';
1409 $value = defined $value ? $value : 'on';
1411 my($the_label) = defined $label ? $label : $name;
1412 $name = $self->escapeHTML($name);
1413 $value = $self->escapeHTML($value);
1414 $the_label = $self->escapeHTML($the_label);
1415 my($other) = @other ? " @other" : '';
1416 $self->register_parameter($name);
1418 <INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label
1424 #### Method: checkbox_group
1425 # Create a list of logically-linked checkboxes.
1427 # $name -> Common name for all the check boxes
1428 # $values -> A pointer to a regular array containing the
1429 # values for each checkbox in the group.
1430 # $defaults -> (optional)
1431 # 1. If a pointer to a regular array of checkbox values,
1432 # then this will be used to decide which
1433 # checkboxes to turn on by default.
1434 # 2. If a scalar, will be assumed to hold the
1435 # value of a single checkbox in the group to turn on.
1436 # $linebreak -> (optional) Set to true to place linebreaks
1437 # between the buttons.
1438 # $labels -> (optional)
1439 # A pointer to an associative array of labels to print next to each checkbox
1440 # in the form $label{'value'}="Long explanatory label".
1441 # Otherwise the provided values are used as the labels.
1443 # An ARRAY containing a series of <INPUT TYPE="checkbox"> fields
1445 'checkbox_group' => <<'END_OF_FUNC',
1446 sub checkbox_group {
1447 my($self,@p) = self_or_default(@_);
1449 my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
1450 $rowheaders,$colheaders,$override,$nolabels,@other) =
1451 $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1452 LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
1453 ROWHEADERS,COLHEADERS,
1454 [OVERRIDE,FORCE],NOLABELS],@p);
1456 my($checked,$break,$result,$label);
1458 my(%checked) = $self->previous_or_default($name,$defaults,$override);
1460 $break = $linebreak ? "<BR>" : '';
1461 $name=$self->escapeHTML($name);
1463 # Create the elements
1465 my(@values) = $values ? @$values : $self->param($name);
1466 my($other) = @other ? " @other" : '';
1468 $checked = $checked{$_} ? ' CHECKED' : '';
1470 unless (defined($nolabels) && $nolabels) {
1472 $label = $labels->{$_} if defined($labels) && $labels->{$_};
1473 $label = $self->escapeHTML($label);
1475 $_ = $self->escapeHTML($_);
1476 push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label} ${break}/);
1478 $self->register_parameter($name);
1479 return wantarray ? @elements : join('',@elements) unless $columns;
1480 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1485 # Escape HTML -- used internally
1486 'escapeHTML' => <<'END_OF_FUNC',
1488 my($self,$toencode) = @_;
1489 return undef unless defined($toencode);
1490 return $toencode if $self->{'dontescape'};
1491 $toencode=~s/&/&/g;
1492 $toencode=~s/\"/"/g;
1493 $toencode=~s/>/>/g;
1494 $toencode=~s/</</g;
1500 # Internal procedure - don't use
1501 '_tableize' => <<'END_OF_FUNC',
1503 my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
1506 $rows = int(0.99 + @elements/$columns) unless $rows;
1507 # rearrange into a pretty table
1508 $result = "<TABLE>";
1510 unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
1511 $result .= "<TR>" if @{$colheaders};
1512 foreach (@{$colheaders}) {
1513 $result .= "<TH>$_</TH>";
1515 for ($row=0;$row<$rows;$row++) {
1517 $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
1518 for ($column=0;$column<$columns;$column++) {
1519 $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>";
1523 $result .= "</TABLE>";
1529 #### Method: radio_group
1530 # Create a list of logically-linked radio buttons.
1532 # $name -> Common name for all the buttons.
1533 # $values -> A pointer to a regular array containing the
1534 # values for each button in the group.
1535 # $default -> (optional) Value of the button to turn on by default. Pass '-'
1536 # to turn _nothing_ on.
1537 # $linebreak -> (optional) Set to true to place linebreaks
1538 # between the buttons.
1539 # $labels -> (optional)
1540 # A pointer to an associative array of labels to print next to each checkbox
1541 # in the form $label{'value'}="Long explanatory label".
1542 # Otherwise the provided values are used as the labels.
1544 # An ARRAY containing a series of <INPUT TYPE="radio"> fields
1546 'radio_group' => <<'END_OF_FUNC',
1548 my($self,@p) = self_or_default(@_);
1550 my($name,$values,$default,$linebreak,$labels,
1551 $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
1552 $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
1553 ROWS,[COLUMNS,COLS],
1554 ROWHEADERS,COLHEADERS,
1555 [OVERRIDE,FORCE],NOLABELS],@p);
1556 my($result,$checked);
1558 if (!$override && defined($self->param($name))) {
1559 $checked = $self->param($name);
1561 $checked = $default;
1563 # If no check array is specified, check the first by default
1564 $checked = $values->[0] unless $checked;
1565 $name=$self->escapeHTML($name);
1568 my(@values) = $values ? @$values : $self->param($name);
1569 my($other) = @other ? " @other" : '';
1571 my($checkit) = $checked eq $_ ? ' CHECKED' : '';
1572 my($break) = $linebreak ? '<BR>' : '';
1574 unless (defined($nolabels) && $nolabels) {
1576 $label = $labels->{$_} if defined($labels) && $labels->{$_};
1577 $label = $self->escapeHTML($label);
1579 $_=$self->escapeHTML($_);
1580 push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label} ${break}/);
1582 $self->register_parameter($name);
1583 return wantarray ? @elements : join('',@elements) unless $columns;
1584 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1589 #### Method: popup_menu
1590 # Create a popup menu.
1592 # $name -> Name for all the menu
1593 # $values -> A pointer to a regular array containing the
1594 # text of each menu item.
1595 # $default -> (optional) Default item to display
1596 # $labels -> (optional)
1597 # A pointer to an associative array of labels to print next to each checkbox
1598 # in the form $label{'value'}="Long explanatory label".
1599 # Otherwise the provided values are used as the labels.
1601 # A string containing the definition of a popup menu.
1603 'popup_menu' => <<'END_OF_FUNC',
1605 my($self,@p) = self_or_default(@_);
1607 my($name,$values,$default,$labels,$override,@other) =
1608 $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
1609 my($result,$selected);
1611 if (!$override && defined($self->param($name))) {
1612 $selected = $self->param($name);
1614 $selected = $default;
1616 $name=$self->escapeHTML($name);
1617 my($other) = @other ? " @other" : '';
1619 my(@values) = $values ? @$values : $self->param($name);
1620 $result = qq/<SELECT NAME="$name"$other>\n/;
1622 my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
1624 $label = $labels->{$_} if defined($labels) && $labels->{$_};
1625 my($value) = $self->escapeHTML($_);
1626 $label=$self->escapeHTML($label);
1627 $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
1630 $result .= "</SELECT>\n";
1636 #### Method: scrolling_list
1637 # Create a scrolling list.
1639 # $name -> name for the list
1640 # $values -> A pointer to a regular array containing the
1641 # values for each option line in the list.
1642 # $defaults -> (optional)
1643 # 1. If a pointer to a regular array of options,
1644 # then this will be used to decide which
1645 # lines to turn on by default.
1646 # 2. Otherwise holds the value of the single line to turn on.
1647 # $size -> (optional) Size of the list.
1648 # $multiple -> (optional) If set, allow multiple selections.
1649 # $labels -> (optional)
1650 # A pointer to an associative array of labels to print next to each checkbox
1651 # in the form $label{'value'}="Long explanatory label".
1652 # Otherwise the provided values are used as the labels.
1654 # A string containing the definition of a scrolling list.
1656 'scrolling_list' => <<'END_OF_FUNC',
1657 sub scrolling_list {
1658 my($self,@p) = self_or_default(@_);
1659 my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
1660 = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1661 SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
1664 my(@values) = $values ? @$values : $self->param($name);
1665 $size = $size || scalar(@values);
1667 my(%selected) = $self->previous_or_default($name,$defaults,$override);
1668 my($is_multiple) = $multiple ? ' MULTIPLE' : '';
1669 my($has_size) = $size ? " SIZE=$size" : '';
1670 my($other) = @other ? " @other" : '';
1672 $name=$self->escapeHTML($name);
1673 $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
1675 my($selectit) = $selected{$_} ? 'SELECTED' : '';
1677 $label = $labels->{$_} if defined($labels) && $labels->{$_};
1678 $label=$self->escapeHTML($label);
1679 my($value)=$self->escapeHTML($_);
1680 $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
1682 $result .= "</SELECT>\n";
1683 $self->register_parameter($name);
1691 # $name -> Name of the hidden field
1692 # @default -> (optional) Initial values of field (may be an array)
1694 # $default->[initial values of field]
1696 # A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
1698 'hidden' => <<'END_OF_FUNC',
1700 my($self,@p) = self_or_default(@_);
1702 # this is the one place where we departed from our standard
1703 # calling scheme, so we have to special-case (darn)
1705 my($name,$default,$override,@other) =
1706 $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
1708 my $do_override = 0;
1709 if ( substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
1710 @value = ref($default) ? @{$default} : $default;
1711 $do_override = $override;
1713 foreach ($default,$override,@other) {
1714 push(@value,$_) if defined($_);
1718 # use previous values if override is not set
1719 my @prev = $self->param($name);
1720 @value = @prev if !$do_override && @prev;
1722 $name=$self->escapeHTML($name);
1724 $_=$self->escapeHTML($_);
1725 push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
1727 return wantarray ? @result : join('',@result);
1732 #### Method: image_button
1734 # $name -> Name of the button
1735 # $src -> URL of the image source
1736 # $align -> Alignment style (TOP, BOTTOM or MIDDLE)
1738 # A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment">
1740 'image_button' => <<'END_OF_FUNC',
1742 my($self,@p) = self_or_default(@_);
1744 my($name,$src,$alignment,@other) =
1745 $self->rearrange([NAME,SRC,ALIGN],@p);
1747 my($align) = $alignment ? " ALIGN=\U$alignment" : '';
1748 my($other) = @other ? " @other" : '';
1749 $name=$self->escapeHTML($name);
1750 return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/;
1755 #### Method: self_url
1756 # Returns a URL containing the current script and all its
1757 # param/value pairs arranged as a query. You can use this
1758 # to create a link that, when selected, will reinvoke the
1759 # script with all its state information preserved.
1761 'self_url' => <<'END_OF_FUNC',
1763 my($self) = self_or_default(@_);
1764 my($query_string) = $self->query_string;
1765 my $protocol = $self->protocol();
1766 my $name = "$protocol://" . $self->server_name;
1767 $name .= ":" . $self->server_port
1768 unless $self->server_port == 80;
1769 $name .= $self->script_name;
1770 $name .= $self->path_info if $self->path_info;
1771 return $name unless $query_string;
1772 return "$name?$query_string";
1777 # This is provided as a synonym to self_url() for people unfortunate
1778 # enough to have incorporated it into their programs already!
1779 'state' => <<'END_OF_FUNC',
1787 # Like self_url, but doesn't return the query string part of
1790 'url' => <<'END_OF_FUNC',
1792 my($self) = self_or_default(@_);
1793 my $protocol = $self->protocol();
1794 my $name = "$protocol://" . $self->server_name;
1795 $name .= ":" . $self->server_port
1796 unless $self->server_port == 80;
1797 $name .= $self->script_name;
1804 # Set or read a cookie from the specified name.
1805 # Cookie can then be passed to header().
1806 # Usual rules apply to the stickiness of -value.
1808 # -name -> name for this cookie (optional)
1809 # -value -> value of this cookie (scalar, array or hash)
1810 # -path -> paths for which this cookie is valid (optional)
1811 # -domain -> internet domain in which this cookie is valid (optional)
1812 # -secure -> if true, cookie only passed through secure channel (optional)
1813 # -expires -> expiry date in format Wdy, DD-Mon-YY HH:MM:SS GMT (optional)
1815 'cookie' => <<'END_OF_FUNC',
1816 # temporary, for debugging.
1818 my($self,@p) = self_or_default(@_);
1819 my($name,$value,$path,$domain,$secure,$expires) =
1820 $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
1823 # if no value is supplied, then we retrieve the
1824 # value of the cookie, if any. For efficiency, we cache the parsed
1825 # cookie in our state variables.
1826 unless (defined($value)) {
1827 unless ($self->{'.cookies'}) {
1828 my(@pairs) = split("; ",$self->raw_cookie);
1830 my($key,$value) = split("=");
1831 my(@values) = map unescape($_),split('&',$value);
1832 $self->{'.cookies'}->{unescape($key)} = [@values];
1836 # If no name is supplied, then retrieve the names of all our cookies.
1837 return () unless $self->{'.cookies'};
1838 return wantarray ? @{$self->{'.cookies'}->{$name}} : $self->{'.cookies'}->{$name}->[0]
1839 if defined($name) && $name ne '';
1840 return keys %{$self->{'.cookies'}};
1844 # Pull out our parameters.
1846 if (ref($value) eq 'ARRAY') {
1848 } elsif (ref($value) eq 'HASH') {
1854 @values = map escape($_),@values;
1856 # I.E. requires the path to be present.
1857 ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $path;
1859 my(@constant_values);
1860 push(@constant_values,"domain=$domain") if $domain;
1861 push(@constant_values,"path=$path") if $path;
1862 push(@constant_values,"expires=".&expires($expires)) if $expires;
1863 push(@constant_values,'secure') if $secure;
1865 my($key) = &escape($name);
1866 my($cookie) = join("=",$key,join("&",@values));
1867 return join("; ",$cookie,@constant_values);
1872 # This internal routine creates an expires string exactly some number of
1873 # hours from the current time in GMT. This is the format
1874 # required by Netscape cookies, and I think it works for the HTTP
1875 # Expires: header as well.
1876 'expires' => <<'END_OF_FUNC',
1879 my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
1880 my(@WDAY) = qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/;
1881 my(%mult) = ('s'=>1,
1887 # format for time can be in any of the forms...
1888 # "now" -- expire immediately
1889 # "+180s" -- in 180 seconds
1890 # "+2m" -- in 2 minutes
1891 # "+12h" -- in 12 hours
1893 # "+3M" -- in 3 months
1894 # "+2y" -- in 2 years
1895 # "-3m" -- 3 minutes ago(!)
1896 # If you don't supply one of these forms, we assume you are
1897 # specifying the date yourself
1899 if (!$time || ($time eq 'now')) {
1901 } elsif ($time=~/^([+-]?\d+)([mhdMy]?)/) {
1902 $offset = ($mult{$2} || 1)*$1;
1906 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime(time+$offset);
1907 $year += 1900 unless $year < 100;
1908 return sprintf("%s, %02d-%s-%02d %02d:%02d:%02d GMT",
1909 $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
1914 ###############################################
1915 # OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
1916 ###############################################
1918 #### Method: path_info
1919 # Return the extra virtual path information provided
1920 # after the URL (if any)
1922 'path_info' => <<'END_OF_FUNC',
1924 return $ENV{'PATH_INFO'};
1929 #### Method: request_method
1930 # Returns 'POST', 'GET', 'PUT' or 'HEAD'
1932 'request_method' => <<'END_OF_FUNC',
1933 sub request_method {
1934 return $ENV{'REQUEST_METHOD'};
1938 #### Method: path_translated
1939 # Return the physical path information provided
1940 # by the URL (if any)
1942 'path_translated' => <<'END_OF_FUNC',
1943 sub path_translated {
1944 return $ENV{'PATH_TRANSLATED'};
1949 #### Method: query_string
1950 # Synthesize a query string from our current
1953 'query_string' => <<'END_OF_FUNC',
1955 my($self) = self_or_default(@_);
1956 my($param,$value,@pairs);
1957 foreach $param ($self->param) {
1958 my($eparam) = &escape($param);
1959 foreach $value ($self->param($param)) {
1960 $value = &escape($value);
1961 push(@pairs,"$eparam=$value");
1964 return join("&",@pairs);
1970 # Without parameters, returns an array of the
1971 # MIME types the browser accepts.
1972 # With a single parameter equal to a MIME
1973 # type, will return undef if the browser won't
1974 # accept it, 1 if the browser accepts it but
1975 # doesn't give a preference, or a floating point
1976 # value between 0.0 and 1.0 if the browser
1977 # declares a quantitative score for it.
1978 # This handles MIME type globs correctly.
1980 'accept' => <<'END_OF_FUNC',
1982 my($self,$search) = self_or_CGI(@_);
1983 my(%prefs,$type,$pref,$pat);
1985 my(@accept) = split(',',$self->http('accept'));
1988 ($pref) = /q=(\d\.\d+|\d+)/;
1989 ($type) = m#(\S+/[^;]+)#;
1991 $prefs{$type}=$pref || 1;
1994 return keys %prefs unless $search;
1996 # if a search type is provided, we may need to
1997 # perform a pattern matching operation.
1998 # The MIME types use a glob mechanism, which
1999 # is easily translated into a perl pattern match
2001 # First return the preference for directly supported
2003 return $prefs{$search} if $prefs{$search};
2005 # Didn't get it, so try pattern matching.
2006 foreach (keys %prefs) {
2007 next unless /\*/; # not a pattern match
2008 ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2009 $pat =~ s/\*/.*/g; # turn it into a pattern
2010 return $prefs{$_} if $search=~/$pat/;
2016 #### Method: user_agent
2017 # If called with no parameters, returns the user agent.
2018 # If called with one parameter, does a pattern match (case
2019 # insensitive) on the user agent.
2021 'user_agent' => <<'END_OF_FUNC',
2023 my($self,$match)=self_or_CGI(@_);
2024 return $self->http('user_agent') unless $match;
2025 return $self->http('user_agent') =~ /$match/i;
2031 # Returns the magic cookie for the session.
2032 # To set the magic cookie for new transations,
2033 # try print $q->header('-Set-cookie'=>'my cookie')
2035 'raw_cookie' => <<'END_OF_FUNC',
2037 my($self) = self_or_CGI(@_);
2038 return $self->http('cookie') || $ENV{'COOKIE'} || '';
2042 #### Method: virtual_host
2043 # Return the name of the virtual_host, which
2044 # is not always the same as the server
2046 'virtual_host' => <<'END_OF_FUNC',
2048 return http('host') || server_name();
2052 #### Method: remote_host
2053 # Return the name of the remote host, or its IP
2054 # address if unavailable. If this variable isn't
2055 # defined, it returns "localhost" for debugging
2058 'remote_host' => <<'END_OF_FUNC',
2060 return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
2066 #### Method: remote_addr
2067 # Return the IP addr of the remote host.
2069 'remote_addr' => <<'END_OF_FUNC',
2071 return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
2076 #### Method: script_name
2077 # Return the partial URL to this script for
2078 # self-referencing scripts. Also see
2079 # self_url(), which returns a URL with all state information
2082 'script_name' => <<'END_OF_FUNC',
2084 return $ENV{'SCRIPT_NAME'} if $ENV{'SCRIPT_NAME'};
2085 # These are for debugging
2086 return "/$0" unless $0=~/^\//;
2092 #### Method: referer
2093 # Return the HTTP_REFERER: useful for generating
2096 'referer' => <<'END_OF_FUNC',
2098 my($self) = self_or_CGI(@_);
2099 return $self->http('referer');
2104 #### Method: server_name
2105 # Return the name of the server
2107 'server_name' => <<'END_OF_FUNC',
2109 return $ENV{'SERVER_NAME'} || 'localhost';
2113 #### Method: server_software
2114 # Return the name of the server software
2116 'server_software' => <<'END_OF_FUNC',
2117 sub server_software {
2118 return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
2122 #### Method: server_port
2123 # Return the tcp/ip port the server is running on
2125 'server_port' => <<'END_OF_FUNC',
2127 return $ENV{'SERVER_PORT'} || 80; # for debugging
2131 #### Method: server_protocol
2132 # Return the protocol (usually HTTP/1.0)
2134 'server_protocol' => <<'END_OF_FUNC',
2135 sub server_protocol {
2136 return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
2141 # Return the value of an HTTP variable, or
2142 # the list of variables if none provided
2144 'http' => <<'END_OF_FUNC',
2146 my ($self,$parameter) = self_or_CGI(@_);
2147 return $ENV{$parameter} if $parameter=~/^HTTP/;
2148 return $ENV{"HTTP_\U$parameter\E"} if $parameter;
2150 foreach (keys %ENV) {
2151 push(@p,$_) if /^HTTP/;
2158 # Return the value of HTTPS
2160 'https' => <<'END_OF_FUNC',
2163 my ($self,$parameter) = self_or_CGI(@_);
2164 return $ENV{HTTPS} unless $parameter;
2165 return $ENV{$parameter} if $parameter=~/^HTTPS/;
2166 return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
2168 foreach (keys %ENV) {
2169 push(@p,$_) if /^HTTPS/;
2175 #### Method: protocol
2176 # Return the protocol (http or https currently)
2178 'protocol' => <<'END_OF_FUNC',
2182 return 'https' if $self->https() eq 'ON';
2183 return 'https' if $self->server_port == 443;
2184 my $prot = $self->server_protocol;
2185 my($protocol,$version) = split('/',$prot);
2186 return "\L$protocol\E";
2190 #### Method: remote_ident
2191 # Return the identity of the remote user
2192 # (but only if his host is running identd)
2194 'remote_ident' => <<'END_OF_FUNC',
2196 return $ENV{'REMOTE_IDENT'};
2201 #### Method: auth_type
2202 # Return the type of use verification/authorization in use, if any.
2204 'auth_type' => <<'END_OF_FUNC',
2206 return $ENV{'AUTH_TYPE'};
2211 #### Method: remote_user
2212 # Return the authorization name used for user
2215 'remote_user' => <<'END_OF_FUNC',
2217 return $ENV{'REMOTE_USER'};
2222 #### Method: user_name
2223 # Try to return the remote user's name by hook or by
2226 'user_name' => <<'END_OF_FUNC',
2228 my ($self) = self_or_CGI(@_);
2229 return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
2234 # Set or return the NPH global flag
2236 'nph' => <<'END_OF_FUNC',
2238 my ($self,$param) = self_or_CGI(@_);
2239 $CGI::nph = $param if defined($param);
2244 # -------------- really private subroutines -----------------
2245 'previous_or_default' => <<'END_OF_FUNC',
2246 sub previous_or_default {
2247 my($self,$name,$defaults,$override) = @_;
2250 if (!$override && ($self->{'.fieldnames'}->{$name} ||
2251 defined($self->param($name)) ) ) {
2252 grep($selected{$_}++,$self->param($name));
2253 } elsif (defined($defaults) && ref($defaults) &&
2254 (ref($defaults) eq 'ARRAY')) {
2255 grep($selected{$_}++,@{$defaults});
2257 $selected{$defaults}++ if defined($defaults);
2264 'register_parameter' => <<'END_OF_FUNC',
2265 sub register_parameter {
2266 my($self,$param) = @_;
2267 $self->{'.parametersToAdd'}->{$param}++;
2271 'get_fields' => <<'END_OF_FUNC',
2274 return $self->hidden('-name'=>'.cgifields',
2275 '-values'=>[keys %{$self->{'.parametersToAdd'}}],
2280 'read_from_cmdline' => <<'END_OF_FUNC',
2281 sub read_from_cmdline {
2282 require "shellwords.pl";
2286 $input = join(" ",@ARGV);
2288 print STDERR "(offline mode: enter name=value pairs on standard input)\n";
2289 chomp(@lines = <>); # remove newlines
2290 $input = join(" ",@lines);
2293 # minimal handling of escape characters
2294 $input=~s/\\=/%3D/g;
2295 $input=~s/\\&/%26/g;
2297 @words = &shellwords($input);
2298 if ("@words"=~/=/) {
2299 $query_string = join('&',@words);
2301 $query_string = join('+',@words);
2303 return $query_string;
2308 # subroutine: read_multipart
2310 # Read multipart data and store it into our parameters.
2311 # An interesting feature is that if any of the parts is a file, we
2312 # create a temporary file and open up a filehandle on it so that the
2313 # caller can read from it if necessary.
2315 'read_multipart' => <<'END_OF_FUNC',
2316 sub read_multipart {
2317 my($self,$boundary,$length) = @_;
2318 my($buffer) = $self->new_MultipartBuffer($boundary,$length);
2319 return unless $buffer;
2321 while (!$buffer->eof) {
2322 %header = $buffer->readHeader;
2324 # In beta1 it was "Content-disposition". In beta2 it's "Content-Disposition"
2326 my($key) = $header{'Content-disposition'} ? 'Content-disposition' : 'Content-Disposition';
2327 my($param)= $header{$key}=~/ name="([^\"]*)"/;
2329 # possible bug: our regular expression expects the filename= part to fall
2330 # at the end of the line. Netscape doesn't escape quotation marks in file names!!!
2331 my($filename) = $header{$key}=~/ filename="(.*)"$/;
2333 # add this parameter to our list
2334 $self->add_parameter($param);
2336 # If no filename specified, then just read the data and assign it
2337 # to our parameter list.
2338 unless ($filename) {
2339 my($value) = $buffer->readBody;
2340 push(@{$self->{$param}},$value);
2344 # If we get here, then we are dealing with a potentially large
2345 # uploaded form. Save the data to a temporary file, then open
2346 # the file for reading.
2347 my($tmpfile) = new TempFile;
2348 my $tmp = $tmpfile->as_string;
2350 open (OUT,">$tmp") || die "CGI open of $tmpfile: $!\n";
2351 $CGI::DefaultClass->binmode(OUT) if $CGI::needs_binmode;
2352 chmod 0666,$tmp; # make sure anyone can delete it.
2354 while ($data = $buffer->read) {
2359 # Now create a new filehandle in the caller's namespace.
2360 # The name of this filehandle just happens to be identical
2361 # to the original filename (NOT the name of the temporary
2362 # file, which is hidden!)
2364 if ($filename=~/^[a-zA-Z_]/) {
2366 do { $cp = caller($frame++); } until !eval("'$cp'->isaCGI()");
2367 $filehandle = "$cp\:\:$filename";
2369 $filehandle = "\:\:$filename";
2372 open($filehandle,$tmp) || die "CGI open of $tmp: $!\n";
2373 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2375 push(@{$self->{$param}},$filename);
2377 # Under Unix, it would be safe to let the temporary file
2378 # be deleted immediately. However, I fear that other operating
2379 # systems are not so forgiving. Therefore we save a reference
2380 # to the temporary file in the CGI object so that the file
2381 # isn't unlinked until the CGI object itself goes out of
2382 # scope. This is a bit hacky, but it has the interesting side
2383 # effect that one can access the name of the tmpfile by
2384 # asking for $query->{$query->param('foo')}, where 'foo'
2385 # is the name of the file upload field.
2386 $self->{'.tmpfiles'}->{$filename}= {
2394 'tmpFileName' => <<'END_OF_FUNC',
2396 my($self,$filename) = self_or_default(@_);
2397 return $self->{'.tmpfiles'}->{$filename}->{name}->as_string;
2401 'uploadInfo' => <<'END_OF_FUNC'
2403 my($self,$filename) = self_or_default(@_);
2404 return $self->{'.tmpfiles'}->{$filename}->{info};
2412 # Globals and stubs for other packages that we use
2413 package MultipartBuffer;
2415 # how many bytes to read at a time. We use
2416 # a 5K buffer by default.
2417 $FILLUNIT = 1024 * 5;
2418 $TIMEOUT = 10*60; # 10 minute timeout
2419 $SPIN_LOOP_MAX = 1000; # bug fix for some Netscape servers
2422 #reuse the autoload function
2423 *MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
2425 ###############################################################################
2426 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
2427 ###############################################################################
2428 $AUTOLOADED_ROUTINES = ''; # prevent -w error
2429 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
2432 'new' => <<'END_OF_FUNC',
2434 my($package,$interface,$boundary,$length,$filehandle) = @_;
2437 my($package) = caller;
2438 # force into caller's package if necessary
2439 $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
2441 $IN = "main::STDIN" unless $IN;
2443 $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
2445 # If the user types garbage into the file upload field,
2446 # then Netscape passes NOTHING to the server (not good).
2447 # We may hang on this read in that case. So we implement
2448 # a read timeout. If nothing is ready to read
2449 # by then, we return.
2451 # Netscape seems to be a little bit unreliable
2452 # about providing boundary strings.
2455 # Under the MIME spec, the boundary consists of the
2456 # characters "--" PLUS the Boundary string
2457 $boundary = "--$boundary";
2458 # Read the topmost (boundary) line plus the CRLF
2460 $length -= $interface->read_from_client($IN,\$null,length($boundary)+2,0);
2462 } else { # otherwise we find it ourselves
2464 ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
2465 $boundary = <$IN>; # BUG: This won't work correctly under mod_perl
2466 $length -= length($boundary);
2467 chomp($boundary); # remove the CRLF
2468 $/ = $old; # restore old line separator
2471 my $self = {LENGTH=>$length,
2472 BOUNDARY=>$boundary,
2474 INTERFACE=>$interface,
2478 $FILLUNIT = length($boundary)
2479 if length($boundary) > $FILLUNIT;
2481 return bless $self,ref $package || $package;
2485 'readHeader' => <<'END_OF_FUNC',
2491 $self->fillBuffer($FILLUNIT);
2492 $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
2493 $ok++ if $self->{BUFFER} eq '';
2494 $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
2497 my($header) = substr($self->{BUFFER},0,$end+2);
2498 substr($self->{BUFFER},0,$end+4) = '';
2500 while ($header=~/^([\w-]+): (.*)$CRLF/mog) {
2507 # This reads and returns the body as a single scalar value.
2508 'readBody' => <<'END_OF_FUNC',
2513 while (defined($data = $self->read)) {
2514 $returnval .= $data;
2520 # This will read $bytes or until the boundary is hit, whichever happens
2521 # first. After the boundary is hit, we return undef. The next read will
2522 # skip over the boundary and begin reading again;
2523 'read' => <<'END_OF_FUNC',
2525 my($self,$bytes) = @_;
2527 # default number of bytes to read
2528 $bytes = $bytes || $FILLUNIT;
2530 # Fill up our internal buffer in such a way that the boundary
2531 # is never split between reads.
2532 $self->fillBuffer($bytes);
2534 # Find the boundary in the buffer (it may not be there).
2535 my $start = index($self->{BUFFER},$self->{BOUNDARY});
2537 # If the boundary begins the data, then skip past it
2538 # and return undef. The +2 here is a fiendish plot to
2539 # remove the CR/LF pair at the end of the boundary.
2542 # clear us out completely if we've hit the last boundary.
2543 if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
2549 # just remove the boundary.
2550 substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
2555 if ($start > 0) { # read up to the boundary
2556 $bytesToReturn = $start > $bytes ? $bytes : $start;
2557 } else { # read the requested number of bytes
2558 # leave enough bytes in the buffer to allow us to read
2559 # the boundary. Thanks to Kevin Hendrick for finding
2561 $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
2564 my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
2565 substr($self->{BUFFER},0,$bytesToReturn)='';
2567 # If we hit the boundary, remove the CRLF from the end.
2568 return ($start > 0) ? substr($returnval,0,-2) : $returnval;
2573 # This fills up our internal buffer in such a way that the
2574 # boundary is never split between reads
2575 'fillBuffer' => <<'END_OF_FUNC',
2577 my($self,$bytes) = @_;
2578 return unless $self->{LENGTH};
2580 my($boundaryLength) = length($self->{BOUNDARY});
2581 my($bufferLength) = length($self->{BUFFER});
2582 my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
2583 $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
2585 # Try to read some data. We may hang here if the browser is screwed up.
2586 my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN},
2591 # An apparent bug in the Netscape Commerce server causes the read()
2592 # to return zero bytes repeatedly without blocking if the
2593 # remote user aborts during a file transfer. I don't know how
2594 # they manage this, but the workaround is to abort if we get
2595 # more than SPIN_LOOP_MAX consecutive zero reads.
2596 if ($bytesRead == 0) {
2597 die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
2598 if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
2600 $self->{ZERO_LOOP_COUNTER}=0;
2603 $self->{LENGTH} -= $bytesRead;
2608 # Return true when we've finished reading
2609 'eof' => <<'END_OF_FUNC'
2612 return 1 if (length($self->{BUFFER}) == 0)
2613 && ($self->{LENGTH} <= 0);
2621 ####################################################################################
2622 ################################## TEMPORARY FILES #################################
2623 ####################################################################################
2627 unless ($TMPDIRECTORY) {
2628 @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp","${SL}tmp","${SL}temp","${SL}Temporary Items");
2630 do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
2634 $TMPDIRECTORY = "." unless $TMPDIRECTORY;
2635 $SEQUENCE="CGItemp${$}0000";
2637 # cute feature, but overload implementation broke it
2638 # %OVERLOAD = ('""'=>'as_string');
2639 *TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
2641 ###############################################################################
2642 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
2643 ###############################################################################
2644 $AUTOLOADED_ROUTINES = ''; # prevent -w error
2645 $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
2648 'new' => <<'END_OF_FUNC',
2652 my $directory = "${TMPDIRECTORY}${SL}${SEQUENCE}";
2653 return bless \$directory;
2657 'DESTROY' => <<'END_OF_FUNC',
2660 unlink $$self; # get rid of the file
2664 'as_string' => <<'END_OF_FUNC'
2676 # We get a whole bunch of warnings about "possibly uninitialized variables"
2677 # when running with the -w switch. Touch them all once to get rid of the
2678 # warnings. This is ugly and I hate it.
2683 $MultipartBuffer::SPIN_LOOP_MAX;
2684 $MultipartBuffer::CRLF;
2685 $MultipartBuffer::TIMEOUT;
2686 $MultipartBuffer::FILLUNIT;
2687 $TempFile::SEQUENCE;
2698 CGI - Simple Common Gateway Interface Class
2702 This perl library uses perl5 objects to make it easy to create
2703 Web fill-out forms and parse their contents. This package
2704 defines CGI objects, entities that contain the values of the
2705 current query string and other state variables.
2706 Using a CGI object's methods, you can examine keywords and parameters
2707 passed to your script, and create forms whose initial values
2708 are taken from the current query (thereby preserving state
2711 The current version of CGI.pm is available at
2713 http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
2714 ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
2716 =head1 INSTALLATION:
2718 To install this package, just change to the directory in which this
2719 file is found and type the following:
2725 This will copy CGI.pm to your perl library directory for use by all
2726 perl scripts. You probably must be root to do this. Now you can
2727 load the CGI routines in your Perl scripts with the line:
2731 If you don't have sufficient privileges to install CGI.pm in the Perl
2732 library directory, you can put CGI.pm into some convenient spot, such
2733 as your home directory, or in cgi-bin itself and prefix all Perl
2734 scripts that call it with something along the lines of the following
2737 use lib '/home/davis/lib';
2740 If you are using a version of perl earlier than 5.002 (such as NT perl), use
2744 unshift(@INC,'/home/davis/lib');
2748 The CGI distribution also comes with a cute module called L<CGI::Carp>.
2749 It redefines the die(), warn(), confess() and croak() error routines
2750 so that they write nicely formatted error messages into the server's
2751 error log (or to the output stream of your choice). This avoids long
2752 hours of groping through the error and access logs, trying to figure
2753 out which CGI script is generating error messages. If you choose,
2754 you can even have fatal error messages echoed to the browser to avoid
2755 the annoying and uninformative "Server Error" message.
2759 =head2 CREATING A NEW QUERY OBJECT:
2763 This will parse the input (from both POST and GET methods) and store
2764 it into a perl5 object called $query.
2766 =head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
2768 $query = new CGI(INPUTFILE);
2770 If you provide a file handle to the new() method, it
2771 will read parameters from the file (or STDIN, or whatever). The
2772 file can be in any of the forms describing below under debugging
2773 (i.e. a series of newline delimited TAG=VALUE pairs will work).
2774 Conveniently, this type of file is created by the save() method
2775 (see below). Multiple records can be saved and restored.
2777 Perl purists will be pleased to know that this syntax accepts
2778 references to file handles, or even references to filehandle globs,
2779 which is the "official" way to pass a filehandle:
2781 $query = new CGI(\*STDIN);
2783 You can also initialize the query object from an associative array
2786 $query = new CGI( {'dinosaur'=>'barney',
2787 'song'=>'I love you',
2788 'friends'=>[qw/Jessica George Nancy/]}
2791 or from a properly formatted, URL-escaped query string:
2793 $query = new CGI('dinosaur=barney&color=purple');
2795 To create an empty query, initialize it from an empty string or hash:
2797 $empty_query = new CGI("");
2799 $empty_query = new CGI({});
2801 =head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
2803 @keywords = $query->keywords
2805 If the script was invoked as the result of an <ISINDEX> search, the
2806 parsed keywords can be obtained as an array using the keywords() method.
2808 =head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
2810 @names = $query->param
2812 If the script was invoked with a parameter list
2813 (e.g. "name1=value1&name2=value2&name3=value3"), the param()
2814 method will return the parameter names as a list. If the
2815 script was invoked as an <ISINDEX> script, there will be a
2816 single parameter named 'keywords'.
2818 NOTE: As of version 1.5, the array of parameter names returned will
2819 be in the same order as they were submitted by the browser.
2820 Usually this order is the same as the order in which the
2821 parameters are defined in the form (however, this isn't part
2822 of the spec, and so isn't guaranteed).
2824 =head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
2826 @values = $query->param('foo');
2830 $value = $query->param('foo');
2832 Pass the param() method a single argument to fetch the value of the
2833 named parameter. If the parameter is multivalued (e.g. from multiple
2834 selections in a scrolling list), you can ask to receive an array. Otherwise
2835 the method will return a single value.
2837 =head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
2839 $query->param('foo','an','array','of','values');
2841 This sets the value for the named parameter 'foo' to an array of
2842 values. This is one way to change the value of a field AFTER
2843 the script has been invoked once before. (Another way is with
2844 the -override parameter accepted by all methods that generate
2847 param() also recognizes a named parameter style of calling described
2848 in more detail later:
2850 $query->param(-name=>'foo',-values=>['an','array','of','values']);
2854 $query->param(-name=>'foo',-value=>'the value');
2856 =head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
2858 $query->append(-name=>;'foo',-values=>['yet','more','values']);
2860 This adds a value or list of values to the named parameter. The
2861 values are appended to the end of the parameter if it already exists.
2862 Otherwise the parameter is created. Note that this method only
2863 recognizes the named argument calling syntax.
2865 =head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
2867 $query->import_names('R');
2869 This creates a series of variables in the 'R' namespace. For example,
2870 $R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
2871 If no namespace is given, this method will assume 'Q'.
2872 WARNING: don't import anything into 'main'; this is a major security
2875 In older versions, this method was called B<import()>. As of version 2.20,
2876 this name has been removed completely to avoid conflict with the built-in
2877 Perl module B<import> operator.
2879 =head2 DELETING A PARAMETER COMPLETELY:
2881 $query->delete('foo');
2883 This completely clears a parameter. It sometimes useful for
2884 resetting parameters that you don't want passed down between
2887 =head2 DELETING ALL PARAMETERS:
2889 $query->delete_all();
2891 This clears the CGI object completely. It might be useful to ensure
2892 that all the defaults are taken when you create a fill-out form.
2894 =head2 SAVING THE STATE OF THE FORM TO A FILE:
2896 $query->save(FILEHANDLE)
2898 This will write the current state of the form to the provided
2899 filehandle. You can read it back in by providing a filehandle
2900 to the new() method. Note that the filehandle can be a file, a pipe,
2903 The format of the saved file is:
2911 Both name and value are URL escaped. Multi-valued CGI parameters are
2912 represented as repeated names. A session record is delimited by a
2913 single = symbol. You can write out multiple records and read them
2914 back in with several calls to B<new>. You can do this across several
2915 sessions by opening the file in append mode, allowing you to create
2916 primitive guest books, or to keep a history of users' queries. Here's
2917 a short example of creating multiple session records:
2921 open (OUT,">>test.out") || die;
2923 foreach (0..$records) {
2925 $q->param(-name=>'counter',-value=>$_);
2930 # reopen for reading
2931 open (IN,"test.out") || die;
2933 my $q = new CGI(IN);
2934 print $q->param('counter'),"\n";
2937 The file format used for save/restore is identical to that used by the
2938 Whitehead Genome Center's data exchange format "Boulderio", and can be
2939 manipulated and even databased using Boulderio utilities. See
2941 http://www.genome.wi.mit.edu/genome_software/other/boulder.html
2943 for further details.
2945 =head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
2947 $myself = $query->self_url;
2948 print "<A HREF=$myself>I'm talking to myself.</A>";
2950 self_url() will return a URL, that, when selected, will reinvoke
2951 this script with all its state information intact. This is most
2952 useful when you want to jump around within the document using
2953 internal anchors but you don't want to disrupt the current contents
2954 of the form(s). Something like this will do the trick.
2956 $myself = $query->self_url;
2957 print "<A HREF=$myself#table1>See table 1</A>";
2958 print "<A HREF=$myself#table2>See table 2</A>";
2959 print "<A HREF=$myself#yourself>See for yourself</A>";
2961 If you don't want to get the whole query string, call
2962 the method url() to return just the URL for the script:
2964 $myself = $query->url;
2965 print "<A HREF=$myself>No query string in this baby!</A>\n";
2967 You can also retrieve the unprocessed query string with query_string():
2969 $the_string = $query->query_string;
2971 =head2 COMPATIBILITY WITH CGI-LIB.PL
2973 To make it easier to port existing programs that use cgi-lib.pl
2974 the compatibility routine "ReadParse" is provided. Porting is
2978 require "cgi-lib.pl";
2980 print "The value of the antique is $in{antique}.\n";
2985 print "The value of the antique is $in{antique}.\n";
2987 CGI.pm's ReadParse() routine creates a tied variable named %in,
2988 which can be accessed to obtain the query variables. Like
2989 ReadParse, you can also provide your own variable. Infrequently
2990 used features of ReadParse, such as the creation of @in and $in
2991 variables, are not supported.
2993 Once you use ReadParse, you can retrieve the query object itself
2997 print $q->textfield(-name=>'wow',
2998 -value=>'does this really work?');
3000 This allows you to start using the more interesting features
3001 of CGI.pm without rewriting your old scripts from scratch.
3003 =head2 CALLING CGI FUNCTIONS THAT TAKE MULTIPLE ARGUMENTS
3005 In versions of CGI.pm prior to 2.0, it could get difficult to remember
3006 the proper order of arguments in CGI function calls that accepted five
3007 or six different arguments. As of 2.0, there's a better way to pass
3008 arguments to the various CGI functions. In this style, you pass a
3009 series of name=>argument pairs, like this:
3011 $field = $query->radio_group(-name=>'OS',
3012 -values=>[Unix,Windows,Macintosh],
3015 The advantages of this style are that you don't have to remember the
3016 exact order of the arguments, and if you leave out a parameter, in
3017 most cases it will default to some reasonable value. If you provide
3018 a parameter that the method doesn't recognize, it will usually do
3019 something useful with it, such as incorporating it into the HTML form
3020 tag. For example if Netscape decides next week to add a new
3021 JUSTIFICATION parameter to the text field tags, you can start using
3022 the feature without waiting for a new version of CGI.pm:
3024 $field = $query->textfield(-name=>'State',
3025 -default=>'gaseous',
3026 -justification=>'RIGHT');
3028 This will result in an HTML tag that looks like this:
3030 <INPUT TYPE="textfield" NAME="State" VALUE="gaseous"
3031 JUSTIFICATION="RIGHT">
3033 Parameter names are case insensitive: you can use -name, or -Name or
3034 -NAME. You don't have to use the hyphen if you don't want to. After
3035 creating a CGI object, call the B<use_named_parameters()> method with
3036 a nonzero value. This will tell CGI.pm that you intend to use named
3037 parameters exclusively:
3040 $query->use_named_parameters(1);
3041 $field = $query->radio_group('name'=>'OS',
3042 'values'=>['Unix','Windows','Macintosh'],
3045 Actually, CGI.pm only looks for a hyphen in the first parameter. So
3046 you can leave it off subsequent parameters if you like. Something to
3047 be wary of is the potential that a string constant like "values" will
3048 collide with a keyword (and in fact it does!) While Perl usually
3049 figures out when you're referring to a function and when you're
3050 referring to a string, you probably should put quotation marks around
3051 all string constants just to play it safe.
3053 =head2 CREATING THE HTTP HEADER:
3055 print $query->header;
3059 print $query->header('image/gif');
3063 print $query->header('text/html','204 No response');
3067 print $query->header(-type=>'image/gif',
3069 -status=>'402 Payment required',
3074 header() returns the Content-type: header. You can provide your own
3075 MIME type if you choose, otherwise it defaults to text/html. An
3076 optional second parameter specifies the status code and a human-readable
3077 message. For example, you can specify 204, "No response" to create a
3078 script that tells the browser to do nothing at all. If you want to
3079 add additional fields to the header, just tack them on to the end:
3081 print $query->header('text/html','200 OK','Content-Length: 3002');
3083 The last example shows the named argument style for passing arguments
3084 to the CGI methods using named parameters. Recognized parameters are
3085 B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other
3086 parameters will be stripped of their initial hyphens and turned into
3087 header fields, allowing you to specify any HTTP header you desire.
3089 Most browsers will not cache the output from CGI scripts. Every time
3090 the browser reloads the page, the script is invoked anew. You can
3091 change this behavior with the B<-expires> parameter. When you specify
3092 an absolute or relative expiration interval with this parameter, some
3093 browsers and proxy servers will cache the script's output until the
3094 indicated expiration date. The following forms are all valid for the
3097 +30s 30 seconds from now
3098 +10m ten minutes from now
3099 +1h one hour from now
3100 -1d yesterday (i.e. "ASAP!")
3103 +10y in ten years time
3104 Thursday, 25-Apr-96 00:40:33 GMT at the indicated time & date
3106 (CGI::expires() is the static function call used internally that turns
3107 relative time intervals into HTTP dates. You can call it directly if
3110 The B<-cookie> parameter generates a header that tells the browser to provide
3111 a "magic cookie" during all subsequent transactions with your script.
3112 Netscape cookies have a special format that includes interesting attributes
3113 such as expiration time. Use the cookie() method to create and retrieve
3116 The B<-nph> parameter, if set to a true value, will issue the correct
3117 headers to work with a NPH (no-parse-header) script. This is important
3118 to use with certain servers, such as Microsoft Internet Explorer, which
3119 expect all their scripts to be NPH.
3121 =head2 GENERATING A REDIRECTION INSTRUCTION
3123 print $query->redirect('http://somewhere.else/in/movie/land');
3125 redirects the browser elsewhere. If you use redirection like this,
3126 you should B<not> print out a header as well. As of version 2.0, we
3127 produce both the unofficial Location: header and the official URI:
3128 header. This should satisfy most servers and browsers.
3130 One hint I can offer is that relative links may not work correctly
3131 when when you generate a redirection to another document on your site.
3132 This is due to a well-intentioned optimization that some servers use.
3133 The solution to this is to use the full URL (including the http: part)
3134 of the document you are redirecting to.
3136 You can use named parameters:
3138 print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
3141 The B<-nph> parameter, if set to a true value, will issue the correct
3142 headers to work with a NPH (no-parse-header) script. This is important
3143 to use with certain servers, such as Microsoft Internet Explorer, which
3144 expect all their scripts to be NPH.
3147 =head2 CREATING THE HTML HEADER:
3149 print $query->start_html(-title=>'Secrets of the Pyramids',
3150 -author=>'fred@capricorn.org',
3153 -meta=>{'keywords'=>'pharaoh secret mummy',
3154 'copyright'=>'copyright 1996 King Tut'},
3159 print $query->start_html('Secrets of the Pyramids',
3160 'fred@capricorn.org','true',
3163 This will return a canned HTML header and the opening <BODY> tag.
3164 All parameters are optional. In the named parameter form, recognized
3165 parameters are -title, -author, -base, -xbase and -target (see below for the
3166 explanation). Any additional parameters you provide, such as the
3167 Netscape unofficial BGCOLOR attribute, are added to the <BODY> tag.
3169 The argument B<-xbase> allows you to provide an HREF for the <BASE> tag
3170 different from the current location, as in
3172 -xbase=>"http://home.mcom.com/"
3174 All relative links will be interpreted relative to this tag.
3176 The argument B<-target> allows you to provide a default target frame
3177 for all the links and fill-out forms on the page. See the Netscape
3178 documentation on frames for details of how to manipulate this.
3180 -target=>"answer_window"
3182 All relative links will be interpreted relative to this tag.
3183 You add arbitrary meta information to the header with the B<-meta>
3184 argument. This argument expects a reference to an associative array
3185 containing name/value pairs of meta information. These will be turned
3186 into a series of header <META> tags that look something like this:
3188 <META NAME="keywords" CONTENT="pharaoh secret mummy">
3189 <META NAME="description" CONTENT="copyright 1996 King Tut">
3191 There is no support for the HTTP-EQUIV type of <META> tag. This is
3192 because you can modify the HTTP header directly with the B<header()>
3195 JAVASCRIPTING: The B<-script>, B<-onLoad> and B<-onUnload> parameters
3196 are used to add Netscape JavaScript calls to your pages. B<-script>
3197 should point to a block of text containing JavaScript function
3198 definitions. This block will be placed within a <SCRIPT> block inside
3199 the HTML (not HTTP) header. The block is placed in the header in
3200 order to give your page a fighting chance of having all its JavaScript
3201 functions in place even if the user presses the stop button before the
3202 page has loaded completely. CGI.pm attempts to format the script in
3203 such a way that JavaScript-naive browsers will not choke on the code:
3204 unfortunately there are some browsers, such as Chimera for Unix, that
3205 get confused by it nevertheless.
3207 The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
3208 code to execute when the page is respectively opened and closed by the
3209 browser. Usually these parameters are calls to functions defined in the
3213 print $query->header;
3215 // Ask a silly question
3216 function riddle_me_this() {
3217 var r = prompt("What walks on four legs in the morning, " +
3218 "two legs in the afternoon, " +
3219 "and three legs in the evening?");
3222 // Get a silly answer
3223 function response(answer) {
3224 if (answer == "man")
3225 alert("Right you are!");
3227 alert("Wrong! Guess again.");
3230 print $query->start_html(-title=>'The Riddle of the Sphinx',
3235 http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
3237 for more information about JavaScript.
3239 The old-style positional parameters are as follows:
3243 =item B<Parameters:>
3251 The author's e-mail address (will create a <LINK REV="MADE"> tag if present
3255 A 'true' flag if you want to include a <BASE> tag in the header. This
3256 helps resolve relative addresses to absolute ones when the document is moved,
3257 but makes the document hierarchy non-portable. Use with care!
3261 Any other parameters you want to include in the <BODY> tag. This is a good
3262 place to put Netscape extensions, such as colors and wallpaper patterns.
3266 =head2 ENDING THE HTML DOCUMENT:
3268 print $query->end_html
3270 This ends an HTML document by printing the </BODY></HTML> tags.
3272 =head1 CREATING FORMS:
3274 I<General note> The various form-creating methods all return strings
3275 to the caller, containing the tag or tags that will create the requested
3276 form element. You are responsible for actually printing out these strings.
3277 It's set up this way so that you can place formatting tags
3278 around the form elements.
3280 I<Another note> The default values that you specify for the forms are only
3281 used the B<first> time the script is invoked (when there is no query
3282 string). On subsequent invocations of the script (when there is a query
3283 string), the former values are used even if they are blank.
3285 If you want to change the value of a field from its previous value, you have two
3288 (1) call the param() method to set it.
3290 (2) use the -override (alias -force) parameter (a new feature in version 2.15).
3291 This forces the default value to be used, regardless of the previous value:
3293 print $query->textfield(-name=>'field_name',
3294 -default=>'starting value',
3299 I<Yet another note> By default, the text and labels of form elements are
3300 escaped according to HTML rules. This means that you can safely use
3301 "<CLICK ME>" as the label for a button. However, it also interferes with
3302 your ability to incorporate special HTML character sequences, such as Á,
3303 into your fields. If you wish to turn off automatic escaping, call the
3304 autoEscape() method with a false value immediately after creating the CGI object:
3307 $query->autoEscape(undef);
3310 =head2 CREATING AN ISINDEX TAG
3312 print $query->isindex(-action=>$action);
3316 print $query->isindex($action);
3318 Prints out an <ISINDEX> tag. Not very exciting. The parameter
3319 -action specifies the URL of the script to process the query. The
3320 default is to process the query with the current script.
3322 =head2 STARTING AND ENDING A FORM
3324 print $query->startform(-method=>$method,
3326 -encoding=>$encoding);
3327 <... various form stuff ...>
3328 print $query->endform;
3332 print $query->startform($method,$action,$encoding);
3333 <... various form stuff ...>
3334 print $query->endform;
3336 startform() will return a <FORM> tag with the optional method,
3337 action and form encoding that you specify. The defaults are:
3341 encoding: application/x-www-form-urlencoded
3343 endform() returns the closing </FORM> tag.
3345 Startform()'s encoding method tells the browser how to package the various
3346 fields of the form before sending the form to the server. Two
3347 values are possible:
3351 =item B<application/x-www-form-urlencoded>
3353 This is the older type of encoding used by all browsers prior to
3354 Netscape 2.0. It is compatible with many CGI scripts and is
3355 suitable for short fields containing text data. For your
3356 convenience, CGI.pm stores the name of this encoding
3357 type in B<$CGI::URL_ENCODED>.
3359 =item B<multipart/form-data>
3361 This is the newer type of encoding introduced by Netscape 2.0.
3362 It is suitable for forms that contain very large fields or that
3363 are intended for transferring binary data. Most importantly,
3364 it enables the "file upload" feature of Netscape 2.0 forms. For
3365 your convenience, CGI.pm stores the name of this encoding type
3366 in B<$CGI::MULTIPART>
3368 Forms that use this type of encoding are not easily interpreted
3369 by CGI scripts unless they use CGI.pm or another library designed
3374 For compatibility, the startform() method uses the older form of
3375 encoding by default. If you want to use the newer form of encoding
3376 by default, you can call B<start_multipart_form()> instead of
3379 JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
3380 for use with JavaScript. The -name parameter gives the
3381 form a name so that it can be identified and manipulated by
3382 JavaScript functions. -onSubmit should point to a JavaScript
3383 function that will be executed just before the form is submitted to your
3384 server. You can use this opportunity to check the contents of the form
3385 for consistency and completeness. If you find something wrong, you
3386 can put up an alert box or maybe fix things up yourself. You can
3387 abort the submission by returning false from this function.
3389 Usually the bulk of JavaScript functions are defined in a <SCRIPT>
3390 block in the HTML header and -onSubmit points to one of these function
3391 call. See start_html() for details.
3393 =head2 CREATING A TEXT FIELD
3395 print $query->textfield(-name=>'field_name',
3396 -default=>'starting value',
3401 print $query->textfield('field_name','starting value',50,80);
3403 textfield() will return a text input field.
3411 The first parameter is the required name for the field (-name).
3415 The optional second parameter is the default starting value for the field
3416 contents (-default).
3420 The optional third parameter is the size of the field in
3425 The optional fourth parameter is the maximum number of characters the
3426 field will accept (-maxlength).
3430 As with all these methods, the field will be initialized with its
3431 previous contents from earlier invocations of the script.
3432 When the form is processed, the value of the text field can be
3435 $value = $query->param('foo');
3437 If you want to reset it from its initial value after the script has been
3438 called once, you can do so like this:
3440 $query->param('foo',"I'm taking over this value!");
3442 NEW AS OF VERSION 2.15: If you don't want the field to take on its previous
3443 value, you can force its current value by using the -override (alias -force)
3446 print $query->textfield(-name=>'field_name',
3447 -default=>'starting value',
3452 JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>, B<-onBlur>
3453 and B<-onSelect> parameters to register JavaScript event handlers.
3454 The onChange handler will be called whenever the user changes the
3455 contents of the text field. You can do text validation if you like.
3456 onFocus and onBlur are called respectively when the insertion point
3457 moves into and out of the text field. onSelect is called when the
3458 user changes the portion of the text that is selected.
3460 =head2 CREATING A BIG TEXT FIELD
3462 print $query->textarea(-name=>'foo',
3463 -default=>'starting value',
3469 print $query->textarea('foo','starting value',10,50);
3471 textarea() is just like textfield, but it allows you to specify
3472 rows and columns for a multiline text entry box. You can provide
3473 a starting value for the field, which can be long and contain
3476 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
3477 and B<-onSelect> parameters are recognized. See textfield().
3479 =head2 CREATING A PASSWORD FIELD
3481 print $query->password_field(-name=>'secret',
3482 -value=>'starting value',
3487 print $query->password_field('secret','starting value',50,80);
3489 password_field() is identical to textfield(), except that its contents
3490 will be starred out on the web page.
3492 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
3493 and B<-onSelect> parameters are recognized. See textfield().
3495 =head2 CREATING A FILE UPLOAD FIELD
3497 print $query->filefield(-name=>'uploaded_file',
3498 -default=>'starting value',
3503 print $query->filefield('uploaded_file','starting value',50,80);
3505 filefield() will return a file upload field for Netscape 2.0 browsers.
3506 In order to take full advantage of this I<you must use the new
3507 multipart encoding scheme> for the form. You can do this either
3508 by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>,
3509 or by calling the new method B<start_multipart_form()> instead of
3510 vanilla B<startform()>.
3518 The first parameter is the required name for the field (-name).
3522 The optional second parameter is the starting value for the field contents
3523 to be used as the default file name (-default).
3525 The beta2 version of Netscape 2.0 currently doesn't pay any attention
3526 to this field, and so the starting value will always be blank. Worse,
3527 the field loses its "sticky" behavior and forgets its previous
3528 contents. The starting value field is called for in the HTML
3529 specification, however, and possibly later versions of Netscape will
3534 The optional third parameter is the size of the field in
3539 The optional fourth parameter is the maximum number of characters the
3540 field will accept (-maxlength).
3544 When the form is processed, you can retrieve the entered filename
3547 $filename = $query->param('uploaded_file');
3549 In Netscape Gold, the filename that gets returned is the full local filename
3550 on the B<remote user's> machine. If the remote user is on a Unix
3551 machine, the filename will follow Unix conventions:
3555 On an MS-DOS/Windows and OS/2 machines, the filename will follow DOS conventions:
3557 C:\PATH\TO\THE\FILE.MSW
3559 On a Macintosh machine, the filename will follow Mac conventions:
3561 HD 40:Desktop Folder:Sort Through:Reminders
3563 The filename returned is also a file handle. You can read the contents
3564 of the file using standard Perl file reading calls:
3566 # Read a text file and print it out
3567 while (<$filename>) {
3571 # Copy a binary file to somewhere safe
3572 open (OUTFILE,">>/usr/local/web/users/feedback");
3573 while ($bytesread=read($filename,$buffer,1024)) {
3574 print OUTFILE $buffer;
3577 When a file is uploaded the browser usually sends along some
3578 information along with it in the format of headers. The information
3579 usually includes the MIME content type. Future browsers may send
3580 other information as well (such as modification date and size). To
3581 retrieve this information, call uploadInfo(). It returns a reference to
3582 an associative array containing all the document headers.
3584 $filename = $query->param('uploaded_file');
3585 $type = $query->uploadInfo($filename)->{'Content-Type'};
3586 unless ($type eq 'text/html') {
3587 die "HTML FILES ONLY!";
3590 If you are using a machine that recognizes "text" and "binary" data
3591 modes, be sure to understand when and how to use them (see the Camel book).
3592 Otherwise you may find that binary files are corrupted during file uploads.
3594 JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
3595 and B<-onSelect> parameters are recognized. See textfield()
3598 =head2 CREATING A POPUP MENU
3600 print $query->popup_menu('menu_name',
3601 ['eenie','meenie','minie'],
3606 %labels = ('eenie'=>'your first choice',
3607 'meenie'=>'your second choice',
3608 'minie'=>'your third choice');
3609 print $query->popup_menu('menu_name',
3610 ['eenie','meenie','minie'],
3613 -or (named parameter style)-
3615 print $query->popup_menu(-name=>'menu_name',
3616 -values=>['eenie','meenie','minie'],
3620 popup_menu() creates a menu.
3626 The required first argument is the menu's name (-name).
3630 The required second argument (-values) is an array B<reference>
3631 containing the list of menu items in the menu. You can pass the
3632 method an anonymous array, as shown in the example, or a reference to
3633 a named array, such as "\@foo".
3637 The optional third parameter (-default) is the name of the default
3638 menu choice. If not specified, the first item will be the default.
3639 The values of the previous choice will be maintained across queries.
3643 The optional fourth parameter (-labels) is provided for people who
3644 want to use different values for the user-visible label inside the
3645 popup menu nd the value returned to your script. It's a pointer to an
3646 associative array relating menu values to user-visible labels. If you
3647 leave this parameter blank, the menu values will be displayed by
3648 default. (You can also leave a label undefined if you want to).
3652 When the form is processed, the selected value of the popup menu can
3655 $popup_menu_value = $query->param('menu_name');
3657 JAVASCRIPTING: popup_menu() recognizes the following event handlers:
3658 B<-onChange>, B<-onFocus>, and B<-onBlur>. See the textfield()
3659 section for details on when these handlers are called.
3661 =head2 CREATING A SCROLLING LIST
3663 print $query->scrolling_list('list_name',
3664 ['eenie','meenie','minie','moe'],
3665 ['eenie','moe'],5,'true');
3668 print $query->scrolling_list('list_name',
3669 ['eenie','meenie','minie','moe'],
3670 ['eenie','moe'],5,'true',
3675 print $query->scrolling_list(-name=>'list_name',
3676 -values=>['eenie','meenie','minie','moe'],
3677 -default=>['eenie','moe'],
3682 scrolling_list() creates a scrolling list.
3686 =item B<Parameters:>
3690 The first and second arguments are the list name (-name) and values
3691 (-values). As in the popup menu, the second argument should be an
3696 The optional third argument (-default) can be either a reference to a
3697 list containing the values to be selected by default, or can be a
3698 single value to select. If this argument is missing or undefined,
3699 then nothing is selected when the list first appears. In the named
3700 parameter version, you can use the synonym "-defaults" for this
3705 The optional fourth argument is the size of the list (-size).
3709 The optional fifth argument can be set to true to allow multiple
3710 simultaneous selections (-multiple). Otherwise only one selection
3711 will be allowed at a time.
3715 The optional sixth argument is a pointer to an associative array
3716 containing long user-visible labels for the list items (-labels).
3717 If not provided, the values will be displayed.
3719 When this form is processed, all selected list items will be returned as
3720 a list under the parameter name 'list_name'. The values of the
3721 selected items can be retrieved with:
3723 @selected = $query->param('list_name');
3727 JAVASCRIPTING: scrolling_list() recognizes the following event handlers:
3728 B<-onChange>, B<-onFocus>, and B<-onBlur>. See textfield() for
3729 the description of when these handlers are called.
3731 =head2 CREATING A GROUP OF RELATED CHECKBOXES
3733 print $query->checkbox_group(-name=>'group_name',
3734 -values=>['eenie','meenie','minie','moe'],
3735 -default=>['eenie','moe'],
3739 print $query->checkbox_group('group_name',
3740 ['eenie','meenie','minie','moe'],
3741 ['eenie','moe'],'true',\%labels);
3743 HTML3-COMPATIBLE BROWSERS ONLY:
3745 print $query->checkbox_group(-name=>'group_name',
3746 -values=>['eenie','meenie','minie','moe'],
3747 -rows=2,-columns=>2);
3750 checkbox_group() creates a list of checkboxes that are related
3755 =item B<Parameters:>
3759 The first and second arguments are the checkbox name and values,
3760 respectively (-name and -values). As in the popup menu, the second
3761 argument should be an array reference. These values are used for the
3762 user-readable labels printed next to the checkboxes as well as for the
3763 values passed to your script in the query string.
3767 The optional third argument (-default) can be either a reference to a
3768 list containing the values to be checked by default, or can be a
3769 single value to checked. If this argument is missing or undefined,
3770 then nothing is selected when the list first appears.
3774 The optional fourth argument (-linebreak) can be set to true to place
3775 line breaks between the checkboxes so that they appear as a vertical
3776 list. Otherwise, they will be strung together on a horizontal line.
3780 The optional fifth argument is a pointer to an associative array
3781 relating the checkbox values to the user-visible labels that will will
3782 be printed next to them (-labels). If not provided, the values will
3783 be used as the default.
3787 B<HTML3-compatible browsers> (such as Netscape) can take advantage
3789 parameters B<-rows>, and B<-columns>. These parameters cause
3790 checkbox_group() to return an HTML3 compatible table containing
3791 the checkbox group formatted with the specified number of rows
3792 and columns. You can provide just the -columns parameter if you
3793 wish; checkbox_group will calculate the correct number of rows
3796 To include row and column headings in the returned table, you
3797 can use the B<-rowheader> and B<-colheader> parameters. Both
3798 of these accept a pointer to an array of headings to use.
3799 The headings are just decorative. They don't reorganize the
3800 interpretation of the checkboxes -- they're still a single named
3805 When the form is processed, all checked boxes will be returned as
3806 a list under the parameter name 'group_name'. The values of the
3807 "on" checkboxes can be retrieved with:
3809 @turned_on = $query->param('group_name');
3811 The value returned by checkbox_group() is actually an array of button
3812 elements. You can capture them and use them within tables, lists,
3813 or in other creative ways:
3815 @h = $query->checkbox_group(-name=>'group_name',-values=>\@values);
3816 &use_in_creative_way(@h);
3818 JAVASCRIPTING: checkbox_group() recognizes the B<-onClick>
3819 parameter. This specifies a JavaScript code fragment or
3820 function call to be executed every time the user clicks on
3821 any of the buttons in the group. You can retrieve the identity
3822 of the particular button clicked on using the "this" variable.
3824 =head2 CREATING A STANDALONE CHECKBOX
3826 print $query->checkbox(-name=>'checkbox_name',
3827 -checked=>'checked',
3829 -label=>'CLICK ME');
3833 print $query->checkbox('checkbox_name','checked','ON','CLICK ME');
3835 checkbox() is used to create an isolated checkbox that isn't logically
3836 related to any others.
3840 =item B<Parameters:>
3844 The first parameter is the required name for the checkbox (-name). It
3845 will also be used for the user-readable label printed next to the
3850 The optional second parameter (-checked) specifies that the checkbox
3851 is turned on by default. Synonyms are -selected and -on.
3855 The optional third parameter (-value) specifies the value of the
3856 checkbox when it is checked. If not provided, the word "on" is
3861 The optional fourth parameter (-label) is the user-readable label to
3862 be attached to the checkbox. If not provided, the checkbox name is
3867 The value of the checkbox can be retrieved using:
3869 $turned_on = $query->param('checkbox_name');
3871 JAVASCRIPTING: checkbox() recognizes the B<-onClick>
3872 parameter. See checkbox_group() for further details.
3874 =head2 CREATING A RADIO BUTTON GROUP
3876 print $query->radio_group(-name=>'group_name',
3877 -values=>['eenie','meenie','minie'],
3884 print $query->radio_group('group_name',['eenie','meenie','minie'],
3885 'meenie','true',\%labels);
3888 HTML3-COMPATIBLE BROWSERS ONLY:
3890 print $query->radio_group(-name=>'group_name',
3891 -values=>['eenie','meenie','minie','moe'],
3892 -rows=2,-columns=>2);
3894 radio_group() creates a set of logically-related radio buttons
3895 (turning one member of the group on turns the others off)
3899 =item B<Parameters:>
3903 The first argument is the name of the group and is required (-name).
3907 The second argument (-values) is the list of values for the radio
3908 buttons. The values and the labels that appear on the page are
3909 identical. Pass an array I<reference> in the second argument, either
3910 using an anonymous array, as shown, or by referencing a named array as
3915 The optional third parameter (-default) is the name of the default
3916 button to turn on. If not specified, the first item will be the
3917 default. You can provide a nonexistent button name, such as "-" to
3918 start up with no buttons selected.
3922 The optional fourth parameter (-linebreak) can be set to 'true' to put
3923 line breaks between the buttons, creating a vertical list.
3927 The optional fifth parameter (-labels) is a pointer to an associative
3928 array relating the radio button values to user-visible labels to be
3929 used in the display. If not provided, the values themselves are
3934 B<HTML3-compatible browsers> (such as Netscape) can take advantage
3936 parameters B<-rows>, and B<-columns>. These parameters cause
3937 radio_group() to return an HTML3 compatible table containing
3938 the radio group formatted with the specified number of rows
3939 and columns. You can provide just the -columns parameter if you
3940 wish; radio_group will calculate the correct number of rows
3943 To include row and column headings in the returned table, you
3944 can use the B<-rowheader> and B<-colheader> parameters. Both
3945 of these accept a pointer to an array of headings to use.
3946 The headings are just decorative. They don't reorganize the
3947 interpetation of the radio buttons -- they're still a single named
3952 When the form is processed, the selected radio button can
3955 $which_radio_button = $query->param('group_name');
3957 The value returned by radio_group() is actually an array of button
3958 elements. You can capture them and use them within tables, lists,
3959 or in other creative ways:
3961 @h = $query->radio_group(-name=>'group_name',-values=>\@values);
3962 &use_in_creative_way(@h);
3964 =head2 CREATING A SUBMIT BUTTON
3966 print $query->submit(-name=>'button_name',
3971 print $query->submit('button_name','value');
3973 submit() will create the query submission button. Every form
3974 should have one of these.
3978 =item B<Parameters:>
3982 The first argument (-name) is optional. You can give the button a
3983 name if you have several submission buttons in your form and you want
3984 to distinguish between them. The name will also be used as the
3985 user-visible label. Be aware that a few older browsers don't deal with this correctly and
3986 B<never> send back a value from a button.
3990 The second argument (-value) is also optional. This gives the button
3991 a value that will be passed to your script in the query string.
3995 You can figure out which button was pressed by using different
3996 values for each one:
3998 $which_one = $query->param('button_name');
4000 JAVASCRIPTING: radio_group() recognizes the B<-onClick>
4001 parameter. See checkbox_group() for further details.
4003 =head2 CREATING A RESET BUTTON
4007 reset() creates the "reset" button. Note that it restores the
4008 form to its value from the last time the script was called,
4009 NOT necessarily to the defaults.
4011 =head2 CREATING A DEFAULT BUTTON
4013 print $query->defaults('button_label')
4015 defaults() creates a button that, when invoked, will cause the
4016 form to be completely reset to its defaults, wiping out all the
4017 changes the user ever made.
4019 =head2 CREATING A HIDDEN FIELD
4021 print $query->hidden(-name=>'hidden_name',
4022 -default=>['value1','value2'...]);
4026 print $query->hidden('hidden_name','value1','value2'...);
4028 hidden() produces a text field that can't be seen by the user. It
4029 is useful for passing state variable information from one invocation
4030 of the script to the next.
4034 =item B<Parameters:>
4038 The first argument is required and specifies the name of this
4043 The second argument is also required and specifies its value
4044 (-default). In the named parameter style of calling, you can provide
4045 a single value here or a reference to a whole list
4049 Fetch the value of a hidden field this way:
4051 $hidden_value = $query->param('hidden_name');
4053 Note, that just like all the other form elements, the value of a
4054 hidden field is "sticky". If you want to replace a hidden field with
4055 some other values after the script has been called once you'll have to
4058 $query->param('hidden_name','new','values','here');
4060 =head2 CREATING A CLICKABLE IMAGE BUTTON
4062 print $query->image_button(-name=>'button_name',
4063 -src=>'/source/URL',
4068 print $query->image_button('button_name','/source/URL','MIDDLE');
4070 image_button() produces a clickable image. When it's clicked on the
4071 position of the click is returned to your script as "button_name.x"
4072 and "button_name.y", where "button_name" is the name you've assigned
4075 JAVASCRIPTING: image_button() recognizes the B<-onClick>
4076 parameter. See checkbox_group() for further details.
4080 =item B<Parameters:>
4084 The first argument (-name) is required and specifies the name of this
4089 The second argument (-src) is also required and specifies the URL
4092 The third option (-align, optional) is an alignment type, and may be
4093 TOP, BOTTOM or MIDDLE
4097 Fetch the value of the button this way:
4098 $x = $query->param('button_name.x');
4099 $y = $query->param('button_name.y');
4101 =head2 CREATING A JAVASCRIPT ACTION BUTTON
4103 print $query->button(-name=>'button_name',
4104 -value=>'user visible label',
4105 -onClick=>"do_something()");
4109 print $query->button('button_name',"do_something()");
4111 button() produces a button that is compatible with Netscape 2.0's
4112 JavaScript. When it's pressed the fragment of JavaScript code
4113 pointed to by the B<-onClick> parameter will be executed. On
4114 non-Netscape browsers this form element will probably not even
4117 =head1 NETSCAPE COOKIES
4119 Netscape browsers versions 1.1 and higher support a so-called
4120 "cookie" designed to help maintain state within a browser session.
4121 CGI.pm has several methods that support cookies.
4123 A cookie is a name=value pair much like the named parameters in a CGI
4124 query string. CGI scripts create one or more cookies and send
4125 them to the browser in the HTTP header. The browser maintains a list
4126 of cookies that belong to a particular Web server, and returns them
4127 to the CGI script during subsequent interactions.
4129 In addition to the required name=value pair, each cookie has several
4130 optional attributes:
4134 =item 1. an expiration time
4136 This is a time/date string (in a special GMT format) that indicates
4137 when a cookie expires. The cookie will be saved and returned to your
4138 script until this expiration date is reached if the user exits
4139 Netscape and restarts it. If an expiration date isn't specified, the cookie
4140 will remain active until the user quits Netscape.
4144 This is a partial or complete domain name for which the cookie is
4145 valid. The browser will return the cookie to any host that matches
4146 the partial domain name. For example, if you specify a domain name
4147 of ".capricorn.com", then Netscape will return the cookie to
4148 Web servers running on any of the machines "www.capricorn.com",
4149 "www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
4150 must contain at least two periods to prevent attempts to match
4151 on top level domains like ".edu". If no domain is specified, then
4152 the browser will only return the cookie to servers on the host the
4153 cookie originated from.
4157 If you provide a cookie path attribute, the browser will check it
4158 against your script's URL before returning the cookie. For example,
4159 if you specify the path "/cgi-bin", then the cookie will be returned
4160 to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
4161 and "/cgi-bin/customer_service/complain.pl", but not to the script
4162 "/cgi-private/site_admin.pl". By default, path is set to "/", which
4163 causes the cookie to be sent to any CGI script on your site.
4165 =item 4. a "secure" flag
4167 If the "secure" attribute is set, the cookie will only be sent to your
4168 script if the CGI request is occurring on a secure channel, such as SSL.
4172 The interface to Netscape cookies is the B<cookie()> method:
4174 $cookie = $query->cookie(-name=>'sessionID',
4177 -path=>'/cgi-bin/database',
4178 -domain=>'.capricorn.org',
4180 print $query->header(-cookie=>$cookie);
4182 B<cookie()> creates a new cookie. Its parameters include:
4188 The name of the cookie (required). This can be any string at all.
4189 Although Netscape limits its cookie names to non-whitespace
4190 alphanumeric characters, CGI.pm removes this restriction by escaping
4191 and unescaping cookies behind the scenes.
4195 The value of the cookie. This can be any scalar value,
4196 array reference, or even associative array reference. For example,
4197 you can store an entire associative array into a cookie this way:
4199 $cookie=$query->cookie(-name=>'family information',
4200 -value=>\%childrens_ages);
4204 The optional partial path for which this cookie will be valid, as described
4209 The optional partial domain for which this cookie will be valid, as described
4214 The optional expiration date for this cookie. The format is as described
4215 in the section on the B<header()> method:
4217 "+1h" one hour from now
4221 If set to true, this cookie will only be used within a secure
4226 The cookie created by cookie() must be incorporated into the HTTP
4227 header within the string returned by the header() method:
4229 print $query->header(-cookie=>$my_cookie);
4231 To create multiple cookies, give header() an array reference:
4233 $cookie1 = $query->cookie(-name=>'riddle_name',
4234 -value=>"The Sphynx's Question");
4235 $cookie2 = $query->cookie(-name=>'answers',
4237 print $query->header(-cookie=>[$cookie1,$cookie2]);
4239 To retrieve a cookie, request it by name by calling cookie()
4240 method without the B<-value> parameter:
4244 %answers = $query->cookie(-name=>'answers');
4245 # $query->cookie('answers') will work too!
4247 The cookie and CGI namespaces are separate. If you have a parameter
4248 named 'answers' and a cookie named 'answers', the values retrieved by
4249 param() and cookie() are independent of each other. However, it's
4250 simple to turn a CGI parameter into a cookie, and vice-versa:
4252 # turn a CGI parameter into a cookie
4253 $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]);
4255 $q->param(-name=>'answers',-value=>[$q->cookie('answers')]);
4257 See the B<cookie.cgi> example script for some ideas on how to use
4258 cookies effectively.
4260 B<NOTE:> There appear to be some (undocumented) restrictions on
4261 Netscape cookies. In Netscape 2.01, at least, I haven't been able to
4262 set more than three cookies at a time. There may also be limits on
4263 the length of cookies. If you need to store a lot of information,
4264 it's probably better to create a unique session ID, store it in a
4265 cookie, and use the session ID to locate an external file/database
4266 saved on the server's side of the connection.
4268 =head1 WORKING WITH NETSCAPE FRAMES
4270 It's possible for CGI.pm scripts to write into several browser
4271 panels and windows using Netscape's frame mechanism.
4272 There are three techniques for defining new frames programmatically:
4276 =item 1. Create a <Frameset> document
4278 After writing out the HTTP header, instead of creating a standard
4279 HTML document using the start_html() call, create a <FRAMESET>
4280 document that defines the frames on the page. Specify your script(s)
4281 (with appropriate parameters) as the SRC for each of the frames.
4283 There is no specific support for creating <FRAMESET> sections
4284 in CGI.pm, but the HTML is very simple to write. See the frame
4285 documentation in Netscape's home pages for details
4287 http://home.netscape.com/assist/net_sites/frames.html
4289 =item 2. Specify the destination for the document in the HTTP header
4291 You may provide a B<-target> parameter to the header() method:
4293 print $q->header(-target=>'ResultsWindow');
4295 This will tell Netscape to load the output of your script into the
4296 frame named "ResultsWindow". If a frame of that name doesn't
4297 already exist, Netscape will pop up a new window and load your
4298 script's document into that. There are a number of magic names
4299 that you can use for targets. See the frame documents on Netscape's
4300 home pages for details.
4302 =item 3. Specify the destination for the document in the <FORM> tag
4304 You can specify the frame to load in the FORM tag itself. With
4305 CGI.pm it looks like this:
4307 print $q->startform(-target=>'ResultsWindow');
4309 When your script is reinvoked by the form, its output will be loaded
4310 into the frame named "ResultsWindow". If one doesn't already exist
4311 a new window will be created.
4315 The script "frameset.cgi" in the examples directory shows one way to
4316 create pages in which the fill-out form and the response live in
4317 side-by-side frames.
4321 If you are running the script
4322 from the command line or in the perl debugger, you can pass the script
4323 a list of keywords or parameter=value pairs on the command line or
4324 from standard input (you don't have to worry about tricking your
4325 script into reading from environment variables).
4326 You can pass keywords like this:
4328 your_script.pl keyword1 keyword2 keyword3
4332 your_script.pl keyword1+keyword2+keyword3
4336 your_script.pl name1=value1 name2=value2
4340 your_script.pl name1=value1&name2=value2
4342 or even as newline-delimited parameters on standard input.
4344 When debugging, you can use quotes and backslashes to escape
4345 characters in the familiar shell manner, letting you place
4346 spaces and other funny characters in your parameter=value
4349 your_script.pl "name1='I am a long value'" "name2=two\ words"
4351 =head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
4353 The dump() method produces a string consisting of all the query's
4354 name/value pairs formatted nicely as a nested list. This is useful
4355 for debugging purposes:
4360 Produces something that looks like:
4374 You can pass a value of 'true' to dump() in order to get it to
4375 print the results out as plain text, suitable for incorporating
4376 into a <PRE> section.
4378 As a shortcut, as of version 1.56 you can interpolate the entire
4379 CGI object into a string and it will be replaced with the
4380 the a nice HTML dump shown above:
4383 print "<H2>Current Values</H2> $query\n";
4385 =head1 FETCHING ENVIRONMENT VARIABLES
4387 Some of the more useful environment variables can be fetched
4388 through this interface. The methods are as follows:
4394 Return a list of MIME types that the remote browser
4395 accepts. If you give this method a single argument
4396 corresponding to a MIME type, as in
4397 $query->accept('text/html'), it will return a
4398 floating point value corresponding to the browser's
4399 preference for this type from 0.0 (don't want) to 1.0.
4400 Glob types (e.g. text/*) in the browser's accept list
4401 are handled correctly.
4403 =item B<raw_cookie()>
4405 Returns the HTTP_COOKIE variable, an HTTP extension
4406 implemented by Netscape browsers version 1.1
4407 and higher. Cookies have a special format, and this
4408 method call just returns the raw form (?cookie dough).
4409 See cookie() for ways of setting and retrieving
4412 =item B<user_agent()>
4414 Returns the HTTP_USER_AGENT variable. If you give
4415 this method a single argument, it will attempt to
4416 pattern match on it, allowing you to do something
4417 like $query->user_agent(netscape);
4419 =item B<path_info()>
4421 Returns additional path information from the script URL.
4422 E.G. fetching /cgi-bin/your_script/additional/stuff will
4423 result in $query->path_info() returning
4426 NOTE: The Microsoft Internet Information Server
4427 is broken with respect to additional path information. If
4428 you use the Perl DLL library, the IIS server will attempt to
4429 execute the additional path information as a Perl script.
4430 If you use the ordinary file associations mapping, the
4431 path information will be present in the environment,
4432 but incorrect. The best thing to do is to avoid using additional
4433 path information in CGI scripts destined for use with IIS.
4435 =item B<path_translated()>
4437 As per path_info() but returns the additional
4438 path information translated into a physical path, e.g.
4439 "/usr/local/etc/httpd/htdocs/additional/stuff".
4441 The Microsoft IIS is broken with respect to the translated
4444 =item B<remote_host()>
4446 Returns either the remote host name or IP address.
4447 if the former is unavailable.
4449 =item B<script_name()>
4450 Return the script name as a partial URL, for self-refering
4455 Return the URL of the page the browser was viewing
4456 prior to fetching your script. Not available for all
4459 =item B<auth_type ()>
4461 Return the authorization/verification method in use for this
4464 =item B<server_name ()>
4466 Returns the name of the server, usually the machine's host
4469 =item B<virtual_host ()>
4471 When using virtual hosts, returns the name of the host that
4472 the browser attempted to contact
4474 =item B<server_software ()>
4476 Returns the server software and version number.
4478 =item B<remote_user ()>
4480 Return the authorization/verification name used for user
4481 verification, if this script is protected.
4483 =item B<user_name ()>
4485 Attempt to obtain the remote user's name, using a variety
4486 of different techniques. This only works with older browsers
4487 such as Mosaic. Netscape does not reliably report the user
4490 =item B<request_method()>
4492 Returns the method used to access your script, usually
4493 one of 'POST', 'GET' or 'HEAD'.
4497 =head1 CREATING HTML ELEMENTS:
4499 In addition to its shortcuts for creating form elements, CGI.pm
4500 defines general HTML shortcut methods as well. HTML shortcuts are
4501 named after a single HTML element and return a fragment of HTML text
4502 that you can then print or manipulate as you like.
4504 This example shows how to use the HTML methods:
4507 print $q->blockquote(
4508 "Many years ago on the island of",
4509 $q->a({href=>"http://crete.org/"},"Crete"),
4510 "there lived a minotaur named",
4511 $q->strong("Fred."),
4515 This results in the following HTML code (extra newlines have been
4516 added for readability):
4519 Many years ago on the island of
4520 <a HREF="http://crete.org/">Crete</a> there lived
4521 a minotaur named <strong>Fred.</strong>
4525 If you find the syntax for calling the HTML shortcuts awkward, you can
4526 import them into your namespace and dispense with the object syntax
4527 completely (see the next section for more details):
4529 use CGI shortcuts; # IMPORT HTML SHORTCUTS
4531 "Many years ago on the island of",
4532 a({href=>"http://crete.org/"},"Crete"),
4533 "there lived a minotaur named",
4538 =head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
4540 The HTML methods will accept zero, one or multiple arguments. If you
4541 provide no arguments, you get a single tag:
4546 If you provide one or more string arguments, they are concatenated
4547 together with spaces and placed between opening and closing tags:
4549 print h1("Chapter","1");
4550 # gives "<h1>Chapter 1</h1>"
4552 If the first argument is an associative array reference, then the keys
4553 and values of the associative array become the HTML tag's attributes:
4555 print a({href=>'fred.html',target=>'_new'},
4556 "Open a new frame");
4557 # gives <a href="fred.html",target="_new">Open a new frame</a>
4559 You are free to use CGI.pm-style dashes in front of the attribute
4560 names if you prefer:
4562 print img {-src=>'fred.gif',-align=>'LEFT'};
4563 # gives <img ALIGN="LEFT" SRC="fred.gif">
4565 =head2 Generating new HTML tags
4567 Since no mere mortal can keep up with Netscape and Microsoft as they
4568 battle it out for control of HTML, the code that generates HTML tags
4569 is general and extensible. You can create new HTML tags freely just
4570 by referring to them on the import line:
4572 use CGI shortcuts,winkin,blinkin,nod;
4574 Now, in addition to the standard CGI shortcuts, you've created HTML
4575 tags named "winkin", "blinkin" and "nod". You can use them like this:
4577 print blinkin {color=>'blue',rate=>'fast'},"Yahoo!";
4578 # <blinkin COLOR="blue" RATE="fast">Yahoo!</blinkin>
4580 =head1 IMPORTING CGI METHOD CALLS INTO YOUR NAME SPACE
4582 As a convenience, you can import most of the CGI method calls directly
4583 into your name space. The syntax for doing this is:
4585 use CGI <list of methods>;
4587 The listed methods will be imported into the current package; you can
4588 call them directly without creating a CGI object first. This example
4589 shows how to import the B<param()> and B<header()>
4590 methods, and then use them directly:
4592 use CGI param,header;
4593 print header('text/plain');
4594 $zipcode = param('zipcode');
4596 You can import groups of methods by referring to a number of special
4603 Import all CGI-handling methods, such as B<param()>, B<path_info()>
4608 Import all fill-out form generating methods, such as B<textfield()>.
4612 Import all methods that generate HTML 2.0 standard elements.
4616 Import all methods that generate HTML 3.0 proposed elements (such as
4617 <table>, <super> and <sub>).
4621 Import all methods that generate Netscape-specific HTML extensions.
4625 Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
4630 Import "standard" features, 'html2', 'form' and 'cgi'.
4634 Import all the available methods. For the full list, see the CGI.pm
4635 code, where the variable %TAGS is defined.
4639 Note that in the interests of execution speed CGI.pm does B<not> use
4640 the standard L<Exporter> syntax for specifying load symbols. This may
4641 change in the future.
4643 If you import any of the state-maintaining CGI or form-generating
4644 methods, a default CGI object will be created and initialized
4645 automatically the first time you use any of the methods that require
4646 one to be present. This includes B<param()>, B<textfield()>,
4647 B<submit()> and the like. (If you need direct access to the CGI
4648 object, you can find it in the global variable B<$CGI::Q>). By
4649 importing CGI.pm methods, you can create visually elegant scripts:
4651 use CGI standard,html2;
4654 start_html('Simple Script'),
4655 h1('Simple Script'),
4657 "What's your name? ",textfield('name'),p,
4658 "What's the combination?",
4659 checkbox_group(-name=>'words',
4660 -values=>['eenie','meenie','minie','moe'],
4661 -defaults=>['eenie','moe']),p,
4662 "What's your favorite color?",
4663 popup_menu(-name=>'color',
4664 -values=>['red','green','blue','chartreuse']),p,
4671 "Your name is ",em(param('name')),p,
4672 "The keywords are: ",em(join(", ",param('words'))),p,
4673 "Your favorite color is ",em(param('color')),".\n";
4677 =head1 USING NPH SCRIPTS
4679 NPH, or "no-parsed-header", scripts bypass the server completely by
4680 sending the complete HTTP header directly to the browser. This has
4681 slight performance benefits, but is of most use for taking advantage
4682 of HTTP extensions that are not directly supported by your server,
4683 such as server push and PICS headers.
4685 Servers use a variety of conventions for designating CGI scripts as
4686 NPH. Many Unix servers look at the beginning of the script's name for
4687 the prefix "nph-". The Macintosh WebSTAR server and Microsoft's
4688 Internet Information Server, in contrast, try to decide whether a
4689 program is an NPH script by examining the first line of script output.
4692 CGI.pm supports NPH scripts with a special NPH mode. When in this
4693 mode, CGI.pm will output the necessary extra header information when
4694 the header() and redirect() methods are
4697 The Microsoft Internet Information Server requires NPH mode. As of version
4698 2.30, CGI.pm will automatically detect when the script is running under IIS
4699 and put itself into this mode. You do not need to do this manually, although
4700 it won't hurt anything if you do.
4702 There are a number of ways to put CGI.pm into NPH mode:
4706 =item In the B<use> statement
4707 Simply add ":nph" to the list of symbols to be imported into your script:
4709 use CGI qw(:standard :nph)
4711 =item By calling the B<nph()> method:
4713 Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
4717 =item By using B<-nph> parameters in the B<header()> and B<redirect()> statements:
4719 print $q->header(-nph=>1);
4723 =head1 AUTHOR INFORMATION
4725 Copyright 1995,1996, Lincoln D. Stein. All rights reserved. It may
4726 be used and modified freely, but I do request that this copyright
4727 notice remain attached to the file. You may modify this module as you
4728 wish, but if you redistribute a modified version, please attach a note
4729 listing the modifications you have made.
4731 Address bug reports and comments to:
4732 lstein@genome.wi.mit.edu
4736 Thanks very much to:
4740 =item Matt Heffron (heffron@falstaff.css.beckman.com)
4742 =item James Taylor (james.taylor@srs.gov)
4744 =item Scott Anguish <sanguish@digifix.com>
4746 =item Mike Jewell (mlj3u@virginia.edu)
4748 =item Timothy Shimmin (tes@kbs.citri.edu.au)
4750 =item Joergen Haegg (jh@axis.se)
4752 =item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu)
4754 =item Richard Resnick (applepi1@aol.com)
4756 =item Craig Bishop (csb@barwonwater.vic.gov.au)
4758 =item Tony Curtis (tc@vcpc.univie.ac.at)
4760 =item Tim Bunce (Tim.Bunce@ig.co.uk)
4762 =item Tom Christiansen (tchrist@convex.com)
4764 =item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
4766 =item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
4768 =item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
4770 =item Stephen Dahmen (joyfire@inxpress.net)
4772 =item Ed Jordan (ed@fidalgo.net)
4774 =item David Alan Pisoni (david@cnation.com)
4776 =item ...and many many more...
4778 for suggestions and bug fixes.
4782 =head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
4785 #!/usr/local/bin/perl
4791 print $query->header;
4792 print $query->start_html("Example CGI.pm Form");
4793 print "<H1> Example CGI.pm Form</H1>\n";
4794 &print_prompt($query);
4797 print $query->end_html;
4802 print $query->startform;
4803 print "<EM>What's your name?</EM><BR>";
4804 print $query->textfield('name');
4805 print $query->checkbox('Not my real name');
4807 print "<P><EM>Where can you find English Sparrows?</EM><BR>";
4808 print $query->checkbox_group(
4809 -name=>'Sparrow locations',
4810 -values=>[England,France,Spain,Asia,Hoboken],
4812 -defaults=>[England,Asia]);
4814 print "<P><EM>How far can they fly?</EM><BR>",
4815 $query->radio_group(
4817 -values=>['10 ft','1 mile','10 miles','real far'],
4818 -default=>'1 mile');
4820 print "<P><EM>What's your favorite color?</EM> ";
4821 print $query->popup_menu(-name=>'Color',
4822 -values=>['black','brown','red','yellow'],
4825 print $query->hidden('Reference','Monty Python and the Holy Grail');
4827 print "<P><EM>What have you got there?</EM><BR>";
4828 print $query->scrolling_list(
4829 -name=>'possessions',
4830 -values=>['A Coconut','A Grail','An Icon',
4831 'A Sword','A Ticket'],
4835 print "<P><EM>Any parting comments?</EM><BR>";
4836 print $query->textarea(-name=>'Comments',
4840 print "<P>",$query->reset;
4841 print $query->submit('Action','Shout');
4842 print $query->submit('Action','Scream');
4843 print $query->endform;
4851 print "<H2>Here are the current settings in this form</H2>";
4853 foreach $key ($query->param) {
4854 print "<STRONG>$key</STRONG> -> ";
4855 @values = $query->param($key);
4856 print join(", ",@values),"<BR>\n";
4863 <ADDRESS>Lincoln D. Stein</ADDRESS><BR>
4864 <A HREF="/">Home Page</A>
4870 This module has grown large and monolithic. Furthermore it's doing many
4871 things, such as handling URLs, parsing CGI input, writing HTML, etc., that
4872 are also done in the LWP modules. It should be discarded in favor of
4873 the CGI::* modules, but somehow I continue to work on it.
4875 Note that the code is truly contorted in order to avoid spurious
4876 warnings when programs are run with the B<-w> switch.
4880 L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>,
4881 L<CGI::Base>, L<CGI::Form>, L<CGI::Apache>, L<CGI::Switch>,
4882 L<CGI::Push>, L<CGI::Fast>