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