This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
enable Errno build on win32, add Errno-1.08 files to repository
[perl5.git] / lib / CGI.pm
CommitLineData
54310121 1package CGI;
2require 5.001;
3
4# See the bottom of this file for the POD documentation. Search for the
5# string '=head'.
6
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).
10
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.
16
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/
20
21# Set this to 1 to enable copious autoloader debugging messages
22$AUTOLOAD_DEBUG=0;
23
24# Set this to 1 to enable NPH scripts
25# or:
26# 1) use CGI qw(:nph)
27# 2) $CGI::nph(1)
28# 3) print header(-nph=>1)
29$NPH=0;
30
7d37aa8e
LS
31# Set this to 1 to make the temporary files created
32# during file uploads safe from prying eyes
33# or do...
34# 1) use CGI qw(:private_tempfiles)
35# 2) $CGI::private_tempfiles(1);
36$PRIVATE_TEMPFILES=0;
37
38$CGI::revision = '$Id: CGI.pm,v 2.36 1997/5/10 8:22 lstein Exp $';
39$CGI::VERSION='2.36';
54310121 40
41# OVERRIDE THE OS HERE IF CGI.pm GUESSES WRONG
42# $OS = 'UNIX';
43# $OS = 'MACINTOSH';
44# $OS = 'WINDOWS';
45# $OS = 'VMS';
46# $OS = 'OS2';
47
48# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
49# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
50# $TempFile::TMPDIRECTORY = '/usr/tmp';
51
52# ------------------ START OF THE LIBRARY ------------
53
54# FIGURE OUT THE OS WE'RE RUNNING UNDER
55# Some systems support the $^O variable. If not
56# available then require() the Config library
57unless ($OS) {
58 unless ($OS = $^O) {
59 require Config;
60 $OS = $Config::Config{'osname'};
61 }
62}
63if ($OS=~/Win/i) {
64 $OS = 'WINDOWS';
65} elsif ($OS=~/vms/i) {
66 $OS = 'VMS';
67} elsif ($OS=~/Mac/i) {
68 $OS = 'MACINTOSH';
69} elsif ($OS=~/os2/i) {
70 $OS = 'OS2';
71} else {
72 $OS = 'UNIX';
73}
74
75# Some OS logic. Binary mode enabled on DOS, NT and VMS
76$needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/;
77
78# This is the default class for the CGI object to use when all else fails.
79$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
80# This is where to look for autoloaded routines.
81$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
82
83# The path separator is a slash, backslash or semicolon, depending
84# on the paltform.
85$SL = {
86 UNIX=>'/',
87 OS2=>'\\',
88 WINDOWS=>'\\',
89 MACINTOSH=>':',
90 VMS=>'\\'
91 }->{$OS};
92
93# Turn on NPH scripts by default when running under IIS server!
94$NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
95
96# Turn on special checking for Doug MacEachern's modperl
12c5d27a 97if (defined($ENV{'GATEWAY_INTERFACE'}) && ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)) {
54310121 98 $NPH++;
99 $| = 1;
100 $SEQNO = 1;
101}
102
103# This is really "\r\n", but the meaning of \n is different
104# in MacPerl, so we resort to octal here.
105$CRLF = "\015\012";
106
107if ($needs_binmode) {
108 $CGI::DefaultClass->binmode(main::STDOUT);
109 $CGI::DefaultClass->binmode(main::STDIN);
110 $CGI::DefaultClass->binmode(main::STDERR);
111}
112
113# Cute feature, but it broke when the overload mechanism changed...
114# %OVERLOAD = ('""'=>'as_string');
115
116%EXPORT_TAGS = (
117 ':html2'=>[h1..h6,qw/p br hr ol ul li dl dt dd menu code var strong em
118 tt i b blockquote pre img a address cite samp dfn html head
119 base body link nextid title meta kbd start_html end_html
120 input Select option/],
7d37aa8e 121 ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont style span/],
54310121 122 ':netscape'=>[qw/blink frameset frame script font fontsize center/],
123 ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
124 submit reset defaults radio_group popup_menu button autoEscape
125 scrolling_list image_button start_form end_form startform endform
126 start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
127 ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump
128 raw_cookie request_method query_string accept user_agent remote_host
129 remote_addr referer server_name server_software server_port server_protocol
7d37aa8e 130 virtual_host remote_ident auth_type http use_named_parameters
54310121 131 remote_user user_name header redirect import_names put/],
132 ':ssl' => [qw/https/],
133 ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
134 ':html' => [qw/:html2 :html3 :netscape/],
135 ':standard' => [qw/:html2 :form :cgi/],
136 ':all' => [qw/:html2 :html3 :netscape :form :cgi/]
137 );
138
139# to import symbols into caller
140sub import {
141 my $self = shift;
142 my ($callpack, $callfile, $callline) = caller;
143 foreach (@_) {
144 $NPH++, next if $_ eq ':nph';
7d37aa8e 145 $PRIVATE_TEMPFILES++, next if $_ eq ':private_tempfiles';
54310121 146 foreach (&expand_tags($_)) {
147 tr/a-zA-Z0-9_//cd; # don't allow weird function names
148 $EXPORT{$_}++;
149 }
150 }
151 # To allow overriding, search through the packages
152 # Till we find one in which the correct subroutine is defined.
153 my @packages = ($self,@{"$self\:\:ISA"});
154 foreach $sym (keys %EXPORT) {
155 my $pck;
156 my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
157 foreach $pck (@packages) {
158 if (defined(&{"$pck\:\:$sym"})) {
159 $def = $pck;
160 last;
161 }
162 }
163 *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
164 }
165}
166
167sub expand_tags {
168 my($tag) = @_;
169 my(@r);
170 return ($tag) unless $EXPORT_TAGS{$tag};
171 foreach (@{$EXPORT_TAGS{$tag}}) {
172 push(@r,&expand_tags($_));
173 }
174 return @r;
175}
176
177#### Method: new
178# The new routine. This will check the current environment
179# for an existing query string, and initialize itself, if so.
180####
181sub new {
182 my($class,$initializer) = @_;
183 my $self = {};
184 bless $self,ref $class || $class || $DefaultClass;
fabdde38 185 $CGI::DefaultClass->_reset_globals() if $MOD_PERL;
54310121 186 $initializer = to_filehandle($initializer) if $initializer;
187 $self->init($initializer);
188 return $self;
189}
190
191# We provide a DESTROY method so that the autoloader
192# doesn't bother trying to find it.
193sub DESTROY { }
194
195#### Method: param
196# Returns the value(s)of a named parameter.
197# If invoked in a list context, returns the
198# entire list. Otherwise returns the first
199# member of the list.
200# If name is not provided, return a list of all
201# the known parameters names available.
202# If more than one argument is provided, the
203# second and subsequent arguments are used to
204# set the value of the parameter.
205####
206sub param {
207 my($self,@p) = self_or_default(@_);
208 return $self->all_parameters unless @p;
209 my($name,$value,@other);
210
211 # For compatibility between old calling style and use_named_parameters() style,
212 # we have to special case for a single parameter present.
213 if (@p > 1) {
214 ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
215 my(@values);
216
217 if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
218 @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
219 } else {
220 foreach ($value,@other) {
221 push(@values,$_) if defined($_);
222 }
223 }
224 # If values is provided, then we set it.
225 if (@values) {
226 $self->add_parameter($name);
227 $self->{$name}=[@values];
228 }
229 } else {
230 $name = $p[0];
231 }
232
233 return () unless defined($name) && $self->{$name};
234 return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
235}
236
237#### Method: delete
238# Deletes the named parameter entirely.
239####
240sub delete {
241 my($self,$name) = self_or_default(@_);
242 delete $self->{$name};
243 delete $self->{'.fieldnames'}->{$name};
244 @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
245 return wantarray ? () : undef;
246}
247
248sub self_or_default {
249 return @_ if defined($_[0]) && !ref($_[0]) && ($_[0] eq 'CGI');
250 unless (defined($_[0]) &&
251 ref($_[0]) &&
252 (ref($_[0]) eq 'CGI' ||
253 eval "\$_[0]->isaCGI()")) { # optimize for the common case
254 $CGI::DefaultClass->_reset_globals()
255 if defined($Q) && $MOD_PERL && $CGI::DefaultClass->_new_request();
256 $Q = $CGI::DefaultClass->new unless defined($Q);
257 unshift(@_,$Q);
258 }
259 return @_;
260}
261
262sub _new_request {
263 return undef unless (defined(Apache->seqno()) or eval { require Apache });
264 if (Apache->seqno() != $SEQNO) {
265 $SEQNO = Apache->seqno();
266 return 1;
267 } else {
268 return undef;
269 }
270}
271
272sub _reset_globals {
273 undef $Q;
274 undef @QUERY_PARAM;
275}
276
277sub self_or_CGI {
278 local $^W=0; # prevent a warning
279 if (defined($_[0]) &&
280 (substr(ref($_[0]),0,3) eq 'CGI'
281 || eval "\$_[0]->isaCGI()")) {
282 return @_;
283 } else {
284 return ($DefaultClass,@_);
285 }
286}
287
288sub isaCGI {
289 return 1;
290}
291
292#### Method: import_names
293# Import all parameters into the given namespace.
294# Assumes namespace 'Q' if not specified
295####
296sub import_names {
297 my($self,$namespace) = self_or_default(@_);
298 $namespace = 'Q' unless defined($namespace);
299 die "Can't import names into 'main'\n"
300 if $namespace eq 'main';
301 my($param,@value,$var);
302 foreach $param ($self->param) {
303 # protect against silly names
304 ($var = $param)=~tr/a-zA-Z0-9_/_/c;
305 $var = "${namespace}::$var";
306 @value = $self->param($param);
307 @{$var} = @value;
308 ${$var} = $value[0];
309 }
310}
311
312#### Method: use_named_parameters
313# Force CGI.pm to use named parameter-style method calls
314# rather than positional parameters. The same effect
315# will happen automatically if the first parameter
316# begins with a -.
317sub use_named_parameters {
318 my($self,$use_named) = self_or_default(@_);
319 return $self->{'.named'} unless defined ($use_named);
320
321 # stupidity to avoid annoying warnings
322 return $self->{'.named'}=$use_named;
323}
324
325########################################
326# THESE METHODS ARE MORE OR LESS PRIVATE
327# GO TO THE __DATA__ SECTION TO SEE MORE
328# PUBLIC METHODS
329########################################
330
331# Initialize the query object from the environment.
332# If a parameter list is found, this object will be set
333# to an associative array in which parameter names are keys
334# and the values are stored as lists
335# If a keyword list is found, this method creates a bogus
336# parameter list with the single parameter 'keywords'.
337
338sub init {
339 my($self,$initializer) = @_;
340 my($query_string,@lines);
341 my($meth) = '';
342
343 # if we get called more than once, we want to initialize
344 # ourselves from the original query (which may be gone
345 # if it was read from STDIN originally.)
346 if (defined(@QUERY_PARAM) && !defined($initializer)) {
347
348 foreach (@QUERY_PARAM) {
349 $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
350 }
351 return;
352 }
353
354 $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
355
356 # If initializer is defined, then read parameters
357 # from it.
358 METHOD: {
359 if (defined($initializer)) {
360
361 if (ref($initializer) && ref($initializer) eq 'HASH') {
362 foreach (keys %$initializer) {
363 $self->param('-name'=>$_,'-value'=>$initializer->{$_});
364 }
365 last METHOD;
366 }
367
368 $initializer = $$initializer if ref($initializer);
369 if (defined(fileno($initializer))) {
370 while (<$initializer>) {
371 chomp;
372 last if /^=/;
373 push(@lines,$_);
374 }
375 # massage back into standard format
376 if ("@lines" =~ /=/) {
377 $query_string=join("&",@lines);
378 } else {
379 $query_string=join("+",@lines);
380 }
381 last METHOD;
382 }
383 $query_string = $initializer;
384 last METHOD;
385 }
386 # If method is GET or HEAD, fetch the query from
387 # the environment.
388 if ($meth=~/^(GET|HEAD)$/) {
389 $query_string = $ENV{'QUERY_STRING'};
390 last METHOD;
391 }
392
393 # If the method is POST, fetch the query from standard
394 # input.
395 if ($meth eq 'POST') {
396
397 if (defined($ENV{'CONTENT_TYPE'})
398 &&
399 $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|) {
400 my($boundary) = $ENV{'CONTENT_TYPE'}=~/boundary=(\S+)/;
401 $self->read_multipart($boundary,$ENV{'CONTENT_LENGTH'});
402
403 } else {
404
405 $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0)
406 if $ENV{'CONTENT_LENGTH'} > 0;
407
408 }
409 # Some people want to have their cake and eat it too!
410 # Uncomment this line to have the contents of the query string
411 # APPENDED to the POST data.
412 # $query_string .= ($query_string ? '&' : '') . $ENV{'QUERY_STRING'} if $ENV{'QUERY_STRING'};
413 last METHOD;
414 }
415
416 # If neither is set, assume we're being debugged offline.
417 # Check the command line and then the standard input for data.
418 # We use the shellwords package in order to behave the way that
419 # UN*X programmers expect.
420 $query_string = &read_from_cmdline;
421 }
422
423 # We now have the query string in hand. We do slightly
424 # different things for keyword lists and parameter lists.
425 if ($query_string) {
426 if ($query_string =~ /=/) {
427 $self->parse_params($query_string);
428 } else {
429 $self->add_parameter('keywords');
430 $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
431 }
432 }
433
434 # Special case. Erase everything if there is a field named
435 # .defaults.
436 if ($self->param('.defaults')) {
437 undef %{$self};
438 }
439
440 # Associative array containing our defined fieldnames
441 $self->{'.fieldnames'} = {};
442 foreach ($self->param('.cgifields')) {
443 $self->{'.fieldnames'}->{$_}++;
444 }
445
446 # Clear out our default submission button flag if present
447 $self->delete('.submit');
448 $self->delete('.cgifields');
449 $self->save_request unless $initializer;
450
451}
452
453
454# FUNCTIONS TO OVERRIDE:
455
456# Turn a string into a filehandle
457sub to_filehandle {
458 my $string = shift;
459 if ($string && !ref($string)) {
460 my($package) = caller(1);
461 my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string";
462 return $tmp if defined(fileno($tmp));
463 }
464 return $string;
465}
466
467# Create a new multipart buffer
468sub new_MultipartBuffer {
469 my($self,$boundary,$length,$filehandle) = @_;
470 return MultipartBuffer->new($self,$boundary,$length,$filehandle);
471}
472
473# Read data from a file handle
474sub read_from_client {
475 my($self, $fh, $buff, $len, $offset) = @_;
476 local $^W=0; # prevent a warning
477 return read($fh, $$buff, $len, $offset);
478}
479
480# put a filehandle into binary mode (DOS)
481sub binmode {
482 binmode($_[1]);
483}
484
485# send output to the browser
486sub put {
487 my($self,@p) = self_or_default(@_);
488 $self->print(@p);
489}
490
491# print to standard output (for overriding in mod_perl)
492sub print {
493 shift;
494 CORE::print(@_);
495}
496
497# unescape URL-encoded data
498sub unescape {
499 my($todecode) = @_;
500 $todecode =~ tr/+/ /; # pluses become spaces
501 $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
502 return $todecode;
503}
504
505# URL-encode data
506sub escape {
507 my($toencode) = @_;
508 $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
509 return $toencode;
510}
511
512sub save_request {
513 my($self) = @_;
514 # We're going to play with the package globals now so that if we get called
515 # again, we initialize ourselves in exactly the same way. This allows
516 # us to have several of these objects.
517 @QUERY_PARAM = $self->param; # save list of parameters
518 foreach (@QUERY_PARAM) {
519 $QUERY_PARAM{$_}=$self->{$_};
520 }
521}
522
523sub parse_keywordlist {
524 my($self,$tosplit) = @_;
525 $tosplit = &unescape($tosplit); # unescape the keywords
526 $tosplit=~tr/+/ /; # pluses to spaces
527 my(@keywords) = split(/\s+/,$tosplit);
528 return @keywords;
529}
530
531sub parse_params {
532 my($self,$tosplit) = @_;
533 my(@pairs) = split('&',$tosplit);
534 my($param,$value);
535 foreach (@pairs) {
536 ($param,$value) = split('=');
537 $param = &unescape($param);
538 $value = &unescape($value);
539 $self->add_parameter($param);
540 push (@{$self->{$param}},$value);
541 }
542}
543
544sub add_parameter {
545 my($self,$param)=@_;
546 push (@{$self->{'.parameters'}},$param)
547 unless defined($self->{$param});
548}
549
550sub all_parameters {
551 my $self = shift;
552 return () unless defined($self) && $self->{'.parameters'};
553 return () unless @{$self->{'.parameters'}};
554 return @{$self->{'.parameters'}};
555}
556
54310121 557#### Method as_string
558#
559# synonym for "dump"
560####
561sub as_string {
562 &dump(@_);
563}
564
565sub AUTOLOAD {
566 print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
567 my($func) = $AUTOLOAD;
568 my($pack,$func_name) = $func=~/(.+)::([^:]+)$/;
569 $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
570 unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
571
572 my($sub) = \%{"$pack\:\:SUBS"};
573 unless (%$sub) {
574 my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
575 eval "package $pack; $$auto";
576 die $@ if $@;
577 }
578 my($code) = $sub->{$func_name};
579
580 $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
581 if (!$code) {
582 if ($EXPORT{':any'} ||
583 $EXPORT{$func_name} ||
584 (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
585 && $EXPORT_OK{$func_name}) {
586 $code = $sub->{'HTML_FUNC'};
587 $code=~s/func_name/$func_name/mg;
588 }
589 }
590 die "Undefined subroutine $AUTOLOAD\n" unless $code;
591 eval "package $pack; $code";
592 if ($@) {
593 $@ =~ s/ at .*\n//;
594 die $@;
595 }
596 goto &{"$pack\:\:$func_name"};
597}
598
599# PRIVATE SUBROUTINE
600# Smart rearrangement of parameters to allow named parameter
601# calling. We do the rearangement if:
602# 1. The first parameter begins with a -
603# 2. The use_named_parameters() method returns true
604sub rearrange {
605 my($self,$order,@param) = @_;
606 return () unless @param;
607
608 return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-')
609 || $self->use_named_parameters;
610
611 my $i;
612 for ($i=0;$i<@param;$i+=2) {
613 $param[$i]=~s/^\-//; # get rid of initial - if present
614 $param[$i]=~tr/a-z/A-Z/; # parameters are upper case
615 }
616
617 my(%param) = @param; # convert into associative array
618 my(@return_array);
619
620 my($key)='';
621 foreach $key (@$order) {
622 my($value);
623 # this is an awful hack to fix spurious warnings when the
624 # -w switch is set.
625 if (ref($key) && ref($key) eq 'ARRAY') {
626 foreach (@$key) {
627 last if defined($value);
628 $value = $param{$_};
629 delete $param{$_};
630 }
631 } else {
632 $value = $param{$key};
633 delete $param{$key};
634 }
635 push(@return_array,$value);
636 }
637 push (@return_array,$self->make_attributes(\%param)) if %param;
638 return (@return_array);
639}
640
641###############################################################################
642################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
643###############################################################################
644$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
645$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
646
647%SUBS = (
648
649'URL_ENCODED'=> <<'END_OF_FUNC',
650sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
651END_OF_FUNC
652
653'MULTIPART' => <<'END_OF_FUNC',
654sub MULTIPART { 'multipart/form-data'; }
655END_OF_FUNC
656
657'HTML_FUNC' => <<'END_OF_FUNC',
658sub func_name {
659
660 # handle various cases in which we're called
661 # most of this bizarre stuff is to avoid -w errors
662 shift if $_[0] &&
663 (!ref($_[0]) && $_[0] eq $CGI::DefaultClass) ||
664 (ref($_[0]) &&
665 (substr(ref($_[0]),0,3) eq 'CGI' ||
666 eval "\$_[0]->isaCGI()"));
667
668 my($attr) = '';
669 if (ref($_[0]) && ref($_[0]) eq 'HASH') {
670 my(@attr) = CGI::make_attributes('',shift);
671 $attr = " @attr" if @attr;
672 }
673 my($tag,$untag) = ("\U<func_name\E$attr>","\U</func_name>\E");
674 return $tag unless @_;
675 if (ref($_[0]) eq 'ARRAY') {
676 my(@r);
677 foreach (@{$_[0]}) {
678 push(@r,"$tag$_$untag");
679 }
680 return "@r";
681 } else {
682 return "$tag@_$untag";
683 }
684}
685END_OF_FUNC
686
687#### Method: keywords
688# Keywords acts a bit differently. Calling it in a list context
689# returns the list of keywords.
690# Calling it in a scalar context gives you the size of the list.
691####
692'keywords' => <<'END_OF_FUNC',
693sub keywords {
694 my($self,@values) = self_or_default(@_);
695 # If values is provided, then we set it.
696 $self->{'keywords'}=[@values] if @values;
697 my(@result) = @{$self->{'keywords'}};
698 @result;
699}
700END_OF_FUNC
701
702# These are some tie() interfaces for compatibility
703# with Steve Brenner's cgi-lib.pl routines
704'ReadParse' => <<'END_OF_FUNC',
705sub ReadParse {
706 local(*in);
707 if (@_) {
708 *in = $_[0];
709 } else {
710 my $pkg = caller();
711 *in=*{"${pkg}::in"};
712 }
713 tie(%in,CGI);
714}
715END_OF_FUNC
716
717'PrintHeader' => <<'END_OF_FUNC',
718sub PrintHeader {
719 my($self) = self_or_default(@_);
720 return $self->header();
721}
722END_OF_FUNC
723
724'HtmlTop' => <<'END_OF_FUNC',
725sub HtmlTop {
726 my($self,@p) = self_or_default(@_);
727 return $self->start_html(@p);
728}
729END_OF_FUNC
730
731'HtmlBot' => <<'END_OF_FUNC',
732sub HtmlBot {
733 my($self,@p) = self_or_default(@_);
734 return $self->end_html(@p);
735}
736END_OF_FUNC
737
738'SplitParam' => <<'END_OF_FUNC',
739sub SplitParam {
740 my ($param) = @_;
741 my (@params) = split ("\0", $param);
742 return (wantarray ? @params : $params[0]);
743}
744END_OF_FUNC
745
746'MethGet' => <<'END_OF_FUNC',
747sub MethGet {
748 return request_method() eq 'GET';
749}
750END_OF_FUNC
751
752'MethPost' => <<'END_OF_FUNC',
753sub MethPost {
754 return request_method() eq 'POST';
755}
756END_OF_FUNC
757
758'TIEHASH' => <<'END_OF_FUNC',
759sub TIEHASH {
760 return new CGI;
761}
762END_OF_FUNC
763
764'STORE' => <<'END_OF_FUNC',
765sub STORE {
766 $_[0]->param($_[1],split("\0",$_[2]));
767}
768END_OF_FUNC
769
770'FETCH' => <<'END_OF_FUNC',
771sub FETCH {
772 return $_[0] if $_[1] eq 'CGI';
773 return undef unless defined $_[0]->param($_[1]);
774 return join("\0",$_[0]->param($_[1]));
775}
776END_OF_FUNC
777
778'FIRSTKEY' => <<'END_OF_FUNC',
779sub FIRSTKEY {
780 $_[0]->{'.iterator'}=0;
781 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
782}
783END_OF_FUNC
784
785'NEXTKEY' => <<'END_OF_FUNC',
786sub NEXTKEY {
787 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
788}
789END_OF_FUNC
790
791'EXISTS' => <<'END_OF_FUNC',
792sub EXISTS {
793 exists $_[0]->{$_[1]};
794}
795END_OF_FUNC
796
797'DELETE' => <<'END_OF_FUNC',
798sub DELETE {
799 $_[0]->delete($_[1]);
800}
801END_OF_FUNC
802
803'CLEAR' => <<'END_OF_FUNC',
804sub CLEAR {
805 %{$_[0]}=();
806}
807####
808END_OF_FUNC
809
810####
811# Append a new value to an existing query
812####
813'append' => <<'EOF',
814sub append {
815 my($self,@p) = @_;
816 my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
817 my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
818 if (@values) {
819 $self->add_parameter($name);
820 push(@{$self->{$name}},@values);
821 }
822 return $self->param($name);
823}
824EOF
825
826#### Method: delete_all
827# Delete all parameters
828####
829'delete_all' => <<'EOF',
830sub delete_all {
831 my($self) = self_or_default(@_);
832 undef %{$self};
833}
834EOF
835
836#### Method: autoescape
837# If you want to turn off the autoescaping features,
838# call this method with undef as the argument
839'autoEscape' => <<'END_OF_FUNC',
840sub autoEscape {
841 my($self,$escape) = self_or_default(@_);
842 $self->{'dontescape'}=!$escape;
843}
844END_OF_FUNC
845
846
847#### Method: version
848# Return the current version
849####
850'version' => <<'END_OF_FUNC',
851sub version {
852 return $VERSION;
853}
854END_OF_FUNC
855
856'make_attributes' => <<'END_OF_FUNC',
857sub make_attributes {
858 my($self,$attr) = @_;
859 return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
860 my(@att);
861 foreach (keys %{$attr}) {
862 my($key) = $_;
863 $key=~s/^\-//; # get rid of initial - if present
864 $key=~tr/a-z/A-Z/; # parameters are upper case
865 push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/);
866 }
867 return @att;
868}
869END_OF_FUNC
870
871#### Method: dump
872# Returns a string in which all the known parameter/value
873# pairs are represented as nested lists, mainly for the purposes
874# of debugging.
875####
876'dump' => <<'END_OF_FUNC',
877sub dump {
878 my($self) = self_or_default(@_);
879 my($param,$value,@result);
880 return '<UL></UL>' unless $self->param;
881 push(@result,"<UL>");
882 foreach $param ($self->param) {
883 my($name)=$self->escapeHTML($param);
884 push(@result,"<LI><STRONG>$param</STRONG>");
885 push(@result,"<UL>");
886 foreach $value ($self->param($param)) {
887 $value = $self->escapeHTML($value);
888 push(@result,"<LI>$value");
889 }
890 push(@result,"</UL>");
891 }
892 push(@result,"</UL>\n");
893 return join("\n",@result);
894}
895END_OF_FUNC
896
897
898#### Method: save
899# Write values out to a filehandle in such a way that they can
900# be reinitialized by the filehandle form of the new() method
901####
902'save' => <<'END_OF_FUNC',
903sub save {
904 my($self,$filehandle) = self_or_default(@_);
905 my($param);
906 my($package) = caller;
907# Check that this still works!
908# $filehandle = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
909 $filehandle = to_filehandle($filehandle);
910 foreach $param ($self->param) {
911 my($escaped_param) = &escape($param);
912 my($value);
913 foreach $value ($self->param($param)) {
914 print $filehandle "$escaped_param=",escape($value),"\n";
915 }
916 }
917 print $filehandle "=\n"; # end of record
918}
919END_OF_FUNC
920
921
922#### Method: header
923# Return a Content-Type: style header
924#
925####
926'header' => <<'END_OF_FUNC',
927sub header {
928 my($self,@p) = self_or_default(@_);
929 my(@header);
930
931 my($type,$status,$cookie,$target,$expires,$nph,@other) =
932 $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
933
934 # rearrange() was designed for the HTML portion, so we
935 # need to fix it up a little.
936 foreach (@other) {
937 next unless my($header,$value) = /([^\s=]+)=(.+)/;
938 substr($header,1,1000)=~tr/A-Z/a-z/;
939 ($value)=$value=~/^"(.*)"$/;
940 $_ = "$header: $value";
941 }
942
943 $type = $type || 'text/html';
944
945 push(@header,'HTTP/1.0 ' . ($status || '200 OK')) if $nph || $NPH;
946 push(@header,"Status: $status") if $status;
947 push(@header,"Window-target: $target") if $target;
948 # push all the cookies -- there may be several
949 if ($cookie) {
950 my(@cookie) = ref($cookie) ? @{$cookie} : $cookie;
951 foreach (@cookie) {
952 push(@header,"Set-cookie: $_");
953 }
954 }
955 # if the user indicates an expiration time, then we need
956 # both an Expires and a Date header (so that the browser is
957 # uses OUR clock)
7d37aa8e
LS
958 push(@header,"Expires: " . &date(&expire_calc($expires),'http'))
959 if $expires;
960 push(@header,"Date: " . &date(&expire_calc(0),'http')) if $expires || $cookie;
54310121 961 push(@header,"Pragma: no-cache") if $self->cache();
962 push(@header,@other);
963 push(@header,"Content-type: $type");
964
965 my $header = join($CRLF,@header);
966 return $header . "${CRLF}${CRLF}";
967}
968END_OF_FUNC
969
970
971#### Method: cache
972# Control whether header() will produce the no-cache
973# Pragma directive.
974####
975'cache' => <<'END_OF_FUNC',
976sub cache {
977 my($self,$new_value) = self_or_default(@_);
978 $new_value = '' unless $new_value;
979 if ($new_value ne '') {
980 $self->{'cache'} = $new_value;
981 }
982 return $self->{'cache'};
983}
984END_OF_FUNC
985
986
987#### Method: redirect
988# Return a Location: style header
989#
990####
991'redirect' => <<'END_OF_FUNC',
992sub redirect {
993 my($self,@p) = self_or_default(@_);
12c5d27a 994 my($url,$target,$cookie,$nph,@other) = $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p);
54310121 995 $url = $url || $self->self_url;
996 my(@o);
997 foreach (@other) { push(@o,split("=")); }
12c5d27a 998 if($MOD_PERL or exists $self->{'.req'}) {
38b79821
CS
999 my $r = $self->{'.req'} || Apache->request;
1000 $r->header_out(Location => $url);
1001 $r->err_header_out(Location => $url);
1002 $r->status(302);
1003 return;
1004 }
54310121 1005 push(@o,
1006 '-Status'=>'302 Found',
1007 '-Location'=>$url,
1008 '-URI'=>$url,
1009 '-nph'=>($nph||$NPH));
1010 push(@o,'-Target'=>$target) if $target;
1011 push(@o,'-Cookie'=>$cookie) if $cookie;
1012 return $self->header(@o);
1013}
1014END_OF_FUNC
1015
1016
1017#### Method: start_html
1018# Canned HTML header
1019#
1020# Parameters:
1021# $title -> (optional) The title for this HTML document (-title)
1022# $author -> (optional) e-mail address of the author (-author)
1023# $base -> (optional) if set to true, will enter the BASE address of this document
1024# for resolving relative references (-base)
1025# $xbase -> (optional) alternative base at some remote location (-xbase)
1026# $target -> (optional) target window to load all links into (-target)
1027# $script -> (option) Javascript code (-script)
47e3cabd 1028# $no_script -> (option) Javascript <noscript> tag (-noscript)
54310121 1029# $meta -> (optional) Meta information tags
7d37aa8e
LS
1030# $head -> (optional) any other elements you'd like to incorporate into the <HEAD> tag
1031# (a scalar or array ref)
1032# $style -> (optional) reference to an external style sheet
54310121 1033# @other -> (optional) any other named parameters you'd like to incorporate into
1034# the <BODY> tag.
1035####
1036'start_html' => <<'END_OF_FUNC',
1037sub start_html {
1038 my($self,@p) = &self_or_default(@_);
7d37aa8e
LS
1039 my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,@other) =
1040 $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE],@p);
54310121 1041
1042 # strangely enough, the title needs to be escaped as HTML
1043 # while the author needs to be escaped as a URL
1044 $title = $self->escapeHTML($title || 'Untitled Document');
1045 $author = $self->escapeHTML($author);
1046 my(@result);
1047 push(@result,'<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">');
1048 push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
1049 push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if $author;
1050
1051 if ($base || $xbase || $target) {
1052 my $href = $xbase || $self->url();
1053 my $t = $target ? qq/ TARGET="$target"/ : '';
1054 push(@result,qq/<BASE HREF="$href"$t>/);
1055 }
1056
1057 if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
1058 foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
1059 }
7d37aa8e
LS
1060
1061 push(@result,ref($head) ? @$head : $head) if $head;
1062
1063 # handle various types of -style parameters
1064 if ($style) {
1065 if (ref($style)) {
1066 my($src,$code,@other) =
1067 $self->rearrange([SRC,CODE],
1068 '-foo'=>'bar', # a trick to allow the '-' to be omitted
1069 ref($style) eq 'ARRAY' ? @$style : %$style);
1070 push(@result,qq/<LINK REL="stylesheet" HREF="$src">/) if $src;
1071 push(@result,style($code)) if $code;
1072 } else {
1073 push(@result,style($style))
1074 }
1075 }
1076
1077 # handle -script parameter
1078 if ($script) {
1079 my($src,$code,$language);
1080 if (ref($script)) { # script is a hash
1081 ($src,$code,$language) =
1082 $self->rearrange([SRC,CODE,LANGUAGE],
1083 '-foo'=>'bar', # a trick to allow the '-' to be omitted
1084 ref($style) eq 'ARRAY' ? @$script : %$script);
1085
1086 } else {
1087 ($src,$code,$language) = ('',$script,'JavaScript');
1088 }
1089 my(@satts);
1090 push(@satts,'src'=>$src) if $src;
1091 push(@satts,'language'=>$language || 'JavaScript');
1092 $code = "<!-- Hide script\n$code\n// End script hiding -->"
1093 if $code && $language=~/javascript/i;
1094 $code = "<!-- Hide script\n$code\n\# End script hiding -->"
1095 if $code && $language=~/perl/i;
1096 push(@result,script({@satts},$code));
1097 }
1098
1099 # handle -noscript parameter
47e3cabd
LS
1100 push(@result,<<END) if $noscript;
1101<NOSCRIPT>
1102$noscript
1103</NOSCRIPT>
1104END
1105 ;
54310121 1106 my($other) = @other ? " @other" : '';
1107 push(@result,"</HEAD><BODY$other>");
1108 return join("\n",@result);
1109}
1110END_OF_FUNC
1111
1112
1113#### Method: end_html
1114# End an HTML document.
1115# Trivial method for completeness. Just returns "</BODY>"
1116####
1117'end_html' => <<'END_OF_FUNC',
1118sub end_html {
1119 return "</BODY></HTML>";
1120}
1121END_OF_FUNC
1122
1123
1124################################
1125# METHODS USED IN BUILDING FORMS
1126################################
1127
1128#### Method: isindex
1129# Just prints out the isindex tag.
1130# Parameters:
1131# $action -> optional URL of script to run
1132# Returns:
1133# A string containing a <ISINDEX> tag
1134'isindex' => <<'END_OF_FUNC',
1135sub isindex {
1136 my($self,@p) = self_or_default(@_);
1137 my($action,@other) = $self->rearrange([ACTION],@p);
1138 $action = qq/ACTION="$action"/ if $action;
1139 my($other) = @other ? " @other" : '';
1140 return "<ISINDEX $action$other>";
1141}
1142END_OF_FUNC
1143
1144
1145#### Method: startform
1146# Start a form
1147# Parameters:
1148# $method -> optional submission method to use (GET or POST)
1149# $action -> optional URL of script to run
1150# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1151'startform' => <<'END_OF_FUNC',
1152sub startform {
1153 my($self,@p) = self_or_default(@_);
1154
1155 my($method,$action,$enctype,@other) =
1156 $self->rearrange([METHOD,ACTION,ENCTYPE],@p);
1157
1158 $method = $method || 'POST';
1159 $enctype = $enctype || &URL_ENCODED;
1160 $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
1161 'ACTION="'.$self->script_name.'"' : '';
1162 my($other) = @other ? " @other" : '';
1163 $self->{'.parametersToAdd'}={};
1164 return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
1165}
1166END_OF_FUNC
1167
1168
1169#### Method: start_form
1170# synonym for startform
1171'start_form' => <<'END_OF_FUNC',
1172sub start_form {
1173 &startform;
1174}
1175END_OF_FUNC
1176
1177
1178#### Method: start_multipart_form
1179# synonym for startform
1180'start_multipart_form' => <<'END_OF_FUNC',
1181sub start_multipart_form {
1182 my($self,@p) = self_or_default(@_);
1183 if ($self->use_named_parameters ||
1184 (defined($param[0]) && substr($param[0],0,1) eq '-')) {
1185 my(%p) = @p;
1186 $p{'-enctype'}=&MULTIPART;
1187 return $self->startform(%p);
1188 } else {
1189 my($method,$action,@other) =
1190 $self->rearrange([METHOD,ACTION],@p);
1191 return $self->startform($method,$action,&MULTIPART,@other);
1192 }
1193}
1194END_OF_FUNC
1195
1196
1197#### Method: endform
1198# End a form
1199'endform' => <<'END_OF_FUNC',
1200sub endform {
1201 my($self,@p) = self_or_default(@_);
1202 return ($self->get_fields,"</FORM>");
1203}
1204END_OF_FUNC
1205
1206
1207#### Method: end_form
1208# synonym for endform
1209'end_form' => <<'END_OF_FUNC',
1210sub end_form {
1211 &endform;
1212}
1213END_OF_FUNC
1214
1215
1216#### Method: textfield
1217# Parameters:
1218# $name -> Name of the text field
1219# $default -> Optional default value of the field if not
1220# already defined.
1221# $size -> Optional width of field in characaters.
1222# $maxlength -> Optional maximum number of characters.
1223# Returns:
1224# A string containing a <INPUT TYPE="text"> field
1225#
1226'textfield' => <<'END_OF_FUNC',
1227sub textfield {
1228 my($self,@p) = self_or_default(@_);
1229 my($name,$default,$size,$maxlength,$override,@other) =
1230 $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1231
1232 my $current = $override ? $default :
1233 (defined($self->param($name)) ? $self->param($name) : $default);
1234
1235 $current = defined($current) ? $self->escapeHTML($current) : '';
1236 $name = defined($name) ? $self->escapeHTML($name) : '';
1237 my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1238 my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
1239 my($other) = @other ? " @other" : '';
1240 return qq/<INPUT TYPE="text" NAME="$name" VALUE="$current"$s$m$other>/;
1241}
1242END_OF_FUNC
1243
1244
1245#### Method: filefield
1246# Parameters:
1247# $name -> Name of the file upload field
1248# $size -> Optional width of field in characaters.
1249# $maxlength -> Optional maximum number of characters.
1250# Returns:
1251# A string containing a <INPUT TYPE="text"> field
1252#
1253'filefield' => <<'END_OF_FUNC',
1254sub filefield {
1255 my($self,@p) = self_or_default(@_);
1256
1257 my($name,$default,$size,$maxlength,$override,@other) =
1258 $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1259
1260 $current = $override ? $default :
1261 (defined($self->param($name)) ? $self->param($name) : $default);
1262
1263 $name = defined($name) ? $self->escapeHTML($name) : '';
1264 my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1265 my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
1266 $current = defined($current) ? $self->escapeHTML($current) : '';
1267 $other = ' ' . join(" ",@other);
1268 return qq/<INPUT TYPE="file" NAME="$name" VALUE="$current"$s$m$other>/;
1269}
1270END_OF_FUNC
1271
1272
1273#### Method: password
1274# Create a "secret password" entry field
1275# Parameters:
1276# $name -> Name of the field
1277# $default -> Optional default value of the field if not
1278# already defined.
1279# $size -> Optional width of field in characters.
1280# $maxlength -> Optional maximum characters that can be entered.
1281# Returns:
1282# A string containing a <INPUT TYPE="password"> field
1283#
1284'password_field' => <<'END_OF_FUNC',
1285sub password_field {
1286 my ($self,@p) = self_or_default(@_);
1287
1288 my($name,$default,$size,$maxlength,$override,@other) =
1289 $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1290
1291 my($current) = $override ? $default :
1292 (defined($self->param($name)) ? $self->param($name) : $default);
1293
1294 $name = defined($name) ? $self->escapeHTML($name) : '';
1295 $current = defined($current) ? $self->escapeHTML($current) : '';
1296 my($s) = defined($size) ? qq/ SIZE=$size/ : '';
1297 my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
1298 my($other) = @other ? " @other" : '';
1299 return qq/<INPUT TYPE="password" NAME="$name" VALUE="$current"$s$m$other>/;
1300}
1301END_OF_FUNC
1302
1303
1304#### Method: textarea
1305# Parameters:
1306# $name -> Name of the text field
1307# $default -> Optional default value of the field if not
1308# already defined.
1309# $rows -> Optional number of rows in text area
1310# $columns -> Optional number of columns in text area
1311# Returns:
1312# A string containing a <TEXTAREA></TEXTAREA> tag
1313#
1314'textarea' => <<'END_OF_FUNC',
1315sub textarea {
1316 my($self,@p) = self_or_default(@_);
1317
1318 my($name,$default,$rows,$cols,$override,@other) =
1319 $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
1320
1321 my($current)= $override ? $default :
1322 (defined($self->param($name)) ? $self->param($name) : $default);
1323
1324 $name = defined($name) ? $self->escapeHTML($name) : '';
1325 $current = defined($current) ? $self->escapeHTML($current) : '';
1326 my($r) = $rows ? " ROWS=$rows" : '';
1327 my($c) = $cols ? " COLS=$cols" : '';
1328 my($other) = @other ? " @other" : '';
1329 return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
1330}
1331END_OF_FUNC
1332
1333
1334#### Method: button
1335# Create a javascript button.
1336# Parameters:
1337# $name -> (optional) Name for the button. (-name)
1338# $value -> (optional) Value of the button when selected (and visible name) (-value)
1339# $onclick -> (optional) Text of the JavaScript to run when the button is
1340# clicked.
1341# Returns:
1342# A string containing a <INPUT TYPE="button"> tag
1343####
1344'button' => <<'END_OF_FUNC',
1345sub button {
1346 my($self,@p) = self_or_default(@_);
1347
1348 my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
1349 [ONCLICK,SCRIPT]],@p);
1350
1351 $label=$self->escapeHTML($label);
1352 $value=$self->escapeHTML($value);
1353 $script=$self->escapeHTML($script);
1354
1355 my($name) = '';
1356 $name = qq/ NAME="$label"/ if $label;
1357 $value = $value || $label;
1358 my($val) = '';
1359 $val = qq/ VALUE="$value"/ if $value;
1360 $script = qq/ ONCLICK="$script"/ if $script;
1361 my($other) = @other ? " @other" : '';
1362 return qq/<INPUT TYPE="button"$name$val$script$other>/;
1363}
1364END_OF_FUNC
1365
1366
1367#### Method: submit
1368# Create a "submit query" button.
1369# Parameters:
1370# $name -> (optional) Name for the button.
1371# $value -> (optional) Value of the button when selected (also doubles as label).
1372# $label -> (optional) Label printed on the button(also doubles as the value).
1373# Returns:
1374# A string containing a <INPUT TYPE="submit"> tag
1375####
1376'submit' => <<'END_OF_FUNC',
1377sub submit {
1378 my($self,@p) = self_or_default(@_);
1379
1380 my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p);
1381
1382 $label=$self->escapeHTML($label);
1383 $value=$self->escapeHTML($value);
1384
1385 my($name) = ' NAME=".submit"';
1386 $name = qq/ NAME="$label"/ if $label;
1387 $value = $value || $label;
1388 my($val) = '';
1389 $val = qq/ VALUE="$value"/ if defined($value);
1390 my($other) = @other ? " @other" : '';
1391 return qq/<INPUT TYPE="submit"$name$val$other>/;
1392}
1393END_OF_FUNC
1394
1395
1396#### Method: reset
1397# Create a "reset" button.
1398# Parameters:
1399# $name -> (optional) Name for the button.
1400# Returns:
1401# A string containing a <INPUT TYPE="reset"> tag
1402####
1403'reset' => <<'END_OF_FUNC',
1404sub reset {
1405 my($self,@p) = self_or_default(@_);
1406 my($label,@other) = $self->rearrange([NAME],@p);
1407 $label=$self->escapeHTML($label);
1408 my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
1409 my($other) = @other ? " @other" : '';
1410 return qq/<INPUT TYPE="reset"$value$other>/;
1411}
1412END_OF_FUNC
1413
1414
1415#### Method: defaults
1416# Create a "defaults" button.
1417# Parameters:
1418# $name -> (optional) Name for the button.
1419# Returns:
1420# A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
1421#
1422# Note: this button has a special meaning to the initialization script,
1423# and tells it to ERASE the current query string so that your defaults
1424# are used again!
1425####
1426'defaults' => <<'END_OF_FUNC',
1427sub defaults {
1428 my($self,@p) = self_or_default(@_);
1429
1430 my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
1431
1432 $label=$self->escapeHTML($label);
1433 $label = $label || "Defaults";
1434 my($value) = qq/ VALUE="$label"/;
1435 my($other) = @other ? " @other" : '';
1436 return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
1437}
1438END_OF_FUNC
1439
1440
1441#### Method: checkbox
1442# Create a checkbox that is not logically linked to any others.
1443# The field value is "on" when the button is checked.
1444# Parameters:
1445# $name -> Name of the checkbox
1446# $checked -> (optional) turned on by default if true
1447# $value -> (optional) value of the checkbox, 'on' by default
1448# $label -> (optional) a user-readable label printed next to the box.
1449# Otherwise the checkbox name is used.
1450# Returns:
1451# A string containing a <INPUT TYPE="checkbox"> field
1452####
1453'checkbox' => <<'END_OF_FUNC',
1454sub checkbox {
1455 my($self,@p) = self_or_default(@_);
1456
1457 my($name,$checked,$value,$label,$override,@other) =
1458 $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
1459
1460 if (!$override && defined($self->param($name))) {
1461 $value = $self->param($name) unless defined $value;
1462 $checked = $self->param($name) eq $value ? ' CHECKED' : '';
1463 } else {
1464 $checked = $checked ? ' CHECKED' : '';
1465 $value = defined $value ? $value : 'on';
1466 }
1467 my($the_label) = defined $label ? $label : $name;
1468 $name = $self->escapeHTML($name);
1469 $value = $self->escapeHTML($value);
1470 $the_label = $self->escapeHTML($the_label);
1471 my($other) = @other ? " @other" : '';
1472 $self->register_parameter($name);
1473 return <<END;
1474<INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label
1475END
1476}
1477END_OF_FUNC
1478
1479
1480#### Method: checkbox_group
1481# Create a list of logically-linked checkboxes.
1482# Parameters:
1483# $name -> Common name for all the check boxes
1484# $values -> A pointer to a regular array containing the
1485# values for each checkbox in the group.
1486# $defaults -> (optional)
1487# 1. If a pointer to a regular array of checkbox values,
1488# then this will be used to decide which
1489# checkboxes to turn on by default.
1490# 2. If a scalar, will be assumed to hold the
1491# value of a single checkbox in the group to turn on.
1492# $linebreak -> (optional) Set to true to place linebreaks
1493# between the buttons.
1494# $labels -> (optional)
1495# A pointer to an associative array of labels to print next to each checkbox
1496# in the form $label{'value'}="Long explanatory label".
1497# Otherwise the provided values are used as the labels.
1498# Returns:
1499# An ARRAY containing a series of <INPUT TYPE="checkbox"> fields
1500####
1501'checkbox_group' => <<'END_OF_FUNC',
1502sub checkbox_group {
1503 my($self,@p) = self_or_default(@_);
1504
1505 my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
1506 $rowheaders,$colheaders,$override,$nolabels,@other) =
1507 $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1508 LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
1509 ROWHEADERS,COLHEADERS,
1510 [OVERRIDE,FORCE],NOLABELS],@p);
1511
1512 my($checked,$break,$result,$label);
1513
1514 my(%checked) = $self->previous_or_default($name,$defaults,$override);
1515
1516 $break = $linebreak ? "<BR>" : '';
1517 $name=$self->escapeHTML($name);
1518
1519 # Create the elements
1520 my(@elements);
1521 my(@values) = $values ? @$values : $self->param($name);
1522 my($other) = @other ? " @other" : '';
1523 foreach (@values) {
1524 $checked = $checked{$_} ? ' CHECKED' : '';
1525 $label = '';
1526 unless (defined($nolabels) && $nolabels) {
1527 $label = $_;
1528 $label = $labels->{$_} if defined($labels) && $labels->{$_};
1529 $label = $self->escapeHTML($label);
1530 }
1531 $_ = $self->escapeHTML($_);
1532 push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label} ${break}/);
1533 }
1534 $self->register_parameter($name);
1535 return wantarray ? @elements : join('',@elements) unless $columns;
1536 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1537}
1538END_OF_FUNC
1539
1540
1541# Escape HTML -- used internally
1542'escapeHTML' => <<'END_OF_FUNC',
1543sub escapeHTML {
1544 my($self,$toencode) = @_;
1545 return undef unless defined($toencode);
1546 return $toencode if $self->{'dontescape'};
1547 $toencode=~s/&/&amp;/g;
1548 $toencode=~s/\"/&quot;/g;
1549 $toencode=~s/>/&gt;/g;
1550 $toencode=~s/</&lt;/g;
1551 return $toencode;
1552}
1553END_OF_FUNC
1554
1555
1556# Internal procedure - don't use
1557'_tableize' => <<'END_OF_FUNC',
1558sub _tableize {
1559 my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
1560 my($result);
1561
1562 $rows = int(0.99 + @elements/$columns) unless $rows;
1563 # rearrange into a pretty table
1564 $result = "<TABLE>";
1565 my($row,$column);
1566 unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
1567 $result .= "<TR>" if @{$colheaders};
1568 foreach (@{$colheaders}) {
1569 $result .= "<TH>$_</TH>";
1570 }
1571 for ($row=0;$row<$rows;$row++) {
1572 $result .= "<TR>";
1573 $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
1574 for ($column=0;$column<$columns;$column++) {
1575 $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>";
1576 }
1577 $result .= "</TR>";
1578 }
1579 $result .= "</TABLE>";
1580 return $result;
1581}
1582END_OF_FUNC
1583
1584
1585#### Method: radio_group
1586# Create a list of logically-linked radio buttons.
1587# Parameters:
1588# $name -> Common name for all the buttons.
1589# $values -> A pointer to a regular array containing the
1590# values for each button in the group.
1591# $default -> (optional) Value of the button to turn on by default. Pass '-'
1592# to turn _nothing_ on.
1593# $linebreak -> (optional) Set to true to place linebreaks
1594# between the buttons.
1595# $labels -> (optional)
1596# A pointer to an associative array of labels to print next to each checkbox
1597# in the form $label{'value'}="Long explanatory label".
1598# Otherwise the provided values are used as the labels.
1599# Returns:
1600# An ARRAY containing a series of <INPUT TYPE="radio"> fields
1601####
1602'radio_group' => <<'END_OF_FUNC',
1603sub radio_group {
1604 my($self,@p) = self_or_default(@_);
1605
1606 my($name,$values,$default,$linebreak,$labels,
1607 $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
1608 $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
1609 ROWS,[COLUMNS,COLS],
1610 ROWHEADERS,COLHEADERS,
1611 [OVERRIDE,FORCE],NOLABELS],@p);
1612 my($result,$checked);
1613
1614 if (!$override && defined($self->param($name))) {
1615 $checked = $self->param($name);
1616 } else {
1617 $checked = $default;
1618 }
1619 # If no check array is specified, check the first by default
1620 $checked = $values->[0] unless $checked;
1621 $name=$self->escapeHTML($name);
1622
1623 my(@elements);
1624 my(@values) = $values ? @$values : $self->param($name);
1625 my($other) = @other ? " @other" : '';
1626 foreach (@values) {
1627 my($checkit) = $checked eq $_ ? ' CHECKED' : '';
1628 my($break) = $linebreak ? '<BR>' : '';
1629 my($label)='';
1630 unless (defined($nolabels) && $nolabels) {
1631 $label = $_;
1632 $label = $labels->{$_} if defined($labels) && $labels->{$_};
1633 $label = $self->escapeHTML($label);
1634 }
1635 $_=$self->escapeHTML($_);
1636 push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label} ${break}/);
1637 }
1638 $self->register_parameter($name);
1639 return wantarray ? @elements : join('',@elements) unless $columns;
1640 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1641}
1642END_OF_FUNC
1643
1644
1645#### Method: popup_menu
1646# Create a popup menu.
1647# Parameters:
1648# $name -> Name for all the menu
1649# $values -> A pointer to a regular array containing the
1650# text of each menu item.
1651# $default -> (optional) Default item to display
1652# $labels -> (optional)
1653# A pointer to an associative array of labels to print next to each checkbox
1654# in the form $label{'value'}="Long explanatory label".
1655# Otherwise the provided values are used as the labels.
1656# Returns:
1657# A string containing the definition of a popup menu.
1658####
1659'popup_menu' => <<'END_OF_FUNC',
1660sub popup_menu {
1661 my($self,@p) = self_or_default(@_);
1662
1663 my($name,$values,$default,$labels,$override,@other) =
1664 $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
1665 my($result,$selected);
1666
1667 if (!$override && defined($self->param($name))) {
1668 $selected = $self->param($name);
1669 } else {
1670 $selected = $default;
1671 }
1672 $name=$self->escapeHTML($name);
1673 my($other) = @other ? " @other" : '';
1674
1675 my(@values) = $values ? @$values : $self->param($name);
1676 $result = qq/<SELECT NAME="$name"$other>\n/;
1677 foreach (@values) {
1678 my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
1679 my($label) = $_;
1680 $label = $labels->{$_} if defined($labels) && $labels->{$_};
1681 my($value) = $self->escapeHTML($_);
1682 $label=$self->escapeHTML($label);
1683 $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
1684 }
1685
1686 $result .= "</SELECT>\n";
1687 return $result;
1688}
1689END_OF_FUNC
1690
1691
1692#### Method: scrolling_list
1693# Create a scrolling list.
1694# Parameters:
1695# $name -> name for the list
1696# $values -> A pointer to a regular array containing the
1697# values for each option line in the list.
1698# $defaults -> (optional)
1699# 1. If a pointer to a regular array of options,
1700# then this will be used to decide which
1701# lines to turn on by default.
1702# 2. Otherwise holds the value of the single line to turn on.
1703# $size -> (optional) Size of the list.
1704# $multiple -> (optional) If set, allow multiple selections.
1705# $labels -> (optional)
1706# A pointer to an associative array of labels to print next to each checkbox
1707# in the form $label{'value'}="Long explanatory label".
1708# Otherwise the provided values are used as the labels.
1709# Returns:
1710# A string containing the definition of a scrolling list.
1711####
1712'scrolling_list' => <<'END_OF_FUNC',
1713sub scrolling_list {
1714 my($self,@p) = self_or_default(@_);
1715 my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
1716 = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1717 SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
1718
1719 my($result);
1720 my(@values) = $values ? @$values : $self->param($name);
1721 $size = $size || scalar(@values);
1722
1723 my(%selected) = $self->previous_or_default($name,$defaults,$override);
1724 my($is_multiple) = $multiple ? ' MULTIPLE' : '';
1725 my($has_size) = $size ? " SIZE=$size" : '';
1726 my($other) = @other ? " @other" : '';
1727
1728 $name=$self->escapeHTML($name);
1729 $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
1730 foreach (@values) {
1731 my($selectit) = $selected{$_} ? 'SELECTED' : '';
1732 my($label) = $_;
1733 $label = $labels->{$_} if defined($labels) && $labels->{$_};
1734 $label=$self->escapeHTML($label);
1735 my($value)=$self->escapeHTML($_);
1736 $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
1737 }
1738 $result .= "</SELECT>\n";
1739 $self->register_parameter($name);
1740 return $result;
1741}
1742END_OF_FUNC
1743
1744
1745#### Method: hidden
1746# Parameters:
1747# $name -> Name of the hidden field
1748# @default -> (optional) Initial values of field (may be an array)
1749# or
1750# $default->[initial values of field]
1751# Returns:
1752# A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
1753####
1754'hidden' => <<'END_OF_FUNC',
1755sub hidden {
1756 my($self,@p) = self_or_default(@_);
1757
1758 # this is the one place where we departed from our standard
1759 # calling scheme, so we have to special-case (darn)
1760 my(@result,@value);
1761 my($name,$default,$override,@other) =
1762 $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
1763
1764 my $do_override = 0;
1765 if ( substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
1766 @value = ref($default) ? @{$default} : $default;
1767 $do_override = $override;
1768 } else {
1769 foreach ($default,$override,@other) {
1770 push(@value,$_) if defined($_);
1771 }
1772 }
1773
1774 # use previous values if override is not set
1775 my @prev = $self->param($name);
1776 @value = @prev if !$do_override && @prev;
1777
1778 $name=$self->escapeHTML($name);
1779 foreach (@value) {
1780 $_=$self->escapeHTML($_);
1781 push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
1782 }
1783 return wantarray ? @result : join('',@result);
1784}
1785END_OF_FUNC
1786
1787
1788#### Method: image_button
1789# Parameters:
1790# $name -> Name of the button
1791# $src -> URL of the image source
1792# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
1793# Returns:
1794# A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment">
1795####
1796'image_button' => <<'END_OF_FUNC',
1797sub image_button {
1798 my($self,@p) = self_or_default(@_);
1799
1800 my($name,$src,$alignment,@other) =
1801 $self->rearrange([NAME,SRC,ALIGN],@p);
1802
1803 my($align) = $alignment ? " ALIGN=\U$alignment" : '';
1804 my($other) = @other ? " @other" : '';
1805 $name=$self->escapeHTML($name);
1806 return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/;
1807}
1808END_OF_FUNC
1809
1810
1811#### Method: self_url
1812# Returns a URL containing the current script and all its
1813# param/value pairs arranged as a query. You can use this
1814# to create a link that, when selected, will reinvoke the
1815# script with all its state information preserved.
1816####
1817'self_url' => <<'END_OF_FUNC',
1818sub self_url {
1819 my($self) = self_or_default(@_);
1820 my($query_string) = $self->query_string;
1821 my $protocol = $self->protocol();
1822 my $name = "$protocol://" . $self->server_name;
1823 $name .= ":" . $self->server_port
1824 unless $self->server_port == 80;
1825 $name .= $self->script_name;
1826 $name .= $self->path_info if $self->path_info;
1827 return $name unless $query_string;
1828 return "$name?$query_string";
1829}
1830END_OF_FUNC
1831
1832
1833# This is provided as a synonym to self_url() for people unfortunate
1834# enough to have incorporated it into their programs already!
1835'state' => <<'END_OF_FUNC',
1836sub state {
1837 &self_url;
1838}
1839END_OF_FUNC
1840
1841
1842#### Method: url
1843# Like self_url, but doesn't return the query string part of
1844# the URL.
1845####
1846'url' => <<'END_OF_FUNC',
1847sub url {
1848 my($self) = self_or_default(@_);
1849 my $protocol = $self->protocol();
1850 my $name = "$protocol://" . $self->server_name;
1851 $name .= ":" . $self->server_port
1852 unless $self->server_port == 80;
1853 $name .= $self->script_name;
1854 return $name;
1855}
1856
1857END_OF_FUNC
1858
1859#### Method: cookie
1860# Set or read a cookie from the specified name.
1861# Cookie can then be passed to header().
1862# Usual rules apply to the stickiness of -value.
1863# Parameters:
1864# -name -> name for this cookie (optional)
1865# -value -> value of this cookie (scalar, array or hash)
1866# -path -> paths for which this cookie is valid (optional)
1867# -domain -> internet domain in which this cookie is valid (optional)
1868# -secure -> if true, cookie only passed through secure channel (optional)
7d37aa8e 1869# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
54310121 1870####
1871'cookie' => <<'END_OF_FUNC',
1872# temporary, for debugging.
1873sub cookie {
1874 my($self,@p) = self_or_default(@_);
1875 my($name,$value,$path,$domain,$secure,$expires) =
1876 $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
1877
1878
1879 # if no value is supplied, then we retrieve the
1880 # value of the cookie, if any. For efficiency, we cache the parsed
1881 # cookie in our state variables.
1882 unless (defined($value)) {
1883 unless ($self->{'.cookies'}) {
1884 my(@pairs) = split("; ",$self->raw_cookie);
1885 foreach (@pairs) {
1886 my($key,$value) = split("=");
1887 my(@values) = map unescape($_),split('&',$value);
1888 $self->{'.cookies'}->{unescape($key)} = [@values];
1889 }
1890 }
1891
1892 # If no name is supplied, then retrieve the names of all our cookies.
1893 return () unless $self->{'.cookies'};
1894 return wantarray ? @{$self->{'.cookies'}->{$name}} : $self->{'.cookies'}->{$name}->[0]
1895 if defined($name) && $name ne '';
1896 return keys %{$self->{'.cookies'}};
1897 }
1898 my(@values);
1899
1900 # Pull out our parameters.
1901 if (ref($value)) {
1902 if (ref($value) eq 'ARRAY') {
1903 @values = @$value;
1904 } elsif (ref($value) eq 'HASH') {
1905 @values = %$value;
1906 }
1907 } else {
1908 @values = ($value);
1909 }
1910 @values = map escape($_),@values;
1911
1912 # I.E. requires the path to be present.
1913 ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $path;
1914
1915 my(@constant_values);
1916 push(@constant_values,"domain=$domain") if $domain;
1917 push(@constant_values,"path=$path") if $path;
7d37aa8e
LS
1918 push(@constant_values,"expires=".&date(&expire_calc($expires),'cookie'))
1919 if $expires;
54310121 1920 push(@constant_values,'secure') if $secure;
1921
1922 my($key) = &escape($name);
1923 my($cookie) = join("=",$key,join("&",@values));
1924 return join("; ",$cookie,@constant_values);
1925}
1926END_OF_FUNC
1927
1928
7d37aa8e
LS
1929# This internal routine creates an expires time exactly some number of
1930# hours from the current time. It incorporates modifications from
1931# Fisher Mark.
1932'expire_calc' => <<'END_OF_FUNC',
1933sub expire_calc {
54310121 1934 my($time) = @_;
54310121 1935 my(%mult) = ('s'=>1,
7d37aa8e
LS
1936 'm'=>60,
1937 'h'=>60*60,
1938 'd'=>60*60*24,
1939 'M'=>60*60*24*30,
1940 'y'=>60*60*24*365);
54310121 1941 # format for time can be in any of the forms...
1942 # "now" -- expire immediately
1943 # "+180s" -- in 180 seconds
1944 # "+2m" -- in 2 minutes
1945 # "+12h" -- in 12 hours
1946 # "+1d" -- in 1 day
1947 # "+3M" -- in 3 months
1948 # "+2y" -- in 2 years
1949 # "-3m" -- 3 minutes ago(!)
1950 # If you don't supply one of these forms, we assume you are
1951 # specifying the date yourself
1952 my($offset);
1953 if (!$time || ($time eq 'now')) {
7d37aa8e 1954 $offset = 0;
54310121 1955 } elsif ($time=~/^([+-]?\d+)([mhdMy]?)/) {
7d37aa8e 1956 $offset = ($mult{$2} || 1)*$1;
54310121 1957 } else {
7d37aa8e 1958 return $time;
54310121 1959 }
7d37aa8e 1960 return (time+$offset);
54310121 1961}
1962END_OF_FUNC
1963
7d37aa8e
LS
1964# This internal routine creates date strings suitable for use in
1965# cookies and HTTP headers. (They differ, unfortunately.)
1966# Thanks to Fisher Mark for this.
1967'date' => <<'END_OF_FUNC',
1968sub date {
1969 my($time,$format) = @_;
1970 my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
1971 my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
1972
1973 # pass through preformatted dates for the sake of expire_calc()
1974 if ("$time" =~ m/^[^0-9]/o) {
1975 return $time;
1976 }
1977
1978 # make HTTP/cookie date string from GMT'ed time
1979 # (cookies use '-' as date separator, HTTP uses ' ')
1980 my($sc) = ' ';
1981 $sc = '-' if $format eq "cookie";
1982 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
1983 $year += 1900;
1984 return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
1985 $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
1986}
1987END_OF_FUNC
54310121 1988
1989###############################################
1990# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
1991###############################################
1992
1993#### Method: path_info
1994# Return the extra virtual path information provided
1995# after the URL (if any)
1996####
1997'path_info' => <<'END_OF_FUNC',
1998sub path_info {
1999 return $ENV{'PATH_INFO'};
2000}
2001END_OF_FUNC
2002
2003
2004#### Method: request_method
2005# Returns 'POST', 'GET', 'PUT' or 'HEAD'
2006####
2007'request_method' => <<'END_OF_FUNC',
2008sub request_method {
2009 return $ENV{'REQUEST_METHOD'};
2010}
2011END_OF_FUNC
2012
2013#### Method: path_translated
2014# Return the physical path information provided
2015# by the URL (if any)
2016####
2017'path_translated' => <<'END_OF_FUNC',
2018sub path_translated {
2019 return $ENV{'PATH_TRANSLATED'};
2020}
2021END_OF_FUNC
2022
2023
2024#### Method: query_string
2025# Synthesize a query string from our current
2026# parameters
2027####
2028'query_string' => <<'END_OF_FUNC',
2029sub query_string {
2030 my($self) = self_or_default(@_);
2031 my($param,$value,@pairs);
2032 foreach $param ($self->param) {
2033 my($eparam) = &escape($param);
2034 foreach $value ($self->param($param)) {
2035 $value = &escape($value);
2036 push(@pairs,"$eparam=$value");
2037 }
2038 }
2039 return join("&",@pairs);
2040}
2041END_OF_FUNC
2042
2043
2044#### Method: accept
2045# Without parameters, returns an array of the
2046# MIME types the browser accepts.
2047# With a single parameter equal to a MIME
2048# type, will return undef if the browser won't
2049# accept it, 1 if the browser accepts it but
2050# doesn't give a preference, or a floating point
2051# value between 0.0 and 1.0 if the browser
2052# declares a quantitative score for it.
2053# This handles MIME type globs correctly.
2054####
2055'accept' => <<'END_OF_FUNC',
2056sub accept {
2057 my($self,$search) = self_or_CGI(@_);
2058 my(%prefs,$type,$pref,$pat);
2059
2060 my(@accept) = split(',',$self->http('accept'));
2061
2062 foreach (@accept) {
2063 ($pref) = /q=(\d\.\d+|\d+)/;
2064 ($type) = m#(\S+/[^;]+)#;
2065 next unless $type;
2066 $prefs{$type}=$pref || 1;
2067 }
2068
2069 return keys %prefs unless $search;
2070
2071 # if a search type is provided, we may need to
2072 # perform a pattern matching operation.
2073 # The MIME types use a glob mechanism, which
2074 # is easily translated into a perl pattern match
2075
2076 # First return the preference for directly supported
2077 # types:
2078 return $prefs{$search} if $prefs{$search};
2079
2080 # Didn't get it, so try pattern matching.
2081 foreach (keys %prefs) {
2082 next unless /\*/; # not a pattern match
2083 ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2084 $pat =~ s/\*/.*/g; # turn it into a pattern
2085 return $prefs{$_} if $search=~/$pat/;
2086 }
2087}
2088END_OF_FUNC
2089
2090
2091#### Method: user_agent
2092# If called with no parameters, returns the user agent.
2093# If called with one parameter, does a pattern match (case
2094# insensitive) on the user agent.
2095####
2096'user_agent' => <<'END_OF_FUNC',
2097sub user_agent {
2098 my($self,$match)=self_or_CGI(@_);
2099 return $self->http('user_agent') unless $match;
2100 return $self->http('user_agent') =~ /$match/i;
2101}
2102END_OF_FUNC
2103
2104
2105#### Method: cookie
2106# Returns the magic cookie for the session.
2107# To set the magic cookie for new transations,
2108# try print $q->header('-Set-cookie'=>'my cookie')
2109####
2110'raw_cookie' => <<'END_OF_FUNC',
2111sub raw_cookie {
2112 my($self) = self_or_CGI(@_);
2113 return $self->http('cookie') || $ENV{'COOKIE'} || '';
2114}
2115END_OF_FUNC
2116
2117#### Method: virtual_host
2118# Return the name of the virtual_host, which
2119# is not always the same as the server
2120######
2121'virtual_host' => <<'END_OF_FUNC',
2122sub virtual_host {
2123 return http('host') || server_name();
2124}
2125END_OF_FUNC
2126
2127#### Method: remote_host
2128# Return the name of the remote host, or its IP
2129# address if unavailable. If this variable isn't
2130# defined, it returns "localhost" for debugging
2131# purposes.
2132####
2133'remote_host' => <<'END_OF_FUNC',
2134sub remote_host {
2135 return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
2136 || 'localhost';
2137}
2138END_OF_FUNC
2139
2140
2141#### Method: remote_addr
2142# Return the IP addr of the remote host.
2143####
2144'remote_addr' => <<'END_OF_FUNC',
2145sub remote_addr {
2146 return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
2147}
2148END_OF_FUNC
2149
2150
2151#### Method: script_name
2152# Return the partial URL to this script for
2153# self-referencing scripts. Also see
2154# self_url(), which returns a URL with all state information
2155# preserved.
2156####
2157'script_name' => <<'END_OF_FUNC',
2158sub script_name {
2159 return $ENV{'SCRIPT_NAME'} if $ENV{'SCRIPT_NAME'};
2160 # These are for debugging
2161 return "/$0" unless $0=~/^\//;
2162 return $0;
2163}
2164END_OF_FUNC
2165
2166
2167#### Method: referer
2168# Return the HTTP_REFERER: useful for generating
2169# a GO BACK button.
2170####
2171'referer' => <<'END_OF_FUNC',
2172sub referer {
2173 my($self) = self_or_CGI(@_);
2174 return $self->http('referer');
2175}
2176END_OF_FUNC
2177
2178
2179#### Method: server_name
2180# Return the name of the server
2181####
2182'server_name' => <<'END_OF_FUNC',
2183sub server_name {
2184 return $ENV{'SERVER_NAME'} || 'localhost';
2185}
2186END_OF_FUNC
2187
2188#### Method: server_software
2189# Return the name of the server software
2190####
2191'server_software' => <<'END_OF_FUNC',
2192sub server_software {
2193 return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
2194}
2195END_OF_FUNC
2196
2197#### Method: server_port
2198# Return the tcp/ip port the server is running on
2199####
2200'server_port' => <<'END_OF_FUNC',
2201sub server_port {
2202 return $ENV{'SERVER_PORT'} || 80; # for debugging
2203}
2204END_OF_FUNC
2205
2206#### Method: server_protocol
2207# Return the protocol (usually HTTP/1.0)
2208####
2209'server_protocol' => <<'END_OF_FUNC',
2210sub server_protocol {
2211 return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
2212}
2213END_OF_FUNC
2214
2215#### Method: http
2216# Return the value of an HTTP variable, or
2217# the list of variables if none provided
2218####
2219'http' => <<'END_OF_FUNC',
2220sub http {
2221 my ($self,$parameter) = self_or_CGI(@_);
2222 return $ENV{$parameter} if $parameter=~/^HTTP/;
2223 return $ENV{"HTTP_\U$parameter\E"} if $parameter;
2224 my(@p);
2225 foreach (keys %ENV) {
2226 push(@p,$_) if /^HTTP/;
2227 }
2228 return @p;
2229}
2230END_OF_FUNC
2231
2232#### Method: https
2233# Return the value of HTTPS
2234####
2235'https' => <<'END_OF_FUNC',
2236sub https {
2237 local($^W)=0;
2238 my ($self,$parameter) = self_or_CGI(@_);
2239 return $ENV{HTTPS} unless $parameter;
2240 return $ENV{$parameter} if $parameter=~/^HTTPS/;
2241 return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
2242 my(@p);
2243 foreach (keys %ENV) {
2244 push(@p,$_) if /^HTTPS/;
2245 }
2246 return @p;
2247}
2248END_OF_FUNC
2249
2250#### Method: protocol
2251# Return the protocol (http or https currently)
2252####
2253'protocol' => <<'END_OF_FUNC',
2254sub protocol {
2255 local($^W)=0;
2256 my $self = shift;
2257 return 'https' if $self->https() eq 'ON';
2258 return 'https' if $self->server_port == 443;
2259 my $prot = $self->server_protocol;
2260 my($protocol,$version) = split('/',$prot);
2261 return "\L$protocol\E";
2262}
2263END_OF_FUNC
2264
2265#### Method: remote_ident
2266# Return the identity of the remote user
2267# (but only if his host is running identd)
2268####
2269'remote_ident' => <<'END_OF_FUNC',
2270sub remote_ident {
2271 return $ENV{'REMOTE_IDENT'};
2272}
2273END_OF_FUNC
2274
2275
2276#### Method: auth_type
2277# Return the type of use verification/authorization in use, if any.
2278####
2279'auth_type' => <<'END_OF_FUNC',
2280sub auth_type {
2281 return $ENV{'AUTH_TYPE'};
2282}
2283END_OF_FUNC
2284
2285
2286#### Method: remote_user
2287# Return the authorization name used for user
2288# verification.
2289####
2290'remote_user' => <<'END_OF_FUNC',
2291sub remote_user {
2292 return $ENV{'REMOTE_USER'};
2293}
2294END_OF_FUNC
2295
2296
2297#### Method: user_name
2298# Try to return the remote user's name by hook or by
2299# crook
2300####
2301'user_name' => <<'END_OF_FUNC',
2302sub user_name {
2303 my ($self) = self_or_CGI(@_);
2304 return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
2305}
2306END_OF_FUNC
2307
2308#### Method: nph
2309# Set or return the NPH global flag
2310####
2311'nph' => <<'END_OF_FUNC',
2312sub nph {
2313 my ($self,$param) = self_or_CGI(@_);
7d37aa8e
LS
2314 $CGI::NPH = $param if defined($param);
2315 return $CGI::NPH;
2316}
2317END_OF_FUNC
2318
2319#### Method: private_tempfiles
2320# Set or return the private_tempfiles global flag
2321####
2322'private_tempfiles' => <<'END_OF_FUNC',
2323sub private_tempfiles {
2324 my ($self,$param) = self_or_CGI(@_);
2325 $CGI::$PRIVATE_TEMPFILES = $param if defined($param);
2326 return $CGI::PRIVATE_TEMPFILES;
54310121 2327}
2328END_OF_FUNC
2329
2330# -------------- really private subroutines -----------------
2331'previous_or_default' => <<'END_OF_FUNC',
2332sub previous_or_default {
2333 my($self,$name,$defaults,$override) = @_;
2334 my(%selected);
2335
2336 if (!$override && ($self->{'.fieldnames'}->{$name} ||
2337 defined($self->param($name)) ) ) {
2338 grep($selected{$_}++,$self->param($name));
2339 } elsif (defined($defaults) && ref($defaults) &&
2340 (ref($defaults) eq 'ARRAY')) {
2341 grep($selected{$_}++,@{$defaults});
2342 } else {
2343 $selected{$defaults}++ if defined($defaults);
2344 }
2345
2346 return %selected;
2347}
2348END_OF_FUNC
2349
2350'register_parameter' => <<'END_OF_FUNC',
2351sub register_parameter {
2352 my($self,$param) = @_;
2353 $self->{'.parametersToAdd'}->{$param}++;
2354}
2355END_OF_FUNC
2356
2357'get_fields' => <<'END_OF_FUNC',
2358sub get_fields {
2359 my($self) = @_;
2360 return $self->hidden('-name'=>'.cgifields',
2361 '-values'=>[keys %{$self->{'.parametersToAdd'}}],
2362 '-override'=>1);
2363}
2364END_OF_FUNC
2365
2366'read_from_cmdline' => <<'END_OF_FUNC',
2367sub read_from_cmdline {
2368 require "shellwords.pl";
2369 my($input,@words);
2370 my($query_string);
2371 if (@ARGV) {
2372 $input = join(" ",@ARGV);
2373 } else {
2374 print STDERR "(offline mode: enter name=value pairs on standard input)\n";
2375 chomp(@lines = <>); # remove newlines
2376 $input = join(" ",@lines);
2377 }
2378
2379 # minimal handling of escape characters
2380 $input=~s/\\=/%3D/g;
2381 $input=~s/\\&/%26/g;
2382
2383 @words = &shellwords($input);
2384 if ("@words"=~/=/) {
2385 $query_string = join('&',@words);
2386 } else {
2387 $query_string = join('+',@words);
2388 }
2389 return $query_string;
2390}
2391END_OF_FUNC
2392
2393#####
2394# subroutine: read_multipart
2395#
2396# Read multipart data and store it into our parameters.
2397# An interesting feature is that if any of the parts is a file, we
2398# create a temporary file and open up a filehandle on it so that the
2399# caller can read from it if necessary.
2400#####
2401'read_multipart' => <<'END_OF_FUNC',
2402sub read_multipart {
2403 my($self,$boundary,$length) = @_;
2404 my($buffer) = $self->new_MultipartBuffer($boundary,$length);
2405 return unless $buffer;
2406 my(%header,$body);
2407 while (!$buffer->eof) {
2408 %header = $buffer->readHeader;
47e3cabd 2409 die "Malformed multipart POST\n" unless %header;
54310121 2410
2411 # In beta1 it was "Content-disposition". In beta2 it's "Content-Disposition"
2412 # Sheesh.
2413 my($key) = $header{'Content-disposition'} ? 'Content-disposition' : 'Content-Disposition';
2414 my($param)= $header{$key}=~/ name="([^\"]*)"/;
2415
2416 # possible bug: our regular expression expects the filename= part to fall
2417 # at the end of the line. Netscape doesn't escape quotation marks in file names!!!
2418 my($filename) = $header{$key}=~/ filename="(.*)"$/;
2419
2420 # add this parameter to our list
2421 $self->add_parameter($param);
2422
2423 # If no filename specified, then just read the data and assign it
2424 # to our parameter list.
2425 unless ($filename) {
2426 my($value) = $buffer->readBody;
2427 push(@{$self->{$param}},$value);
2428 next;
2429 }
2430
2431 # If we get here, then we are dealing with a potentially large
2432 # uploaded form. Save the data to a temporary file, then open
2433 # the file for reading.
2434 my($tmpfile) = new TempFile;
2435 my $tmp = $tmpfile->as_string;
2436
54310121 2437 # Now create a new filehandle in the caller's namespace.
2438 # The name of this filehandle just happens to be identical
2439 # to the original filename (NOT the name of the temporary
2440 # file, which is hidden!)
2441 my($filehandle);
2442 if ($filename=~/^[a-zA-Z_]/) {
2443 my($frame,$cp)=(1);
2444 do { $cp = caller($frame++); } until !eval("'$cp'->isaCGI()");
2445 $filehandle = "$cp\:\:$filename";
2446 } else {
2447 $filehandle = "\:\:$filename";
2448 }
2449
7d37aa8e
LS
2450 # potential security problem -- this type of line can clobber
2451 # tempfile, and can be abused by malicious users.
2452 # open ($filehandle,">$tmp") || die "CGI open of $tmpfile: $!\n";
2453
2454 # This technique causes open to fail if file already exists.
2455 unless (defined(&O_RDWR)) {
2456 require Fcntl;
2457 import Fcntl qw/O_RDWR O_CREAT O_EXCL/;
2458 }
2459 sysopen($filehandle,$tmp,&O_RDWR|&O_CREAT|&O_EXCL) || die "CGI open of $tmp: $!\n";
2460 unlink($tmp) if $PRIVATE_TEMPFILES;
2461
54310121 2462 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
7d37aa8e
LS
2463 chmod 0600,$tmp; # only the owner can tamper with it
2464 my $data;
2465 while (defined($data = $buffer->read)) {
2466 print $filehandle $data;
2467 }
54310121 2468
7d37aa8e 2469 seek($filehandle,0,0); #rewind file
54310121 2470 push(@{$self->{$param}},$filename);
2471
2472 # Under Unix, it would be safe to let the temporary file
2473 # be deleted immediately. However, I fear that other operating
2474 # systems are not so forgiving. Therefore we save a reference
2475 # to the temporary file in the CGI object so that the file
2476 # isn't unlinked until the CGI object itself goes out of
2477 # scope. This is a bit hacky, but it has the interesting side
2478 # effect that one can access the name of the tmpfile by
2479 # asking for $query->{$query->param('foo')}, where 'foo'
2480 # is the name of the file upload field.
2481 $self->{'.tmpfiles'}->{$filename}= {
7d37aa8e 2482 name=>($PRIVATE_TEMPFILES ? '' : $tmpfile),
54310121 2483 info=>{%header}
2484 }
2485 }
2486}
2487END_OF_FUNC
2488
2489'tmpFileName' => <<'END_OF_FUNC',
2490sub tmpFileName {
2491 my($self,$filename) = self_or_default(@_);
7d37aa8e
LS
2492 return $self->{'.tmpfiles'}->{$filename}->{name} ?
2493 $self->{'.tmpfiles'}->{$filename}->{name}->as_string
2494 : '';
54310121 2495}
2496END_OF_FUNC
2497
2498'uploadInfo' => <<'END_OF_FUNC'
2499sub uploadInfo {
2500 my($self,$filename) = self_or_default(@_);
2501 return $self->{'.tmpfiles'}->{$filename}->{info};
2502}
2503END_OF_FUNC
2504
2505);
2506END_OF_AUTOLOAD
2507;
2508
2509# Globals and stubs for other packages that we use
2510package MultipartBuffer;
2511
2512# how many bytes to read at a time. We use
2513# a 5K buffer by default.
2514$FILLUNIT = 1024 * 5;
2515$TIMEOUT = 10*60; # 10 minute timeout
2516$SPIN_LOOP_MAX = 1000; # bug fix for some Netscape servers
2517$CRLF=$CGI::CRLF;
2518
2519#reuse the autoload function
2520*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
2521
2522###############################################################################
2523################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
2524###############################################################################
2525$AUTOLOADED_ROUTINES = ''; # prevent -w error
2526$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
2527%SUBS = (
2528
2529'new' => <<'END_OF_FUNC',
2530sub new {
2531 my($package,$interface,$boundary,$length,$filehandle) = @_;
2532 my $IN;
2533 if ($filehandle) {
2534 my($package) = caller;
2535 # force into caller's package if necessary
2536 $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
2537 }
2538 $IN = "main::STDIN" unless $IN;
2539
2540 $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
2541
2542 # If the user types garbage into the file upload field,
2543 # then Netscape passes NOTHING to the server (not good).
2544 # We may hang on this read in that case. So we implement
2545 # a read timeout. If nothing is ready to read
2546 # by then, we return.
2547
2548 # Netscape seems to be a little bit unreliable
2549 # about providing boundary strings.
2550 if ($boundary) {
2551
2552 # Under the MIME spec, the boundary consists of the
2553 # characters "--" PLUS the Boundary string
2554 $boundary = "--$boundary";
2555 # Read the topmost (boundary) line plus the CRLF
2556 my($null) = '';
2557 $length -= $interface->read_from_client($IN,\$null,length($boundary)+2,0);
54310121 2558 } else { # otherwise we find it ourselves
2559 my($old);
2560 ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
2561 $boundary = <$IN>; # BUG: This won't work correctly under mod_perl
2562 $length -= length($boundary);
2563 chomp($boundary); # remove the CRLF
2564 $/ = $old; # restore old line separator
2565 }
2566
2567 my $self = {LENGTH=>$length,
2568 BOUNDARY=>$boundary,
2569 IN=>$IN,
2570 INTERFACE=>$interface,
2571 BUFFER=>'',
2572 };
2573
2574 $FILLUNIT = length($boundary)
2575 if length($boundary) > $FILLUNIT;
2576
2577 return bless $self,ref $package || $package;
2578}
2579END_OF_FUNC
2580
2581'readHeader' => <<'END_OF_FUNC',
2582sub readHeader {
2583 my($self) = @_;
2584 my($end);
2585 my($ok) = 0;
47e3cabd 2586 my($bad) = 0;
54310121 2587 do {
2588 $self->fillBuffer($FILLUNIT);
2589 $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
2590 $ok++ if $self->{BUFFER} eq '';
47e3cabd 2591 $bad++ if !$ok && $self->{LENGTH} <= 0;
54310121 2592 $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
47e3cabd
LS
2593 } until $ok || $bad;
2594 return () if $bad;
54310121 2595
2596 my($header) = substr($self->{BUFFER},0,$end+2);
2597 substr($self->{BUFFER},0,$end+4) = '';
2598 my %return;
2599 while ($header=~/^([\w-]+): (.*)$CRLF/mog) {
2600 $return{$1}=$2;
2601 }
2602 return %return;
2603}
2604END_OF_FUNC
2605
2606# This reads and returns the body as a single scalar value.
2607'readBody' => <<'END_OF_FUNC',
2608sub readBody {
2609 my($self) = @_;
2610 my($data);
2611 my($returnval)='';
2612 while (defined($data = $self->read)) {
2613 $returnval .= $data;
2614 }
2615 return $returnval;
2616}
2617END_OF_FUNC
2618
2619# This will read $bytes or until the boundary is hit, whichever happens
2620# first. After the boundary is hit, we return undef. The next read will
2621# skip over the boundary and begin reading again;
2622'read' => <<'END_OF_FUNC',
2623sub read {
2624 my($self,$bytes) = @_;
2625
2626 # default number of bytes to read
2627 $bytes = $bytes || $FILLUNIT;
2628
2629 # Fill up our internal buffer in such a way that the boundary
2630 # is never split between reads.
2631 $self->fillBuffer($bytes);
2632
2633 # Find the boundary in the buffer (it may not be there).
2634 my $start = index($self->{BUFFER},$self->{BOUNDARY});
47e3cabd
LS
2635 # protect against malformed multipart POST operations
2636 die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
54310121 2637
2638 # If the boundary begins the data, then skip past it
2639 # and return undef. The +2 here is a fiendish plot to
2640 # remove the CR/LF pair at the end of the boundary.
2641 if ($start == 0) {
2642
2643 # clear us out completely if we've hit the last boundary.
2644 if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
2645 $self->{BUFFER}='';
2646 $self->{LENGTH}=0;
2647 return undef;
2648 }
2649
2650 # just remove the boundary.
2651 substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
2652 return undef;
2653 }
2654
2655 my $bytesToReturn;
2656 if ($start > 0) { # read up to the boundary
2657 $bytesToReturn = $start > $bytes ? $bytes : $start;
2658 } else { # read the requested number of bytes
2659 # leave enough bytes in the buffer to allow us to read
2660 # the boundary. Thanks to Kevin Hendrick for finding
2661 # this one.
2662 $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
2663 }
2664
2665 my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
2666 substr($self->{BUFFER},0,$bytesToReturn)='';
2667
2668 # If we hit the boundary, remove the CRLF from the end.
2669 return ($start > 0) ? substr($returnval,0,-2) : $returnval;
2670}
2671END_OF_FUNC
2672
2673
2674# This fills up our internal buffer in such a way that the
2675# boundary is never split between reads
2676'fillBuffer' => <<'END_OF_FUNC',
2677sub fillBuffer {
2678 my($self,$bytes) = @_;
2679 return unless $self->{LENGTH};
2680
2681 my($boundaryLength) = length($self->{BOUNDARY});
2682 my($bufferLength) = length($self->{BUFFER});
2683 my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
2684 $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
2685
2686 # Try to read some data. We may hang here if the browser is screwed up.
2687 my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN},
2688 \$self->{BUFFER},
2689 $bytesToRead,
2690 $bufferLength);
2691
47e3cabd 2692 # An apparent bug in the Apache server causes the read()
54310121 2693 # to return zero bytes repeatedly without blocking if the
2694 # remote user aborts during a file transfer. I don't know how
2695 # they manage this, but the workaround is to abort if we get
2696 # more than SPIN_LOOP_MAX consecutive zero reads.
2697 if ($bytesRead == 0) {
2698 die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
2699 if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
2700 } else {
2701 $self->{ZERO_LOOP_COUNTER}=0;
2702 }
2703
2704 $self->{LENGTH} -= $bytesRead;
2705}
2706END_OF_FUNC
2707
2708
2709# Return true when we've finished reading
2710'eof' => <<'END_OF_FUNC'
2711sub eof {
2712 my($self) = @_;
2713 return 1 if (length($self->{BUFFER}) == 0)
2714 && ($self->{LENGTH} <= 0);
2715 undef;
2716}
2717END_OF_FUNC
2718
2719);
2720END_OF_AUTOLOAD
2721
2722####################################################################################
2723################################## TEMPORARY FILES #################################
2724####################################################################################
2725package TempFile;
2726
2727$SL = $CGI::SL;
2728unless ($TMPDIRECTORY) {
2729 @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp","${SL}tmp","${SL}temp","${SL}Temporary Items");
2730 foreach (@TEMP) {
2731 do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
2732 }
2733}
2734
2735$TMPDIRECTORY = "." unless $TMPDIRECTORY;
2736$SEQUENCE="CGItemp${$}0000";
2737
2738# cute feature, but overload implementation broke it
2739# %OVERLOAD = ('""'=>'as_string');
2740*TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
2741
2742###############################################################################
2743################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
2744###############################################################################
2745$AUTOLOADED_ROUTINES = ''; # prevent -w error
2746$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
2747%SUBS = (
2748
2749'new' => <<'END_OF_FUNC',
2750sub new {
2751 my($package) = @_;
2752 $SEQUENCE++;
2753 my $directory = "${TMPDIRECTORY}${SL}${SEQUENCE}";
2754 return bless \$directory;
2755}
2756END_OF_FUNC
2757
2758'DESTROY' => <<'END_OF_FUNC',
2759sub DESTROY {
2760 my($self) = @_;
2761 unlink $$self; # get rid of the file
2762}
2763END_OF_FUNC
2764
2765'as_string' => <<'END_OF_FUNC'
2766sub as_string {
2767 my($self) = @_;
2768 return $$self;
2769}
2770END_OF_FUNC
2771
2772);
2773END_OF_AUTOLOAD
2774
2775package CGI;
2776
2777# We get a whole bunch of warnings about "possibly uninitialized variables"
2778# when running with the -w switch. Touch them all once to get rid of the
2779# warnings. This is ugly and I hate it.
2780if ($^W) {
2781 $CGI::CGI = '';
2782 $CGI::CGI=<<EOF;
2783 $CGI::VERSION;
2784 $MultipartBuffer::SPIN_LOOP_MAX;
2785 $MultipartBuffer::CRLF;
2786 $MultipartBuffer::TIMEOUT;
2787 $MultipartBuffer::FILLUNIT;
2788 $TempFile::SEQUENCE;
2789EOF
2790 ;
2791}
2792
2793$revision;
2794
2795__END__
2796
2797=head1 NAME
2798
2799CGI - Simple Common Gateway Interface Class
2800
dc848c6f 2801=head1 SYNOPSIS
2802
2803 use CGI;
2804 # the rest is too complicated for a synopsis; keep reading
2805
54310121 2806=head1 ABSTRACT
2807
2808This perl library uses perl5 objects to make it easy to create
2809Web fill-out forms and parse their contents. This package
2810defines CGI objects, entities that contain the values of the
2811current query string and other state variables.
2812Using a CGI object's methods, you can examine keywords and parameters
2813passed to your script, and create forms whose initial values
2814are taken from the current query (thereby preserving state
2815information).
2816
2817The current version of CGI.pm is available at
2818
2819 http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
2820 ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
2821
47e3cabd
LS
2822=head1 INSTALLATION
2823
2824CGI is a part of the base Perl installation. However, you may need
2825to install a newer version someday. Therefore:
54310121 2826
2827To install this package, just change to the directory in which this
2828file is found and type the following:
2829
2830 perl Makefile.PL
2831 make
2832 make install
2833
2834This will copy CGI.pm to your perl library directory for use by all
2835perl scripts. You probably must be root to do this. Now you can
2836load the CGI routines in your Perl scripts with the line:
2837
2838 use CGI;
2839
2840If you don't have sufficient privileges to install CGI.pm in the Perl
2841library directory, you can put CGI.pm into some convenient spot, such
2842as your home directory, or in cgi-bin itself and prefix all Perl
2843scripts that call it with something along the lines of the following
2844preamble:
2845
2846 use lib '/home/davis/lib';
2847 use CGI;
2848
2849If you are using a version of perl earlier than 5.002 (such as NT perl), use
2850this instead:
2851
2852 BEGIN {
2853 unshift(@INC,'/home/davis/lib');
2854 }
2855 use CGI;
2856
2857The CGI distribution also comes with a cute module called L<CGI::Carp>.
2858It redefines the die(), warn(), confess() and croak() error routines
2859so that they write nicely formatted error messages into the server's
2860error log (or to the output stream of your choice). This avoids long
2861hours of groping through the error and access logs, trying to figure
2862out which CGI script is generating error messages. If you choose,
2863you can even have fatal error messages echoed to the browser to avoid
2864the annoying and uninformative "Server Error" message.
2865
2866=head1 DESCRIPTION
2867
2868=head2 CREATING A NEW QUERY OBJECT:
2869
2870 $query = new CGI;
2871
2872This will parse the input (from both POST and GET methods) and store
2873it into a perl5 object called $query.
2874
2875=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
2876
2877 $query = new CGI(INPUTFILE);
2878
2879If you provide a file handle to the new() method, it
2880will read parameters from the file (or STDIN, or whatever). The
2881file can be in any of the forms describing below under debugging
2882(i.e. a series of newline delimited TAG=VALUE pairs will work).
2883Conveniently, this type of file is created by the save() method
2884(see below). Multiple records can be saved and restored.
2885
2886Perl purists will be pleased to know that this syntax accepts
2887references to file handles, or even references to filehandle globs,
2888which is the "official" way to pass a filehandle:
2889
2890 $query = new CGI(\*STDIN);
2891
2892You can also initialize the query object from an associative array
2893reference:
2894
2895 $query = new CGI( {'dinosaur'=>'barney',
2896 'song'=>'I love you',
2897 'friends'=>[qw/Jessica George Nancy/]}
2898 );
2899
2900or from a properly formatted, URL-escaped query string:
2901
2902 $query = new CGI('dinosaur=barney&color=purple');
2903
2904To create an empty query, initialize it from an empty string or hash:
2905
2906 $empty_query = new CGI("");
2907 -or-
2908 $empty_query = new CGI({});
2909
2910=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
2911
2912 @keywords = $query->keywords
2913
2914If the script was invoked as the result of an <ISINDEX> search, the
2915parsed keywords can be obtained as an array using the keywords() method.
2916
2917=head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
2918
2919 @names = $query->param
2920
2921If the script was invoked with a parameter list
2922(e.g. "name1=value1&name2=value2&name3=value3"), the param()
2923method will return the parameter names as a list. If the
2924script was invoked as an <ISINDEX> script, there will be a
2925single parameter named 'keywords'.
2926
2927NOTE: As of version 1.5, the array of parameter names returned will
2928be in the same order as they were submitted by the browser.
2929Usually this order is the same as the order in which the
2930parameters are defined in the form (however, this isn't part
2931of the spec, and so isn't guaranteed).
2932
2933=head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
2934
2935 @values = $query->param('foo');
2936
2937 -or-
2938
2939 $value = $query->param('foo');
2940
2941Pass the param() method a single argument to fetch the value of the
2942named parameter. If the parameter is multivalued (e.g. from multiple
2943selections in a scrolling list), you can ask to receive an array. Otherwise
2944the method will return a single value.
2945
2946=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
2947
2948 $query->param('foo','an','array','of','values');
2949
2950This sets the value for the named parameter 'foo' to an array of
2951values. This is one way to change the value of a field AFTER
2952the script has been invoked once before. (Another way is with
2953the -override parameter accepted by all methods that generate
2954form elements.)
2955
2956param() also recognizes a named parameter style of calling described
2957in more detail later:
2958
2959 $query->param(-name=>'foo',-values=>['an','array','of','values']);
2960
2961 -or-
2962
2963 $query->param(-name=>'foo',-value=>'the value');
2964
2965=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
2966
2967 $query->append(-name=>;'foo',-values=>['yet','more','values']);
2968
2969This adds a value or list of values to the named parameter. The
2970values are appended to the end of the parameter if it already exists.
2971Otherwise the parameter is created. Note that this method only
2972recognizes the named argument calling syntax.
2973
2974=head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
2975
2976 $query->import_names('R');
2977
2978This creates a series of variables in the 'R' namespace. For example,
2979$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
2980If no namespace is given, this method will assume 'Q'.
2981WARNING: don't import anything into 'main'; this is a major security
2982risk!!!!
2983
2984In older versions, this method was called B<import()>. As of version 2.20,
2985this name has been removed completely to avoid conflict with the built-in
2986Perl module B<import> operator.
2987
2988=head2 DELETING A PARAMETER COMPLETELY:
2989
2990 $query->delete('foo');
2991
2992This completely clears a parameter. It sometimes useful for
2993resetting parameters that you don't want passed down between
2994script invocations.
2995
2996=head2 DELETING ALL PARAMETERS:
2997
2998$query->delete_all();
2999
3000This clears the CGI object completely. It might be useful to ensure
3001that all the defaults are taken when you create a fill-out form.
3002
3003=head2 SAVING THE STATE OF THE FORM TO A FILE:
3004
3005 $query->save(FILEHANDLE)
3006
3007This will write the current state of the form to the provided
3008filehandle. You can read it back in by providing a filehandle
3009to the new() method. Note that the filehandle can be a file, a pipe,
3010or whatever!
3011
3012The format of the saved file is:
3013
3014 NAME1=VALUE1
3015 NAME1=VALUE1'
3016 NAME2=VALUE2
3017 NAME3=VALUE3
3018 =
3019
3020Both name and value are URL escaped. Multi-valued CGI parameters are
3021represented as repeated names. A session record is delimited by a
3022single = symbol. You can write out multiple records and read them
3023back in with several calls to B<new>. You can do this across several
3024sessions by opening the file in append mode, allowing you to create
3025primitive guest books, or to keep a history of users' queries. Here's
3026a short example of creating multiple session records:
3027
3028 use CGI;
3029
3030 open (OUT,">>test.out") || die;
3031 $records = 5;
3032 foreach (0..$records) {
3033 my $q = new CGI;
3034 $q->param(-name=>'counter',-value=>$_);
3035 $q->save(OUT);
3036 }
3037 close OUT;
3038
3039 # reopen for reading
3040 open (IN,"test.out") || die;
3041 while (!eof(IN)) {
3042 my $q = new CGI(IN);
3043 print $q->param('counter'),"\n";
3044 }
3045
3046The file format used for save/restore is identical to that used by the
3047Whitehead Genome Center's data exchange format "Boulderio", and can be
3048manipulated and even databased using Boulderio utilities. See
3049
3050 http://www.genome.wi.mit.edu/genome_software/other/boulder.html
3051
3052for further details.
3053
3054=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
3055
3056 $myself = $query->self_url;
3057 print "<A HREF=$myself>I'm talking to myself.</A>";
3058
3059self_url() will return a URL, that, when selected, will reinvoke
3060this script with all its state information intact. This is most
3061useful when you want to jump around within the document using
3062internal anchors but you don't want to disrupt the current contents
3063of the form(s). Something like this will do the trick.
3064
3065 $myself = $query->self_url;
3066 print "<A HREF=$myself#table1>See table 1</A>";
3067 print "<A HREF=$myself#table2>See table 2</A>";
3068 print "<A HREF=$myself#yourself>See for yourself</A>";
3069
3070If you don't want to get the whole query string, call
3071the method url() to return just the URL for the script:
3072
3073 $myself = $query->url;
3074 print "<A HREF=$myself>No query string in this baby!</A>\n";
3075
3076You can also retrieve the unprocessed query string with query_string():
3077
3078 $the_string = $query->query_string;
3079
3080=head2 COMPATIBILITY WITH CGI-LIB.PL
3081
3082To make it easier to port existing programs that use cgi-lib.pl
3083the compatibility routine "ReadParse" is provided. Porting is
3084simple:
3085
3086OLD VERSION
3087 require "cgi-lib.pl";
3088 &ReadParse;
3089 print "The value of the antique is $in{antique}.\n";
3090
3091NEW VERSION
3092 use CGI;
3093 CGI::ReadParse
3094 print "The value of the antique is $in{antique}.\n";
3095
3096CGI.pm's ReadParse() routine creates a tied variable named %in,
3097which can be accessed to obtain the query variables. Like
3098ReadParse, you can also provide your own variable. Infrequently
3099used features of ReadParse, such as the creation of @in and $in
3100variables, are not supported.
3101
3102Once you use ReadParse, you can retrieve the query object itself
3103this way:
3104
3105 $q = $in{CGI};
3106 print $q->textfield(-name=>'wow',
3107 -value=>'does this really work?');
3108
3109This allows you to start using the more interesting features
3110of CGI.pm without rewriting your old scripts from scratch.
3111
3112=head2 CALLING CGI FUNCTIONS THAT TAKE MULTIPLE ARGUMENTS
3113
3114In versions of CGI.pm prior to 2.0, it could get difficult to remember
3115the proper order of arguments in CGI function calls that accepted five
3116or six different arguments. As of 2.0, there's a better way to pass
3117arguments to the various CGI functions. In this style, you pass a
3118series of name=>argument pairs, like this:
3119
3120 $field = $query->radio_group(-name=>'OS',
3121 -values=>[Unix,Windows,Macintosh],
3122 -default=>'Unix');
3123
3124The advantages of this style are that you don't have to remember the
3125exact order of the arguments, and if you leave out a parameter, in
3126most cases it will default to some reasonable value. If you provide
3127a parameter that the method doesn't recognize, it will usually do
3128something useful with it, such as incorporating it into the HTML form
3129tag. For example if Netscape decides next week to add a new
3130JUSTIFICATION parameter to the text field tags, you can start using
3131the feature without waiting for a new version of CGI.pm:
3132
3133 $field = $query->textfield(-name=>'State',
3134 -default=>'gaseous',
3135 -justification=>'RIGHT');
3136
3137This will result in an HTML tag that looks like this:
3138
3139 <INPUT TYPE="textfield" NAME="State" VALUE="gaseous"
3140 JUSTIFICATION="RIGHT">
3141
3142Parameter names are case insensitive: you can use -name, or -Name or
3143-NAME. You don't have to use the hyphen if you don't want to. After
3144creating a CGI object, call the B<use_named_parameters()> method with
3145a nonzero value. This will tell CGI.pm that you intend to use named
3146parameters exclusively:
3147
3148 $query = new CGI;
3149 $query->use_named_parameters(1);
3150 $field = $query->radio_group('name'=>'OS',
3151 'values'=>['Unix','Windows','Macintosh'],
3152 'default'=>'Unix');
3153
3154Actually, CGI.pm only looks for a hyphen in the first parameter. So
3155you can leave it off subsequent parameters if you like. Something to
3156be wary of is the potential that a string constant like "values" will
3157collide with a keyword (and in fact it does!) While Perl usually
3158figures out when you're referring to a function and when you're
3159referring to a string, you probably should put quotation marks around
3160all string constants just to play it safe.
3161
3162=head2 CREATING THE HTTP HEADER:
3163
3164 print $query->header;
3165
3166 -or-
3167
3168 print $query->header('image/gif');
3169
3170 -or-
3171
3172 print $query->header('text/html','204 No response');
3173
3174 -or-
3175
3176 print $query->header(-type=>'image/gif',
3177 -nph=>1,
3178 -status=>'402 Payment required',
3179 -expires=>'+3d',
3180 -cookie=>$cookie,
3181 -Cost=>'$2.00');
3182
3183header() returns the Content-type: header. You can provide your own
3184MIME type if you choose, otherwise it defaults to text/html. An
3185optional second parameter specifies the status code and a human-readable
3186message. For example, you can specify 204, "No response" to create a
3187script that tells the browser to do nothing at all. If you want to
3188add additional fields to the header, just tack them on to the end:
3189
3190 print $query->header('text/html','200 OK','Content-Length: 3002');
3191
3192The last example shows the named argument style for passing arguments
3193to the CGI methods using named parameters. Recognized parameters are
3194B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other
3195parameters will be stripped of their initial hyphens and turned into
3196header fields, allowing you to specify any HTTP header you desire.
3197
3198Most browsers will not cache the output from CGI scripts. Every time
3199the browser reloads the page, the script is invoked anew. You can
3200change this behavior with the B<-expires> parameter. When you specify
3201an absolute or relative expiration interval with this parameter, some
3202browsers and proxy servers will cache the script's output until the
3203indicated expiration date. The following forms are all valid for the
3204-expires field:
3205
3206 +30s 30 seconds from now
3207 +10m ten minutes from now
3208 +1h one hour from now
3209 -1d yesterday (i.e. "ASAP!")
3210 now immediately
3211 +3M in three months
3212 +10y in ten years time
3213 Thursday, 25-Apr-96 00:40:33 GMT at the indicated time & date
3214
3215(CGI::expires() is the static function call used internally that turns
3216relative time intervals into HTTP dates. You can call it directly if
3217you wish.)
3218
3219The B<-cookie> parameter generates a header that tells the browser to provide
3220a "magic cookie" during all subsequent transactions with your script.
3221Netscape cookies have a special format that includes interesting attributes
3222such as expiration time. Use the cookie() method to create and retrieve
3223session cookies.
3224
3225The B<-nph> parameter, if set to a true value, will issue the correct
3226headers to work with a NPH (no-parse-header) script. This is important
3227to use with certain servers, such as Microsoft Internet Explorer, which
3228expect all their scripts to be NPH.
3229
3230=head2 GENERATING A REDIRECTION INSTRUCTION
3231
3232 print $query->redirect('http://somewhere.else/in/movie/land');
3233
3234redirects the browser elsewhere. If you use redirection like this,
3235you should B<not> print out a header as well. As of version 2.0, we
3236produce both the unofficial Location: header and the official URI:
3237header. This should satisfy most servers and browsers.
3238
3239One hint I can offer is that relative links may not work correctly
7a2e2cd6 3240when you generate a redirection to another document on your site.
54310121 3241This is due to a well-intentioned optimization that some servers use.
3242The solution to this is to use the full URL (including the http: part)
3243of the document you are redirecting to.
3244
3245You can use named parameters:
3246
3247 print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
3248 -nph=>1);
3249
3250The B<-nph> parameter, if set to a true value, will issue the correct
3251headers to work with a NPH (no-parse-header) script. This is important
3252to use with certain servers, such as Microsoft Internet Explorer, which
3253expect all their scripts to be NPH.
3254
3255
3256=head2 CREATING THE HTML HEADER:
3257
3258 print $query->start_html(-title=>'Secrets of the Pyramids',
3259 -author=>'fred@capricorn.org',
3260 -base=>'true',
3261 -target=>'_blank',
3262 -meta=>{'keywords'=>'pharaoh secret mummy',
3263 'copyright'=>'copyright 1996 King Tut'},
7d37aa8e 3264 -style=>{'src'=>'/styles/style1.css'},
54310121 3265 -BGCOLOR=>'blue');
3266
3267 -or-
3268
3269 print $query->start_html('Secrets of the Pyramids',
3270 'fred@capricorn.org','true',
3271 'BGCOLOR="blue"');
3272
3273This will return a canned HTML header and the opening <BODY> tag.
3274All parameters are optional. In the named parameter form, recognized
3275parameters are -title, -author, -base, -xbase and -target (see below for the
3276explanation). Any additional parameters you provide, such as the
3277Netscape unofficial BGCOLOR attribute, are added to the <BODY> tag.
3278
3279The argument B<-xbase> allows you to provide an HREF for the <BASE> tag
3280different from the current location, as in
3281
3282 -xbase=>"http://home.mcom.com/"
3283
3284All relative links will be interpreted relative to this tag.
3285
3286The argument B<-target> allows you to provide a default target frame
3287for all the links and fill-out forms on the page. See the Netscape
3288documentation on frames for details of how to manipulate this.
3289
3290 -target=>"answer_window"
3291
3292All relative links will be interpreted relative to this tag.
3293You add arbitrary meta information to the header with the B<-meta>
3294argument. This argument expects a reference to an associative array
3295containing name/value pairs of meta information. These will be turned
3296into a series of header <META> tags that look something like this:
3297
3298 <META NAME="keywords" CONTENT="pharaoh secret mummy">
3299 <META NAME="description" CONTENT="copyright 1996 King Tut">
3300
3301There is no support for the HTTP-EQUIV type of <META> tag. This is
3302because you can modify the HTTP header directly with the B<header()>
7d37aa8e
LS
3303method. For example, if you want to send the Refresh: header, do it
3304in the header() method:
3305
3306 print $q->header(-Refresh=>'10; URL=http://www.capricorn.com');
3307
3308The B<-style> tag is used to incorporate cascading stylesheets into
3309your code. See the section on CASCADING STYLESHEETS for more information.
3310
3311You can place other arbitrary HTML elements to the <HEAD> section with the
3312B<-head> tag. For example, to place the rarely-used <LINK> element in the
3313head section, use this:
3314
3315 print $q->header(-head=>link({-rel=>'next',
3316 -href=>'http://www.capricorn.com/s2.html'}));
3317
3318To incorporate multiple HTML elements into the <HEAD> section, just pass an
3319array reference:
3320
3321 print $q->header(-head=>[ link({-rel=>'next',
3322 -href=>'http://www.capricorn.com/s2.html'}),
3323 link({-rel=>'previous',
3324 -href=>'http://www.capricorn.com/s1.html'})
3325 ]
3326 );
3327
54310121 3328
47e3cabd 3329JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad> and B<-onUnload> parameters
54310121 3330are used to add Netscape JavaScript calls to your pages. B<-script>
3331should point to a block of text containing JavaScript function
3332definitions. This block will be placed within a <SCRIPT> block inside
3333the HTML (not HTTP) header. The block is placed in the header in
3334order to give your page a fighting chance of having all its JavaScript
3335functions in place even if the user presses the stop button before the
3336page has loaded completely. CGI.pm attempts to format the script in
3337such a way that JavaScript-naive browsers will not choke on the code:
3338unfortunately there are some browsers, such as Chimera for Unix, that
3339get confused by it nevertheless.
3340
3341The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
3342code to execute when the page is respectively opened and closed by the
3343browser. Usually these parameters are calls to functions defined in the
3344B<-script> field:
3345
3346 $query = new CGI;
3347 print $query->header;
3348 $JSCRIPT=<<END;
3349 // Ask a silly question
3350 function riddle_me_this() {
3351 var r = prompt("What walks on four legs in the morning, " +
3352 "two legs in the afternoon, " +
3353 "and three legs in the evening?");
3354 response(r);
3355 }
3356 // Get a silly answer
3357 function response(answer) {
3358 if (answer == "man")
3359 alert("Right you are!");
3360 else
3361 alert("Wrong! Guess again.");
3362 }
3363 END
3364 print $query->start_html(-title=>'The Riddle of the Sphinx',
3365 -script=>$JSCRIPT);
3366
47e3cabd
LS
3367Use the B<-noScript> parameter to pass some HTML text that will be displayed on
3368browsers that do not have JavaScript (or browsers where JavaScript is turned
3369off).
3370
7d37aa8e
LS
3371Netscape 3.0 recognizes several attributes of the <SCRIPT> tag,
3372including LANGUAGE and SRC. The latter is particularly interesting,
3373as it allows you to keep the JavaScript code in a file or CGI script
3374rather than cluttering up each page with the source. To use these
3375attributes pass a HASH reference in the B<-script> parameter containing
3376one or more of -language, -src, or -code:
3377
3378 print $q->start_html(-title=>'The Riddle of the Sphinx',
3379 -script=>{-language=>'JAVASCRIPT',
3380 -src=>'/javascript/sphinx.js'}
3381 );
3382
3383 print $q->(-title=>'The Riddle of the Sphinx',
3384 -script=>{-language=>'PERLSCRIPT'},
3385 -code=>'print "hello world!\n;"'
3386 );
3387
3388
54310121 3389See
3390
3391 http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
3392
3393for more information about JavaScript.
3394
3395The old-style positional parameters are as follows:
3396
3397=over 4
3398
3399=item B<Parameters:>
3400
3401=item 1.
3402
3403The title
3404
3405=item 2.
3406
3407The author's e-mail address (will create a <LINK REV="MADE"> tag if present
3408
3409=item 3.
3410
3411A 'true' flag if you want to include a <BASE> tag in the header. This
3412helps resolve relative addresses to absolute ones when the document is moved,
3413but makes the document hierarchy non-portable. Use with care!
3414
3415=item 4, 5, 6...
3416
3417Any other parameters you want to include in the <BODY> tag. This is a good
3418place to put Netscape extensions, such as colors and wallpaper patterns.
3419
3420=back
3421
3422=head2 ENDING THE HTML DOCUMENT:
3423
3424 print $query->end_html
3425
3426This ends an HTML document by printing the </BODY></HTML> tags.
3427
47e3cabd 3428=head1 CREATING FORMS
54310121 3429
3430I<General note> The various form-creating methods all return strings
3431to the caller, containing the tag or tags that will create the requested
3432form element. You are responsible for actually printing out these strings.
3433It's set up this way so that you can place formatting tags
3434around the form elements.
3435
3436I<Another note> The default values that you specify for the forms are only
3437used the B<first> time the script is invoked (when there is no query
3438string). On subsequent invocations of the script (when there is a query
3439string), the former values are used even if they are blank.
3440
3441If you want to change the value of a field from its previous value, you have two
3442choices:
3443
3444(1) call the param() method to set it.
3445
3446(2) use the -override (alias -force) parameter (a new feature in version 2.15).
3447This forces the default value to be used, regardless of the previous value:
3448
3449 print $query->textfield(-name=>'field_name',
3450 -default=>'starting value',
3451 -override=>1,
3452 -size=>50,
3453 -maxlength=>80);
3454
3455I<Yet another note> By default, the text and labels of form elements are
3456escaped according to HTML rules. This means that you can safely use
3457"<CLICK ME>" as the label for a button. However, it also interferes with
3458your ability to incorporate special HTML character sequences, such as &Aacute;,
3459into your fields. If you wish to turn off automatic escaping, call the
3460autoEscape() method with a false value immediately after creating the CGI object:
3461
3462 $query = new CGI;
3463 $query->autoEscape(undef);
3464
3465
3466=head2 CREATING AN ISINDEX TAG
3467
3468 print $query->isindex(-action=>$action);
3469
3470 -or-
3471
3472 print $query->isindex($action);
3473
3474Prints out an <ISINDEX> tag. Not very exciting. The parameter
3475-action specifies the URL of the script to process the query. The
3476default is to process the query with the current script.
3477
3478=head2 STARTING AND ENDING A FORM
3479
3480 print $query->startform(-method=>$method,
3481 -action=>$action,
3482 -encoding=>$encoding);
3483 <... various form stuff ...>
3484 print $query->endform;
3485
3486 -or-
3487
3488 print $query->startform($method,$action,$encoding);
3489 <... various form stuff ...>
3490 print $query->endform;
3491
3492startform() will return a <FORM> tag with the optional method,
3493action and form encoding that you specify. The defaults are:
3494
3495 method: POST
3496 action: this script
3497 encoding: application/x-www-form-urlencoded
3498
3499endform() returns the closing </FORM> tag.
3500
3501Startform()'s encoding method tells the browser how to package the various
3502fields of the form before sending the form to the server. Two
3503values are possible:
3504
3505=over 4
3506
3507=item B<application/x-www-form-urlencoded>
3508
3509This is the older type of encoding used by all browsers prior to
3510Netscape 2.0. It is compatible with many CGI scripts and is
3511suitable for short fields containing text data. For your
3512convenience, CGI.pm stores the name of this encoding
3513type in B<$CGI::URL_ENCODED>.
3514
3515=item B<multipart/form-data>
3516
3517This is the newer type of encoding introduced by Netscape 2.0.
3518It is suitable for forms that contain very large fields or that
3519are intended for transferring binary data. Most importantly,
3520it enables the "file upload" feature of Netscape 2.0 forms. For
3521your convenience, CGI.pm stores the name of this encoding type
3522in B<$CGI::MULTIPART>
3523
3524Forms that use this type of encoding are not easily interpreted
3525by CGI scripts unless they use CGI.pm or another library designed
3526to handle them.
3527
3528=back
3529
3530For compatibility, the startform() method uses the older form of
3531encoding by default. If you want to use the newer form of encoding
3532by default, you can call B<start_multipart_form()> instead of
3533B<startform()>.
3534
3535JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
3536for use with JavaScript. The -name parameter gives the
3537form a name so that it can be identified and manipulated by
3538JavaScript functions. -onSubmit should point to a JavaScript
3539function that will be executed just before the form is submitted to your
3540server. You can use this opportunity to check the contents of the form
3541for consistency and completeness. If you find something wrong, you
3542can put up an alert box or maybe fix things up yourself. You can
3543abort the submission by returning false from this function.
3544
3545Usually the bulk of JavaScript functions are defined in a <SCRIPT>
3546block in the HTML header and -onSubmit points to one of these function
3547call. See start_html() for details.
3548
3549=head2 CREATING A TEXT FIELD
3550
3551 print $query->textfield(-name=>'field_name',
3552 -default=>'starting value',
3553 -size=>50,
3554 -maxlength=>80);
3555 -or-
3556
3557 print $query->textfield('field_name','starting value',50,80);
3558
3559textfield() will return a text input field.
3560
3561=over 4
3562
3563=item B<Parameters>
3564
3565=item 1.
3566
3567The first parameter is the required name for the field (-name).
3568
3569=item 2.
3570
3571The optional second parameter is the default starting value for the field
3572contents (-default).
3573
3574=item 3.
3575
3576The optional third parameter is the size of the field in
3577 characters (-size).
3578
3579=item 4.
3580
3581The optional fourth parameter is the maximum number of characters the
3582 field will accept (-maxlength).
3583
3584=back
3585
3586As with all these methods, the field will be initialized with its
3587previous contents from earlier invocations of the script.
3588When the form is processed, the value of the text field can be
3589retrieved with:
3590
3591 $value = $query->param('foo');
3592
3593If you want to reset it from its initial value after the script has been
3594called once, you can do so like this:
3595
3596 $query->param('foo',"I'm taking over this value!");
3597
3598NEW AS OF VERSION 2.15: If you don't want the field to take on its previous
3599value, you can force its current value by using the -override (alias -force)
3600parameter:
3601
3602 print $query->textfield(-name=>'field_name',
3603 -default=>'starting value',
3604 -override=>1,
3605 -size=>50,
3606 -maxlength=>80);
3607
3608JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>, B<-onBlur>
3609and B<-onSelect> parameters to register JavaScript event handlers.
3610The onChange handler will be called whenever the user changes the
3611contents of the text field. You can do text validation if you like.
3612onFocus and onBlur are called respectively when the insertion point
3613moves into and out of the text field. onSelect is called when the
3614user changes the portion of the text that is selected.
3615
3616=head2 CREATING A BIG TEXT FIELD
3617
3618 print $query->textarea(-name=>'foo',
3619 -default=>'starting value',
3620 -rows=>10,
3621 -columns=>50);
3622
3623 -or
3624
3625 print $query->textarea('foo','starting value',10,50);
3626
3627textarea() is just like textfield, but it allows you to specify
3628rows and columns for a multiline text entry box. You can provide
3629a starting value for the field, which can be long and contain
3630multiple lines.
3631
3632JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
3633and B<-onSelect> parameters are recognized. See textfield().
3634
3635=head2 CREATING A PASSWORD FIELD
3636
3637 print $query->password_field(-name=>'secret',
3638 -value=>'starting value',
3639 -size=>50,
3640 -maxlength=>80);
3641 -or-
3642
3643 print $query->password_field('secret','starting value',50,80);
3644
3645password_field() is identical to textfield(), except that its contents
3646will be starred out on the web page.
3647
3648JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
3649and B<-onSelect> parameters are recognized. See textfield().
3650
3651=head2 CREATING A FILE UPLOAD FIELD
3652
3653 print $query->filefield(-name=>'uploaded_file',
3654 -default=>'starting value',
3655 -size=>50,
3656 -maxlength=>80);
3657 -or-
3658
3659 print $query->filefield('uploaded_file','starting value',50,80);
3660
3661filefield() will return a file upload field for Netscape 2.0 browsers.
3662In order to take full advantage of this I<you must use the new
3663multipart encoding scheme> for the form. You can do this either
3664by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>,
3665or by calling the new method B<start_multipart_form()> instead of
3666vanilla B<startform()>.
3667
3668=over 4
3669
3670=item B<Parameters>
3671
3672=item 1.
3673
3674The first parameter is the required name for the field (-name).
3675
3676=item 2.
3677
3678The optional second parameter is the starting value for the field contents
3679to be used as the default file name (-default).
3680
3681The beta2 version of Netscape 2.0 currently doesn't pay any attention
3682to this field, and so the starting value will always be blank. Worse,
3683the field loses its "sticky" behavior and forgets its previous
3684contents. The starting value field is called for in the HTML
3685specification, however, and possibly later versions of Netscape will
3686honor it.
3687
3688=item 3.
3689
3690The optional third parameter is the size of the field in
3691characters (-size).
3692
3693=item 4.
3694
3695The optional fourth parameter is the maximum number of characters the
3696field will accept (-maxlength).
3697
3698=back
3699
3700When the form is processed, you can retrieve the entered filename
3701by calling param().
3702
3703 $filename = $query->param('uploaded_file');
3704
3705In Netscape Gold, the filename that gets returned is the full local filename
3706on the B<remote user's> machine. If the remote user is on a Unix
3707machine, the filename will follow Unix conventions:
3708
3709 /path/to/the/file
3710
3711On an MS-DOS/Windows and OS/2 machines, the filename will follow DOS conventions:
3712
3713 C:\PATH\TO\THE\FILE.MSW
3714
3715On a Macintosh machine, the filename will follow Mac conventions:
3716
3717 HD 40:Desktop Folder:Sort Through:Reminders
3718
3719The filename returned is also a file handle. You can read the contents
3720of the file using standard Perl file reading calls:
3721
3722 # Read a text file and print it out
3723 while (<$filename>) {
3724 print;
3725 }
3726
3727 # Copy a binary file to somewhere safe
3728 open (OUTFILE,">>/usr/local/web/users/feedback");
3729 while ($bytesread=read($filename,$buffer,1024)) {
3730 print OUTFILE $buffer;
3731 }
3732
3733When a file is uploaded the browser usually sends along some
3734information along with it in the format of headers. The information
3735usually includes the MIME content type. Future browsers may send
3736other information as well (such as modification date and size). To
3737retrieve this information, call uploadInfo(). It returns a reference to
3738an associative array containing all the document headers.
3739
3740 $filename = $query->param('uploaded_file');
3741 $type = $query->uploadInfo($filename)->{'Content-Type'};
3742 unless ($type eq 'text/html') {
3743 die "HTML FILES ONLY!";
3744 }
3745
3746If you are using a machine that recognizes "text" and "binary" data
3747modes, be sure to understand when and how to use them (see the Camel book).
3748Otherwise you may find that binary files are corrupted during file uploads.
3749
3750JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>
3751and B<-onSelect> parameters are recognized. See textfield()
3752for details.
3753
3754=head2 CREATING A POPUP MENU
3755
3756 print $query->popup_menu('menu_name',
3757 ['eenie','meenie','minie'],
3758 'meenie');
3759
3760 -or-
3761
3762 %labels = ('eenie'=>'your first choice',
3763 'meenie'=>'your second choice',
3764 'minie'=>'your third choice');
3765 print $query->popup_menu('menu_name',
3766 ['eenie','meenie','minie'],
3767 'meenie',\%labels);
3768
3769 -or (named parameter style)-
3770
3771 print $query->popup_menu(-name=>'menu_name',
3772 -values=>['eenie','meenie','minie'],
3773 -default=>'meenie',
3774 -labels=>\%labels);
3775
3776popup_menu() creates a menu.
3777
3778=over 4
3779
3780=item 1.
3781
3782The required first argument is the menu's name (-name).
3783
3784=item 2.
3785
3786The required second argument (-values) is an array B<reference>
3787containing the list of menu items in the menu. You can pass the
3788method an anonymous array, as shown in the example, or a reference to
3789a named array, such as "\@foo".
3790
3791=item 3.
3792
3793The optional third parameter (-default) is the name of the default
3794menu choice. If not specified, the first item will be the default.
3795The values of the previous choice will be maintained across queries.
3796
3797=item 4.
3798
3799The optional fourth parameter (-labels) is provided for people who
3800want to use different values for the user-visible label inside the
3801popup menu nd the value returned to your script. It's a pointer to an
3802associative array relating menu values to user-visible labels. If you
3803leave this parameter blank, the menu values will be displayed by
3804default. (You can also leave a label undefined if you want to).
3805
3806=back
3807
3808When the form is processed, the selected value of the popup menu can
3809be retrieved using:
3810
3811 $popup_menu_value = $query->param('menu_name');
3812
3813JAVASCRIPTING: popup_menu() recognizes the following event handlers:
3814B<-onChange>, B<-onFocus>, and B<-onBlur>. See the textfield()
3815section for details on when these handlers are called.
3816
3817=head2 CREATING A SCROLLING LIST
3818
3819 print $query->scrolling_list('list_name',
3820 ['eenie','meenie','minie','moe'],
3821 ['eenie','moe'],5,'true');
3822 -or-
3823
3824 print $query->scrolling_list('list_name',
3825 ['eenie','meenie','minie','moe'],
3826 ['eenie','moe'],5,'true',
3827 \%labels);
3828
3829 -or-
3830
3831 print $query->scrolling_list(-name=>'list_name',
3832 -values=>['eenie','meenie','minie','moe'],
3833 -default=>['eenie','moe'],
3834 -size=>5,
3835 -multiple=>'true',
3836 -labels=>\%labels);
3837
3838scrolling_list() creates a scrolling list.
3839
3840=over 4
3841
3842=item B<Parameters:>
3843
3844=item 1.
3845
3846The first and second arguments are the list name (-name) and values
3847(-values). As in the popup menu, the second argument should be an
3848array reference.
3849
3850=item 2.
3851
3852The optional third argument (-default) can be either a reference to a
3853list containing the values to be selected by default, or can be a
3854single value to select. If this argument is missing or undefined,
3855then nothing is selected when the list first appears. In the named
3856parameter version, you can use the synonym "-defaults" for this
3857parameter.
3858
3859=item 3.
3860
3861The optional fourth argument is the size of the list (-size).
3862
3863=item 4.
3864
3865The optional fifth argument can be set to true to allow multiple
3866simultaneous selections (-multiple). Otherwise only one selection
3867will be allowed at a time.
3868
3869=item 5.
3870
3871The optional sixth argument is a pointer to an associative array
3872containing long user-visible labels for the list items (-labels).
3873If not provided, the values will be displayed.
3874
3875When this form is processed, all selected list items will be returned as
3876a list under the parameter name 'list_name'. The values of the
3877selected items can be retrieved with:
3878
3879 @selected = $query->param('list_name');
3880
3881=back
3882
3883JAVASCRIPTING: scrolling_list() recognizes the following event handlers:
3884B<-onChange>, B<-onFocus>, and B<-onBlur>. See textfield() for
3885the description of when these handlers are called.
3886
3887=head2 CREATING A GROUP OF RELATED CHECKBOXES
3888
3889 print $query->checkbox_group(-name=>'group_name',
3890 -values=>['eenie','meenie','minie','moe'],
3891 -default=>['eenie','moe'],
3892 -linebreak=>'true',
3893 -labels=>\%labels);
3894
3895 print $query->checkbox_group('group_name',
3896 ['eenie','meenie','minie','moe'],
3897 ['eenie','moe'],'true',\%labels);
3898
3899 HTML3-COMPATIBLE BROWSERS ONLY:
3900
3901 print $query->checkbox_group(-name=>'group_name',
3902 -values=>['eenie','meenie','minie','moe'],
3903 -rows=2,-columns=>2);
3904
3905
3906checkbox_group() creates a list of checkboxes that are related
3907by the same name.
3908
3909=over 4
3910
3911=item B<Parameters:>
3912
3913=item 1.
3914
3915The first and second arguments are the checkbox name and values,
3916respectively (-name and -values). As in the popup menu, the second
3917argument should be an array reference. These values are used for the
3918user-readable labels printed next to the checkboxes as well as for the
3919values passed to your script in the query string.
3920
3921=item 2.
3922
3923The optional third argument (-default) can be either a reference to a
3924list containing the values to be checked by default, or can be a
3925single value to checked. If this argument is missing or undefined,
3926then nothing is selected when the list first appears.
3927
3928=item 3.
3929
3930The optional fourth argument (-linebreak) can be set to true to place
3931line breaks between the checkboxes so that they appear as a vertical
3932list. Otherwise, they will be strung together on a horizontal line.
3933
3934=item 4.
3935
3936The optional fifth argument is a pointer to an associative array
7a2e2cd6 3937relating the checkbox values to the user-visible labels that will
54310121 3938be printed next to them (-labels). If not provided, the values will
3939be used as the default.
3940
3941=item 5.
3942
3943B<HTML3-compatible browsers> (such as Netscape) can take advantage
3944of the optional
3945parameters B<-rows>, and B<-columns>. These parameters cause
3946checkbox_group() to return an HTML3 compatible table containing
3947the checkbox group formatted with the specified number of rows
3948and columns. You can provide just the -columns parameter if you
3949wish; checkbox_group will calculate the correct number of rows
3950for you.
3951
3952To include row and column headings in the returned table, you
3953can use the B<-rowheader> and B<-colheader> parameters. Both
3954of these accept a pointer to an array of headings to use.
3955The headings are just decorative. They don't reorganize the
3956interpretation of the checkboxes -- they're still a single named
3957unit.
3958
3959=back
3960
3961When the form is processed, all checked boxes will be returned as
3962a list under the parameter name 'group_name'. The values of the
3963"on" checkboxes can be retrieved with:
3964
3965 @turned_on = $query->param('group_name');
3966
3967The value returned by checkbox_group() is actually an array of button
3968elements. You can capture them and use them within tables, lists,
3969or in other creative ways:
3970
3971 @h = $query->checkbox_group(-name=>'group_name',-values=>\@values);
3972 &use_in_creative_way(@h);
3973
3974JAVASCRIPTING: checkbox_group() recognizes the B<-onClick>
3975parameter. This specifies a JavaScript code fragment or
3976function call to be executed every time the user clicks on
3977any of the buttons in the group. You can retrieve the identity
3978of the particular button clicked on using the "this" variable.
3979
3980=head2 CREATING A STANDALONE CHECKBOX
3981
3982 print $query->checkbox(-name=>'checkbox_name',
3983 -checked=>'checked',
3984 -value=>'ON',
3985 -label=>'CLICK ME');
3986
3987 -or-
3988
3989 print $query->checkbox('checkbox_name','checked','ON','CLICK ME');
3990
3991checkbox() is used to create an isolated checkbox that isn't logically
3992related to any others.
3993
3994=over 4
3995
3996=item B<Parameters:>
3997
3998=item 1.
3999
4000The first parameter is the required name for the checkbox (-name). It
4001will also be used for the user-readable label printed next to the
4002checkbox.
4003
4004=item 2.
4005
4006The optional second parameter (-checked) specifies that the checkbox
4007is turned on by default. Synonyms are -selected and -on.
4008
4009=item 3.
4010
4011The optional third parameter (-value) specifies the value of the
4012checkbox when it is checked. If not provided, the word "on" is
4013assumed.
4014
4015=item 4.
4016
4017The optional fourth parameter (-label) is the user-readable label to
4018be attached to the checkbox. If not provided, the checkbox name is
4019used.
4020
4021=back
4022
4023The value of the checkbox can be retrieved using:
4024
4025 $turned_on = $query->param('checkbox_name');
4026
4027JAVASCRIPTING: checkbox() recognizes the B<-onClick>
4028parameter. See checkbox_group() for further details.
4029
4030=head2 CREATING A RADIO BUTTON GROUP
4031
4032 print $query->radio_group(-name=>'group_name',
4033 -values=>['eenie','meenie','minie'],
4034 -default=>'meenie',
4035 -linebreak=>'true',
4036 -labels=>\%labels);
4037
4038 -or-
4039
4040 print $query->radio_group('group_name',['eenie','meenie','minie'],
4041 'meenie','true',\%labels);
4042
4043
4044 HTML3-COMPATIBLE BROWSERS ONLY:
4045
4046 print $query->radio_group(-name=>'group_name',
4047 -values=>['eenie','meenie','minie','moe'],
4048 -rows=2,-columns=>2);
4049
4050radio_group() creates a set of logically-related radio buttons
4051(turning one member of the group on turns the others off)
4052
4053=over 4
4054
4055=item B<Parameters:>
4056
4057=item 1.
4058
4059The first argument is the name of the group and is required (-name).
4060
4061=item 2.
4062
4063The second argument (-values) is the list of values for the radio
4064buttons. The values and the labels that appear on the page are
4065identical. Pass an array I<reference> in the second argument, either
4066using an anonymous array, as shown, or by referencing a named array as
4067in "\@foo".
4068
4069=item 3.
4070
4071The optional third parameter (-default) is the name of the default
4072button to turn on. If not specified, the first item will be the
4073default. You can provide a nonexistent button name, such as "-" to
4074start up with no buttons selected.
4075
4076=item 4.
4077
4078The optional fourth parameter (-linebreak) can be set to 'true' to put
4079line breaks between the buttons, creating a vertical list.
4080
4081=item 5.
4082
4083The optional fifth parameter (-labels) is a pointer to an associative
4084array relating the radio button values to user-visible labels to be
4085used in the display. If not provided, the values themselves are
4086displayed.
4087
4088=item 6.
4089
4090B<HTML3-compatible browsers> (such as Netscape) can take advantage
4091of the optional
4092parameters B<-rows>, and B<-columns>. These parameters cause
4093radio_group() to return an HTML3 compatible table containing
4094the radio group formatted with the specified number of rows
4095and columns. You can provide just the -columns parameter if you
4096wish; radio_group will calculate the correct number of rows
4097for you.
4098
4099To include row and column headings in the returned table, you
4100can use the B<-rowheader> and B<-colheader> parameters. Both
4101of these accept a pointer to an array of headings to use.
4102The headings are just decorative. They don't reorganize the
4103interpetation of the radio buttons -- they're still a single named
4104unit.
4105
4106=back
4107
4108When the form is processed, the selected radio button can
4109be retrieved using:
4110
4111 $which_radio_button = $query->param('group_name');
4112
4113The value returned by radio_group() is actually an array of button
4114elements. You can capture them and use them within tables, lists,
4115or in other creative ways:
4116
4117 @h = $query->radio_group(-name=>'group_name',-values=>\@values);
4118 &use_in_creative_way(@h);
4119
4120=head2 CREATING A SUBMIT BUTTON
4121
4122 print $query->submit(-name=>'button_name',
4123 -value=>'value');
4124
4125 -or-
4126
4127 print $query->submit('button_name','value');
4128
4129submit() will create the query submission button. Every form
4130should have one of these.
4131
4132=over 4
4133
4134=item B<Parameters:>
4135
4136=item 1.
4137
4138The first argument (-name) is optional. You can give the button a
4139name if you have several submission buttons in your form and you want
4140to distinguish between them. The name will also be used as the
4141user-visible label. Be aware that a few older browsers don't deal with this correctly and
4142B<never> send back a value from a button.
4143
4144=item 2.
4145
4146The second argument (-value) is also optional. This gives the button
4147a value that will be passed to your script in the query string.
4148
4149=back
4150
4151You can figure out which button was pressed by using different
4152values for each one:
4153
4154 $which_one = $query->param('button_name');
4155
4156JAVASCRIPTING: radio_group() recognizes the B<-onClick>
4157parameter. See checkbox_group() for further details.
4158
4159=head2 CREATING A RESET BUTTON
4160
4161 print $query->reset
4162
4163reset() creates the "reset" button. Note that it restores the
4164form to its value from the last time the script was called,
4165NOT necessarily to the defaults.
4166
4167=head2 CREATING A DEFAULT BUTTON
4168
4169 print $query->defaults('button_label')
4170
4171defaults() creates a button that, when invoked, will cause the
4172form to be completely reset to its defaults, wiping out all the
4173changes the user ever made.
4174
4175=head2 CREATING A HIDDEN FIELD
4176
4177 print $query->hidden(-name=>'hidden_name',
4178 -default=>['value1','value2'...]);
4179
4180 -or-
4181
4182 print $query->hidden('hidden_name','value1','value2'...);
4183
4184hidden() produces a text field that can't be seen by the user. It
4185is useful for passing state variable information from one invocation
4186of the script to the next.
4187
4188=over 4
4189
4190=item B<Parameters:>
4191
4192=item 1.
4193
4194The first argument is required and specifies the name of this
4195field (-name).
4196
4197=item 2.
4198
4199The second argument is also required and specifies its value
4200(-default). In the named parameter style of calling, you can provide
4201a single value here or a reference to a whole list
4202
4203=back
4204
4205Fetch the value of a hidden field this way:
4206
4207 $hidden_value = $query->param('hidden_name');
4208
4209Note, that just like all the other form elements, the value of a
4210hidden field is "sticky". If you want to replace a hidden field with
4211some other values after the script has been called once you'll have to
4212do it manually:
4213
4214 $query->param('hidden_name','new','values','here');
4215
4216=head2 CREATING A CLICKABLE IMAGE BUTTON
4217
4218 print $query->image_button(-name=>'button_name',
4219 -src=>'/source/URL',
4220 -align=>'MIDDLE');
4221
4222 -or-
4223
4224 print $query->image_button('button_name','/source/URL','MIDDLE');
4225
4226image_button() produces a clickable image. When it's clicked on the
4227position of the click is returned to your script as "button_name.x"
4228and "button_name.y", where "button_name" is the name you've assigned
4229to it.
4230
4231JAVASCRIPTING: image_button() recognizes the B<-onClick>
4232parameter. See checkbox_group() for further details.
4233
4234=over 4
4235
4236=item B<Parameters:>
4237
4238=item 1.
4239
4240The first argument (-name) is required and specifies the name of this
4241field.
4242
4243=item 2.
4244
4245The second argument (-src) is also required and specifies the URL
4246
4247=item 3.
4248The third option (-align, optional) is an alignment type, and may be
4249TOP, BOTTOM or MIDDLE
4250
4251=back
4252
4253Fetch the value of the button this way:
4254 $x = $query->param('button_name.x');
4255 $y = $query->param('button_name.y');
4256
4257=head2 CREATING A JAVASCRIPT ACTION BUTTON
4258
4259 print $query->button(-name=>'button_name',
4260 -value=>'user visible label',
4261 -onClick=>"do_something()");
4262
4263 -or-
4264
4265 print $query->button('button_name',"do_something()");
4266
4267button() produces a button that is compatible with Netscape 2.0's
4268JavaScript. When it's pressed the fragment of JavaScript code
4269pointed to by the B<-onClick> parameter will be executed. On
4270non-Netscape browsers this form element will probably not even
4271display.
4272
4273=head1 NETSCAPE COOKIES
4274
4275Netscape browsers versions 1.1 and higher support a so-called
4276"cookie" designed to help maintain state within a browser session.
4277CGI.pm has several methods that support cookies.
4278
4279A cookie is a name=value pair much like the named parameters in a CGI
4280query string. CGI scripts create one or more cookies and send
4281them to the browser in the HTTP header. The browser maintains a list
4282of cookies that belong to a particular Web server, and returns them
4283to the CGI script during subsequent interactions.
4284
4285In addition to the required name=value pair, each cookie has several
4286optional attributes:
4287
4288=over 4
4289
4290=item 1. an expiration time
4291
4292This is a time/date string (in a special GMT format) that indicates
4293when a cookie expires. The cookie will be saved and returned to your
4294script until this expiration date is reached if the user exits
4295Netscape and restarts it. If an expiration date isn't specified, the cookie
4296will remain active until the user quits Netscape.
4297
4298=item 2. a domain
4299
4300This is a partial or complete domain name for which the cookie is
4301valid. The browser will return the cookie to any host that matches
4302the partial domain name. For example, if you specify a domain name
4303of ".capricorn.com", then Netscape will return the cookie to
4304Web servers running on any of the machines "www.capricorn.com",
4305"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
4306must contain at least two periods to prevent attempts to match
4307on top level domains like ".edu". If no domain is specified, then
4308the browser will only return the cookie to servers on the host the
4309cookie originated from.
4310
4311=item 3. a path
4312
4313If you provide a cookie path attribute, the browser will check it
4314against your script's URL before returning the cookie. For example,
4315if you specify the path "/cgi-bin", then the cookie will be returned
4316to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
4317and "/cgi-bin/customer_service/complain.pl", but not to the script
4318"/cgi-private/site_admin.pl". By default, path is set to "/", which
4319causes the cookie to be sent to any CGI script on your site.
4320
4321=item 4. a "secure" flag
4322
4323If the "secure" attribute is set, the cookie will only be sent to your
4324script if the CGI request is occurring on a secure channel, such as SSL.
4325
4326=back
4327
4328The interface to Netscape cookies is the B<cookie()> method:
4329
4330 $cookie = $query->cookie(-name=>'sessionID',
4331 -value=>'xyzzy',
4332 -expires=>'+1h',
4333 -path=>'/cgi-bin/database',
4334 -domain=>'.capricorn.org',
4335 -secure=>1);
4336 print $query->header(-cookie=>$cookie);
4337
4338B<cookie()> creates a new cookie. Its parameters include:
4339
4340=over 4
4341
4342=item B<-name>
4343
4344The name of the cookie (required). This can be any string at all.
4345Although Netscape limits its cookie names to non-whitespace
4346alphanumeric characters, CGI.pm removes this restriction by escaping
4347and unescaping cookies behind the scenes.
4348
4349=item B<-value>
4350
4351The value of the cookie. This can be any scalar value,
4352array reference, or even associative array reference. For example,
4353you can store an entire associative array into a cookie this way:
4354
4355 $cookie=$query->cookie(-name=>'family information',
4356 -value=>\%childrens_ages);
4357
4358=item B<-path>
4359
4360The optional partial path for which this cookie will be valid, as described
4361above.
4362
4363=item B<-domain>
4364
4365The optional partial domain for which this cookie will be valid, as described
4366above.
4367
4368=item B<-expires>
4369
4370The optional expiration date for this cookie. The format is as described
4371in the section on the B<header()> method:
4372
4373 "+1h" one hour from now
4374
4375=item B<-secure>
4376
4377If set to true, this cookie will only be used within a secure
4378SSL session.
4379
4380=back
4381
4382The cookie created by cookie() must be incorporated into the HTTP
4383header within the string returned by the header() method:
4384
4385 print $query->header(-cookie=>$my_cookie);
4386
4387To create multiple cookies, give header() an array reference:
4388
4389 $cookie1 = $query->cookie(-name=>'riddle_name',
4390 -value=>"The Sphynx's Question");
4391 $cookie2 = $query->cookie(-name=>'answers',
4392 -value=>\%answers);
4393 print $query->header(-cookie=>[$cookie1,$cookie2]);
4394
4395To retrieve a cookie, request it by name by calling cookie()
4396method without the B<-value> parameter:
4397
4398 use CGI;
4399 $query = new CGI;
4400 %answers = $query->cookie(-name=>'answers');
4401 # $query->cookie('answers') will work too!
4402
4403The cookie and CGI namespaces are separate. If you have a parameter
4404named 'answers' and a cookie named 'answers', the values retrieved by
4405param() and cookie() are independent of each other. However, it's
4406simple to turn a CGI parameter into a cookie, and vice-versa:
4407
4408 # turn a CGI parameter into a cookie
4409 $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]);
4410 # vice-versa
4411 $q->param(-name=>'answers',-value=>[$q->cookie('answers')]);
4412
4413See the B<cookie.cgi> example script for some ideas on how to use
4414cookies effectively.
4415
4416B<NOTE:> There appear to be some (undocumented) restrictions on
4417Netscape cookies. In Netscape 2.01, at least, I haven't been able to
4418set more than three cookies at a time. There may also be limits on
4419the length of cookies. If you need to store a lot of information,
4420it's probably better to create a unique session ID, store it in a
4421cookie, and use the session ID to locate an external file/database
4422saved on the server's side of the connection.
4423
4424=head1 WORKING WITH NETSCAPE FRAMES