projects / OpenSPARC-T2-DV / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial commit of OpenSPARC T2 design and verification files.
[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / 5.8.0 / CGI.pm
CommitLineData
86530b38
AT		 1package CGI;
2require 5.004;
3use Carp 'croak';
4
5# See the bottom of this file for the POD documentation. Search for the
6# string '=head'.
7
8# You can run this file through either pod2man or pod2html to produce pretty
9# documentation in manual or html file format (these utilities are part of the
10# Perl 5 distribution).
11
12# Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
13# It may be used and modified freely, but I do request that this copyright
14# notice remain attached to the file. You may modify this module as you
15# wish, but if you redistribute a modified version, please attach a note
16# listing the modifications you have made.
17
18# The most recent version and complete docs are available at:
19# http://stein.cshl.org/WWW/software/CGI/
20
21$CGI::revision = '$Id: CGI.pm,v 1.62 2002/04/10 19:36:01 lstein Exp $';
22$CGI::VERSION='2.81';
23
24# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
25# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
26# $CGITempFile::TMPDIRECTORY = '/usr/tmp';
27use CGI::Util qw(rearrange make_attributes unescape escape expires);
28
29#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
30# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
31
32use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
33 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
34
35# >>>>> Here are some globals that you might want to adjust <<<<<<
36sub initialize_globals {
37 # Set this to 1 to enable copious autoloader debugging messages
38 $AUTOLOAD_DEBUG = 0;
39
40 # Set this to 1 to generate XTML-compatible output
41 $XHTML = 1;
42
43 # Change this to the preferred DTD to print in start_html()
44 # or use default_dtd('text of DTD to use');
45 $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
46 'http://www.w3.org/TR/html4/loose.dtd' ] ;
47
48 # Set this to 1 to enable NOSTICKY scripts
49 # or:
50 # 1) use CGI qw(-nosticky)
51 # 2) $CGI::nosticky(1)
52 $NOSTICKY = 0;
53
54 # Set this to 1 to enable NPH scripts
55 # or:
56 # 1) use CGI qw(-nph)
57 # 2) CGI::nph(1)
58 # 3) print header(-nph=>1)
59 $NPH = 0;
60
61 # Set this to 1 to enable debugging from @ARGV
62 # Set to 2 to enable debugging from STDIN
63 $DEBUG = 1;
64
65 # Set this to 1 to make the temporary files created
66 # during file uploads safe from prying eyes
67 # or do...
68 # 1) use CGI qw(:private_tempfiles)
69 # 2) CGI::private_tempfiles(1);
70 $PRIVATE_TEMPFILES = 0;
71
72 # Set this to a positive value to limit the size of a POSTing
73 # to a certain number of bytes:
74 $POST_MAX = -1;
75
76 # Change this to 1 to disable uploads entirely:
77 $DISABLE_UPLOADS = 0;
78
79 # Automatically determined -- don't change
80 $EBCDIC = 0;
81
82 # Change this to 1 to suppress redundant HTTP headers
83 $HEADERS_ONCE = 0;
84
85 # separate the name=value pairs by semicolons rather than ampersands
86 $USE_PARAM_SEMICOLONS = 1;
87
88 # Do not include undefined params parsed from query string
89 # use CGI qw(-no_undef_params);
90 $NO_UNDEF_PARAMS = 0;
91
92 # Other globals that you shouldn't worry about.
93 undef $Q;
94 $BEEN_THERE = 0;
95 undef @QUERY_PARAM;
96 undef %EXPORT;
97 undef $QUERY_CHARSET;
98 undef %QUERY_FIELDNAMES;
99
100 # prevent complaints by mod_perl
101 1;
102}
103
104# ------------------ START OF THE LIBRARY ------------
105
106# make mod_perlhappy
107initialize_globals();
108
109# FIGURE OUT THE OS WE'RE RUNNING UNDER
110# Some systems support the $^O variable. If not
111# available then require() the Config library
112unless ($OS) {
113 unless ($OS = $^O) {
114 require Config;
115 $OS = $Config::Config{'osname'};
116 }
117}
118if ($OS =~ /^MSWin/i) {
119 $OS = 'WINDOWS';
120} elsif ($OS =~ /^VMS/i) {
121 $OS = 'VMS';
122} elsif ($OS =~ /^dos/i) {
123 $OS = 'DOS';
124} elsif ($OS =~ /^MacOS/i) {
125 $OS = 'MACINTOSH';
126} elsif ($OS =~ /^os2/i) {
127 $OS = 'OS2';
128} elsif ($OS =~ /^epoc/i) {
129 $OS = 'EPOC';
130} else {
131 $OS = 'UNIX';
132}
133
134# Some OS logic. Binary mode enabled on DOS, NT and VMS
135$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/;
136
137# This is the default class for the CGI object to use when all else fails.
138$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
139
140# This is where to look for autoloaded routines.
141$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
142
143# The path separator is a slash, backslash or semicolon, depending
144# on the paltform.
145$SL = {
146 UNIX=>'/', OS2=>'\\', EPOC=>'/',
147 WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
148 }->{$OS};
149
150# This no longer seems to be necessary
151# Turn on NPH scripts by default when running under IIS server!
152# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
153$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
154
155# Turn on special checking for Doug MacEachern's modperl
156if (exists $ENV{'GATEWAY_INTERFACE'}
157 &&
158 ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
159{
160 $| = 1;
161 require Apache;
162}
163# Turn on special checking for ActiveState's PerlEx
164$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
165
166# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
167# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
168# and sometimes CR). The most popular VMS web server
169# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
170# use ASCII, so \015\012 means something different. I find this all
171# really annoying.
172$EBCDIC = "\t" ne "\011";
173if ($OS eq 'VMS') {
174 $CRLF = "\n";
175} elsif ($EBCDIC) {
176 $CRLF= "\r\n";
177} else {
178 $CRLF = "\015\012";
179}
180
181if ($needs_binmode) {
182 $CGI::DefaultClass->binmode(main::STDOUT);
183 $CGI::DefaultClass->binmode(main::STDIN);
184 $CGI::DefaultClass->binmode(main::STDERR);
185}
186
187%EXPORT_TAGS = (
188 ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
189 tt u i b blockquote pre img a address cite samp dfn html head
190 base body Link nextid title meta kbd start_html end_html
191 input Select option comment charset escapeHTML/],
192 ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param
193 embed basefont style span layer ilayer font frameset frame script small big/],
194 ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
195 ins label legend noframes noscript object optgroup Q
196 thead tbody tfoot/],
197 ':netscape'=>[qw/blink fontsize center/],
198 ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
199 submit reset defaults radio_group popup_menu button autoEscape
200 scrolling_list image_button start_form end_form startform endform
201 start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
202 ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump
203 raw_cookie request_method query_string Accept user_agent remote_host content_type
204 remote_addr referer server_name server_software server_port server_protocol
205 virtual_host remote_ident auth_type http
206 save_parameters restore_parameters param_fetch
207 remote_user user_name header redirect import_names put
208 Delete Delete_all url_param cgi_error/],
209 ':ssl' => [qw/https/],
210 ':imagemap' => [qw/Area Map/],
211 ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
212 ':html' => [qw/:html2 :html3 :html4 :netscape/],
213 ':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
214 ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
215 ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/]
216 );
217
218# to import symbols into caller
219sub import {
220 my $self = shift;
221
222# This causes modules to clash.
223 undef %EXPORT_OK;
224 undef %EXPORT;
225
226 $self->_setup_symbols(@_);
227 my ($callpack, $callfile, $callline) = caller;
228
229 # To allow overriding, search through the packages
230 # Till we find one in which the correct subroutine is defined.
231 my @packages = ($self,@{"$self\:\:ISA"});
232 foreach $sym (keys %EXPORT) {
233 my $pck;
234 my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
235 foreach $pck (@packages) {
236 if (defined(&{"$pck\:\:$sym"})) {
237 $def = $pck;
238 last;
239 }
240 }
241 *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
242 }
243}
244
245sub compile {
246 my $pack = shift;
247 $pack->_setup_symbols('-compile',@_);
248}
249
250sub expand_tags {
251 my($tag) = @_;
252 return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
253 my(@r);
254 return ($tag) unless $EXPORT_TAGS{$tag};
255 foreach (@{$EXPORT_TAGS{$tag}}) {
256 push(@r,&expand_tags($_));
257 }
258 return @r;
259}
260
261#### Method: new
262# The new routine. This will check the current environment
263# for an existing query string, and initialize itself, if so.
264####
265sub new {
266 my($class,$initializer) = @_;
267 my $self = {};
268 bless $self,ref $class || $class || $DefaultClass;
269 if ($MOD_PERL && defined Apache->request) {
270 Apache->request->register_cleanup(\&CGI::_reset_globals);
271 undef $NPH;
272 }
273 $self->_reset_globals if $PERLEX;
274 $self->init($initializer);
275 return $self;
276}
277
278# We provide a DESTROY method so that the autoloader
279# doesn't bother trying to find it.
280sub DESTROY { }
281
282#### Method: param
283# Returns the value(s)of a named parameter.
284# If invoked in a list context, returns the
285# entire list. Otherwise returns the first
286# member of the list.
287# If name is not provided, return a list of all
288# the known parameters names available.
289# If more than one argument is provided, the
290# second and subsequent arguments are used to
291# set the value of the parameter.
292####
293sub param {
294 my($self,@p) = self_or_default(@_);
295 return $self->all_parameters unless @p;
296 my($name,$value,@other);
297
298 # For compatibility between old calling style and use_named_parameters() style,
299 # we have to special case for a single parameter present.
300 if (@p > 1) {
301 ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
302 my(@values);
303
304 if (substr($p[0],0,1) eq '-') {
305 @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
306 } else {
307 foreach ($value,@other) {
308 push(@values,$_) if defined($_);
309 }
310 }
311 # If values is provided, then we set it.
312 if (@values) {
313 $self->add_parameter($name);
314 $self->{$name}=[@values];
315 }
316 } else {
317 $name = $p[0];
318 }
319
320 return unless defined($name) && $self->{$name};
321 return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
322}
323
324sub self_or_default {
325 return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
326 unless (defined($_[0]) &&
327 (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
328 ) {
329 $Q = $CGI::DefaultClass->new unless defined($Q);
330 unshift(@_,$Q);
331 }
332 return wantarray ? @_ : $Q;
333}
334
335sub self_or_CGI {
336 local $^W=0; # prevent a warning
337 if (defined($_[0]) &&
338 (substr(ref($_[0]),0,3) eq 'CGI'
339 || UNIVERSAL::isa($_[0],'CGI'))) {
340 return @_;
341 } else {
342 return ($DefaultClass,@_);
343 }
344}
345
346########################################
347# THESE METHODS ARE MORE OR LESS PRIVATE
348# GO TO THE __DATA__ SECTION TO SEE MORE
349# PUBLIC METHODS
350########################################
351
352# Initialize the query object from the environment.
353# If a parameter list is found, this object will be set
354# to an associative array in which parameter names are keys
355# and the values are stored as lists
356# If a keyword list is found, this method creates a bogus
357# parameter list with the single parameter 'keywords'.
358
359sub init {
360 my($self,$initializer) = @_;
361 my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
362 local($/) = "\n";
363
364 # if we get called more than once, we want to initialize
365 # ourselves from the original query (which may be gone
366 # if it was read from STDIN originally.)
367 if (defined(@QUERY_PARAM) && !defined($initializer)) {
368 foreach (@QUERY_PARAM) {
369 $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
370 }
371 $self->charset($QUERY_CHARSET);
372 $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
373 return;
374 }
375
376 $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
377 $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
378
379 $fh = to_filehandle($initializer) if $initializer;
380
381 # set charset to the safe ISO-8859-1
382 $self->charset('ISO-8859-1');
383
384 METHOD: {
385
386 # avoid unreasonably large postings
387 if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
388 $self->cgi_error("413 Request entity too large");
389 last METHOD;
390 }
391
392 # Process multipart postings, but only if the initializer is
393 # not defined.
394 if ($meth eq 'POST'
395 && defined($ENV{'CONTENT_TYPE'})
396 && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
397 && !defined($initializer)
398 ) {
399 my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
400 $self->read_multipart($boundary,$content_length);
401 last METHOD;
402 }
403
404 # If initializer is defined, then read parameters
405 # from it.
406 if (defined($initializer)) {
407 if (UNIVERSAL::isa($initializer,'CGI')) {
408 $query_string = $initializer->query_string;
409 last METHOD;
410 }
411 if (ref($initializer) && ref($initializer) eq 'HASH') {
412 foreach (keys %$initializer) {
413 $self->param('-name'=>$_,'-value'=>$initializer->{$_});
414 }
415 last METHOD;
416 }
417
418 if (defined($fh) && ($fh ne '')) {
419 while (<$fh>) {
420 chomp;
421 last if /^=/;
422 push(@lines,$_);
423 }
424 # massage back into standard format
425 if ("@lines" =~ /=/) {
426 $query_string=join("&",@lines);
427 } else {
428 $query_string=join("+",@lines);
429 }
430 last METHOD;
431 }
432
433 # last chance -- treat it as a string
434 $initializer = $$initializer if ref($initializer) eq 'SCALAR';
435 $query_string = $initializer;
436
437 last METHOD;
438 }
439
440 # If method is GET or HEAD, fetch the query from
441 # the environment.
442 if ($meth=~/^(GET|HEAD)$/) {
443 if ($MOD_PERL) {
444 $query_string = Apache->request->args;
445 } else {
446 $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
447 $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
448 }
449 last METHOD;
450 }
451
452 if ($meth eq 'POST') {
453 $self->read_from_client(\*STDIN,\$query_string,$content_length,0)
454 if $content_length > 0;
455 # Some people want to have their cake and eat it too!
456 # Uncomment this line to have the contents of the query string
457 # APPENDED to the POST data.
458 # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
459 last METHOD;
460 }
461
462 # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
463 # Check the command line and then the standard input for data.
464 # We use the shellwords package in order to behave the way that
465 # UN*X programmers expect.
466 $query_string = read_from_cmdline() if $DEBUG;
467 }
468
469 # We now have the query string in hand. We do slightly
470 # different things for keyword lists and parameter lists.
471 if (defined $query_string && length $query_string) {
472 if ($query_string =~ /[&=;]/) {
473 $self->parse_params($query_string);
474 } else {
475 $self->add_parameter('keywords');
476 $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
477 }
478 }
479
480 # Special case. Erase everything if there is a field named
481 # .defaults.
482 if ($self->param('.defaults')) {
483 undef %{$self};
484 }
485
486 # Associative array containing our defined fieldnames
487 $self->{'.fieldnames'} = {};
488 foreach ($self->param('.cgifields')) {
489 $self->{'.fieldnames'}->{$_}++;
490 }
491
492 # Clear out our default submission button flag if present
493 $self->delete('.submit');
494 $self->delete('.cgifields');
495
496 $self->save_request unless $initializer;
497}
498
499# FUNCTIONS TO OVERRIDE:
500# Turn a string into a filehandle
501sub to_filehandle {
502 my $thingy = shift;
503 return undef unless $thingy;
504 return $thingy if UNIVERSAL::isa($thingy,'GLOB');
505 return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
506 if (!ref($thingy)) {
507 my $caller = 1;
508 while (my $package = caller($caller++)) {
509 my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
510 return $tmp if defined(fileno($tmp));
511 }
512 }
513 return undef;
514}
515
516# send output to the browser
517sub put {
518 my($self,@p) = self_or_default(@_);
519 $self->print(@p);
520}
521
522# print to standard output (for overriding in mod_perl)
523sub print {
524 shift;
525 CORE::print(@_);
526}
527
528# get/set last cgi_error
529sub cgi_error {
530 my ($self,$err) = self_or_default(@_);
531 $self->{'.cgi_error'} = $err if defined $err;
532 return $self->{'.cgi_error'};
533}
534
535sub save_request {
536 my($self) = @_;
537 # We're going to play with the package globals now so that if we get called
538 # again, we initialize ourselves in exactly the same way. This allows
539 # us to have several of these objects.
540 @QUERY_PARAM = $self->param; # save list of parameters
541 foreach (@QUERY_PARAM) {
542 next unless defined $_;
543 $QUERY_PARAM{$_}=$self->{$_};
544 }
545 $QUERY_CHARSET = $self->charset;
546 %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
547}
548
549sub parse_params {
550 my($self,$tosplit) = @_;
551 my(@pairs) = split(/[&;]/,$tosplit);
552 my($param,$value);
553 foreach (@pairs) {
554 ($param,$value) = split('=',$_,2);
555 next unless defined $param;
556 next if $NO_UNDEF_PARAMS and not defined $value;
557 $value = '' unless defined $value;
558 $param = unescape($param);
559 $value = unescape($value);
560 $self->add_parameter($param);
561 push (@{$self->{$param}},$value);
562 }
563}
564
565sub add_parameter {
566 my($self,$param)=@_;
567 return unless defined $param;
568 push (@{$self->{'.parameters'}},$param)
569 unless defined($self->{$param});
570}
571
572sub all_parameters {
573 my $self = shift;
574 return () unless defined($self) && $self->{'.parameters'};
575 return () unless @{$self->{'.parameters'}};
576 return @{$self->{'.parameters'}};
577}
578
579# put a filehandle into binary mode (DOS)
580sub binmode {
581 CORE::binmode($_[1]);
582}
583
584sub _make_tag_func {
585 my ($self,$tagname) = @_;
586 my $func = qq(
587 sub $tagname {
588 shift if \$_[0] &&
589 (ref(\$_[0]) &&
590 (substr(ref(\$_[0]),0,3) eq 'CGI' ||
591 UNIVERSAL::isa(\$_[0],'CGI')));
592 my(\$attr) = '';
593 if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') {
594 my(\@attr) = make_attributes(shift()||undef,1);
595 \$attr = " \@attr" if \@attr;
596 }
597 );
598 if ($tagname=~/start_(\w+)/i) {
599 $func .= qq! return "<\L$1\E\$attr>";} !;
600 } elsif ($tagname=~/end_(\w+)/i) {
601 $func .= qq! return "<\L/$1\E>"; } !;
602 } else {
603 $func .= qq#
604 return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@_;
605 my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
606 my \@result = map { "\$tag\$_\$untag" }
607 (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
608 return "\@result";
609 }#;
610 }
611return $func;
612}
613
614sub AUTOLOAD {
615 print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
616 my $func = &_compile;
617 goto &$func;
618}
619
620sub _compile {
621 my($func) = $AUTOLOAD;
622 my($pack,$func_name);
623 {
624 local($1,$2); # this fixes an obscure variable suicide problem.
625 $func=~/(.+)::([^:]+)$/;
626 ($pack,$func_name) = ($1,$2);
627 $pack=~s/::SUPER$//; # fix another obscure problem
628 $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
629 unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
630
631 my($sub) = \%{"$pack\:\:SUBS"};
632 unless (%$sub) {
633 my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
634 eval "package $pack; $$auto";
635 croak("$AUTOLOAD: $@") if $@;
636 $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
637 }
638 my($code) = $sub->{$func_name};
639
640 $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
641 if (!$code) {
642 (my $base = $func_name) =~ s/^(start_|end_)//i;
643 if ($EXPORT{':any'} ||
644 $EXPORT{'-any'} ||
645 $EXPORT{$base} ||
646 (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
647 && $EXPORT_OK{$base}) {
648 $code = $CGI::DefaultClass->_make_tag_func($func_name);
649 }
650 }
651 croak("Undefined subroutine $AUTOLOAD\n") unless $code;
652 eval "package $pack; $code";
653 if ($@) {
654 $@ =~ s/ at .*\n//;
655 croak("$AUTOLOAD: $@");
656 }
657 }
658 CORE::delete($sub->{$func_name}); #free storage
659 return "$pack\:\:$func_name";
660}
661
662sub _selected {
663 my $self = shift;
664 my $value = shift;
665 return '' unless $value;
666 return $XHTML ? qq( selected="selected") : qq( selected);
667}
668
669sub _checked {
670 my $self = shift;
671 my $value = shift;
672 return '' unless $value;
673 return $XHTML ? qq( checked="checked") : qq( checked);
674}
675
676sub _reset_globals { initialize_globals(); }
677
678sub _setup_symbols {
679 my $self = shift;
680 my $compile = 0;
681
682 # to avoid reexporting unwanted variables
683 undef %EXPORT;
684
685 foreach (@_) {
686 $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
687 $NPH++, next if /^[:-]nph$/;
688 $NOSTICKY++, next if /^[:-]nosticky$/;
689 $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
690 $DEBUG=2, next if /^[:-][Dd]ebug$/;
691 $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
692 $XHTML++, next if /^[:-]xhtml$/;
693 $XHTML=0, next if /^[:-]no_?xhtml$/;
694 $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
695 $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
696 $EXPORT{$_}++, next if /^[:-]any$/;
697 $compile++, next if /^[:-]compile$/;
698 $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
699
700 # This is probably extremely evil code -- to be deleted some day.
701 if (/^[-]autoload$/) {
702 my($pkg) = caller(1);
703 *{"${pkg}::AUTOLOAD"} = sub {
704 my($routine) = $AUTOLOAD;
705 $routine =~ s/^.*::/CGI::/;
706 &$routine;
707 };
708 next;
709 }
710
711 foreach (&expand_tags($_)) {
712 tr/a-zA-Z0-9_//cd; # don't allow weird function names
713 $EXPORT{$_}++;
714 }
715 }
716 _compile_all(keys %EXPORT) if $compile;
717}
718
719sub charset {
720 my ($self,$charset) = self_or_default(@_);
721 $self->{'.charset'} = $charset if defined $charset;
722 $self->{'.charset'};
723}
724
725###############################################################################
726################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
727###############################################################################
728$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
729$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
730
731%SUBS = (
732
733'URL_ENCODED'=> <<'END_OF_FUNC',
734sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
735END_OF_FUNC
736
737'MULTIPART' => <<'END_OF_FUNC',
738sub MULTIPART { 'multipart/form-data'; }
739END_OF_FUNC
740
741'SERVER_PUSH' => <<'END_OF_FUNC',
742sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
743END_OF_FUNC
744
745'new_MultipartBuffer' => <<'END_OF_FUNC',
746# Create a new multipart buffer
747sub new_MultipartBuffer {
748 my($self,$boundary,$length,$filehandle) = @_;
749 return MultipartBuffer->new($self,$boundary,$length,$filehandle);
750}
751END_OF_FUNC
752
753'read_from_client' => <<'END_OF_FUNC',
754# Read data from a file handle
755sub read_from_client {
756 my($self, $fh, $buff, $len, $offset) = @_;
757 local $^W=0; # prevent a warning
758 return undef unless defined($fh);
759 return read($fh, $$buff, $len, $offset);
760}
761END_OF_FUNC
762
763'delete' => <<'END_OF_FUNC',
764#### Method: delete
765# Deletes the named parameter entirely.
766####
767sub delete {
768 my($self,@p) = self_or_default(@_);
769 my($name) = rearrange([NAME],@p);
770 CORE::delete $self->{$name};
771 CORE::delete $self->{'.fieldnames'}->{$name};
772 @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
773 return wantarray ? () : undef;
774}
775END_OF_FUNC
776
777#### Method: import_names
778# Import all parameters into the given namespace.
779# Assumes namespace 'Q' if not specified
780####
781'import_names' => <<'END_OF_FUNC',
782sub import_names {
783 my($self,$namespace,$delete) = self_or_default(@_);
784 $namespace = 'Q' unless defined($namespace);
785 die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
786 if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
787 # can anyone find an easier way to do this?
788 foreach (keys %{"${namespace}::"}) {
789 local *symbol = "${namespace}::${_}";
790 undef $symbol;
791 undef @symbol;
792 undef %symbol;
793 }
794 }
795 my($param,@value,$var);
796 foreach $param ($self->param) {
797 # protect against silly names
798 ($var = $param)=~tr/a-zA-Z0-9_/_/c;
799 $var =~ s/^(?=\d)/_/;
800 local *symbol = "${namespace}::$var";
801 @value = $self->param($param);
802 @symbol = @value;
803 $symbol = $value[0];
804 }
805}
806END_OF_FUNC
807
808#### Method: keywords
809# Keywords acts a bit differently. Calling it in a list context
810# returns the list of keywords.
811# Calling it in a scalar context gives you the size of the list.
812####
813'keywords' => <<'END_OF_FUNC',
814sub keywords {
815 my($self,@values) = self_or_default(@_);
816 # If values is provided, then we set it.
817 $self->{'keywords'}=[@values] if @values;
818 my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
819 @result;
820}
821END_OF_FUNC
822
823# These are some tie() interfaces for compatibility
824# with Steve Brenner's cgi-lib.pl routines
825'Vars' => <<'END_OF_FUNC',
826sub Vars {
827 my $q = shift;
828 my %in;
829 tie(%in,CGI,$q);
830 return %in if wantarray;
831 return \%in;
832}
833END_OF_FUNC
834
835# These are some tie() interfaces for compatibility
836# with Steve Brenner's cgi-lib.pl routines
837'ReadParse' => <<'END_OF_FUNC',
838sub ReadParse {
839 local(*in);
840 if (@_) {
841 *in = $_[0];
842 } else {
843 my $pkg = caller();
844 *in=*{"${pkg}::in"};
845 }
846 tie(%in,CGI);
847 return scalar(keys %in);
848}
849END_OF_FUNC
850
851'PrintHeader' => <<'END_OF_FUNC',
852sub PrintHeader {
853 my($self) = self_or_default(@_);
854 return $self->header();
855}
856END_OF_FUNC
857
858'HtmlTop' => <<'END_OF_FUNC',
859sub HtmlTop {
860 my($self,@p) = self_or_default(@_);
861 return $self->start_html(@p);
862}
863END_OF_FUNC
864
865'HtmlBot' => <<'END_OF_FUNC',
866sub HtmlBot {
867 my($self,@p) = self_or_default(@_);
868 return $self->end_html(@p);
869}
870END_OF_FUNC
871
872'SplitParam' => <<'END_OF_FUNC',
873sub SplitParam {
874 my ($param) = @_;
875 my (@params) = split ("\0", $param);
876 return (wantarray ? @params : $params[0]);
877}
878END_OF_FUNC
879
880'MethGet' => <<'END_OF_FUNC',
881sub MethGet {
882 return request_method() eq 'GET';
883}
884END_OF_FUNC
885
886'MethPost' => <<'END_OF_FUNC',
887sub MethPost {
888 return request_method() eq 'POST';
889}
890END_OF_FUNC
891
892'TIEHASH' => <<'END_OF_FUNC',
893sub TIEHASH {
894 return $_[1] if defined $_[1];
895 return $Q ||= new shift;
896}
897END_OF_FUNC
898
899'STORE' => <<'END_OF_FUNC',
900sub STORE {
901 my $self = shift;
902 my $tag = shift;
903 my $vals = shift;
904 my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
905 $self->param(-name=>$tag,-value=>\@vals);
906}
907END_OF_FUNC
908
909'FETCH' => <<'END_OF_FUNC',
910sub FETCH {
911 return $_[0] if $_[1] eq 'CGI';
912 return undef unless defined $_[0]->param($_[1]);
913 return join("\0",$_[0]->param($_[1]));
914}
915END_OF_FUNC
916
917'FIRSTKEY' => <<'END_OF_FUNC',
918sub FIRSTKEY {
919 $_[0]->{'.iterator'}=0;
920 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
921}
922END_OF_FUNC
923
924'NEXTKEY' => <<'END_OF_FUNC',
925sub NEXTKEY {
926 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
927}
928END_OF_FUNC
929
930'EXISTS' => <<'END_OF_FUNC',
931sub EXISTS {
932 exists $_[0]->{$_[1]};
933}
934END_OF_FUNC
935
936'DELETE' => <<'END_OF_FUNC',
937sub DELETE {
938 $_[0]->delete($_[1]);
939}
940END_OF_FUNC
941
942'CLEAR' => <<'END_OF_FUNC',
943sub CLEAR {
944 %{$_[0]}=();
945}
946####
947END_OF_FUNC
948
949####
950# Append a new value to an existing query
951####
952'append' => <<'EOF',
953sub append {
954 my($self,@p) = @_;
955 my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
956 my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
957 if (@values) {
958 $self->add_parameter($name);
959 push(@{$self->{$name}},@values);
960 }
961 return $self->param($name);
962}
963EOF
964
965#### Method: delete_all
966# Delete all parameters
967####
968'delete_all' => <<'EOF',
969sub delete_all {
970 my($self) = self_or_default(@_);
971 undef %{$self};
972}
973EOF
974
975'Delete' => <<'EOF',
976sub Delete {
977 my($self,@p) = self_or_default(@_);
978 $self->delete(@p);
979}
980EOF
981
982'Delete_all' => <<'EOF',
983sub Delete_all {
984 my($self,@p) = self_or_default(@_);
985 $self->delete_all(@p);
986}
987EOF
988
989#### Method: autoescape
990# If you want to turn off the autoescaping features,
991# call this method with undef as the argument
992'autoEscape' => <<'END_OF_FUNC',
993sub autoEscape {
994 my($self,$escape) = self_or_default(@_);
995 $self->{'dontescape'}=!$escape;
996}
997END_OF_FUNC
998
999
1000#### Method: version
1001# Return the current version
1002####
1003'version' => <<'END_OF_FUNC',
1004sub version {
1005 return $VERSION;
1006}
1007END_OF_FUNC
1008
1009#### Method: url_param
1010# Return a parameter in the QUERY_STRING, regardless of
1011# whether this was a POST or a GET
1012####
1013'url_param' => <<'END_OF_FUNC',
1014sub url_param {
1015 my ($self,@p) = self_or_default(@_);
1016 my $name = shift(@p);
1017 return undef unless exists($ENV{QUERY_STRING});
1018 unless (exists($self->{'.url_param'})) {
1019 $self->{'.url_param'}={}; # empty hash
1020 if ($ENV{QUERY_STRING} =~ /=/) {
1021 my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
1022 my($param,$value);
1023 foreach (@pairs) {
1024 ($param,$value) = split('=',$_,2);
1025 $param = unescape($param);
1026 $value = unescape($value);
1027 push(@{$self->{'.url_param'}->{$param}},$value);
1028 }
1029 } else {
1030 $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
1031 }
1032 }
1033 return keys %{$self->{'.url_param'}} unless defined($name);
1034 return () unless $self->{'.url_param'}->{$name};
1035 return wantarray ? @{$self->{'.url_param'}->{$name}}
1036 : $self->{'.url_param'}->{$name}->[0];
1037}
1038END_OF_FUNC
1039
1040#### Method: Dump
1041# Returns a string in which all the known parameter/value
1042# pairs are represented as nested lists, mainly for the purposes
1043# of debugging.
1044####
1045'Dump' => <<'END_OF_FUNC',
1046sub Dump {
1047 my($self) = self_or_default(@_);
1048 my($param,$value,@result);
1049 return '<ul></ul>' unless $self->param;
1050 push(@result,"<ul>");
1051 foreach $param ($self->param) {
1052 my($name)=$self->escapeHTML($param);
1053 push(@result,"<li><strong>$param</strong>");
1054 push(@result,"<ul>");
1055 foreach $value ($self->param($param)) {
1056 $value = $self->escapeHTML($value);
1057 $value =~ s/\n/<br>\n/g;
1058 push(@result,"<li>$value");
1059 }
1060 push(@result,"</ul>");
1061 }
1062 push(@result,"</ul>");
1063 return join("\n",@result);
1064}
1065END_OF_FUNC
1066
1067#### Method as_string
1068#
1069# synonym for "dump"
1070####
1071'as_string' => <<'END_OF_FUNC',
1072sub as_string {
1073 &Dump(@_);
1074}
1075END_OF_FUNC
1076
1077#### Method: save
1078# Write values out to a filehandle in such a way that they can
1079# be reinitialized by the filehandle form of the new() method
1080####
1081'save' => <<'END_OF_FUNC',
1082sub save {
1083 my($self,$filehandle) = self_or_default(@_);
1084 $filehandle = to_filehandle($filehandle);
1085 my($param);
1086 local($,) = ''; # set print field separator back to a sane value
1087 local($\) = ''; # set output line separator to a sane value
1088 foreach $param ($self->param) {
1089 my($escaped_param) = escape($param);
1090 my($value);
1091 foreach $value ($self->param($param)) {
1092 print $filehandle "$escaped_param=",escape("$value"),"\n";
1093 }
1094 }
1095 foreach (keys %{$self->{'.fieldnames'}}) {
1096 print $filehandle ".cgifields=",escape("$_"),"\n";
1097 }
1098 print $filehandle "=\n"; # end of record
1099}
1100END_OF_FUNC
1101
1102
1103#### Method: save_parameters
1104# An alias for save() that is a better name for exportation.
1105# Only intended to be used with the function (non-OO) interface.
1106####
1107'save_parameters' => <<'END_OF_FUNC',
1108sub save_parameters {
1109 my $fh = shift;
1110 return save(to_filehandle($fh));
1111}
1112END_OF_FUNC
1113
1114#### Method: restore_parameters
1115# A way to restore CGI parameters from an initializer.
1116# Only intended to be used with the function (non-OO) interface.
1117####
1118'restore_parameters' => <<'END_OF_FUNC',
1119sub restore_parameters {
1120 $Q = $CGI::DefaultClass->new(@_);
1121}
1122END_OF_FUNC
1123
1124#### Method: multipart_init
1125# Return a Content-Type: style header for server-push
1126# This has to be NPH on most web servers, and it is advisable to set $| = 1
1127#
1128# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1129# contribution, updated by Andrew Benham (adsb@bigfoot.com)
1130####
1131'multipart_init' => <<'END_OF_FUNC',
1132sub multipart_init {
1133 my($self,@p) = self_or_default(@_);
1134 my($boundary,@other) = rearrange([BOUNDARY],@p);
1135 $boundary = $boundary || '------- =_aaaaaaaaaa0';
1136 $self->{'separator'} = "$CRLF--$boundary$CRLF";
1137 $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
1138 $type = SERVER_PUSH($boundary);
1139 return $self->header(
1140 -nph => 1,
1141 -type => $type,
1142 (map { split "=", $_, 2 } @other),
1143 ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
1144}
1145END_OF_FUNC
1146
1147
1148#### Method: multipart_start
1149# Return a Content-Type: style header for server-push, start of section
1150#
1151# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1152# contribution, updated by Andrew Benham (adsb@bigfoot.com)
1153####
1154'multipart_start' => <<'END_OF_FUNC',
1155sub multipart_start {
1156 my(@header);
1157 my($self,@p) = self_or_default(@_);
1158 my($type,@other) = rearrange([TYPE],@p);
1159 $type = $type || 'text/html';
1160 push(@header,"Content-Type: $type");
1161
1162 # rearrange() was designed for the HTML portion, so we
1163 # need to fix it up a little.
1164 foreach (@other) {
1165 next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
1166 ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
1167 }
1168 push(@header,@other);
1169 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1170 return $header;
1171}
1172END_OF_FUNC
1173
1174
1175#### Method: multipart_end
1176# Return a MIME boundary separator for server-push, end of section
1177#
1178# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1179# contribution
1180####
1181'multipart_end' => <<'END_OF_FUNC',
1182sub multipart_end {
1183 my($self,@p) = self_or_default(@_);
1184 return $self->{'separator'};
1185}
1186END_OF_FUNC
1187
1188
1189#### Method: multipart_final
1190# Return a MIME boundary separator for server-push, end of all sections
1191#
1192# Contributed by Andrew Benham (adsb@bigfoot.com)
1193####
1194'multipart_final' => <<'END_OF_FUNC',
1195sub multipart_final {
1196 my($self,@p) = self_or_default(@_);
1197 return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
1198}
1199END_OF_FUNC
1200
1201
1202#### Method: header
1203# Return a Content-Type: style header
1204#
1205####
1206'header' => <<'END_OF_FUNC',
1207sub header {
1208 my($self,@p) = self_or_default(@_);
1209 my(@header);
1210
1211 return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
1212
1213 my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,@other) =
1214 rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
1215 'STATUS',['COOKIE','COOKIES'],'TARGET',
1216 'EXPIRES','NPH','CHARSET',
1217 'ATTACHMENT'],@p);
1218
1219 $nph ||= $NPH;
1220 if (defined $charset) {
1221 $self->charset($charset);
1222 } else {
1223 $charset = $self->charset;
1224 }
1225
1226 # rearrange() was designed for the HTML portion, so we
1227 # need to fix it up a little.
1228 foreach (@other) {
1229 next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
1230 ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
1231 $header = ucfirst($header);
1232 }
1233
1234 $type ||= 'text/html' unless defined($type);
1235 $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/;
1236
1237 # Maybe future compatibility. Maybe not.
1238 my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
1239 push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
1240 push(@header,"Server: " . &server_software()) if $nph;
1241
1242 push(@header,"Status: $status") if $status;
1243 push(@header,"Window-Target: $target") if $target;
1244 # push all the cookies -- there may be several
1245 if ($cookie) {
1246 my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
1247 foreach (@cookie) {
1248 my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
1249 push(@header,"Set-Cookie: $cs") if $cs ne '';
1250 }
1251 }
1252 # if the user indicates an expiration time, then we need
1253 # both an Expires and a Date header (so that the browser is
1254 # uses OUR clock)
1255 push(@header,"Expires: " . expires($expires,'http'))
1256 if $expires;
1257 push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
1258 push(@header,"Pragma: no-cache") if $self->cache();
1259 push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
1260 push(@header,map {ucfirst $_} @other);
1261 push(@header,"Content-Type: $type") if $type ne '';
1262
1263 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1264 if ($MOD_PERL and not $nph) {
1265 my $r = Apache->request;
1266 $r->send_cgi_header($header);
1267 return '';
1268 }
1269 return $header;
1270}
1271END_OF_FUNC
1272
1273
1274#### Method: cache
1275# Control whether header() will produce the no-cache
1276# Pragma directive.
1277####
1278'cache' => <<'END_OF_FUNC',
1279sub cache {
1280 my($self,$new_value) = self_or_default(@_);
1281 $new_value = '' unless $new_value;
1282 if ($new_value ne '') {
1283 $self->{'cache'} = $new_value;
1284 }
1285 return $self->{'cache'};
1286}
1287END_OF_FUNC
1288
1289
1290#### Method: redirect
1291# Return a Location: style header
1292#
1293####
1294'redirect' => <<'END_OF_FUNC',
1295sub redirect {
1296 my($self,@p) = self_or_default(@_);
1297 my($url,$target,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p);
1298 $url ||= $self->self_url;
1299 my(@o);
1300 foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
1301 unshift(@o,
1302 '-Status'=>'302 Moved',
1303 '-Location'=>$url,
1304 '-nph'=>$nph);
1305 unshift(@o,'-Target'=>$target) if $target;
1306 unshift(@o,'-Cookie'=>$cookie) if $cookie;
1307 unshift(@o,'-Type'=>'');
1308 return $self->header(@o);
1309}
1310END_OF_FUNC
1311
1312
1313#### Method: start_html
1314# Canned HTML header
1315#
1316# Parameters:
1317# $title -> (optional) The title for this HTML document (-title)
1318# $author -> (optional) e-mail address of the author (-author)
1319# $base -> (optional) if set to true, will enter the BASE address of this document
1320# for resolving relative references (-base)
1321# $xbase -> (optional) alternative base at some remote location (-xbase)
1322# $target -> (optional) target window to load all links into (-target)
1323# $script -> (option) Javascript code (-script)
1324# $no_script -> (option) Javascript <noscript> tag (-noscript)
1325# $meta -> (optional) Meta information tags
1326# $head -> (optional) any other elements you'd like to incorporate into the <head> tag
1327# (a scalar or array ref)
1328# $style -> (optional) reference to an external style sheet
1329# @other -> (optional) any other named parameters you'd like to incorporate into
1330# the <body> tag.
1331####
1332'start_html' => <<'END_OF_FUNC',
1333sub start_html {
1334 my($self,@p) = &self_or_default(@_);
1335 my($title,$author,$base,$xbase,$script,$noscript,
1336 $target,$meta,$head,$style,$dtd,$lang,$encoding,@other) =
1337 rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD,LANG,ENCODING],@p);
1338
1339 $encoding = 'iso-8859-1' unless defined $encoding;
1340
1341 # strangely enough, the title needs to be escaped as HTML
1342 # while the author needs to be escaped as a URL
1343 $title = $self->escapeHTML($title || 'Untitled Document');
1344 $author = $self->escape($author);
1345 $lang ||= 'en-US';
1346 my(@result,$xml_dtd);
1347 if ($dtd) {
1348 if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
1349 $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
1350 } else {
1351 $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
1352 }
1353 } else {
1354 $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
1355 }
1356
1357 $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
1358 $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
1359 push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd;
1360
1361 if (ref($dtd) && ref($dtd) eq 'ARRAY') {
1362 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
1363 } else {
1364 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
1365 }
1366 push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml" lang="$lang"><head><title>$title</title>)
1367 : qq(<html lang="$lang"><head><title>$title</title>));
1368 if (defined $author) {
1369 push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
1370 : "<link rev=\"made\" href=\"mailto:$author\">");
1371 }
1372
1373 if ($base || $xbase || $target) {
1374 my $href = $xbase || $self->url('-path'=>1);
1375 my $t = $target ? qq/ target="$target"/ : '';
1376 push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
1377 }
1378
1379 if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
1380 foreach (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
1381 : qq(<meta name="$_" content="$meta->{$_}">)); }
1382 }
1383
1384 push(@result,ref($head) ? @$head : $head) if $head;
1385
1386 # handle the infrequently-used -style and -script parameters
1387 push(@result,$self->_style($style)) if defined $style;
1388 push(@result,$self->_script($script)) if defined $script;
1389
1390 # handle -noscript parameter
1391 push(@result,<<END) if $noscript;
1392<noscript>
1393$noscript
1394</noscript>
1395END
1396 ;
1397 my($other) = @other ? " @other" : '';
1398 push(@result,"</head><body$other>");
1399 return join("\n",@result);
1400}
1401END_OF_FUNC
1402
1403### Method: _style
1404# internal method for generating a CSS style section
1405####
1406'_style' => <<'END_OF_FUNC',
1407sub _style {
1408 my ($self,$style) = @_;
1409 my (@result);
1410 my $type = 'text/css';
1411
1412 my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
1413 my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
1414
1415 if (ref($style)) {
1416 my($src,$code,$stype,@other) =
1417 rearrange([SRC,CODE,TYPE],
1418 '-foo'=>'bar', # a trick to allow the '-' to be omitted
1419 ref($style) eq 'ARRAY' ? @$style : %$style);
1420 $type = $stype if $stype;
1421 if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
1422 { # If it is, push a LINK tag for each one.
1423 foreach $src (@$src)
1424 {
1425 push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" />)
1426 : qq(<link rel="stylesheet" type="$type" href="$src">)) if $src;
1427 }
1428 }
1429 else
1430 { # Otherwise, push the single -src, if it exists.
1431 push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" />)
1432 : qq(<link rel="stylesheet" type="$type" href="$src">)
1433 ) if $src;
1434 }
1435 push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code;
1436 } else {
1437 push(@result,style({'type'=>$type},"$cdata_start\n$style\n$cdata_end"));
1438 }
1439 @result;
1440}
1441END_OF_FUNC
1442
1443'_script' => <<'END_OF_FUNC',
1444sub _script {
1445 my ($self,$script) = @_;
1446 my (@result);
1447
1448 my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
1449 foreach $script (@scripts) {
1450 my($src,$code,$language);
1451 if (ref($script)) { # script is a hash
1452 ($src,$code,$language, $type) =
1453 rearrange([SRC,CODE,LANGUAGE,TYPE],
1454 '-foo'=>'bar', # a trick to allow the '-' to be omitted
1455 ref($script) eq 'ARRAY' ? @$script : %$script);
1456 # User may not have specified language
1457 $language ||= 'JavaScript';
1458 unless (defined $type) {
1459 $type = lc $language;
1460 # strip '1.2' from 'javascript1.2'
1461 $type =~ s/^(\D+).*$/text\/$1/;
1462 }
1463 } else {
1464 ($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript');
1465 }
1466
1467 my $comment = '//'; # javascript by default
1468 $comment = '#' if $type=~/perl|tcl/i;
1469 $comment = "'" if $type=~/vbscript/i;
1470
1471 my $cdata_start = "\n<!-- Hide script\n";
1472 $cdata_start .= "$comment<![CDATA[\n" if $XHTML;
1473 my $cdata_end = $XHTML ? "\n$comment]]>" : $comment;
1474 $cdata_end .= " End script hiding -->\n";
1475
1476 my(@satts);
1477 push(@satts,'src'=>$src) if $src;
1478 push(@satts,'language'=>$language);
1479 push(@satts,'type'=>$type);
1480 $code = "$cdata_start$code$cdata_end" if defined $code;
1481 push(@result,script({@satts},$code || ''));
1482 }
1483 @result;
1484}
1485END_OF_FUNC
1486
1487#### Method: end_html
1488# End an HTML document.
1489# Trivial method for completeness. Just returns "</body>"
1490####
1491'end_html' => <<'END_OF_FUNC',
1492sub end_html {
1493 return "</body></html>";
1494}
1495END_OF_FUNC
1496
1497
1498################################
1499# METHODS USED IN BUILDING FORMS
1500################################
1501
1502#### Method: isindex
1503# Just prints out the isindex tag.
1504# Parameters:
1505# $action -> optional URL of script to run
1506# Returns:
1507# A string containing a <ISINDEX> tag
1508'isindex' => <<'END_OF_FUNC',
1509sub isindex {
1510 my($self,@p) = self_or_default(@_);
1511 my($action,@other) = rearrange([ACTION],@p);
1512 $action = qq/action="$action"/ if $action;
1513 my($other) = @other ? " @other" : '';
1514 return $XHTML ? "<isindex $action$other />" : "<isindex $action$other>";
1515}
1516END_OF_FUNC
1517
1518
1519#### Method: startform
1520# Start a form
1521# Parameters:
1522# $method -> optional submission method to use (GET or POST)
1523# $action -> optional URL of script to run
1524# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1525'startform' => <<'END_OF_FUNC',
1526sub startform {
1527 my($self,@p) = self_or_default(@_);
1528
1529 my($method,$action,$enctype,@other) =
1530 rearrange([METHOD,ACTION,ENCTYPE],@p);
1531
1532 $method = lc($method) || 'post';
1533 $enctype = $enctype || &URL_ENCODED;
1534 unless (defined $action) {
1535 $action = $self->url(-absolute=>1,-path=>1);
1536 $action .= "?$ENV{QUERY_STRING}" if $ENV{QUERY_STRING};
1537 }
1538 $action = qq(action="$action");
1539 my($other) = @other ? " @other" : '';
1540 $self->{'.parametersToAdd'}={};
1541 return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
1542}
1543END_OF_FUNC
1544
1545
1546#### Method: start_form
1547# synonym for startform
1548'start_form' => <<'END_OF_FUNC',
1549sub start_form {
1550 &startform;
1551}
1552END_OF_FUNC
1553
1554'end_multipart_form' => <<'END_OF_FUNC',
1555sub end_multipart_form {
1556 &endform;
1557}
1558END_OF_FUNC
1559
1560#### Method: start_multipart_form
1561# synonym for startform
1562'start_multipart_form' => <<'END_OF_FUNC',
1563sub start_multipart_form {
1564 my($self,@p) = self_or_default(@_);
1565 if (defined($param[0]) && substr($param[0],0,1) eq '-') {
1566 my(%p) = @p;
1567 $p{'-enctype'}=&MULTIPART;
1568 return $self->startform(%p);
1569 } else {
1570 my($method,$action,@other) =
1571 rearrange([METHOD,ACTION],@p);
1572 return $self->startform($method,$action,&MULTIPART,@other);
1573 }
1574}
1575END_OF_FUNC
1576
1577
1578#### Method: endform
1579# End a form
1580'endform' => <<'END_OF_FUNC',
1581sub endform {
1582 my($self,@p) = self_or_default(@_);
1583 if ( $NOSTICKY ) {
1584 return wantarray ? ("</form>") : "\n</form>";
1585 } else {
1586 return wantarray ? ($self->get_fields,"</form>") :
1587 $self->get_fields ."\n</form>";
1588 }
1589}
1590END_OF_FUNC
1591
1592
1593#### Method: end_form
1594# synonym for endform
1595'end_form' => <<'END_OF_FUNC',
1596sub end_form {
1597 &endform;
1598}
1599END_OF_FUNC
1600
1601
1602'_textfield' => <<'END_OF_FUNC',
1603sub _textfield {
1604 my($self,$tag,@p) = self_or_default(@_);
1605 my($name,$default,$size,$maxlength,$override,@other) =
1606 rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
1607
1608 my $current = $override ? $default :
1609 (defined($self->param($name)) ? $self->param($name) : $default);
1610
1611 $current = defined($current) ? $self->escapeHTML($current,1) : '';
1612 $name = defined($name) ? $self->escapeHTML($name) : '';
1613 my($s) = defined($size) ? qq/ size="$size"/ : '';
1614 my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
1615 my($other) = @other ? " @other" : '';
1616 # this entered at cristy's request to fix problems with file upload fields
1617 # and WebTV -- not sure it won't break stuff
1618 my($value) = $current ne '' ? qq(value="$current") : '';
1619 return $XHTML ? qq(<input type="$tag" name="$name" $value$s$m$other />)
1620 : qq(<input type="$tag" name="$name" $value$s$m$other>);
1621}
1622END_OF_FUNC
1623
1624#### Method: textfield
1625# Parameters:
1626# $name -> Name of the text field
1627# $default -> Optional default value of the field if not
1628# already defined.
1629# $size -> Optional width of field in characaters.
1630# $maxlength -> Optional maximum number of characters.
1631# Returns:
1632# A string containing a <INPUT TYPE="text"> field
1633#
1634'textfield' => <<'END_OF_FUNC',
1635sub textfield {
1636 my($self,@p) = self_or_default(@_);
1637 $self->_textfield('text',@p);
1638}
1639END_OF_FUNC
1640
1641
1642#### Method: filefield
1643# Parameters:
1644# $name -> Name of the file upload field
1645# $size -> Optional width of field in characaters.
1646# $maxlength -> Optional maximum number of characters.
1647# Returns:
1648# A string containing a <INPUT TYPE="text"> field
1649#
1650'filefield' => <<'END_OF_FUNC',
1651sub filefield {
1652 my($self,@p) = self_or_default(@_);
1653 $self->_textfield('file',@p);
1654}
1655END_OF_FUNC
1656
1657
1658#### Method: password
1659# Create a "secret password" entry field
1660# Parameters:
1661# $name -> Name of the field
1662# $default -> Optional default value of the field if not
1663# already defined.
1664# $size -> Optional width of field in characters.
1665# $maxlength -> Optional maximum characters that can be entered.
1666# Returns:
1667# A string containing a <INPUT TYPE="password"> field
1668#
1669'password_field' => <<'END_OF_FUNC',
1670sub password_field {
1671 my ($self,@p) = self_or_default(@_);
1672 $self->_textfield('password',@p);
1673}
1674END_OF_FUNC
1675
1676#### Method: textarea
1677# Parameters:
1678# $name -> Name of the text field
1679# $default -> Optional default value of the field if not
1680# already defined.
1681# $rows -> Optional number of rows in text area
1682# $columns -> Optional number of columns in text area
1683# Returns:
1684# A string containing a <textarea></textarea> tag
1685#
1686'textarea' => <<'END_OF_FUNC',
1687sub textarea {
1688 my($self,@p) = self_or_default(@_);
1689
1690 my($name,$default,$rows,$cols,$override,@other) =
1691 rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
1692
1693 my($current)= $override ? $default :
1694 (defined($self->param($name)) ? $self->param($name) : $default);
1695
1696 $name = defined($name) ? $self->escapeHTML($name) : '';
1697 $current = defined($current) ? $self->escapeHTML($current) : '';
1698 my($r) = $rows ? qq/ rows="$rows"/ : '';
1699 my($c) = $cols ? qq/ cols="$cols"/ : '';
1700 my($other) = @other ? " @other" : '';
1701 return qq{<textarea name="$name"$r$c$other>$current</textarea>};
1702}
1703END_OF_FUNC
1704
1705
1706#### Method: button
1707# Create a javascript button.
1708# Parameters:
1709# $name -> (optional) Name for the button. (-name)
1710# $value -> (optional) Value of the button when selected (and visible name) (-value)
1711# $onclick -> (optional) Text of the JavaScript to run when the button is
1712# clicked.
1713# Returns:
1714# A string containing a <INPUT TYPE="button"> tag
1715####
1716'button' => <<'END_OF_FUNC',
1717sub button {
1718 my($self,@p) = self_or_default(@_);
1719
1720 my($label,$value,$script,@other) = rearrange([NAME,[VALUE,LABEL],
1721 [ONCLICK,SCRIPT]],@p);
1722
1723 $label=$self->escapeHTML($label);
1724 $value=$self->escapeHTML($value,1);
1725 $script=$self->escapeHTML($script);
1726
1727 my($name) = '';
1728 $name = qq/ name="$label"/ if $label;
1729 $value = $value || $label;
1730 my($val) = '';
1731 $val = qq/ value="$value"/ if $value;
1732 $script = qq/ onclick="$script"/ if $script;
1733 my($other) = @other ? " @other" : '';
1734 return $XHTML ? qq(<input type="button"$name$val$script$other />)
1735 : qq(<input type="button"$name$val$script$other>);
1736}
1737END_OF_FUNC
1738
1739
1740#### Method: submit
1741# Create a "submit query" button.
1742# Parameters:
1743# $name -> (optional) Name for the button.
1744# $value -> (optional) Value of the button when selected (also doubles as label).
1745# $label -> (optional) Label printed on the button(also doubles as the value).
1746# Returns:
1747# A string containing a <INPUT TYPE="submit"> tag
1748####
1749'submit' => <<'END_OF_FUNC',
1750sub submit {
1751 my($self,@p) = self_or_default(@_);
1752
1753 my($label,$value,@other) = rearrange([NAME,[VALUE,LABEL]],@p);
1754
1755 $label=$self->escapeHTML($label);
1756 $value=$self->escapeHTML($value,1);
1757
1758 my($name) = ' name=".submit"' unless $NOSTICKY;
1759 $name = qq/ name="$label"/ if defined($label);
1760 $value = defined($value) ? $value : $label;
1761 my($val) = '';
1762 $val = qq/ value="$value"/ if defined($value);
1763 my($other) = @other ? " @other" : '';
1764 return $XHTML ? qq(<input type="submit"$name$val$other />)
1765 : qq(<input type="submit"$name$val$other>);
1766}
1767END_OF_FUNC
1768
1769
1770#### Method: reset
1771# Create a "reset" button.
1772# Parameters:
1773# $name -> (optional) Name for the button.
1774# Returns:
1775# A string containing a <INPUT TYPE="reset"> tag
1776####
1777'reset' => <<'END_OF_FUNC',
1778sub reset {
1779 my($self,@p) = self_or_default(@_);
1780 my($label,@other) = rearrange([NAME],@p);
1781 $label=$self->escapeHTML($label);
1782 my($value) = defined($label) ? qq/ value="$label"/ : '';
1783 my($other) = @other ? " @other" : '';
1784 return $XHTML ? qq(<input type="reset"$value$other />)
1785 : qq(<input type="reset"$value$other>);
1786}
1787END_OF_FUNC
1788
1789
1790#### Method: defaults
1791# Create a "defaults" button.
1792# Parameters:
1793# $name -> (optional) Name for the button.
1794# Returns:
1795# A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
1796#
1797# Note: this button has a special meaning to the initialization script,
1798# and tells it to ERASE the current query string so that your defaults
1799# are used again!
1800####
1801'defaults' => <<'END_OF_FUNC',
1802sub defaults {
1803 my($self,@p) = self_or_default(@_);
1804
1805 my($label,@other) = rearrange([[NAME,VALUE]],@p);
1806
1807 $label=$self->escapeHTML($label,1);
1808 $label = $label || "Defaults";
1809 my($value) = qq/ value="$label"/;
1810 my($other) = @other ? " @other" : '';
1811 return $XHTML ? qq(<input type="submit" name=".defaults"$value$other />)
1812 : qq/<input type="submit" NAME=".defaults"$value$other>/;
1813}
1814END_OF_FUNC
1815
1816
1817#### Method: comment
1818# Create an HTML <!-- comment -->
1819# Parameters: a string
1820'comment' => <<'END_OF_FUNC',
1821sub comment {
1822 my($self,@p) = self_or_CGI(@_);
1823 return "<!-- @p -->";
1824}
1825END_OF_FUNC
1826
1827#### Method: checkbox
1828# Create a checkbox that is not logically linked to any others.
1829# The field value is "on" when the button is checked.
1830# Parameters:
1831# $name -> Name of the checkbox
1832# $checked -> (optional) turned on by default if true
1833# $value -> (optional) value of the checkbox, 'on' by default
1834# $label -> (optional) a user-readable label printed next to the box.
1835# Otherwise the checkbox name is used.
1836# Returns:
1837# A string containing a <INPUT TYPE="checkbox"> field
1838####
1839'checkbox' => <<'END_OF_FUNC',
1840sub checkbox {
1841 my($self,@p) = self_or_default(@_);
1842
1843 my($name,$checked,$value,$label,$override,@other) =
1844 rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
1845
1846 $value = defined $value ? $value : 'on';
1847
1848 if (!$override && ($self->{'.fieldnames'}->{$name} ||
1849 defined $self->param($name))) {
1850 $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
1851 } else {
1852 $checked = $self->_checked($checked);
1853 }
1854 my($the_label) = defined $label ? $label : $name;
1855 $name = $self->escapeHTML($name);
1856 $value = $self->escapeHTML($value,1);
1857 $the_label = $self->escapeHTML($the_label);
1858 my($other) = @other ? " @other" : '';
1859 $self->register_parameter($name);
1860 return $XHTML ? qq{<input type="checkbox" name="$name" value="$value"$checked$other />$the_label}
1861 : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
1862}
1863END_OF_FUNC
1864
1865
1866#### Method: checkbox_group
1867# Create a list of logically-linked checkboxes.
1868# Parameters:
1869# $name -> Common name for all the check boxes
1870# $values -> A pointer to a regular array containing the
1871# values for each checkbox in the group.
1872# $defaults -> (optional)
1873# 1. If a pointer to a regular array of checkbox values,
1874# then this will be used to decide which
1875# checkboxes to turn on by default.
1876# 2. If a scalar, will be assumed to hold the
1877# value of a single checkbox in the group to turn on.
1878# $linebreak -> (optional) Set to true to place linebreaks
1879# between the buttons.
1880# $labels -> (optional)
1881# A pointer to an associative array of labels to print next to each checkbox
1882# in the form $label{'value'}="Long explanatory label".
1883# Otherwise the provided values are used as the labels.
1884# Returns:
1885# An ARRAY containing a series of <INPUT TYPE="checkbox"> fields
1886####
1887'checkbox_group' => <<'END_OF_FUNC',
1888sub checkbox_group {
1889 my($self,@p) = self_or_default(@_);
1890
1891 my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
1892 $rowheaders,$colheaders,$override,$nolabels,@other) =
1893 rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1894 LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
1895 ROWHEADERS,COLHEADERS,
1896 [OVERRIDE,FORCE],NOLABELS],@p);
1897
1898 my($checked,$break,$result,$label);
1899
1900 my(%checked) = $self->previous_or_default($name,$defaults,$override);
1901
1902 if ($linebreak) {
1903 $break = $XHTML ? "<br />" : "<br>";
1904 }
1905 else {
1906 $break = '';
1907 }
1908 $name=$self->escapeHTML($name);
1909
1910 # Create the elements
1911 my(@elements,@values);
1912
1913 @values = $self->_set_values_and_labels($values,\$labels,$name);
1914
1915 my($other) = @other ? " @other" : '';
1916 foreach (@values) {
1917 $checked = $self->_checked($checked{$_});
1918 $label = '';
1919 unless (defined($nolabels) && $nolabels) {
1920 $label = $_;
1921 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1922 $label = $self->escapeHTML($label);
1923 }
1924 $_ = $self->escapeHTML($_,1);
1925 push(@elements,$XHTML ? qq(<input type="checkbox" name="$name" value="$_"$checked$other />${label}${break})
1926 : qq/<input type="checkbox" name="$name" value="$_"$checked$other>${label}${break}/);
1927 }
1928 $self->register_parameter($name);
1929 return wantarray ? @elements : join(' ',@elements)
1930 unless defined($columns) || defined($rows);
1931 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1932}
1933END_OF_FUNC
1934
1935# Escape HTML -- used internally
1936'escapeHTML' => <<'END_OF_FUNC',
1937sub escapeHTML {
1938 # hack to work around earlier hacks
1939 push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
1940 my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
1941 return undef unless defined($toencode);
1942 return $toencode if ref($self) && $self->{'dontescape'};
1943 $toencode =~ s{&}{&amp;}gso;
1944 $toencode =~ s{<}{&lt;}gso;
1945 $toencode =~ s{>}{&gt;}gso;
1946 $toencode =~ s{"}{&quot;}gso;
1947 my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' ||
1948 uc $self->{'.charset'} eq 'WINDOWS-1252';
1949 if ($latin) { # bug in some browsers
1950 $toencode =~ s{'}{&#39;}gso;
1951 $toencode =~ s{\x8b}{&#139;}gso;
1952 $toencode =~ s{\x9b}{&#155;}gso;
1953 if (defined $newlinestoo && $newlinestoo) {
1954 $toencode =~ s{\012}{&#10;}gso;
1955 $toencode =~ s{\015}{&#13;}gso;
1956 }
1957 }
1958 return $toencode;
1959}
1960END_OF_FUNC
1961
1962# unescape HTML -- used internally
1963'unescapeHTML' => <<'END_OF_FUNC',
1964sub unescapeHTML {
1965 my ($self,$string) = CGI::self_or_default(@_);
1966 return undef unless defined($string);
1967 my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
1968 : 1;
1969 # thanks to Randal Schwartz for the correct solution to this one
1970 $string=~ s[&(.*?);]{
1971 local $_ = $1;
1972 /^amp$/i ? "&" :
1973 /^quot$/i ? '"' :
1974 /^gt$/i ? ">" :
1975 /^lt$/i ? "<" :
1976 /^#(\d+)$/ && $latin ? chr($1) :
1977 /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
1978 $_
1979 }gex;
1980 return $string;
1981}
1982END_OF_FUNC
1983
1984# Internal procedure - don't use
1985'_tableize' => <<'END_OF_FUNC',
1986sub _tableize {
1987 my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
1988 $rowheaders = [] unless defined $rowheaders;
1989 $colheaders = [] unless defined $colheaders;
1990 my($result);
1991
1992 if (defined($columns)) {
1993 $rows = int(0.99 + @elements/$columns) unless defined($rows);
1994 }
1995 if (defined($rows)) {
1996 $columns = int(0.99 + @elements/$rows) unless defined($columns);
1997 }
1998
1999 # rearrange into a pretty table
2000 $result = "<table>";
2001 my($row,$column);
2002 unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
2003 $result .= "<tr>" if @{$colheaders};
2004 foreach (@{$colheaders}) {
2005 $result .= "<th>$_</th>";
2006 }
2007 for ($row=0;$row<$rows;$row++) {
2008 $result .= "<tr>";
2009 $result .= "<th>$rowheaders->[$row]</th>" if @$rowheaders;
2010 for ($column=0;$column<$columns;$column++) {
2011 $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
2012 if defined($elements[$column*$rows + $row]);
2013 }
2014 $result .= "</tr>";
2015 }
2016 $result .= "</table>";
2017 return $result;
2018}
2019END_OF_FUNC
2020
2021
2022#### Method: radio_group
2023# Create a list of logically-linked radio buttons.
2024# Parameters:
2025# $name -> Common name for all the buttons.
2026# $values -> A pointer to a regular array containing the
2027# values for each button in the group.
2028# $default -> (optional) Value of the button to turn on by default. Pass '-'
2029# to turn _nothing_ on.
2030# $linebreak -> (optional) Set to true to place linebreaks
2031# between the buttons.
2032# $labels -> (optional)
2033# A pointer to an associative array of labels to print next to each checkbox
2034# in the form $label{'value'}="Long explanatory label".
2035# Otherwise the provided values are used as the labels.
2036# Returns:
2037# An ARRAY containing a series of <INPUT TYPE="radio"> fields
2038####
2039'radio_group' => <<'END_OF_FUNC',
2040sub radio_group {
2041 my($self,@p) = self_or_default(@_);
2042
2043 my($name,$values,$default,$linebreak,$labels,
2044 $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
2045 rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
2046 ROWS,[COLUMNS,COLS],
2047 ROWHEADERS,COLHEADERS,
2048 [OVERRIDE,FORCE],NOLABELS],@p);
2049 my($result,$checked);
2050
2051 if (!$override && defined($self->param($name))) {
2052 $checked = $self->param($name);
2053 } else {
2054 $checked = $default;
2055 }
2056 my(@elements,@values);
2057 @values = $self->_set_values_and_labels($values,\$labels,$name);
2058
2059 # If no check array is specified, check the first by default
2060 $checked = $values[0] unless defined($checked) && $checked ne '';
2061 $name=$self->escapeHTML($name);
2062
2063 my($other) = @other ? " @other" : '';
2064 foreach (@values) {
2065 my($checkit) = $checked eq $_ ? qq/ checked="checked"/ : '';
2066 my($break);
2067 if ($linebreak) {
2068 $break = $XHTML ? "<br />" : "<br>";
2069 }
2070 else {
2071 $break = '';
2072 }
2073 my($label)='';
2074 unless (defined($nolabels) && $nolabels) {
2075 $label = $_;
2076 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2077 $label = $self->escapeHTML($label,1);
2078 }
2079 $_=$self->escapeHTML($_);
2080 push(@elements,$XHTML ? qq(<input type="radio" name="$name" value="$_"$checkit$other />${label}${break})
2081 : qq/<input type="radio" name="$name" value="$_"$checkit$other>${label}${break}/);
2082 }
2083 $self->register_parameter($name);
2084 return wantarray ? @elements : join(' ',@elements)
2085 unless defined($columns) || defined($rows);
2086 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
2087}
2088END_OF_FUNC
2089
2090
2091#### Method: popup_menu
2092# Create a popup menu.
2093# Parameters:
2094# $name -> Name for all the menu
2095# $values -> A pointer to a regular array containing the
2096# text of each menu item.
2097# $default -> (optional) Default item to display
2098# $labels -> (optional)
2099# A pointer to an associative array of labels to print next to each checkbox
2100# in the form $label{'value'}="Long explanatory label".
2101# Otherwise the provided values are used as the labels.
2102# Returns:
2103# A string containing the definition of a popup menu.
2104####
2105'popup_menu' => <<'END_OF_FUNC',
2106sub popup_menu {
2107 my($self,@p) = self_or_default(@_);
2108
2109 my($name,$values,$default,$labels,$override,@other) =
2110 rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
2111 my($result,$selected);
2112
2113 if (!$override && defined($self->param($name))) {
2114 $selected = $self->param($name);
2115 } else {
2116 $selected = $default;
2117 }
2118 $name=$self->escapeHTML($name);
2119 my($other) = @other ? " @other" : '';
2120
2121 my(@values);
2122 @values = $self->_set_values_and_labels($values,\$labels,$name);
2123
2124 $result = qq/<select name="$name"$other>\n/;
2125 foreach (@values) {
2126 my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : '';
2127 my($label) = $_;
2128 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2129 my($value) = $self->escapeHTML($_);
2130 $label=$self->escapeHTML($label,1);
2131 $result .= "<option$selectit value=\"$value\">$label</option>\n";
2132 }
2133
2134 $result .= "</select>";
2135 return $result;
2136}
2137END_OF_FUNC
2138
2139
2140#### Method: scrolling_list
2141# Create a scrolling list.
2142# Parameters:
2143# $name -> name for the list
2144# $values -> A pointer to a regular array containing the
2145# values for each option line in the list.
2146# $defaults -> (optional)
2147# 1. If a pointer to a regular array of options,
2148# then this will be used to decide which
2149# lines to turn on by default.
2150# 2. Otherwise holds the value of the single line to turn on.
2151# $size -> (optional) Size of the list.
2152# $multiple -> (optional) If set, allow multiple selections.
2153# $labels -> (optional)
2154# A pointer to an associative array of labels to print next to each checkbox
2155# in the form $label{'value'}="Long explanatory label".
2156# Otherwise the provided values are used as the labels.
2157# Returns:
2158# A string containing the definition of a scrolling list.
2159####
2160'scrolling_list' => <<'END_OF_FUNC',
2161sub scrolling_list {
2162 my($self,@p) = self_or_default(@_);
2163 my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
2164 = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
2165 SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
2166
2167 my($result,@values);
2168 @values = $self->_set_values_and_labels($values,\$labels,$name);
2169
2170 $size = $size || scalar(@values);
2171
2172 my(%selected) = $self->previous_or_default($name,$defaults,$override);
2173 my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
2174 my($has_size) = $size ? qq/ size="$size"/: '';
2175 my($other) = @other ? " @other" : '';
2176
2177 $name=$self->escapeHTML($name);
2178 $result = qq/<select name="$name"$has_size$is_multiple$other>\n/;
2179 foreach (@values) {
2180 my($selectit) = $self->_selected($selected{$_});
2181 my($label) = $_;
2182 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
2183 $label=$self->escapeHTML($label);
2184 my($value)=$self->escapeHTML($_,1);
2185 $result .= "<option$selectit value=\"$value\">$label</option>\n";
2186 }
2187 $result .= "</select>";
2188 $self->register_parameter($name);
2189 return $result;
2190}
2191END_OF_FUNC
2192
2193
2194#### Method: hidden
2195# Parameters:
2196# $name -> Name of the hidden field
2197# @default -> (optional) Initial values of field (may be an array)
2198# or
2199# $default->[initial values of field]
2200# Returns:
2201# A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
2202####
2203'hidden' => <<'END_OF_FUNC',
2204sub hidden {
2205 my($self,@p) = self_or_default(@_);
2206
2207 # this is the one place where we departed from our standard
2208 # calling scheme, so we have to special-case (darn)
2209 my(@result,@value);
2210 my($name,$default,$override,@other) =
2211 rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
2212
2213 my $do_override = 0;
2214 if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
2215 @value = ref($default) ? @{$default} : $default;
2216 $do_override = $override;
2217 } else {
2218 foreach ($default,$override,@other) {
2219 push(@value,$_) if defined($_);
2220 }
2221 }
2222
2223 # use previous values if override is not set
2224 my @prev = $self->param($name);
2225 @value = @prev if !$do_override && @prev;
2226
2227 $name=$self->escapeHTML($name);
2228 foreach (@value) {
2229 $_ = defined($_) ? $self->escapeHTML($_,1) : '';
2230 push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" />)
2231 : qq(<input type="hidden" name="$name" value="$_">);
2232 }
2233 return wantarray ? @result : join('',@result);
2234}
2235END_OF_FUNC
2236
2237
2238#### Method: image_button
2239# Parameters:
2240# $name -> Name of the button
2241# $src -> URL of the image source
2242# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
2243# Returns:
2244# A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment">
2245####
2246'image_button' => <<'END_OF_FUNC',
2247sub image_button {
2248 my($self,@p) = self_or_default(@_);
2249
2250 my($name,$src,$alignment,@other) =
2251 rearrange([NAME,SRC,ALIGN],@p);
2252
2253 my($align) = $alignment ? " align=\U\"$alignment\"" : '';
2254 my($other) = @other ? " @other" : '';
2255 $name=$self->escapeHTML($name);
2256 return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
2257 : qq/<input type="image" name="$name" src="$src"$align$other>/;
2258}
2259END_OF_FUNC
2260
2261
2262#### Method: self_url
2263# Returns a URL containing the current script and all its
2264# param/value pairs arranged as a query. You can use this
2265# to create a link that, when selected, will reinvoke the
2266# script with all its state information preserved.
2267####
2268'self_url' => <<'END_OF_FUNC',
2269sub self_url {
2270 my($self,@p) = self_or_default(@_);
2271 return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
2272}
2273END_OF_FUNC
2274
2275
2276# This is provided as a synonym to self_url() for people unfortunate
2277# enough to have incorporated it into their programs already!
2278'state' => <<'END_OF_FUNC',
2279sub state {
2280 &self_url;
2281}
2282END_OF_FUNC
2283
2284
2285#### Method: url
2286# Like self_url, but doesn't return the query string part of
2287# the URL.
2288####
2289'url' => <<'END_OF_FUNC',
2290sub url {
2291 my($self,@p) = self_or_default(@_);
2292 my ($relative,$absolute,$full,$path_info,$query,$base) =
2293 rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE'],@p);
2294 my $url;
2295 $full++ if $base || !($relative || $absolute);
2296
2297 my $path = $self->path_info;
2298 my $script_name = $self->script_name;
2299
2300 # for compatibility with Apache's MultiViews
2301 if (exists($ENV{REQUEST_URI})) {
2302 my $index;
2303 $script_name = $ENV{REQUEST_URI};
2304 $script_name =~ s/\?.+$//; # strip query string
2305 # and path
2306 if (exists($ENV{PATH_INFO})) {
2307 (my $encoded_path = $ENV{PATH_INFO}) =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
2308 $script_name =~ s/$encoded_path$//i;
2309 }
2310 }
2311
2312 if ($full) {
2313 my $protocol = $self->protocol();
2314 $url = "$protocol://";
2315 my $vh = http('host');
2316 if ($vh) {
2317 $url .= $vh;
2318 } else {
2319 $url .= server_name();
2320 my $port = $self->server_port;
2321 $url .= ":" . $port
2322 unless (lc($protocol) eq 'http' && $port == 80)
2323 || (lc($protocol) eq 'https' && $port == 443);
2324 }
2325 return $url if $base;
2326 $url .= $script_name;
2327 } elsif ($relative) {
2328 ($url) = $script_name =~ m!([^/]+)$!;
2329 } elsif ($absolute) {
2330 $url = $script_name;
2331 }
2332
2333 $url .= $path if $path_info and defined $path;
2334 $url .= "?" . $self->query_string if $query and $self->query_string;
2335 $url = '' unless defined $url;
2336 $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
2337 return $url;
2338}
2339
2340END_OF_FUNC
2341
2342#### Method: cookie
2343# Set or read a cookie from the specified name.
2344# Cookie can then be passed to header().
2345# Usual rules apply to the stickiness of -value.
2346# Parameters:
2347# -name -> name for this cookie (optional)
2348# -value -> value of this cookie (scalar, array or hash)
2349# -path -> paths for which this cookie is valid (optional)
2350# -domain -> internet domain in which this cookie is valid (optional)
2351# -secure -> if true, cookie only passed through secure channel (optional)
2352# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
2353####
2354'cookie' => <<'END_OF_FUNC',
2355sub cookie {
2356 my($self,@p) = self_or_default(@_);
2357 my($name,$value,$path,$domain,$secure,$expires) =
2358 rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
2359
2360 require CGI::Cookie;
2361
2362 # if no value is supplied, then we retrieve the
2363 # value of the cookie, if any. For efficiency, we cache the parsed
2364 # cookies in our state variables.
2365 unless ( defined($value) ) {
2366 $self->{'.cookies'} = CGI::Cookie->fetch
2367 unless $self->{'.cookies'};
2368
2369 # If no name is supplied, then retrieve the names of all our cookies.
2370 return () unless $self->{'.cookies'};
2371 return keys %{$self->{'.cookies'}} unless $name;
2372 return () unless $self->{'.cookies'}->{$name};
2373 return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
2374 }
2375
2376 # If we get here, we're creating a new cookie
2377 return undef unless defined($name) && $name ne ''; # this is an error
2378
2379 my @param;
2380 push(@param,'-name'=>$name);
2381 push(@param,'-value'=>$value);
2382 push(@param,'-domain'=>$domain) if $domain;
2383 push(@param,'-path'=>$path) if $path;
2384 push(@param,'-expires'=>$expires) if $expires;
2385 push(@param,'-secure'=>$secure) if $secure;
2386
2387 return new CGI::Cookie(@param);
2388}
2389END_OF_FUNC
2390
2391'parse_keywordlist' => <<'END_OF_FUNC',
2392sub parse_keywordlist {
2393 my($self,$tosplit) = @_;
2394 $tosplit = unescape($tosplit); # unescape the keywords
2395 $tosplit=~tr/+/ /; # pluses to spaces
2396 my(@keywords) = split(/\s+/,$tosplit);
2397 return @keywords;
2398}
2399END_OF_FUNC
2400
2401'param_fetch' => <<'END_OF_FUNC',
2402sub param_fetch {
2403 my($self,@p) = self_or_default(@_);
2404 my($name) = rearrange([NAME],@p);
2405 unless (exists($self->{$name})) {
2406 $self->add_parameter($name);
2407 $self->{$name} = [];
2408 }
2409
2410 return $self->{$name};
2411}
2412END_OF_FUNC
2413
2414###############################################
2415# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
2416###############################################
2417
2418#### Method: path_info
2419# Return the extra virtual path information provided
2420# after the URL (if any)
2421####
2422'path_info' => <<'END_OF_FUNC',
2423sub path_info {
2424 my ($self,$info) = self_or_default(@_);
2425 if (defined($info)) {
2426 $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
2427 $self->{'.path_info'} = $info;
2428 } elsif (! defined($self->{'.path_info'}) ) {
2429 $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ?
2430 $ENV{'PATH_INFO'} : '';
2431
2432 # hack to fix broken path info in IIS
2433 $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
2434
2435 }
2436 return $self->{'.path_info'};
2437}
2438END_OF_FUNC
2439
2440
2441#### Method: request_method
2442# Returns 'POST', 'GET', 'PUT' or 'HEAD'
2443####
2444'request_method' => <<'END_OF_FUNC',
2445sub request_method {
2446 return $ENV{'REQUEST_METHOD'};
2447}
2448END_OF_FUNC
2449
2450#### Method: content_type
2451# Returns the content_type string
2452####
2453'content_type' => <<'END_OF_FUNC',
2454sub content_type {
2455 return $ENV{'CONTENT_TYPE'};
2456}
2457END_OF_FUNC
2458
2459#### Method: path_translated
2460# Return the physical path information provided
2461# by the URL (if any)
2462####
2463'path_translated' => <<'END_OF_FUNC',
2464sub path_translated {
2465 return $ENV{'PATH_TRANSLATED'};
2466}
2467END_OF_FUNC
2468
2469
2470#### Method: query_string
2471# Synthesize a query string from our current
2472# parameters
2473####
2474'query_string' => <<'END_OF_FUNC',
2475sub query_string {
2476 my($self) = self_or_default(@_);
2477 my($param,$value,@pairs);
2478 foreach $param ($self->param) {
2479 my($eparam) = escape($param);
2480 foreach $value ($self->param($param)) {
2481 $value = escape($value);
2482 next unless defined $value;
2483 push(@pairs,"$eparam=$value");
2484 }
2485 }
2486 foreach (keys %{$self->{'.fieldnames'}}) {
2487 push(@pairs,".cgifields=".escape("$_"));
2488 }
2489 return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
2490}
2491END_OF_FUNC
2492
2493
2494#### Method: accept
2495# Without parameters, returns an array of the
2496# MIME types the browser accepts.
2497# With a single parameter equal to a MIME
2498# type, will return undef if the browser won't
2499# accept it, 1 if the browser accepts it but
2500# doesn't give a preference, or a floating point
2501# value between 0.0 and 1.0 if the browser
2502# declares a quantitative score for it.
2503# This handles MIME type globs correctly.
2504####
2505'Accept' => <<'END_OF_FUNC',
2506sub Accept {
2507 my($self,$search) = self_or_CGI(@_);
2508 my(%prefs,$type,$pref,$pat);
2509
2510 my(@accept) = split(',',$self->http('accept'));
2511
2512 foreach (@accept) {
2513 ($pref) = /q=(\d\.\d+|\d+)/;
2514 ($type) = m#(\S+/[^;]+)#;
2515 next unless $type;
2516 $prefs{$type}=$pref || 1;
2517 }
2518
2519 return keys %prefs unless $search;
2520
2521 # if a search type is provided, we may need to
2522 # perform a pattern matching operation.
2523 # The MIME types use a glob mechanism, which
2524 # is easily translated into a perl pattern match
2525
2526 # First return the preference for directly supported
2527 # types:
2528 return $prefs{$search} if $prefs{$search};
2529
2530 # Didn't get it, so try pattern matching.
2531 foreach (keys %prefs) {
2532 next unless /\*/; # not a pattern match
2533 ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2534 $pat =~ s/\*/.*/g; # turn it into a pattern
2535 return $prefs{$_} if $search=~/$pat/;
2536 }
2537}
2538END_OF_FUNC
2539
2540
2541#### Method: user_agent
2542# If called with no parameters, returns the user agent.
2543# If called with one parameter, does a pattern match (case
2544# insensitive) on the user agent.
2545####
2546'user_agent' => <<'END_OF_FUNC',
2547sub user_agent {
2548 my($self,$match)=self_or_CGI(@_);
2549 return $self->http('user_agent') unless $match;
2550 return $self->http('user_agent') =~ /$match/i;
2551}
2552END_OF_FUNC
2553
2554
2555#### Method: raw_cookie
2556# Returns the magic cookies for the session.
2557# The cookies are not parsed or altered in any way, i.e.
2558# cookies are returned exactly as given in the HTTP
2559# headers. If a cookie name is given, only that cookie's
2560# value is returned, otherwise the entire raw cookie
2561# is returned.
2562####
2563'raw_cookie' => <<'END_OF_FUNC',
2564sub raw_cookie {
2565 my($self,$key) = self_or_CGI(@_);
2566
2567 require CGI::Cookie;
2568
2569 if (defined($key)) {
2570 $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
2571 unless $self->{'.raw_cookies'};
2572
2573 return () unless $self->{'.raw_cookies'};
2574 return () unless $self->{'.raw_cookies'}->{$key};
2575 return $self->{'.raw_cookies'}->{$key};
2576 }
2577 return $self->http('cookie') || $ENV{'COOKIE'} || '';
2578}
2579END_OF_FUNC
2580
2581#### Method: virtual_host
2582# Return the name of the virtual_host, which
2583# is not always the same as the server
2584######
2585'virtual_host' => <<'END_OF_FUNC',
2586sub virtual_host {
2587 my $vh = http('host') || server_name();
2588 $vh =~ s/:\d+$//; # get rid of port number
2589 return $vh;
2590}
2591END_OF_FUNC
2592
2593#### Method: remote_host
2594# Return the name of the remote host, or its IP
2595# address if unavailable. If this variable isn't
2596# defined, it returns "localhost" for debugging
2597# purposes.
2598####
2599'remote_host' => <<'END_OF_FUNC',
2600sub remote_host {
2601 return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
2602 || 'localhost';
2603}
2604END_OF_FUNC
2605
2606
2607#### Method: remote_addr
2608# Return the IP addr of the remote host.
2609####
2610'remote_addr' => <<'END_OF_FUNC',
2611sub remote_addr {
2612 return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
2613}
2614END_OF_FUNC
2615
2616
2617#### Method: script_name
2618# Return the partial URL to this script for
2619# self-referencing scripts. Also see
2620# self_url(), which returns a URL with all state information
2621# preserved.
2622####
2623'script_name' => <<'END_OF_FUNC',
2624sub script_name {
2625 return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'});
2626 # These are for debugging
2627 return "/$0" unless $0=~/^\//;
2628 return $0;
2629}
2630END_OF_FUNC
2631
2632
2633#### Method: referer
2634# Return the HTTP_REFERER: useful for generating
2635# a GO BACK button.
2636####
2637'referer' => <<'END_OF_FUNC',
2638sub referer {
2639 my($self) = self_or_CGI(@_);
2640 return $self->http('referer');
2641}
2642END_OF_FUNC
2643
2644
2645#### Method: server_name
2646# Return the name of the server
2647####
2648'server_name' => <<'END_OF_FUNC',
2649sub server_name {
2650 return $ENV{'SERVER_NAME'} || 'localhost';
2651}
2652END_OF_FUNC
2653
2654#### Method: server_software
2655# Return the name of the server software
2656####
2657'server_software' => <<'END_OF_FUNC',
2658sub server_software {
2659 return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
2660}
2661END_OF_FUNC
2662
2663#### Method: server_port
2664# Return the tcp/ip port the server is running on
2665####
2666'server_port' => <<'END_OF_FUNC',
2667sub server_port {
2668 return $ENV{'SERVER_PORT'} || 80; # for debugging
2669}
2670END_OF_FUNC
2671
2672#### Method: server_protocol
2673# Return the protocol (usually HTTP/1.0)
2674####
2675'server_protocol' => <<'END_OF_FUNC',
2676sub server_protocol {
2677 return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
2678}
2679END_OF_FUNC
2680
2681#### Method: http
2682# Return the value of an HTTP variable, or
2683# the list of variables if none provided
2684####
2685'http' => <<'END_OF_FUNC',
2686sub http {
2687 my ($self,$parameter) = self_or_CGI(@_);
2688 return $ENV{$parameter} if $parameter=~/^HTTP/;
2689 $parameter =~ tr/-/_/;
2690 return $ENV{"HTTP_\U$parameter\E"} if $parameter;
2691 my(@p);
2692 foreach (keys %ENV) {
2693 push(@p,$_) if /^HTTP/;
2694 }
2695 return @p;
2696}
2697END_OF_FUNC
2698
2699#### Method: https
2700# Return the value of HTTPS
2701####
2702'https' => <<'END_OF_FUNC',
2703sub https {
2704 local($^W)=0;
2705 my ($self,$parameter) = self_or_CGI(@_);
2706 return $ENV{HTTPS} unless $parameter;
2707 return $ENV{$parameter} if $parameter=~/^HTTPS/;
2708 $parameter =~ tr/-/_/;
2709 return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
2710 my(@p);
2711 foreach (keys %ENV) {
2712 push(@p,$_) if /^HTTPS/;
2713 }
2714 return @p;
2715}
2716END_OF_FUNC
2717
2718#### Method: protocol
2719# Return the protocol (http or https currently)
2720####
2721'protocol' => <<'END_OF_FUNC',
2722sub protocol {
2723 local($^W)=0;
2724 my $self = shift;
2725 return 'https' if uc($self->https()) eq 'ON';
2726 return 'https' if $self->server_port == 443;
2727 my $prot = $self->server_protocol;
2728 my($protocol,$version) = split('/',$prot);
2729 return "\L$protocol\E";
2730}
2731END_OF_FUNC
2732
2733#### Method: remote_ident
2734# Return the identity of the remote user
2735# (but only if his host is running identd)
2736####
2737'remote_ident' => <<'END_OF_FUNC',
2738sub remote_ident {
2739 return $ENV{'REMOTE_IDENT'};
2740}
2741END_OF_FUNC
2742
2743
2744#### Method: auth_type
2745# Return the type of use verification/authorization in use, if any.
2746####
2747'auth_type' => <<'END_OF_FUNC',
2748sub auth_type {
2749 return $ENV{'AUTH_TYPE'};
2750}
2751END_OF_FUNC
2752
2753
2754#### Method: remote_user
2755# Return the authorization name used for user
2756# verification.
2757####
2758'remote_user' => <<'END_OF_FUNC',
2759sub remote_user {
2760 return $ENV{'REMOTE_USER'};
2761}
2762END_OF_FUNC
2763
2764
2765#### Method: user_name
2766# Try to return the remote user's name by hook or by
2767# crook
2768####
2769'user_name' => <<'END_OF_FUNC',
2770sub user_name {
2771 my ($self) = self_or_CGI(@_);
2772 return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
2773}
2774END_OF_FUNC
2775
2776#### Method: nosticky
2777# Set or return the NOSTICKY global flag
2778####
2779'nosticky' => <<'END_OF_FUNC',
2780sub nosticky {
2781 my ($self,$param) = self_or_CGI(@_);
2782 $CGI::NOSTICKY = $param if defined($param);
2783 return $CGI::NOSTICKY;
2784}
2785END_OF_FUNC
2786
2787#### Method: nph
2788# Set or return the NPH global flag
2789####
2790'nph' => <<'END_OF_FUNC',
2791sub nph {
2792 my ($self,$param) = self_or_CGI(@_);
2793 $CGI::NPH = $param if defined($param);
2794 return $CGI::NPH;
2795}
2796END_OF_FUNC
2797
2798#### Method: private_tempfiles
2799# Set or return the private_tempfiles global flag
2800####
2801'private_tempfiles' => <<'END_OF_FUNC',
2802sub private_tempfiles {
2803 my ($self,$param) = self_or_CGI(@_);
2804 $CGI::PRIVATE_TEMPFILES = $param if defined($param);
2805 return $CGI::PRIVATE_TEMPFILES;
2806}
2807END_OF_FUNC
2808
2809#### Method: default_dtd
2810# Set or return the default_dtd global
2811####
2812'default_dtd' => <<'END_OF_FUNC',
2813sub default_dtd {
2814 my ($self,$param,$param2) = self_or_CGI(@_);
2815 if (defined $param2 && defined $param) {
2816 $CGI::DEFAULT_DTD = [ $param, $param2 ];
2817 } elsif (defined $param) {
2818 $CGI::DEFAULT_DTD = $param;
2819 }
2820 return $CGI::DEFAULT_DTD;
2821}
2822END_OF_FUNC
2823
2824# -------------- really private subroutines -----------------
2825'previous_or_default' => <<'END_OF_FUNC',
2826sub previous_or_default {
2827 my($self,$name,$defaults,$override) = @_;
2828 my(%selected);
2829
2830 if (!$override && ($self->{'.fieldnames'}->{$name} ||
2831 defined($self->param($name)) ) ) {
2832 grep($selected{$_}++,$self->param($name));
2833 } elsif (defined($defaults) && ref($defaults) &&
2834 (ref($defaults) eq 'ARRAY')) {
2835 grep($selected{$_}++,@{$defaults});
2836 } else {
2837 $selected{$defaults}++ if defined($defaults);
2838 }
2839
2840 return %selected;
2841}
2842END_OF_FUNC
2843
2844'register_parameter' => <<'END_OF_FUNC',
2845sub register_parameter {
2846 my($self,$param) = @_;
2847 $self->{'.parametersToAdd'}->{$param}++;
2848}
2849END_OF_FUNC
2850
2851'get_fields' => <<'END_OF_FUNC',
2852sub get_fields {
2853 my($self) = @_;
2854 return $self->CGI::hidden('-name'=>'.cgifields',
2855 '-values'=>[keys %{$self->{'.parametersToAdd'}}],
2856 '-override'=>1);
2857}
2858END_OF_FUNC
2859
2860'read_from_cmdline' => <<'END_OF_FUNC',
2861sub read_from_cmdline {
2862 my($input,@words);
2863 my($query_string);
2864 if ($DEBUG && @ARGV) {
2865 @words = @ARGV;
2866 } elsif ($DEBUG > 1) {
2867 require "shellwords.pl";
2868 print STDERR "(offline mode: enter name=value pairs on standard input)\n";
2869 chomp(@lines = <STDIN>); # remove newlines
2870 $input = join(" ",@lines);
2871 @words = &shellwords($input);
2872 }
2873 foreach (@words) {
2874 s/\\=/%3D/g;
2875 s/\\&/%26/g;
2876 }
2877
2878 if ("@words"=~/=/) {
2879 $query_string = join('&',@words);
2880 } else {
2881 $query_string = join('+',@words);
2882 }
2883 return $query_string;
2884}
2885END_OF_FUNC
2886
2887#####
2888# subroutine: read_multipart
2889#
2890# Read multipart data and store it into our parameters.
2891# An interesting feature is that if any of the parts is a file, we
2892# create a temporary file and open up a filehandle on it so that the
2893# caller can read from it if necessary.
2894#####
2895'read_multipart' => <<'END_OF_FUNC',
2896sub read_multipart {
2897 my($self,$boundary,$length,$filehandle) = @_;
2898 my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle);
2899 return unless $buffer;
2900 my(%header,$body);
2901 my $filenumber = 0;
2902 while (!$buffer->eof) {
2903 %header = $buffer->readHeader;
2904
2905 unless (%header) {
2906 $self->cgi_error("400 Bad request (malformed multipart POST)");
2907 return;
2908 }
2909
2910 my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
2911
2912 # Bug: Netscape doesn't escape quotation marks in file names!!!
2913 my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\"]*)"?/;
2914
2915 # add this parameter to our list
2916 $self->add_parameter($param);
2917
2918 # If no filename specified, then just read the data and assign it
2919 # to our parameter list.
2920 if ( !defined($filename) || $filename eq '' ) {
2921 my($value) = $buffer->readBody;
2922 push(@{$self->{$param}},$value);
2923 next;
2924 }
2925
2926 my ($tmpfile,$tmp,$filehandle);
2927 UPLOADS: {
2928 # If we get here, then we are dealing with a potentially large
2929 # uploaded form. Save the data to a temporary file, then open
2930 # the file for reading.
2931
2932 # skip the file if uploads disabled
2933 if ($DISABLE_UPLOADS) {
2934 while (defined($data = $buffer->read)) { }
2935 last UPLOADS;
2936 }
2937
2938 # choose a relatively unpredictable tmpfile sequence number
2939 my $seqno = unpack("%16C*",join('',localtime,values %ENV));
2940 for (my $cnt=10;$cnt>0;$cnt--) {
2941 next unless $tmpfile = new CGITempFile($seqno);
2942 $tmp = $tmpfile->as_string;
2943 last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
2944 $seqno += int rand(100);
2945 }
2946 die "CGI open of tmpfile: $!\n" unless defined $filehandle;
2947 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2948
2949 my ($data);
2950 local($\) = '';
2951 while (defined($data = $buffer->read)) {
2952 print $filehandle $data;
2953 }
2954
2955 # back up to beginning of file
2956 seek($filehandle,0,0);
2957 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2958
2959 # Save some information about the uploaded file where we can get
2960 # at it later.
2961 $self->{'.tmpfiles'}->{fileno($filehandle)}= {
2962 name => $tmpfile,
2963 info => {%header},
2964 };
2965 push(@{$self->{$param}},$filehandle);
2966 }
2967 }
2968}
2969END_OF_FUNC
2970
2971'upload' =><<'END_OF_FUNC',
2972sub upload {
2973 my($self,$param_name) = self_or_default(@_);
2974 my @param = grep(ref && fileno($_), $self->param($param_name));
2975 return unless @param;
2976 return wantarray ? @param : $param[0];
2977}
2978END_OF_FUNC
2979
2980'tmpFileName' => <<'END_OF_FUNC',
2981sub tmpFileName {
2982 my($self,$filename) = self_or_default(@_);
2983 return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ?
2984 $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string
2985 : '';
2986}
2987END_OF_FUNC
2988
2989'uploadInfo' => <<'END_OF_FUNC',
2990sub uploadInfo {
2991 my($self,$filename) = self_or_default(@_);
2992 return $self->{'.tmpfiles'}->{fileno($filename)}->{info};
2993}
2994END_OF_FUNC
2995
2996# internal routine, don't use
2997'_set_values_and_labels' => <<'END_OF_FUNC',
2998sub _set_values_and_labels {
2999 my $self = shift;
3000 my ($v,$l,$n) = @_;
3001 $$l = $v if ref($v) eq 'HASH' && !ref($$l);
3002 return $self->param($n) if !defined($v);
3003 return $v if !ref($v);
3004 return ref($v) eq 'HASH' ? keys %$v : @$v;
3005}
3006END_OF_FUNC
3007
3008'_compile_all' => <<'END_OF_FUNC',
3009sub _compile_all {
3010 foreach (@_) {
3011 next if defined(&$_);
3012 $AUTOLOAD = "CGI::$_";
3013 _compile();
3014 }
3015}
3016END_OF_FUNC
3017
3018);
3019END_OF_AUTOLOAD
3020;
3021
3022#########################################################
3023# Globals and stubs for other packages that we use.
3024#########################################################
3025
3026################### Fh -- lightweight filehandle ###############
3027package Fh;
3028use overload
3029 '""' => \&asString,
3030 'cmp' => \&compare,
3031 'fallback'=>1;
3032
3033$FH='fh00000';
3034
3035*Fh::AUTOLOAD = \&CGI::AUTOLOAD;
3036
3037$AUTOLOADED_ROUTINES = ''; # prevent -w error
3038$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3039%SUBS = (
3040'asString' => <<'END_OF_FUNC',
3041sub asString {
3042 my $self = shift;
3043 # get rid of package name
3044 (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
3045 $i =~ s/%(..)/ chr(hex($1)) /eg;
3046 return $i;
3047# BEGIN DEAD CODE
3048# This was an extremely clever patch that allowed "use strict refs".
3049# Unfortunately it relied on another bug that caused leaky file descriptors.
3050# The underlying bug has been fixed, so this no longer works. However
3051# "strict refs" still works for some reason.
3052# my $self = shift;
3053# return ${*{$self}{SCALAR}};
3054# END DEAD CODE
3055}
3056END_OF_FUNC
3057
3058'compare' => <<'END_OF_FUNC',
3059sub compare {
3060 my $self = shift;
3061 my $value = shift;
3062 return "$self" cmp $value;
3063}
3064END_OF_FUNC
3065
3066'new' => <<'END_OF_FUNC',
3067sub new {
3068 my($pack,$name,$file,$delete) = @_;
3069 require Fcntl unless defined &Fcntl::O_RDWR;
3070 (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
3071 my $fv = ++$FH . $safename;
3072 my $ref = \*{"Fh::$fv"};
3073 sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
3074 unlink($file) if $delete;
3075 CORE::delete $Fh::{$fv};
3076 return bless $ref,$pack;
3077}
3078END_OF_FUNC
3079
3080'DESTROY' => <<'END_OF_FUNC',
3081sub DESTROY {
3082 my $self = shift;
3083 close $self;
3084}
3085END_OF_FUNC
3086
3087);
3088END_OF_AUTOLOAD
3089
3090######################## MultipartBuffer ####################
3091package MultipartBuffer;
3092
3093# how many bytes to read at a time. We use
3094# a 4K buffer by default.
3095$INITIAL_FILLUNIT = 1024 * 4;
3096$TIMEOUT = 240*60; # 4 hour timeout for big files
3097$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
3098$CRLF=$CGI::CRLF;
3099
3100#reuse the autoload function
3101*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
3102
3103# avoid autoloader warnings
3104sub DESTROY {}
3105
3106###############################################################################
3107################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3108###############################################################################
3109$AUTOLOADED_ROUTINES = ''; # prevent -w error
3110$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3111%SUBS = (
3112
3113'new' => <<'END_OF_FUNC',
3114sub new {
3115 my($package,$interface,$boundary,$length,$filehandle) = @_;
3116 $FILLUNIT = $INITIAL_FILLUNIT;
3117 my $IN;
3118 if ($filehandle) {
3119 my($package) = caller;
3120 # force into caller's package if necessary
3121 $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
3122 }
3123 $IN = "main::STDIN" unless $IN;
3124
3125 $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
3126
3127 # If the user types garbage into the file upload field,
3128 # then Netscape passes NOTHING to the server (not good).
3129 # We may hang on this read in that case. So we implement
3130 # a read timeout. If nothing is ready to read
3131 # by then, we return.
3132
3133 # Netscape seems to be a little bit unreliable
3134 # about providing boundary strings.
3135 my $boundary_read = 0;
3136 if ($boundary) {
3137
3138 # Under the MIME spec, the boundary consists of the
3139 # characters "--" PLUS the Boundary string
3140
3141 # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
3142 # the two extra hyphens. We do a special case here on the user-agent!!!!
3143 $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport');
3144
3145 } else { # otherwise we find it ourselves
3146 my($old);
3147 ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
3148 $boundary = <$IN>; # BUG: This won't work correctly under mod_perl
3149 $length -= length($boundary);
3150 chomp($boundary); # remove the CRLF
3151 $/ = $old; # restore old line separator
3152 $boundary_read++;
3153 }
3154
3155 my $self = {LENGTH=>$length,
3156 BOUNDARY=>$boundary,
3157 IN=>$IN,
3158 INTERFACE=>$interface,
3159 BUFFER=>'',
3160 };
3161
3162 $FILLUNIT = length($boundary)
3163 if length($boundary) > $FILLUNIT;
3164
3165 my $retval = bless $self,ref $package || $package;
3166
3167 # Read the preamble and the topmost (boundary) line plus the CRLF.
3168 unless ($boundary_read) {
3169 while ($self->read(0)) { }
3170 }
3171 die "Malformed multipart POST\n" if $self->eof;
3172
3173 return $retval;
3174}
3175END_OF_FUNC
3176
3177'readHeader' => <<'END_OF_FUNC',
3178sub readHeader {
3179 my($self) = @_;
3180 my($end);
3181 my($ok) = 0;
3182 my($bad) = 0;
3183
3184 local($CRLF) = "\015\012" if $CGI::OS eq 'VMS';
3185
3186 do {
3187 $self->fillBuffer($FILLUNIT);
3188 $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
3189 $ok++ if $self->{BUFFER} eq '';
3190 $bad++ if !$ok && $self->{LENGTH} <= 0;
3191 # this was a bad idea
3192 # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
3193 } until $ok || $bad;
3194 return () if $bad;
3195
3196 my($header) = substr($self->{BUFFER},0,$end+2);
3197 substr($self->{BUFFER},0,$end+4) = '';
3198 my %return;
3199
3200
3201 # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
3202 # (Folding Long Header Fields), 3.4.3 (Comments)
3203 # and 3.4.5 (Quoted-Strings).
3204
3205 my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
3206 $header=~s/$CRLF\s+/ /og; # merge continuation lines
3207 while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
3208 my ($field_name,$field_value) = ($1,$2); # avoid taintedness
3209 $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
3210 $return{$field_name}=$field_value;
3211 }
3212 return %return;
3213}
3214END_OF_FUNC
3215
3216# This reads and returns the body as a single scalar value.
3217'readBody' => <<'END_OF_FUNC',
3218sub readBody {
3219 my($self) = @_;
3220 my($data);
3221 my($returnval)='';
3222 while (defined($data = $self->read)) {
3223 $returnval .= $data;
3224 }
3225 return $returnval;
3226}
3227END_OF_FUNC
3228
3229# This will read $bytes or until the boundary is hit, whichever happens
3230# first. After the boundary is hit, we return undef. The next read will
3231# skip over the boundary and begin reading again;
3232'read' => <<'END_OF_FUNC',
3233sub read {
3234 my($self,$bytes) = @_;
3235
3236 # default number of bytes to read
3237 $bytes = $bytes || $FILLUNIT;
3238
3239 # Fill up our internal buffer in such a way that the boundary
3240 # is never split between reads.
3241 $self->fillBuffer($bytes);
3242
3243 # Find the boundary in the buffer (it may not be there).
3244 my $start = index($self->{BUFFER},$self->{BOUNDARY});
3245 # protect against malformed multipart POST operations
3246 die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
3247
3248 # If the boundary begins the data, then skip past it
3249 # and return undef.
3250 if ($start == 0) {
3251
3252 # clear us out completely if we've hit the last boundary.
3253 if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
3254 $self->{BUFFER}='';
3255 $self->{LENGTH}=0;
3256 return undef;
3257 }
3258
3259 # just remove the boundary.
3260 substr($self->{BUFFER},0,length($self->{BOUNDARY}))='';
3261 $self->{BUFFER} =~ s/^\012\015?//;
3262 return undef;
3263 }
3264
3265 my $bytesToReturn;
3266 if ($start > 0) { # read up to the boundary
3267 $bytesToReturn = $start > $bytes ? $bytes : $start;
3268 } else { # read the requested number of bytes
3269 # leave enough bytes in the buffer to allow us to read
3270 # the boundary. Thanks to Kevin Hendrick for finding
3271 # this one.
3272 $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
3273 }
3274
3275 my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
3276 substr($self->{BUFFER},0,$bytesToReturn)='';
3277
3278 # If we hit the boundary, remove the CRLF from the end.
3279 return (($start > 0) && ($start <= $bytes))
3280 ? substr($returnval,0,-2) : $returnval;
3281}
3282END_OF_FUNC
3283
3284
3285# This fills up our internal buffer in such a way that the
3286# boundary is never split between reads
3287'fillBuffer' => <<'END_OF_FUNC',
3288sub fillBuffer {
3289 my($self,$bytes) = @_;
3290 return unless $self->{LENGTH};
3291
3292 my($boundaryLength) = length($self->{BOUNDARY});
3293 my($bufferLength) = length($self->{BUFFER});
3294 my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
3295 $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
3296
3297 # Try to read some data. We may hang here if the browser is screwed up.
3298 my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN},
3299 \$self->{BUFFER},
3300 $bytesToRead,
3301 $bufferLength);
3302 $self->{BUFFER} = '' unless defined $self->{BUFFER};
3303
3304 # An apparent bug in the Apache server causes the read()
3305 # to return zero bytes repeatedly without blocking if the
3306 # remote user aborts during a file transfer. I don't know how
3307 # they manage this, but the workaround is to abort if we get
3308 # more than SPIN_LOOP_MAX consecutive zero reads.
3309 if ($bytesRead == 0) {
3310 die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
3311 if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
3312 } else {
3313 $self->{ZERO_LOOP_COUNTER}=0;
3314 }
3315
3316 $self->{LENGTH} -= $bytesRead;
3317}
3318END_OF_FUNC
3319
3320
3321# Return true when we've finished reading
3322'eof' => <<'END_OF_FUNC'
3323sub eof {
3324 my($self) = @_;
3325 return 1 if (length($self->{BUFFER}) == 0)
3326 && ($self->{LENGTH} <= 0);
3327 undef;
3328}
3329END_OF_FUNC
3330
3331);
3332END_OF_AUTOLOAD
3333
3334####################################################################################
3335################################## TEMPORARY FILES #################################
3336####################################################################################
3337package CGITempFile;
3338
3339$SL = $CGI::SL;
3340$MAC = $CGI::OS eq 'MACINTOSH';
3341my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
3342unless ($TMPDIRECTORY) {
3343 @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
3344 "C:${SL}temp","${SL}tmp","${SL}temp",
3345 "${vol}${SL}Temporary Items",
3346 "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
3347 "C:${SL}system${SL}temp");
3348 unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'};
3349
3350 # this feature was supposed to provide per-user tmpfiles, but
3351 # it is problematic.
3352 # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
3353 # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
3354 # : can generate a 'getpwuid() not implemented' exception, even though
3355 # : it's never called. Found under DOS/Win with the DJGPP perl port.
3356 # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
3357 # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
3358
3359 foreach (@TEMP) {
3360 do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
3361 }
3362}
3363
3364$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
3365$MAXTRIES = 5000;
3366
3367# cute feature, but overload implementation broke it
3368# %OVERLOAD = ('""'=>'as_string');
3369*CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD;
3370
3371sub DESTROY {
3372 my($self) = @_;
3373 unlink $$self; # get rid of the file
3374}
3375
3376###############################################################################
3377################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3378###############################################################################
3379$AUTOLOADED_ROUTINES = ''; # prevent -w error
3380$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3381%SUBS = (
3382
3383'new' => <<'END_OF_FUNC',
3384sub new {
3385 my($package,$sequence) = @_;
3386 my $filename;
3387 for (my $i = 0; $i < $MAXTRIES; $i++) {
3388 last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
3389 }
3390 # untaint the darn thing
3391 return unless $filename =~ m!^([a-zA-Z0-9_ '":/.\$\\-]+)$!;
3392 $filename = $1;
3393 return bless \$filename;
3394}
3395END_OF_FUNC
3396
3397'as_string' => <<'END_OF_FUNC'
3398sub as_string {
3399 my($self) = @_;
3400 return $$self;
3401}
3402END_OF_FUNC
3403
3404);
3405END_OF_AUTOLOAD
3406
3407package CGI;
3408
3409# We get a whole bunch of warnings about "possibly uninitialized variables"
3410# when running with the -w switch. Touch them all once to get rid of the
3411# warnings. This is ugly and I hate it.
3412if ($^W) {
3413 $CGI::CGI = '';
3414 $CGI::CGI=<<EOF;
3415 $CGI::VERSION;
3416 $MultipartBuffer::SPIN_LOOP_MAX;
3417 $MultipartBuffer::CRLF;
3418 $MultipartBuffer::TIMEOUT;
3419 $MultipartBuffer::INITIAL_FILLUNIT;
3420EOF
3421 ;
3422}
3423
34241;
3425
3426__END__
3427
3428=head1 NAME
3429
3430CGI - Simple Common Gateway Interface Class
3431
3432=head1 SYNOPSIS
3433
3434 # CGI script that creates a fill-out form
3435 # and echoes back its values.
3436
3437 use CGI qw/:standard/;
3438 print header,
3439 start_html('A Simple Example'),
3440 h1('A Simple Example'),
3441 start_form,
3442 "What's your name? ",textfield('name'),p,
3443 "What's the combination?", p,
3444 checkbox_group(-name=>'words',
3445 -values=>['eenie','meenie','minie','moe'],
3446 -defaults=>['eenie','minie']), p,
3447 "What's your favorite color? ",
3448 popup_menu(-name=>'color',
3449 -values=>['red','green','blue','chartreuse']),p,
3450 submit,
3451 end_form,
3452 hr;
3453
3454 if (param()) {
3455 print "Your name is",em(param('name')),p,
3456 "The keywords are: ",em(join(", ",param('words'))),p,
3457 "Your favorite color is ",em(param('color')),
3458 hr;
3459 }
3460
3461=head1 ABSTRACT
3462
3463This perl library uses perl5 objects to make it easy to create Web
3464fill-out forms and parse their contents. This package defines CGI
3465objects, entities that contain the values of the current query string
3466and other state variables. Using a CGI object's methods, you can
3467examine keywords and parameters passed to your script, and create
3468forms whose initial values are taken from the current query (thereby
3469preserving state information). The module provides shortcut functions
3470that produce boilerplate HTML, reducing typing and coding errors. It
3471also provides functionality for some of the more advanced features of
3472CGI scripting, including support for file uploads, cookies, cascading
3473style sheets, server push, and frames.
3474
3475CGI.pm also provides a simple function-oriented programming style for
3476those who don't need its object-oriented features.
3477
3478The current version of CGI.pm is available at
3479
3480 http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
3481 ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
3482
3483=head1 DESCRIPTION
3484
3485=head2 PROGRAMMING STYLE
3486
3487There are two styles of programming with CGI.pm, an object-oriented
3488style and a function-oriented style. In the object-oriented style you
3489create one or more CGI objects and then use object methods to create
3490the various elements of the page. Each CGI object starts out with the
3491list of named parameters that were passed to your CGI script by the
3492server. You can modify the objects, save them to a file or database
3493and recreate them. Because each object corresponds to the "state" of
3494the CGI script, and because each object's parameter list is
3495independent of the others, this allows you to save the state of the
3496script and restore it later.
3497
3498For example, using the object oriented style, here is how you create
3499a simple "Hello World" HTML page:
3500
3501 #!/usr/local/bin/perl -w
3502 use CGI; # load CGI routines
3503 $q = new CGI; # create new CGI object
3504 print $q->header, # create the HTTP header
3505 $q->start_html('hello world'), # start the HTML
3506 $q->h1('hello world'), # level 1 header
3507 $q->end_html; # end the HTML
3508
3509In the function-oriented style, there is one default CGI object that
3510you rarely deal with directly. Instead you just call functions to
3511retrieve CGI parameters, create HTML tags, manage cookies, and so
3512on. This provides you with a cleaner programming interface, but
3513limits you to using one CGI object at a time. The following example
3514prints the same page, but uses the function-oriented interface.
3515The main differences are that we now need to import a set of functions
3516into our name space (usually the "standard" functions), and we don't
3517need to create the CGI object.
3518
3519 #!/usr/local/bin/perl
3520 use CGI qw/:standard/; # load standard CGI routines
3521 print header, # create the HTTP header
3522 start_html('hello world'), # start the HTML
3523 h1('hello world'), # level 1 header
3524 end_html; # end the HTML
3525
3526The examples in this document mainly use the object-oriented style.
3527See HOW TO IMPORT FUNCTIONS for important information on
3528function-oriented programming in CGI.pm
3529
3530=head2 CALLING CGI.PM ROUTINES
3531
3532Most CGI.pm routines accept several arguments, sometimes as many as 20
3533optional ones! To simplify this interface, all routines use a named
3534argument calling style that looks like this:
3535
3536 print $q->header(-type=>'image/gif',-expires=>'+3d');
3537
3538Each argument name is preceded by a dash. Neither case nor order
3539matters in the argument list. -type, -Type, and -TYPE are all
3540acceptable. In fact, only the first argument needs to begin with a
3541dash. If a dash is present in the first argument, CGI.pm assumes
3542dashes for the subsequent ones.
3543
3544Several routines are commonly called with just one argument. In the
3545case of these routines you can provide the single argument without an
3546argument name. header() happens to be one of these routines. In this
3547case, the single argument is the document type.
3548
3549 print $q->header('text/html');
3550
3551Other such routines are documented below.
3552
3553Sometimes named arguments expect a scalar, sometimes a reference to an
3554array, and sometimes a reference to a hash. Often, you can pass any
3555type of argument and the routine will do whatever is most appropriate.
3556For example, the param() routine is used to set a CGI parameter to a
3557single or a multi-valued value. The two cases are shown below:
3558
3559 $q->param(-name=>'veggie',-value=>'tomato');
3560 $q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']);
3561
3562A large number of routines in CGI.pm actually aren't specifically
3563defined in the module, but are generated automatically as needed.
3564These are the "HTML shortcuts," routines that generate HTML tags for
3565use in dynamically-generated pages. HTML tags have both attributes
3566(the attribute="value" pairs within the tag itself) and contents (the
3567part between the opening and closing pairs.) To distinguish between
3568attributes and contents, CGI.pm uses the convention of passing HTML
3569attributes as a hash reference as the first argument, and the
3570contents, if any, as any subsequent arguments. It works out like
3571this:
3572
3573 Code Generated HTML
3574 ---- --------------
3575 h1() <h1>
3576 h1('some','contents'); <h1>some contents</h1>
3577 h1({-align=>left}); <h1 ALIGN="LEFT">
3578 h1({-align=>left},'contents'); <h1 ALIGN="LEFT">contents</h1>
3579
3580HTML tags are described in more detail later.
3581
3582Many newcomers to CGI.pm are puzzled by the difference between the
3583calling conventions for the HTML shortcuts, which require curly braces
3584around the HTML tag attributes, and the calling conventions for other
3585routines, which manage to generate attributes without the curly
3586brackets. Don't be confused. As a convenience the curly braces are
3587optional in all but the HTML shortcuts. If you like, you can use
3588curly braces when calling any routine that takes named arguments. For
3589example:
3590
3591 print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
3592
3593If you use the B<-w> switch, you will be warned that some CGI.pm argument
3594names conflict with built-in Perl functions. The most frequent of
3595these is the -values argument, used to create multi-valued menus,
3596radio button clusters and the like. To get around this warning, you
3597have several choices:
3598
3599=over 4
3600
3601=item 1.
3602
3603Use another name for the argument, if one is available.
3604For example, -value is an alias for -values.
3605
3606=item 2.
3607
3608Change the capitalization, e.g. -Values
3609
3610=item 3.
3611
3612Put quotes around the argument name, e.g. '-values'
3613
3614=back
3615
3616Many routines will do something useful with a named argument that it
3617doesn't recognize. For example, you can produce non-standard HTTP
3618header fields by providing them as named arguments:
3619
3620 print $q->header(-type => 'text/html',
3621 -cost => 'Three smackers',
3622 -annoyance_level => 'high',
3623 -complaints_to => 'bit bucket');
3624
3625This will produce the following nonstandard HTTP header:
3626
3627 HTTP/1.0 200 OK
3628 Cost: Three smackers
3629 Annoyance-level: high
3630 Complaints-to: bit bucket
3631 Content-type: text/html
3632
3633Notice the way that underscores are translated automatically into
3634hyphens. HTML-generating routines perform a different type of
3635translation.
3636
3637This feature allows you to keep up with the rapidly changing HTTP and
3638HTML "standards".
3639
3640=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
3641
3642 $query = new CGI;
3643
3644This will parse the input (from both POST and GET methods) and store
3645it into a perl5 object called $query.
3646
3647=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
3648
3649 $query = new CGI(INPUTFILE);
3650
3651If you provide a file handle to the new() method, it will read
3652parameters from the file (or STDIN, or whatever). The file can be in
3653any of the forms describing below under debugging (i.e. a series of
3654newline delimited TAG=VALUE pairs will work). Conveniently, this type
3655of file is created by the save() method (see below). Multiple records
3656can be saved and restored.
3657
3658Perl purists will be pleased to know that this syntax accepts
3659references to file handles, or even references to filehandle globs,
3660which is the "official" way to pass a filehandle:
3661
3662 $query = new CGI(\*STDIN);
3663
3664You can also initialize the CGI object with a FileHandle or IO::File
3665object.
3666
3667If you are using the function-oriented interface and want to
3668initialize CGI state from a file handle, the way to do this is with
3669B<restore_parameters()>. This will (re)initialize the
3670default CGI object from the indicated file handle.
3671
3672 open (IN,"test.in") || die;
3673 restore_parameters(IN);
3674 close IN;
3675
3676You can also initialize the query object from an associative array
3677reference:
3678
3679 $query = new CGI( {'dinosaur'=>'barney',
3680 'song'=>'I love you',
3681 'friends'=>[qw/Jessica George Nancy/]}
3682 );
3683
3684or from a properly formatted, URL-escaped query string:
3685
3686 $query = new CGI('dinosaur=barney&color=purple');
3687
3688or from a previously existing CGI object (currently this clones the
3689parameter list, but none of the other object-specific fields, such as
3690autoescaping):
3691
3692 $old_query = new CGI;
3693 $new_query = new CGI($old_query);
3694
3695To create an empty query, initialize it from an empty string or hash:
3696
3697 $empty_query = new CGI("");
3698
3699 -or-
3700
3701 $empty_query = new CGI({});
3702
3703=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
3704
3705 @keywords = $query->keywords
3706
3707If the script was invoked as the result of an <ISINDEX> search, the
3708parsed keywords can be obtained as an array using the keywords() method.
3709
3710=head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
3711
3712 @names = $query->param
3713
3714If the script was invoked with a parameter list
3715(e.g. "name1=value1&name2=value2&name3=value3"), the param() method
3716will return the parameter names as a list. If the script was invoked
3717as an <ISINDEX> script and contains a string without ampersands
3718(e.g. "value1+value2+value3") , there will be a single parameter named
3719"keywords" containing the "+"-delimited keywords.
3720
3721NOTE: As of version 1.5, the array of parameter names returned will
3722be in the same order as they were submitted by the browser.
3723Usually this order is the same as the order in which the
3724parameters are defined in the form (however, this isn't part
3725of the spec, and so isn't guaranteed).
3726
3727=head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
3728
3729 @values = $query->param('foo');
3730
3731 -or-
3732
3733 $value = $query->param('foo');
3734
3735Pass the param() method a single argument to fetch the value of the
3736named parameter. If the parameter is multivalued (e.g. from multiple
3737selections in a scrolling list), you can ask to receive an array. Otherwise
3738the method will return a single value.
3739
3740If a value is not given in the query string, as in the queries
3741"name1=&name2=" or "name1&name2", it will be returned as an empty
3742string. This feature is new in 2.63.
3743
3744=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
3745
3746 $query->param('foo','an','array','of','values');
3747
3748This sets the value for the named parameter 'foo' to an array of
3749values. This is one way to change the value of a field AFTER
3750the script has been invoked once before. (Another way is with
3751the -override parameter accepted by all methods that generate
3752form elements.)
3753
3754param() also recognizes a named parameter style of calling described
3755in more detail later:
3756
3757 $query->param(-name=>'foo',-values=>['an','array','of','values']);
3758
3759 -or-
3760
3761 $query->param(-name=>'foo',-value=>'the value');
3762
3763=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
3764
3765 $query->append(-name=>'foo',-values=>['yet','more','values']);
3766
3767This adds a value or list of values to the named parameter. The
3768values are appended to the end of the parameter if it already exists.
3769Otherwise the parameter is created. Note that this method only
3770recognizes the named argument calling syntax.
3771
3772=head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
3773
3774 $query->import_names('R');
3775
3776This creates a series of variables in the 'R' namespace. For example,
3777$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
3778If no namespace is given, this method will assume 'Q'.
3779WARNING: don't import anything into 'main'; this is a major security
3780risk!!!!
3781
3782In older versions, this method was called B<import()>. As of version 2.20,
3783this name has been removed completely to avoid conflict with the built-in
3784Perl module B<import> operator.
3785
3786=head2 DELETING A PARAMETER COMPLETELY:
3787
3788 $query->delete('foo');
3789
3790This completely clears a parameter. It sometimes useful for
3791resetting parameters that you don't want passed down between
3792script invocations.
3793
3794If you are using the function call interface, use "Delete()" instead
3795to avoid conflicts with Perl's built-in delete operator.
3796
3797=head2 DELETING ALL PARAMETERS:
3798
3799 $query->delete_all();
3800
3801This clears the CGI object completely. It might be useful to ensure
3802that all the defaults are taken when you create a fill-out form.
3803
3804Use Delete_all() instead if you are using the function call interface.
3805
3806=head2 DIRECT ACCESS TO THE PARAMETER LIST:
3807
3808 $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
3809 unshift @{$q->param_fetch(-name=>'address')},'George Munster';
3810
3811If you need access to the parameter list in a way that isn't covered
3812by the methods above, you can obtain a direct reference to it by
3813calling the B<param_fetch()> method with the name of the . This
3814will return an array reference to the named parameters, which you then
3815can manipulate in any way you like.
3816
3817You can also use a named argument style using the B<-name> argument.
3818
3819=head2 FETCHING THE PARAMETER LIST AS A HASH:
3820
3821 $params = $q->Vars;
3822 print $params->{'address'};
3823 @foo = split("\0",$params->{'foo'});
3824 %params = $q->Vars;
3825
3826 use CGI ':cgi-lib';
3827 $params = Vars;
3828
3829Many people want to fetch the entire parameter list as a hash in which
3830the keys are the names of the CGI parameters, and the values are the
3831parameters' values. The Vars() method does this. Called in a scalar
3832context, it returns the parameter list as a tied hash reference.
3833Changing a key changes the value of the parameter in the underlying
3834CGI parameter list. Called in a list context, it returns the
3835parameter list as an ordinary hash. This allows you to read the
3836contents of the parameter list, but not to change it.
3837
3838When using this, the thing you must watch out for are multivalued CGI
3839parameters. Because a hash cannot distinguish between scalar and
3840list context, multivalued parameters will be returned as a packed
3841string, separated by the "\0" (null) character. You must split this
3842packed string in order to get at the individual values. This is the
3843convention introduced long ago by Steve Brenner in his cgi-lib.pl
3844module for Perl version 4.
3845
3846If you wish to use Vars() as a function, import the I<:cgi-lib> set of
3847function calls (also see the section on CGI-LIB compatibility).
3848
3849=head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
3850
3851 $query->save(FILEHANDLE)
3852
3853This will write the current state of the form to the provided
3854filehandle. You can read it back in by providing a filehandle
3855to the new() method. Note that the filehandle can be a file, a pipe,
3856or whatever!
3857
3858The format of the saved file is:
3859
3860 NAME1=VALUE1
3861 NAME1=VALUE1'
3862 NAME2=VALUE2
3863 NAME3=VALUE3
3864 =
3865
3866Both name and value are URL escaped. Multi-valued CGI parameters are
3867represented as repeated names. A session record is delimited by a
3868single = symbol. You can write out multiple records and read them
3869back in with several calls to B<new>. You can do this across several
3870sessions by opening the file in append mode, allowing you to create
3871primitive guest books, or to keep a history of users' queries. Here's
3872a short example of creating multiple session records:
3873
3874 use CGI;
3875
3876 open (OUT,">>test.out") || die;
3877 $records = 5;
3878 foreach (0..$records) {
3879 my $q = new CGI;
3880 $q->param(-name=>'counter',-value=>$_);
3881 $q->save(OUT);
3882 }
3883 close OUT;
3884
3885 # reopen for reading
3886 open (IN,"test.out") || die;
3887 while (!eof(IN)) {
3888 my $q = new CGI(IN);
3889 print $q->param('counter'),"\n";
3890 }
3891
3892The file format used for save/restore is identical to that used by the
3893Whitehead Genome Center's data exchange format "Boulderio", and can be
3894manipulated and even databased using Boulderio utilities. See
3895
3896 http://stein.cshl.org/boulder/
3897
3898for further details.
3899
3900If you wish to use this method from the function-oriented (non-OO)
3901interface, the exported name for this method is B<save_parameters()>.
3902
3903=head2 RETRIEVING CGI ERRORS
3904
3905Errors can occur while processing user input, particularly when
3906processing uploaded files. When these errors occur, CGI will stop
3907processing and return an empty parameter list. You can test for
3908the existence and nature of errors using the I<cgi_error()> function.
3909The error messages are formatted as HTTP status codes. You can either
3910incorporate the error text into an HTML page, or use it as the value
3911of the HTTP status:
3912
3913 my $error = $q->cgi_error;
3914 if ($error) {
3915 print $q->header(-status=>$error),
3916 $q->start_html('Problems'),
3917 $q->h2('Request not processed'),
3918 $q->strong($error);
3919 exit 0;
3920 }
3921
3922When using the function-oriented interface (see the next section),
3923errors may only occur the first time you call I<param()>. Be ready
3924for this!
3925
3926=head2 USING THE FUNCTION-ORIENTED INTERFACE
3927
3928To use the function-oriented interface, you must specify which CGI.pm
3929routines or sets of routines to import into your script's namespace.
3930There is a small overhead associated with this importation, but it
3931isn't much.
3932
3933 use CGI <list of methods>;
3934
3935The listed methods will be imported into the current package; you can
3936call them directly without creating a CGI object first. This example
3937shows how to import the B<param()> and B<header()>
3938methods, and then use them directly:
3939
3940 use CGI 'param','header';
3941 print header('text/plain');
3942 $zipcode = param('zipcode');
3943
3944More frequently, you'll import common sets of functions by referring
3945to the groups by name. All function sets are preceded with a ":"
3946character as in ":html3" (for tags defined in the HTML 3 standard).
3947
3948Here is a list of the function sets you can import:
3949
3950=over 4
3951
3952=item B<:cgi>
3953
3954Import all CGI-handling methods, such as B<param()>, B<path_info()>
3955and the like.
3956
3957=item B<:form>
3958
3959Import all fill-out form generating methods, such as B<textfield()>.
3960
3961=item B<:html2>
3962
3963Import all methods that generate HTML 2.0 standard elements.
3964
3965=item B<:html3>
3966
3967Import all methods that generate HTML 3.0 elements (such as
3968<table>, <super> and <sub>).
3969
3970=item B<:html4>
3971
3972Import all methods that generate HTML 4 elements (such as
3973<abbrev>, <acronym> and <thead>).
3974
3975=item B<:netscape>
3976
3977Import all methods that generate Netscape-specific HTML extensions.
3978
3979=item B<:html>
3980
3981Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
3982'netscape')...
3983
3984=item B<:standard>
3985
3986Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'.
3987
3988=item B<:all>
3989
3990Import all the available methods. For the full list, see the CGI.pm
3991code, where the variable %EXPORT_TAGS is defined.
3992
3993=back
3994
3995If you import a function name that is not part of CGI.pm, the module
3996will treat it as a new HTML tag and generate the appropriate
3997subroutine. You can then use it like any other HTML tag. This is to
3998provide for the rapidly-evolving HTML "standard." For example, say
3999Microsoft comes out with a new tag called <gradient> (which causes the
4000user's desktop to be flooded with a rotating gradient fill until his
4001machine reboots). You don't need to wait for a new version of CGI.pm
4002to start using it immediately:
4003
4004 use CGI qw/:standard :html3 gradient/;
4005 print gradient({-start=>'red',-end=>'blue'});
4006
4007Note that in the interests of execution speed CGI.pm does B<not> use
4008the standard L<Exporter> syntax for specifying load symbols. This may
4009change in the future.
4010
4011If you import any of the state-maintaining CGI or form-generating
4012methods, a default CGI object will be created and initialized
4013automatically the first time you use any of the methods that require
4014one to be present. This includes B<param()>, B<textfield()>,
4015B<submit()> and the like. (If you need direct access to the CGI
4016object, you can find it in the global variable B<$CGI::Q>). By
4017importing CGI.pm methods, you can create visually elegant scripts:
4018
4019 use CGI qw/:standard/;
4020 print
4021 header,
4022 start_html('Simple Script'),
4023 h1('Simple Script'),
4024 start_form,
4025 "What's your name? ",textfield('name'),p,
4026 "What's the combination?",
4027 checkbox_group(-name=>'words',
4028 -values=>['eenie','meenie','minie','moe'],
4029 -defaults=>['eenie','moe']),p,
4030 "What's your favorite color?",
4031 popup_menu(-name=>'color',
4032 -values=>['red','green','blue','chartreuse']),p,
4033 submit,
4034 end_form,
4035 hr,"\n";
4036
4037 if (param) {
4038 print
4039 "Your name is ",em(param('name')),p,
4040 "The keywords are: ",em(join(", ",param('words'))),p,
4041 "Your favorite color is ",em(param('color')),".\n";
4042 }
4043 print end_html;
4044
4045=head2 PRAGMAS
4046
4047In addition to the function sets, there are a number of pragmas that
4048you can import. Pragmas, which are always preceded by a hyphen,
4049change the way that CGI.pm functions in various ways. Pragmas,
4050function sets, and individual functions can all be imported in the
4051same use() line. For example, the following use statement imports the
4052standard set of functions and enables debugging mode (pragma
4053-debug):
4054
4055 use CGI qw/:standard -debug/;
4056
4057The current list of pragmas is as follows:
4058
4059=over 4
4060
4061=item -any
4062
4063When you I<use CGI -any>, then any method that the query object
4064doesn't recognize will be interpreted as a new HTML tag. This allows
4065you to support the next I<ad hoc> Netscape or Microsoft HTML
4066extension. This lets you go wild with new and unsupported tags:
4067
4068 use CGI qw(-any);
4069 $q=new CGI;
4070 print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
4071
4072Since using <cite>any</cite> causes any mistyped method name
4073to be interpreted as an HTML tag, use it with care or not at
4074all.
4075
4076=item -compile
4077
4078This causes the indicated autoloaded methods to be compiled up front,
4079rather than deferred to later. This is useful for scripts that run
4080for an extended period of time under FastCGI or mod_perl, and for
4081those destined to be crunched by Malcom Beattie's Perl compiler. Use
4082it in conjunction with the methods or method families you plan to use.
4083
4084 use CGI qw(-compile :standard :html3);
4085
4086or even
4087
4088 use CGI qw(-compile :all);
4089
4090Note that using the -compile pragma in this way will always have
4091the effect of importing the compiled functions into the current
4092namespace. If you want to compile without importing use the
4093compile() method instead (see below).
4094
4095=item -nosticky
4096
4097This makes CGI.pm not generating the hidden fields .submit
4098and .cgifields. It is very useful if you don't want to
4099have the hidden fields appear in the querystring in a GET method.
4100For example, a search script generated this way will have
4101a very nice url with search parameters for bookmarking.
4102
4103=item -no_undef_params
4104
4105This keeps CGI.pm from including undef params in the parameter list.
4106
4107=item -no_xhtml
4108
4109By default, CGI.pm versions 2.69 and higher emit XHTML
4110(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this
4111feature. Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this
4112feature.
4113
4114=item -nph
4115
4116This makes CGI.pm produce a header appropriate for an NPH (no
4117parsed header) script. You may need to do other things as well
4118to tell the server that the script is NPH. See the discussion
4119of NPH scripts below.
4120
4121=item -newstyle_urls
4122
4123Separate the name=value pairs in CGI parameter query strings with
4124semicolons rather than ampersands. For example:
4125
4126 ?name=fred;age=24;favorite_color=3
4127
4128Semicolon-delimited query strings are always accepted, but will not be
4129emitted by self_url() and query_string() unless the -newstyle_urls
4130pragma is specified.
4131
4132This became the default in version 2.64.
4133
4134=item -oldstyle_urls
4135
4136Separate the name=value pairs in CGI parameter query strings with
4137ampersands rather than semicolons. This is no longer the default.
4138
4139=item -autoload
4140
4141This overrides the autoloader so that any function in your program
4142that is not recognized is referred to CGI.pm for possible evaluation.
4143This allows you to use all the CGI.pm functions without adding them to
4144your symbol table, which is of concern for mod_perl users who are
4145worried about memory consumption. I<Warning:> when
4146I<-autoload> is in effect, you cannot use "poetry mode"
4147(functions without the parenthesis). Use I<hr()> rather
4148than I<hr>, or add something like I<use subs qw/hr p header/>
4149to the top of your script.
4150
4151=item -no_debug
4152
4153This turns off the command-line processing features. If you want to
4154run a CGI.pm script from the command line to produce HTML, and you
4155don't want it to read CGI parameters from the command line or STDIN,
4156then use this pragma:
4157
4158 use CGI qw(-no_debug :standard);
4159
4160=item -debug
4161
4162This turns on full debugging. In addition to reading CGI arguments
4163from the command-line processing, CGI.pm will pause and try to read
4164arguments from STDIN, producing the message "(offline mode: enter
4165name=value pairs on standard input)" features.
4166
4167See the section on debugging for more details.
4168
4169=item -private_tempfiles
4170
4171CGI.pm can process uploaded file. Ordinarily it spools the uploaded
4172file to a temporary directory, then deletes the file when done.
4173However, this opens the risk of eavesdropping as described in the file
4174upload section. Another CGI script author could peek at this data
4175during the upload, even if it is confidential information. On Unix
4176systems, the -private_tempfiles pragma will cause the temporary file
4177to be unlinked as soon as it is opened and before any data is written
4178into it, reducing, but not eliminating the risk of eavesdropping
4179(there is still a potential race condition). To make life harder for
4180the attacker, the program chooses tempfile names by calculating a 32
4181bit checksum of the incoming HTTP headers.
4182
4183To ensure that the temporary file cannot be read by other CGI scripts,
4184use suEXEC or a CGI wrapper program to run your script. The temporary
4185file is created with mode 0600 (neither world nor group readable).
4186
4187The temporary directory is selected using the following algorithm:
4188
4189 1. if the current user (e.g. "nobody") has a directory named
4190 "tmp" in its home directory, use that (Unix systems only).
4191
4192 2. if the environment variable TMPDIR exists, use the location
4193 indicated.
4194
4195 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp,
4196 /tmp, /temp, ::Temporary Items, and \WWW_ROOT.
4197
4198Each of these locations is checked that it is a directory and is
4199writable. If not, the algorithm tries the next choice.
4200
4201=back
4202
4203=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS
4204
4205Many of the methods generate HTML tags. As described below, tag
4206functions automatically generate both the opening and closing tags.
4207For example:
4208
4209 print h1('Level 1 Header');
4210
4211produces
4212
4213 <h1>Level 1 Header</h1>
4214
4215There will be some times when you want to produce the start and end
4216tags yourself. In this case, you can use the form start_I<tag_name>
4217and end_I<tag_name>, as in:
4218
4219 print start_h1,'Level 1 Header',end_h1;
4220
4221With a few exceptions (described below), start_I<tag_name> and
4222end_I<tag_name> functions are not generated automatically when you
4223I<use CGI>. However, you can specify the tags you want to generate
4224I<start/end> functions for by putting an asterisk in front of their
4225name, or, alternatively, requesting either "start_I<tag_name>" or
4226"end_I<tag_name>" in the import list.
4227
4228Example:
4229
4230 use CGI qw/:standard *table start_ul/;
4231
4232In this example, the following functions are generated in addition to
4233the standard ones:
4234
4235=over 4
4236
4237=item 1. start_table() (generates a <table> tag)
4238
4239=item 2. end_table() (generates a </table> tag)
4240
4241=item 3. start_ul() (generates a <ul> tag)
4242
4243=item 4. end_ul() (generates a </ul> tag)
4244
4245=back
4246
4247=head1 GENERATING DYNAMIC DOCUMENTS
4248
4249Most of CGI.pm's functions deal with creating documents on the fly.
4250Generally you will produce the HTTP header first, followed by the
4251document itself. CGI.pm provides functions for generating HTTP
4252headers of various types as well as for generating HTML. For creating
4253GIF images, see the GD.pm module.
4254
4255Each of these functions produces a fragment of HTML or HTTP which you
4256can print out directly so that it displays in the browser window,
4257append to a string, or save to a file for later use.
4258
4259=head2 CREATING A STANDARD HTTP HEADER:
4260
4261Normally the first thing you will do in any CGI script is print out an
4262HTTP header. This tells the browser what type of document to expect,
4263and gives other optional information, such as the language, expiration
4264date, and whether to cache the document. The header can also be
4265manipulated for special purposes, such as server push and pay per view
4266pages.
4267
4268 print $query->header;
4269
4270 -or-
4271
4272 print $query->header('image/gif');
4273
4274 -or-
4275
4276 print $query->header('text/html','204 No response');
4277
4278 -or-
4279
4280 print $query->header(-type=>'image/gif',
4281 -nph=>1,
4282 -status=>'402 Payment required',
4283 -expires=>'+3d',
4284 -cookie=>$cookie,
4285 -charset=>'utf-7',
4286 -attachment=>'foo.gif',
4287 -Cost=>'$2.00');
4288
4289header() returns the Content-type: header. You can provide your own
4290MIME type if you choose, otherwise it defaults to text/html. An
4291optional second parameter specifies the status code and a human-readable
4292message. For example, you can specify 204, "No response" to create a
4293script that tells the browser to do nothing at all.
4294
4295The last example shows the named argument style for passing arguments
4296to the CGI methods using named parameters. Recognized parameters are
4297B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named
4298parameters will be stripped of their initial hyphens and turned into
4299header fields, allowing you to specify any HTTP header you desire.
4300Internal underscores will be turned into hyphens:
4301
4302 print $query->header(-Content_length=>3002);
4303
4304Most browsers will not cache the output from CGI scripts. Every time
4305the browser reloads the page, the script is invoked anew. You can
4306change this behavior with the B<-expires> parameter. When you specify
4307an absolute or relative expiration interval with this parameter, some
4308browsers and proxy servers will cache the script's output until the
4309indicated expiration date. The following forms are all valid for the
4310-expires field:
4311
4312 +30s 30 seconds from now
4313 +10m ten minutes from now
4314 +1h one hour from now
4315 -1d yesterday (i.e. "ASAP!")
4316 now immediately
4317 +3M in three months
4318 +10y in ten years time
4319 Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date
4320
4321The B<-cookie> parameter generates a header that tells the browser to provide
4322a "magic cookie" during all subsequent transactions with your script.
4323Netscape cookies have a special format that includes interesting attributes
4324such as expiration time. Use the cookie() method to create and retrieve
4325session cookies.
4326
4327The B<-nph> parameter, if set to a true value, will issue the correct
4328headers to work with an NPH (no-parse-header) script. This is important
4329to use with certain servers that expect all their scripts to be NPH.
4330
4331The B<-charset> parameter can be used to control the character set
4332sent to the browser. If not provided, defaults to ISO-8859-1. As a
4333side effect, this sets the charset() method as well.
4334
4335The B<-attachment> parameter can be used to turn the page into an
4336attachment. Instead of displaying the page, some browsers will prompt
4337the user to save it to disk. The value of the argument is the
4338suggested name for the saved file. In order for this to work, you may
4339have to set the B<-type> to "application/octet-stream".
4340
4341=head2 GENERATING A REDIRECTION HEADER
4342
4343 print $query->redirect('http://somewhere.else/in/movie/land');
4344
4345Sometimes you don't want to produce a document yourself, but simply
4346redirect the browser elsewhere, perhaps choosing a URL based on the
4347time of day or the identity of the user.
4348
4349The redirect() function redirects the browser to a different URL. If
4350you use redirection like this, you should B<not> print out a header as
4351well.
4352
4353One hint I can offer is that relative links may not work correctly
4354when you generate a redirection to another document on your site.
4355This is due to a well-intentioned optimization that some servers use.
4356The solution to this is to use the full URL (including the http: part)
4357of the document you are redirecting to.
4358
4359You can also use named arguments:
4360
4361 print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
4362 -nph=>1);
4363
4364The B<-nph> parameter, if set to a true value, will issue the correct
4365headers to work with an NPH (no-parse-header) script. This is important
4366to use with certain servers, such as Microsoft Internet Explorer, which
4367expect all their scripts to be NPH.
4368
4369=head2 CREATING THE HTML DOCUMENT HEADER
4370
4371 print $query->start_html(-title=>'Secrets of the Pyramids',
4372 -author=>'fred@capricorn.org',
4373 -base=>'true',
4374 -target=>'_blank',
4375 -meta=>{'keywords'=>'pharaoh secret mummy',
4376 'copyright'=>'copyright 1996 King Tut'},
4377 -style=>{'src'=>'/styles/style1.css'},
4378 -BGCOLOR=>'blue');
4379
4380After creating the HTTP header, most CGI scripts will start writing
4381out an HTML document. The start_html() routine creates the top of the
4382page, along with a lot of optional information that controls the
4383page's appearance and behavior.
4384
4385This method returns a canned HTML header and the opening <body> tag.
4386All parameters are optional. In the named parameter form, recognized
4387parameters are -title, -author, -base, -xbase, -dtd, -lang and -target
4388(see below for the explanation). Any additional parameters you
4389provide, such as the Netscape unofficial BGCOLOR attribute, are added
4390to the <body> tag. Additional parameters must be proceeded by a
4391hyphen.
4392
4393The argument B<-xbase> allows you to provide an HREF for the <base> tag
4394different from the current location, as in
4395
4396 -xbase=>"http://home.mcom.com/"
4397
4398All relative links will be interpreted relative to this tag.
4399
4400The argument B<-target> allows you to provide a default target frame
4401for all the links and fill-out forms on the page. B<This is a
4402non-standard HTTP feature which only works with Netscape browsers!>
4403See the Netscape documentation on frames for details of how to
4404manipulate this.
4405
4406 -target=>"answer_window"
4407
4408All relative links will be interpreted relative to this tag.
4409You add arbitrary meta information to the header with the B<-meta>
4410argument. This argument expects a reference to an associative array
4411containing name/value pairs of meta information. These will be turned
4412into a series of header <meta> tags that look something like this:
4413
4414 <meta name="keywords" content="pharaoh secret mummy">
4415 <meta name="description" content="copyright 1996 King Tut">
4416
4417To create an HTTP-EQUIV type of <meta> tag, use B<-head>, described
4418below.
4419
4420The B<-style> argument is used to incorporate cascading stylesheets
4421into your code. See the section on CASCADING STYLESHEETS for more
4422information.
4423
4424The B<-lang> argument is used to incorporate a language attribute into
4425the <html> tag. The default if not specified is "en-US" for US
4426English. For example:
4427
4428 print $q->start_html(-lang=>'fr-CA');
4429
4430The B<-encoding> argument can be used to specify the character set for
4431XHTML. It defaults to iso-8859-1 if not specified.
4432
4433You can place other arbitrary HTML elements to the <head> section with the
4434B<-head> tag. For example, to place the rarely-used <link> element in the
4435head section, use this:
4436
4437 print start_html(-head=>Link({-rel=>'next',
4438 -href=>'http://www.capricorn.com/s2.html'}));
4439
4440To incorporate multiple HTML elements into the <head> section, just pass an
4441array reference:
4442
4443 print start_html(-head=>[
4444 Link({-rel=>'next',
4445 -href=>'http://www.capricorn.com/s2.html'}),
4446 Link({-rel=>'previous',
4447 -href=>'http://www.capricorn.com/s1.html'})
4448 ]
4449 );
4450
4451And here's how to create an HTTP-EQUIV <meta> tag:
4452
4453 print start_html(-head=>meta({-http_equiv => 'Content-Type',
4454 -content => 'text/html'}))
4455
4456
4457JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
4458B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
4459to add Netscape JavaScript calls to your pages. B<-script> should
4460point to a block of text containing JavaScript function definitions.
4461This block will be placed within a <script> block inside the HTML (not
4462HTTP) header. The block is placed in the header in order to give your
4463page a fighting chance of having all its JavaScript functions in place
4464even if the user presses the stop button before the page has loaded
4465completely. CGI.pm attempts to format the script in such a way that
4466JavaScript-naive browsers will not choke on the code: unfortunately
4467there are some browsers, such as Chimera for Unix, that get confused
4468by it nevertheless.
4469
4470The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
4471code to execute when the page is respectively opened and closed by the
4472browser. Usually these parameters are calls to functions defined in the
4473B<-script> field:
4474
4475 $query = new CGI;
4476 print $query->header;
4477 $JSCRIPT=<<END;
4478 // Ask a silly question
4479 function riddle_me_this() {
4480 var r = prompt("What walks on four legs in the morning, " +
4481 "two legs in the afternoon, " +
4482 "and three legs in the evening?");
4483 response(r);
4484 }
4485 // Get a silly answer
4486 function response(answer) {
4487 if (answer == "man")
4488 alert("Right you are!");
4489 else
4490 alert("Wrong! Guess again.");
4491 }
4492 END
4493 print $query->start_html(-title=>'The Riddle of the Sphinx',
4494 -script=>$JSCRIPT);
4495
4496Use the B<-noScript> parameter to pass some HTML text that will be displayed on
4497browsers that do not have JavaScript (or browsers where JavaScript is turned
4498off).
4499
4500Netscape 3.0 recognizes several attributes of the <script> tag,
4501including LANGUAGE and SRC. The latter is particularly interesting,
4502as it allows you to keep the JavaScript code in a file or CGI script
4503rather than cluttering up each page with the source. To use these
4504attributes pass a HASH reference in the B<-script> parameter containing
4505one or more of -language, -src, or -code:
4506
4507 print $q->start_html(-title=>'The Riddle of the Sphinx',
4508 -script=>{-language=>'JAVASCRIPT',
4509 -src=>'/javascript/sphinx.js'}
4510 );
4511
4512 print $q->(-title=>'The Riddle of the Sphinx',
4513 -script=>{-language=>'PERLSCRIPT',
4514 -code=>'print "hello world!\n;"'}
4515 );
4516
4517
4518A final feature allows you to incorporate multiple <script> sections into the
4519header. Just pass the list of script sections as an array reference.
4520this allows you to specify different source files for different dialects
4521of JavaScript. Example:
4522
4523 print $q->start_html(-title=>'The Riddle of the Sphinx',
4524 -script=>[
4525 { -language => 'JavaScript1.0',
4526 -src => '/javascript/utilities10.js'
4527 },
4528 { -language => 'JavaScript1.1',
4529 -src => '/javascript/utilities11.js'
4530 },
4531 { -language => 'JavaScript1.2',
4532 -src => '/javascript/utilities12.js'
4533 },
4534 { -language => 'JavaScript28.2',
4535 -src => '/javascript/utilities219.js'
4536 }
4537 ]
4538 );
4539
4540If this looks a bit extreme, take my advice and stick with straight CGI scripting.
4541
4542See
4543
4544 http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
4545
4546for more information about JavaScript.
4547
4548The old-style positional parameters are as follows:
4549
4550=over 4
4551
4552=item B<Parameters:>
4553
4554=item 1.
4555
4556The title
4557
4558=item 2.
4559
4560The author's e-mail address (will create a <link rev="MADE"> tag if present
4561
4562=item 3.
4563
4564A 'true' flag if you want to include a <base> tag in the header. This
4565helps resolve relative addresses to absolute ones when the document is moved,
4566but makes the document hierarchy non-portable. Use with care!
4567
4568=item 4, 5, 6...
4569
4570Any other parameters you want to include in the <body> tag. This is a good
4571place to put Netscape extensions, such as colors and wallpaper patterns.
4572
4573=back
4574
4575=head2 ENDING THE HTML DOCUMENT:
4576
4577 print $query->end_html
4578
4579This ends an HTML document by printing the </body></html> tags.
4580
4581=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
4582
4583 $myself = $query->self_url;
4584 print q(<a href="$myself">I'm talking to myself.</a>);
4585
4586self_url() will return a URL, that, when selected, will reinvoke
4587this script with all its state information intact. This is most
4588useful when you want to jump around within the document using
4589internal anchors but you don't want to disrupt the current contents
4590of the form(s). Something like this will do the trick.
4591
4592 $myself = $query->self_url;
4593 print "<a href=$myself#table1>See table 1</a>";
4594 print "<a href=$myself#table2>See table 2</a>";
4595 print "<a href=$myself#yourself>See for yourself</a>";
4596
4597If you want more control over what's returned, using the B<url()>
4598method instead.
4599
4600You can also retrieve the unprocessed query string with query_string():
4601
4602 $the_string = $query->query_string;
4603
4604=head2 OBTAINING THE SCRIPT'S URL
4605
4606 $full_url = $query->url();
4607 $full_url = $query->url(-full=>1); #alternative syntax
4608 $relative_url = $query->url(-relative=>1);
4609 $absolute_url = $query->url(-absolute=>1);
4610 $url_with_path = $query->url(-path_info=>1);
4611 $url_with_path_and_query = $query->url(-path_info=>1,-query=>1);
4612 $netloc = $query->url(-base => 1);
4613
4614B<url()> returns the script's URL in a variety of formats. Called
4615without any arguments, it returns the full form of the URL, including
4616host name and port number
4617
4618 http://your.host.com/path/to/script.cgi
4619
4620You can modify this format with the following named arguments:
4621
4622=over 4
4623
4624=item B<-absolute>
4625
4626If true, produce an absolute URL, e.g.
4627
4628 /path/to/script.cgi
4629
4630=item B<-relative>
4631
4632Produce a relative URL. This is useful if you want to reinvoke your
4633script with different parameters. For example:
4634
4635 script.cgi
4636
4637=item B<-full>
4638
4639Produce the full URL, exactly as if called without any arguments.
4640This overrides the -relative and -absolute arguments.
4641
4642=item B<-path> (B<-path_info>)
4643
4644Append the additional path information to the URL. This can be
4645combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info>
4646is provided as a synonym.
4647
4648=item B<-query> (B<-query_string>)
4649
4650Append the query string to the URL. This can be combined with
4651B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
4652as a synonym.
4653
4654=item B<-base>
4655
4656Generate just the protocol and net location, as in http://www.foo.com:8000
4657
4658=back
4659
4660=head2 MIXING POST AND URL PARAMETERS
4661
4662 $color = $query-&gt;url_param('color');
4663
4664It is possible for a script to receive CGI parameters in the URL as
4665well as in the fill-out form by creating a form that POSTs to a URL
4666containing a query string (a "?" mark followed by arguments). The
4667B<param()> method will always return the contents of the POSTed
4668fill-out form, ignoring the URL's query string. To retrieve URL
4669parameters, call the B<url_param()> method. Use it in the same way as
4670B<param()>. The main difference is that it allows you to read the
4671parameters, but not set them.
4672
4673
4674Under no circumstances will the contents of the URL query string
4675interfere with similarly-named CGI parameters in POSTed forms. If you
4676try to mix a URL query string with a form submitted with the GET
4677method, the results will not be what you expect.
4678
4679=head1 CREATING STANDARD HTML ELEMENTS:
4680
4681CGI.pm defines general HTML shortcut methods for most, if not all of
4682the HTML 3 and HTML 4 tags. HTML shortcuts are named after a single
4683HTML element and return a fragment of HTML text that you can then
4684print or manipulate as you like. Each shortcut returns a fragment of
4685HTML code that you can append to a string, save to a file, or, most
4686commonly, print out so that it displays in the browser window.
4687
4688This example shows how to use the HTML methods:
4689
4690 $q = new CGI;
4691 print $q->blockquote(
4692 "Many years ago on the island of",
4693 $q->a({href=>"http://crete.org/"},"Crete"),
4694 "there lived a Minotaur named",
4695 $q->strong("Fred."),
4696 ),
4697 $q->hr;
4698
4699This results in the following HTML code (extra newlines have been
4700added for readability):
4701
4702 <blockquote>
4703 Many years ago on the island of
4704 <a href="http://crete.org/">Crete</a> there lived
4705 a minotaur named <strong>Fred.</strong>
4706 </blockquote>
4707 <hr>
4708
4709If you find the syntax for calling the HTML shortcuts awkward, you can
4710import them into your namespace and dispense with the object syntax
4711completely (see the next section for more details):
4712
4713 use CGI ':standard';
4714 print blockquote(
4715 "Many years ago on the island of",
4716 a({href=>"http://crete.org/"},"Crete"),
4717 "there lived a minotaur named",
4718 strong("Fred."),
4719 ),
4720 hr;
4721
4722=head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
4723
4724The HTML methods will accept zero, one or multiple arguments. If you
4725provide no arguments, you get a single tag:
4726
4727 print hr; # <hr>
4728
4729If you provide one or more string arguments, they are concatenated
4730together with spaces and placed between opening and closing tags:
4731
4732 print h1("Chapter","1"); # <h1>Chapter 1</h1>"
4733
4734If the first argument is an associative array reference, then the keys
4735and values of the associative array become the HTML tag's attributes:
4736
4737 print a({-href=>'fred.html',-target=>'_new'},
4738 "Open a new frame");
4739
4740 <a href="fred.html",target="_new">Open a new frame</a>
4741
4742You may dispense with the dashes in front of the attribute names if
4743you prefer:
4744
4745 print img {src=>'fred.gif',align=>'LEFT'};
4746
4747 <img align="LEFT" src="fred.gif">
4748
4749Sometimes an HTML tag attribute has no argument. For example, ordered
4750lists can be marked as COMPACT. The syntax for this is an argument
4751that points to an undef string:
4752
4753 print ol({compact=>undef},li('one'),li('two'),li('three'));
4754
4755Prior to CGI.pm version 2.41, providing an empty ('') string as an
4756attribute argument was the same as providing undef. However, this has
4757changed in order to accommodate those who want to create tags of the form
4758<img alt="">. The difference is shown in these two pieces of code:
4759
4760 CODE RESULT
4761 img({alt=>undef}) <img alt>
4762 img({alt=>''}) <img alt="">
4763
4764=head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
4765
4766One of the cool features of the HTML shortcuts is that they are
4767distributive. If you give them an argument consisting of a
4768B<reference> to a list, the tag will be distributed across each
4769element of the list. For example, here's one way to make an ordered
4770list:
4771
4772 print ul(
4773 li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy'])
4774 );
4775
4776This example will result in HTML output that looks like this:
4777
4778 <ul>
4779 <li type="disc">Sneezy</li>
4780 <li type="disc">Doc</li>
4781 <li type="disc">Sleepy</li>
4782 <li type="disc">Happy</li>
4783 </ul>
4784
4785This is extremely useful for creating tables. For example:
4786
4787 print table({-border=>undef},
4788 caption('When Should You Eat Your Vegetables?'),
4789 Tr({-align=>CENTER,-valign=>TOP},
4790 [
4791 th(['Vegetable', 'Breakfast','Lunch','Dinner']),
4792 td(['Tomatoes' , 'no', 'yes', 'yes']),
4793 td(['Broccoli' , 'no', 'no', 'yes']),
4794 td(['Onions' , 'yes','yes', 'yes'])
4795 ]
4796 )
4797 );
4798
4799=head2 HTML SHORTCUTS AND LIST INTERPOLATION
4800
4801Consider this bit of code:
4802
4803 print blockquote(em('Hi'),'mom!'));
4804
4805It will ordinarily return the string that you probably expect, namely:
4806
4807 <blockquote><em>Hi</em> mom!</blockquote>
4808
4809Note the space between the element "Hi" and the element "mom!".
4810CGI.pm puts the extra space there using array interpolation, which is
4811controlled by the magic $" variable. Sometimes this extra space is
4812not what you want, for example, when you are trying to align a series
4813of images. In this case, you can simply change the value of $" to an
4814empty string.
4815
4816 {
4817 local($") = '';
4818 print blockquote(em('Hi'),'mom!'));
4819 }
4820
4821I suggest you put the code in a block as shown here. Otherwise the
4822change to $" will affect all subsequent code until you explicitly
4823reset it.
4824
4825=head2 NON-STANDARD HTML SHORTCUTS
4826
4827A few HTML tags don't follow the standard pattern for various
4828reasons.
4829
4830B<comment()> generates an HTML comment (<!-- comment -->). Call it
4831like
4832
4833 print comment('here is my comment');
4834
4835Because of conflicts with built-in Perl functions, the following functions
4836begin with initial caps:
4837
4838 Select
4839 Tr
4840 Link
4841 Delete
4842 Accept
4843 Sub
4844
4845In addition, start_html(), end_html(), start_form(), end_form(),
4846start_multipart_form() and all the fill-out form tags are special.
4847See their respective sections.
4848
4849=head2 AUTOESCAPING HTML
4850
4851By default, all HTML that is emitted by the form-generating functions
4852is passed through a function called escapeHTML():
4853
4854=over 4
4855
4856=item $escaped_string = escapeHTML("unescaped string");
4857
4858Escape HTML formatting characters in a string.
4859
4860=back
4861
4862Provided that you have specified a character set of ISO-8859-1 (the
4863default), the standard HTML escaping rules will be used. The "<"
4864character becomes "&lt;", ">" becomes "&gt;", "&" becomes "&amp;", and
4865the quote character becomes "&quot;". In addition, the hexadecimal
48660x8b and 0x9b characters, which many windows-based browsers interpret
4867as the left and right angle-bracket characters, are replaced by their
4868numeric HTML entities ("&#139" and "&#155;"). If you manually change
4869the charset, either by calling the charset() method explicitly or by
4870passing a -charset argument to header(), then B<all> characters will
4871be replaced by their numeric entities, since CGI.pm has no lookup
4872table for all the possible encodings.
4873
4874The automatic escaping does not apply to other shortcuts, such as
4875h1(). You should call escapeHTML() yourself on untrusted data in
4876order to protect your pages against nasty tricks that people may enter
4877into guestbooks, etc.. To change the character set, use charset().
4878To turn autoescaping off completely, use autoescape():
4879
4880=over 4
4881
4882=item $charset = charset([$charset]);
4883
4884Get or set the current character set.
4885
4886=item $flag = autoEscape([$flag]);
4887
4888Get or set the value of the autoescape flag.
4889
4890=back
4891
4892=head2 PRETTY-PRINTING HTML
4893
4894By default, all the HTML produced by these functions comes out as one
4895long line without carriage returns or indentation. This is yuck, but
4896it does reduce the size of the documents by 10-20%. To get
4897pretty-printed output, please use L<CGI::Pretty>, a subclass
4898contributed by Brian Paulsen.
4899
4900=head1 CREATING FILL-OUT FORMS:
4901
4902I<General note> The various form-creating methods all return strings
4903to the caller, containing the tag or tags that will create the requested
4904form element. You are responsible for actually printing out these strings.
4905It's set up this way so that you can place formatting tags
4906around the form elements.
4907
4908I<Another note> The default values that you specify for the forms are only
4909used the B<first> time the script is invoked (when there is no query
4910string). On subsequent invocations of the script (when there is a query
4911string), the former values are used even if they are blank.
4912
4913If you want to change the value of a field from its previous value, you have two
4914choices:
4915
4916(1) call the param() method to set it.
4917
4918(2) use the -override (alias -force) parameter (a new feature in version 2.15).
4919This forces the default value to be used, regardless of the previous value:
4920
4921 print $query->textfield(-name=>'field_name',
4922 -default=>'starting value',
4923 -override=>1,
4924 -size=>50,
4925 -maxlength=>80);
4926
4927I<Yet another note> By default, the text and labels of form elements are
4928escaped according to HTML rules. This means that you can safely use
4929"<CLICK ME>" as the label for a button. However, it also interferes with
4930your ability to incorporate special HTML character sequences, such as &Aacute;,
4931into your fields. If you wish to turn off automatic escaping, call the
4932autoEscape() method with a false value immediately after creating the CGI object:
4933
4934 $query = new CGI;
4935 $query->autoEscape(undef);
4936
4937=head2 CREATING AN ISINDEX TAG
4938
4939 print $query->isindex(-action=>$action);
4940
4941 -or-
4942
4943 print $query->isindex($action);
4944
4945Prints out an <isindex> tag. Not very exciting. The parameter
4946-action specifies the URL of the script to process the query. The
4947default is to process the query with the current script.
4948
4949=head2 STARTING AND ENDING A FORM
4950
4951 print $query->start_form(-method=>$method,
4952 -action=>$action,
4953 -enctype=>$encoding);
4954 <... various form stuff ...>
4955 print $query->endform;
4956
4957 -or-
4958
4959 print $query->start_form($method,$action,$encoding);
4960 <... various form stuff ...>
4961 print $query->endform;
4962
4963start_form() will return a <form> tag with the optional method,
4964action and form encoding that you specify. The defaults are:
4965
4966 method: POST
4967 action: this script
4968 enctype: application/x-www-form-urlencoded
4969
4970endform() returns the closing </form> tag.
4971
4972Start_form()'s enctype argument tells the browser how to package the various
4973fields of the form before sending the form to the server. Two
4974values are possible:
4975
4976B<Note:> This method was previously named startform(), and startform()
4977is still recognized as an alias.
4978
4979=over 4
4980
4981=item B<application/x-www-form-urlencoded>
4982
4983This is the older type of encoding used by all browsers prior to
4984Netscape 2.0. It is compatible with many CGI scripts and is
4985suitable for short fields containing text data. For your
4986convenience, CGI.pm stores the name of this encoding
4987type in B<&CGI::URL_ENCODED>.
4988
4989=item B<multipart/form-data>
4990
4991This is the newer type of encoding introduced by Netscape 2.0.
4992It is suitable for forms that contain very large fields or that
4993are intended for transferring binary data. Most importantly,
4994it enables the "file upload" feature of Netscape 2.0 forms. For
4995your convenience, CGI.pm stores the name of this encoding type
4996in B<&CGI::MULTIPART>
4997
4998Forms that use this type of encoding are not easily interpreted
4999by CGI scripts unless they use CGI.pm or another library designed
5000to handle them.
5001
5002=back
5003
5004For compatibility, the start_form() method uses the older form of
5005encoding by default. If you want to use the newer form of encoding
5006by default, you can call B<start_multipart_form()> instead of
5007B<start_form()>.
5008
5009JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
5010for use with JavaScript. The -name parameter gives the
5011form a name so that it can be identified and manipulated by
5012JavaScript functions. -onSubmit should point to a JavaScript
5013function that will be executed just before the form is submitted to your
5014server. You can use this opportunity to check the contents of the form
5015for consistency and completeness. If you find something wrong, you
5016can put up an alert box or maybe fix things up yourself. You can
5017abort the submission by returning false from this function.
5018
5019Usually the bulk of JavaScript functions are defined in a <script>
5020block in the HTML header and -onSubmit points to one of these function
5021call. See start_html() for details.
5022
5023=head2 CREATING A TEXT FIELD
5024
5025 print $query->textfield(-name=>'field_name',
5026 -default=>'starting value',
5027 -size=>50,
5028 -maxlength=>80);
5029 -or-
5030
5031 print $query->textfield('field_name','starting value',50,80);
5032
5033textfield() will return a text input field.
5034
5035=over 4
5036
5037=item B<Parameters>
5038
5039=item 1.
5040
5041The first parameter is the required name for the field (-name).
5042
5043=item 2.
5044
5045The optional second parameter is the default starting value for the field
5046contents (-default).
5047
5048=item 3.
5049
5050The optional third parameter is the size of the field in
5051 characters (-size).
5052
5053=item 4.
5054
5055The optional fourth parameter is the maximum number of characters the
5056 field will accept (-maxlength).
5057
5058=back
5059
5060As with all these methods, the field will be initialized with its
5061previous contents from earlier invocations of the script.
5062When the form is processed, the value of the text field can be
5063retrieved with:
5064
5065 $value = $query->param('foo');
5066
5067If you want to reset it from its initial value after the script has been
5068called once, you can do so like this:
5069
5070 $query->param('foo',"I'm taking over this value!");
5071
5072NEW AS OF VERSION 2.15: If you don't want the field to take on its previous
5073value, you can force its current value by using the -override (alias -force)
5074parameter:
5075
5076 print $query->textfield(-name=>'field_name',
5077 -default=>'starting value',
5078 -override=>1,
5079 -size=>50,
5080 -maxlength=>80);
5081
5082JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>,
5083B<-onBlur>, B<-onMouseOver>, B<-onMouseOut> and B<-onSelect>
5084parameters to register JavaScript event handlers. The onChange
5085handler will be called whenever the user changes the contents of the
5086text field. You can do text validation if you like. onFocus and
5087onBlur are called respectively when the insertion point moves into and
5088out of the text field. onSelect is called when the user changes the
5089portion of the text that is selected.
5090
5091=head2 CREATING A BIG TEXT FIELD
5092
5093 print $query->textarea(-name=>'foo',
5094 -default=>'starting value',
5095 -rows=>10,
5096 -columns=>50);
5097
5098 -or
5099
5100 print $query->textarea('foo','starting value',10,50);
5101
5102textarea() is just like textfield, but it allows you to specify
5103rows and columns for a multiline text entry box. You can provide
5104a starting value for the field, which can be long and contain
5105multiple lines.
5106
5107JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> ,
5108B<-onMouseOver>, B<-onMouseOut>, and B<-onSelect> parameters are
5109recognized. See textfield().
5110
5111=head2 CREATING A PASSWORD FIELD
5112
5113 print $query->password_field(-name=>'secret',
5114 -value=>'starting value',
5115 -size=>50,
5116 -maxlength=>80);
5117 -or-
5118
5119 print $query->password_field('secret','starting value',50,80);
5120
5121password_field() is identical to textfield(), except that its contents
5122will be starred out on the web page.
5123
5124JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
5125B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
5126recognized. See textfield().
5127
5128=head2 CREATING A FILE UPLOAD FIELD
5129
5130 print $query->filefield(-name=>'uploaded_file',
5131 -default=>'starting value',
5132 -size=>50,
5133 -maxlength=>80);
5134 -or-
5135
5136 print $query->filefield('uploaded_file','starting value',50,80);
5137
5138filefield() will return a file upload field for Netscape 2.0 browsers.
5139In order to take full advantage of this I<you must use the new
5140multipart encoding scheme> for the form. You can do this either
5141by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>,
5142or by calling the new method B<start_multipart_form()> instead of
5143vanilla B<start_form()>.
5144
5145=over 4
5146
5147=item B<Parameters>
5148
5149=item 1.
5150
5151The first parameter is the required name for the field (-name).
5152
5153=item 2.
5154
5155The optional second parameter is the starting value for the field contents
5156to be used as the default file name (-default).
5157
5158For security reasons, browsers don't pay any attention to this field,
5159and so the starting value will always be blank. Worse, the field
5160loses its "sticky" behavior and forgets its previous contents. The
5161starting value field is called for in the HTML specification, however,
5162and possibly some browser will eventually provide support for it.
5163
5164=item 3.
5165
5166The optional third parameter is the size of the field in
5167characters (-size).
5168
5169=item 4.
5170
5171The optional fourth parameter is the maximum number of characters the
5172field will accept (-maxlength).
5173
5174=back
5175
5176When the form is processed, you can retrieve the entered filename
5177by calling param():
5178
5179 $filename = $query->param('uploaded_file');
5180
5181Different browsers will return slightly different things for the
5182name. Some browsers return the filename only. Others return the full
5183path to the file, using the path conventions of the user's machine.
5184Regardless, the name returned is always the name of the file on the
5185I<user's> machine, and is unrelated to the name of the temporary file
5186that CGI.pm creates during upload spooling (see below).
5187
5188The filename returned is also a file handle. You can read the contents
5189of the file using standard Perl file reading calls:
5190
5191 # Read a text file and print it out
5192 while (<$filename>) {
5193 print;
5194 }
5195
5196 # Copy a binary file to somewhere safe
5197 open (OUTFILE,">>/usr/local/web/users/feedback");
5198 while ($bytesread=read($filename,$buffer,1024)) {
5199 print OUTFILE $buffer;
5200 }
5201
5202However, there are problems with the dual nature of the upload fields.
5203If you C<use strict>, then Perl will complain when you try to use a
5204string as a filehandle. You can get around this by placing the file
5205reading code in a block containing the C<no strict> pragma. More
5206seriously, it is possible for the remote user to type garbage into the
5207upload field, in which case what you get from param() is not a
5208filehandle at all, but a string.
5209
5210To be safe, use the I<upload()> function (new in version 2.47). When
5211called with the name of an upload field, I<upload()> returns a
5212filehandle, or undef if the parameter is not a valid filehandle.
5213
5214 $fh = $query->upload('uploaded_file');
5215 while (<$fh>) {
5216 print;
5217 }
5218
5219In an array context, upload() will return an array of filehandles.
5220This makes it possible to create forms that use the same name for
5221multiple upload fields.
5222
5223This is the recommended idiom.
5224
5225When a file is uploaded the browser usually sends along some
5226information along with it in the format of headers. The information
5227usually includes the MIME content type. Future browsers may send
5228other information as well (such as modification date and size). To
5229retrieve this information, call uploadInfo(). It returns a reference to
5230an associative array containing all the document headers.
5231
5232 $filename = $query->param('uploaded_file');
5233 $type = $query->uploadInfo($filename)->{'Content-Type'};
5234 unless ($type eq 'text/html') {
5235 die "HTML FILES ONLY!";
5236 }
5237
5238If you are using a machine that recognizes "text" and "binary" data
5239modes, be sure to understand when and how to use them (see the Camel book).
5240Otherwise you may find that binary files are corrupted during file
5241uploads.
5242
5243There are occasionally problems involving parsing the uploaded file.
5244This usually happens when the user presses "Stop" before the upload is
5245finished. In this case, CGI.pm will return undef for the name of the
5246uploaded file and set I<cgi_error()> to the string "400 Bad request
5247(malformed multipart POST)". This error message is designed so that
5248you can incorporate it into a status code to be sent to the browser.
5249Example:
5250
5251 $file = $query->upload('uploaded_file');
5252 if (!$file && $query->cgi_error) {
5253 print $query->header(-status=>$query->cgi_error);
5254 exit 0;
5255 }
5256
5257You are free to create a custom HTML page to complain about the error,
5258if you wish.
5259
5260If you are using CGI.pm on a Windows platform and find that binary
5261files get slightly larger when uploaded but that text files remain the
5262same, then you have forgotten to activate binary mode on the output
5263filehandle. Be sure to call binmode() on any handle that you create
5264to write the uploaded file to disk.
5265
5266JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
5267B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
5268recognized. See textfield() for details.
5269
5270=head2 CREATING A POPUP MENU
5271
5272 print $query->popup_menu('menu_name',
5273 ['eenie','meenie','minie'],
5274 'meenie');
5275
5276 -or-
5277
5278 %labels = ('eenie'=>'your first choice',
5279 'meenie'=>'your second choice',
5280 'minie'=>'your third choice');
5281 print $query->popup_menu('menu_name',
5282 ['eenie','meenie','minie'],
5283 'meenie',\%labels);
5284
5285 -or (named parameter style)-
5286
5287 print $query->popup_menu(-name=>'menu_name',
5288 -values=>['eenie','meenie','minie'],
5289 -default=>'meenie',
5290 -labels=>\%labels);
5291
5292popup_menu() creates a menu.
5293
5294=over 4
5295
5296=item 1.
5297
5298The required first argument is the menu's name (-name).
5299
5300=item 2.
5301
5302The required second argument (-values) is an array B<reference>
5303containing the list of menu items in the menu. You can pass the
5304method an anonymous array, as shown in the example, or a reference to
5305a named array, such as "\@foo".
5306
5307=item 3.
5308
5309The optional third parameter (-default) is the name of the default
5310menu choice. If not specified, the first item will be the default.
5311The values of the previous choice will be maintained across queries.
5312
5313=item 4.
5314
5315The optional fourth parameter (-labels) is provided for people who
5316want to use different values for the user-visible label inside the
5317popup menu nd the value returned to your script. It's a pointer to an
5318associative array relating menu values to user-visible labels. If you
5319leave this parameter blank, the menu values will be displayed by
5320default. (You can also leave a label undefined if you want to).
5321
5322=back
5323
5324When the form is processed, the selected value of the popup menu can
5325be retrieved using:
5326
5327 $popup_menu_value = $query->param('menu_name');
5328
5329JAVASCRIPTING: popup_menu() recognizes the following event handlers:
5330B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>, and
5331B<-onBlur>. See the textfield() section for details on when these
5332handlers are called.
5333
5334=head2 CREATING A SCROLLING LIST
5335
5336 print $query->scrolling_list('list_name',
5337 ['eenie','meenie','minie','moe'],
5338 ['eenie','moe'],5,'true');
5339 -or-
5340
5341 print $query->scrolling_list('list_name',
5342 ['eenie','meenie','minie','moe'],
5343 ['eenie','moe'],5,'true',
5344 \%labels);
5345
5346 -or-
5347
5348 print $query->scrolling_list(-name=>'list_name',
5349 -values=>['eenie','meenie','minie','moe'],
5350 -default=>['eenie','moe'],
5351 -size=>5,
5352 -multiple=>'true',
5353 -labels=>\%labels);
5354
5355scrolling_list() creates a scrolling list.
5356
5357=over 4
5358
5359=item B<Parameters:>
5360
5361=item 1.
5362
5363The first and second arguments are the list name (-name) and values
5364(-values). As in the popup menu, the second argument should be an
5365array reference.
5366
5367=item 2.
5368
5369The optional third argument (-default) can be either a reference to a
5370list containing the values to be selected by default, or can be a
5371single value to select. If this argument is missing or undefined,
5372then nothing is selected when the list first appears. In the named
5373parameter version, you can use the synonym "-defaults" for this
5374parameter.
5375
5376=item 3.
5377
5378The optional fourth argument is the size of the list (-size).
5379
5380=item 4.
5381
5382The optional fifth argument can be set to true to allow multiple
5383simultaneous selections (-multiple). Otherwise only one selection
5384will be allowed at a time.
5385
5386=item 5.
5387
5388The optional sixth argument is a pointer to an associative array
5389containing long user-visible labels for the list items (-labels).
5390If not provided, the values will be displayed.
5391
5392When this form is processed, all selected list items will be returned as
5393a list under the parameter name 'list_name'. The values of the
5394selected items can be retrieved with:
5395
5396 @selected = $query->param('list_name');
5397
5398=back
5399
5400JAVASCRIPTING: scrolling_list() recognizes the following event
5401handlers: B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>
5402and B<-onBlur>. See textfield() for the description of when these
5403handlers are called.
5404
5405=head2 CREATING A GROUP OF RELATED CHECKBOXES
5406
5407 print $query->checkbox_group(-name=>'group_name',
5408 -values=>['eenie','meenie','minie','moe'],
5409 -default=>['eenie','moe'],
5410 -linebreak=>'true',
5411 -labels=>\%labels);
5412
5413 print $query->checkbox_group('group_name',
5414 ['eenie','meenie','minie','moe'],
5415 ['eenie','moe'],'true',\%labels);
5416
5417 HTML3-COMPATIBLE BROWSERS ONLY:
5418
5419 print $query->checkbox_group(-name=>'group_name',
5420 -values=>['eenie','meenie','minie','moe'],
5421 -rows=2,-columns=>2);
5422
5423
5424checkbox_group() creates a list of checkboxes that are related
5425by the same name.
5426
5427=over 4
5428
5429=item B<Parameters:>
5430
5431=item 1.
5432
5433The first and second arguments are the checkbox name and values,
5434respectively (-name and -values). As in the popup menu, the second
5435argument should be an array reference. These values are used for the
5436user-readable labels printed next to the checkboxes as well as for the
5437values passed to your script in the query string.
5438
5439=item 2.
5440
5441The optional third argument (-default) can be either a reference to a
5442list containing the values to be checked by default, or can be a
5443single value to checked. If this argument is missing or undefined,
5444then nothing is selected when the list first appears.
5445
5446=item 3.
5447
5448The optional fourth argument (-linebreak) can be set to true to place
5449line breaks between the checkboxes so that they appear as a vertical
5450list. Otherwise, they will be strung together on a horizontal line.
5451
5452=item 4.
5453
5454The optional fifth argument is a pointer to an associative array
5455relating the checkbox values to the user-visible labels that will
5456be printed next to them (-labels). If not provided, the values will
5457be used as the default.
5458
5459=item 5.
5460
5461B<HTML3-compatible browsers> (such as Netscape) can take advantage of
5462the optional parameters B<-rows>, and B<-columns>. These parameters
5463cause checkbox_group() to return an HTML3 compatible table containing
5464the checkbox group formatted with the specified number of rows and
5465columns. You can provide just the -columns parameter if you wish;
5466checkbox_group will calculate the correct number of rows for you.
5467
5468To include row and column headings in the returned table, you
5469can use the B<-rowheaders> and B<-colheaders> parameters. Both
5470of these accept a pointer to an array of headings to use.
5471The headings are just decorative. They don't reorganize the
5472interpretation of the checkboxes -- they're still a single named
5473unit.
5474
5475=back
5476
5477When the form is processed, all checked boxes will be returned as
5478a list under the parameter name 'group_name'. The values of the
5479"on" checkboxes can be retrieved with:
5480
5481 @turned_on = $query->param('group_name');
5482
5483The value returned by checkbox_group() is actually an array of button
5484elements. You can capture them and use them within tables, lists,
5485or in other creative ways:
5486
5487 @h = $query->checkbox_group(-name=>'group_name',-values=>\@values);
5488 &use_in_creative_way(@h);
5489
5490JAVASCRIPTING: checkbox_group() recognizes the B<-onClick>
5491parameter. This specifies a JavaScript code fragment or
5492function call to be executed every time the user clicks on
5493any of the buttons in the group. You can retrieve the identity
5494of the particular button clicked on using the "this" variable.
5495
5496=head2 CREATING A STANDALONE CHECKBOX
5497
5498 print $query->checkbox(-name=>'checkbox_name',
5499 -checked=>1,
5500 -value=>'ON',
5501 -label=>'CLICK ME');
5502
5503 -or-
5504
5505 print $query->checkbox('checkbox_name','checked','ON','CLICK ME');
5506
5507checkbox() is used to create an isolated checkbox that isn't logically
5508related to any others.
5509
5510=over 4
5511
5512=item B<Parameters:>
5513
5514=item 1.
5515
5516The first parameter is the required name for the checkbox (-name). It
5517will also be used for the user-readable label printed next to the
5518checkbox.
5519
5520=item 2.
5521
5522The optional second parameter (-checked) specifies that the checkbox
5523is turned on by default. Synonyms are -selected and -on.
5524
5525=item 3.
5526
5527The optional third parameter (-value) specifies the value of the
5528checkbox when it is checked. If not provided, the word "on" is
5529assumed.
5530
5531=item 4.
5532
5533The optional fourth parameter (-label) is the user-readable label to
5534be attached to the checkbox. If not provided, the checkbox name is
5535used.
5536
5537=back
5538
5539The value of the checkbox can be retrieved using:
5540
5541 $turned_on = $query->param('checkbox_name');
5542
5543JAVASCRIPTING: checkbox() recognizes the B<-onClick>
5544parameter. See checkbox_group() for further details.
5545
5546=head2 CREATING A RADIO BUTTON GROUP
5547
5548 print $query->radio_group(-name=>'group_name',
5549 -values=>['eenie','meenie','minie'],
5550 -default=>'meenie',
5551 -linebreak=>'true',
5552 -labels=>\%labels);
5553
5554 -or-
5555
5556 print $query->radio_group('group_name',['eenie','meenie','minie'],
5557 'meenie','true',\%labels);
5558
5559
5560 HTML3-COMPATIBLE BROWSERS ONLY:
5561
5562 print $query->radio_group(-name=>'group_name',
5563 -values=>['eenie','meenie','minie','moe'],
5564 -rows=2,-columns=>2);
5565
5566radio_group() creates a set of logically-related radio buttons
5567(turning one member of the group on turns the others off)
5568
5569=over 4
5570
5571=item B<Parameters:>
5572
5573=item 1.
5574
5575The first argument is the name of the group and is required (-name).
5576
5577=item 2.
5578
5579The second argument (-values) is the list of values for the radio
5580buttons. The values and the labels that appear on the page are
5581identical. Pass an array I<reference> in the second argument, either
5582using an anonymous array, as shown, or by referencing a named array as
5583in "\@foo".
5584
5585=item 3.
5586
5587The optional third parameter (-default) is the name of the default
5588button to turn on. If not specified, the first item will be the
5589default. You can provide a nonexistent button name, such as "-" to
5590start up with no buttons selected.
5591
5592=item 4.
5593
5594The optional fourth parameter (-linebreak) can be set to 'true' to put
5595line breaks between the buttons, creating a vertical list.
5596
5597=item 5.
5598
5599The optional fifth parameter (-labels) is a pointer to an associative
5600array relating the radio button values to user-visible labels to be
5601used in the display. If not provided, the values themselves are
5602displayed.
5603
5604=item 6.
5605
5606B<HTML3-compatible browsers> (such as Netscape) can take advantage
5607of the optional
5608parameters B<-rows>, and B<-columns>. These parameters cause
5609radio_group() to return an HTML3 compatible table containing
5610the radio group formatted with the specified number of rows
5611and columns. You can provide just the -columns parameter if you
5612wish; radio_group will calculate the correct number of rows
5613for you.
5614
5615To include row and column headings in the returned table, you
5616can use the B<-rowheader> and B<-colheader> parameters. Both
5617of these accept a pointer to an array of headings to use.
5618The headings are just decorative. They don't reorganize the
5619interpretation of the radio buttons -- they're still a single named
5620unit.
5621
5622=back
5623
5624When the form is processed, the selected radio button can
5625be retrieved using:
5626
5627 $which_radio_button = $query->param('group_name');
5628
5629The value returned by radio_group() is actually an array of button
5630elements. You can capture them and use them within tables, lists,
5631or in other creative ways:
5632
5633 @h = $query->radio_group(-name=>'group_name',-values=>\@values);
5634 &use_in_creative_way(@h);
5635
5636=head2 CREATING A SUBMIT BUTTON
5637
5638 print $query->submit(-name=>'button_name',
5639 -value=>'value');
5640
5641 -or-
5642
5643 print $query->submit('button_name','value');
5644
5645submit() will create the query submission button. Every form
5646should have one of these.
5647
5648=over 4
5649
5650=item B<Parameters:>
5651
5652=item 1.
5653
5654The first argument (-name) is optional. You can give the button a
5655name if you have several submission buttons in your form and you want
5656to distinguish between them. The name will also be used as the
5657user-visible label. Be aware that a few older browsers don't deal with this correctly and
5658B<never> send back a value from a button.
5659
5660=item 2.
5661
5662The second argument (-value) is also optional. This gives the button
5663a value that will be passed to your script in the query string.
5664
5665=back
5666
5667You can figure out which button was pressed by using different
5668values for each one:
5669
5670 $which_one = $query->param('button_name');
5671
5672JAVASCRIPTING: radio_group() recognizes the B<-onClick>
5673parameter. See checkbox_group() for further details.
5674
5675=head2 CREATING A RESET BUTTON
5676
5677 print $query->reset
5678
5679reset() creates the "reset" button. Note that it restores the
5680form to its value from the last time the script was called,
5681NOT necessarily to the defaults.
5682
5683Note that this conflicts with the Perl reset() built-in. Use
5684CORE::reset() to get the original reset function.
5685
5686=head2 CREATING A DEFAULT BUTTON
5687
5688 print $query->defaults('button_label')
5689
5690defaults() creates a button that, when invoked, will cause the
5691form to be completely reset to its defaults, wiping out all the
5692changes the user ever made.
5693
5694=head2 CREATING A HIDDEN FIELD
5695
5696 print $query->hidden(-name=>'hidden_name',
5697 -default=>['value1','value2'...]);
5698
5699 -or-
5700
5701 print $query->hidden('hidden_name','value1','value2'...);
5702
5703hidden() produces a text field that can't be seen by the user. It
5704is useful for passing state variable information from one invocation
5705of the script to the next.
5706
5707=over 4
5708
5709=item B<Parameters:>
5710
5711=item 1.
5712
5713The first argument is required and specifies the name of this
5714field (-name).
5715
5716=item 2.
5717
5718The second argument is also required and specifies its value
5719(-default). In the named parameter style of calling, you can provide
5720a single value here or a reference to a whole list
5721
5722=back
5723
5724Fetch the value of a hidden field this way:
5725
5726 $hidden_value = $query->param('hidden_name');
5727
5728Note, that just like all the other form elements, the value of a
5729hidden field is "sticky". If you want to replace a hidden field with
5730some other values after the script has been called once you'll have to
5731do it manually:
5732
5733 $query->param('hidden_name','new','values','here');
5734
5735=head2 CREATING A CLICKABLE IMAGE BUTTON
5736
5737 print $query->image_button(-name=>'button_name',
5738 -src=>'/source/URL',
5739 -align=>'MIDDLE');
5740
5741 -or-
5742
5743 print $query->image_button('button_name','/source/URL','MIDDLE');
5744
5745image_button() produces a clickable image. When it's clicked on the
5746position of the click is returned to your script as "button_name.x"
5747and "button_name.y", where "button_name" is the name you've assigned
5748to it.
5749
5750JAVASCRIPTING: image_button() recognizes the B<-onClick>
5751parameter. See checkbox_group() for further details.
5752
5753=over 4
5754
5755=item B<Parameters:>
5756
5757=item 1.
5758
5759The first argument (-name) is required and specifies the name of this
5760field.
5761
5762=item 2.
5763
5764The second argument (-src) is also required and specifies the URL
5765
5766=item 3.
5767
5768The third option (-align, optional) is an alignment type, and may be
5769TOP, BOTTOM or MIDDLE
5770
5771=back
5772
5773Fetch the value of the button this way:
5774 $x = $query->param('button_name.x');
5775 $y = $query->param('button_name.y');
5776
5777=head2 CREATING A JAVASCRIPT ACTION BUTTON
5778
5779 print $query->button(-name=>'button_name',
5780 -value=>'user visible label',
5781 -onClick=>"do_something()");
5782
5783 -or-
5784
5785 print $query->button('button_name',"do_something()");
5786
5787button() produces a button that is compatible with Netscape 2.0's
5788JavaScript. When it's pressed the fragment of JavaScript code
5789pointed to by the B<-onClick> parameter will be executed. On
5790non-Netscape browsers this form element will probably not even
5791display.
5792
5793=head1 HTTP COOKIES
5794
5795Netscape browsers versions 1.1 and higher, and all versions of
5796Internet Explorer, support a so-called "cookie" designed to help
5797maintain state within a browser session. CGI.pm has several methods
5798that support cookies.
5799
5800A cookie is a name=value pair much like the named parameters in a CGI
5801query string. CGI scripts create one or more cookies and send
5802them to the browser in the HTTP header. The browser maintains a list
5803of cookies that belong to a particular Web server, and returns them
5804to the CGI script during subsequent interactions.
5805
5806In addition to the required name=value pair, each cookie has several
5807optional attributes:
5808
5809=over 4
5810
5811=item 1. an expiration time
5812
5813This is a time/date string (in a special GMT format) that indicates
5814when a cookie expires. The cookie will be saved and returned to your
5815script until this expiration date is reached if the user exits
5816the browser and restarts it. If an expiration date isn't specified, the cookie
5817will remain active until the user quits the browser.
5818
5819=item 2. a domain
5820
5821This is a partial or complete domain name for which the cookie is
5822valid. The browser will return the cookie to any host that matches
5823the partial domain name. For example, if you specify a domain name
5824of ".capricorn.com", then the browser will return the cookie to
5825Web servers running on any of the machines "www.capricorn.com",
5826"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
5827must contain at least two periods to prevent attempts to match
5828on top level domains like ".edu". If no domain is specified, then
5829the browser will only return the cookie to servers on the host the
5830cookie originated from.
5831
5832=item 3. a path
5833
5834If you provide a cookie path attribute, the browser will check it
5835against your script's URL before returning the cookie. For example,
5836if you specify the path "/cgi-bin", then the cookie will be returned
5837to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
5838and "/cgi-bin/customer_service/complain.pl", but not to the script
5839"/cgi-private/site_admin.pl". By default, path is set to "/", which
5840causes the cookie to be sent to any CGI script on your site.
5841
5842=item 4. a "secure" flag
5843
5844If the "secure" attribute is set, the cookie will only be sent to your
5845script if the CGI request is occurring on a secure channel, such as SSL.
5846
5847=back
5848
5849The interface to HTTP cookies is the B<cookie()> method:
5850
5851 $cookie = $query->cookie(-name=>'sessionID',
5852 -value=>'xyzzy',
5853 -expires=>'+1h',
5854 -path=>'/cgi-bin/database',
5855 -domain=>'.capricorn.org',
5856 -secure=>1);
5857 print $query->header(-cookie=>$cookie);
5858
5859B<cookie()> creates a new cookie. Its parameters include:
5860
5861=over 4
5862
5863=item B<-name>
5864
5865The name of the cookie (required). This can be any string at all.
5866Although browsers limit their cookie names to non-whitespace
5867alphanumeric characters, CGI.pm removes this restriction by escaping
5868and unescaping cookies behind the scenes.
5869
5870=item B<-value>
5871
5872The value of the cookie. This can be any scalar value,
5873array reference, or even associative array reference. For example,
5874you can store an entire associative array into a cookie this way:
5875
5876 $cookie=$query->cookie(-name=>'family information',
5877 -value=>\%childrens_ages);
5878
5879=item B<-path>
5880
5881The optional partial path for which this cookie will be valid, as described
5882above.
5883
5884=item B<-domain>
5885
5886The optional partial domain for which this cookie will be valid, as described
5887above.
5888
5889=item B<-expires>
5890
5891The optional expiration date for this cookie. The format is as described
5892in the section on the B<header()> method:
5893
5894 "+1h" one hour from now
5895
5896=item B<-secure>
5897
5898If set to true, this cookie will only be used within a secure
5899SSL session.
5900
5901=back
5902
5903The cookie created by cookie() must be incorporated into the HTTP
5904header within the string returned by the header() method:
5905
5906 print $query->header(-cookie=>$my_cookie);
5907
5908To create multiple cookies, give header() an array reference:
5909
5910 $cookie1 = $query->cookie(-name=>'riddle_name',
5911 -value=>"The Sphynx's Question");
5912 $cookie2 = $query->cookie(-name=>'answers',
5913 -value=>\%answers);
5914 print $query->header(-cookie=>[$cookie1,$cookie2]);
5915
5916To retrieve a cookie, request it by name by calling cookie() method
5917without the B<-value> parameter:
5918
5919 use CGI;
5920 $query = new CGI;
5921 $riddle = $query->cookie('riddle_name');
5922 %answers = $query->cookie('answers');
5923
5924Cookies created with a single scalar value, such as the "riddle_name"
5925cookie, will be returned in that form. Cookies with array and hash
5926values can also be retrieved.
5927
5928The cookie and CGI namespaces are separate. If you have a parameter
5929named 'answers' and a cookie named 'answers', the values retrieved by
5930param() and cookie() are independent of each other. However, it's
5931simple to turn a CGI parameter into a cookie, and vice-versa:
5932
5933 # turn a CGI parameter into a cookie
5934 $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]);
5935 # vice-versa
5936 $q->param(-name=>'answers',-value=>[$q->cookie('answers')]);
5937
5938See the B<cookie.cgi> example script for some ideas on how to use
5939cookies effectively.
5940
5941=head1 WORKING WITH FRAMES
5942
5943It's possible for CGI.pm scripts to write into several browser panels
5944and windows using the HTML 4 frame mechanism. There are three
5945techniques for defining new frames programmatically:
5946
5947=over 4
5948
5949=item 1. Create a <Frameset> document
5950
5951After writing out the HTTP header, instead of creating a standard
5952HTML document using the start_html() call, create a <frameset>
5953document that defines the frames on the page. Specify your script(s)
5954(with appropriate parameters) as the SRC for each of the frames.
5955
5956There is no specific support for creating <frameset> sections
5957in CGI.pm, but the HTML is very simple to write. See the frame
5958documentation in Netscape's home pages for details
5959
5960 http://home.netscape.com/assist/net_sites/frames.html
5961
5962=item 2. Specify the destination for the document in the HTTP header
5963
5964You may provide a B<-target> parameter to the header() method:
5965
5966 print $q->header(-target=>'ResultsWindow');
5967
5968This will tell the browser to load the output of your script into the
5969frame named "ResultsWindow". If a frame of that name doesn't already
5970exist, the browser will pop up a new window and load your script's
5971document into that. There are a number of magic names that you can
5972use for targets. See the frame documents on Netscape's home pages for
5973details.
5974
5975=item 3. Specify the destination for the document in the <form> tag
5976
5977You can specify the frame to load in the FORM tag itself. With
5978CGI.pm it looks like this:
5979
5980 print $q->start_form(-target=>'ResultsWindow');
5981
5982When your script is reinvoked by the form, its output will be loaded
5983into the frame named "ResultsWindow". If one doesn't already exist
5984a new window will be created.
5985
5986=back
5987
5988The script "frameset.cgi" in the examples directory shows one way to
5989create pages in which the fill-out form and the response live in
5990side-by-side frames.
5991
5992=head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
5993
5994CGI.pm has limited support for HTML3's cascading style sheets (css).
5995To incorporate a stylesheet into your document, pass the
5996start_html() method a B<-style> parameter. The value of this
5997parameter may be a scalar, in which case it is incorporated directly
5998into a <style> section, or it may be a hash reference. In the latter
5999case you should provide the hash with one or more of B<-src> or
6000B<-code>. B<-src> points to a URL where an externally-defined
6001stylesheet can be found. B<-code> points to a scalar value to be
6002incorporated into a <style> section. Style definitions in B<-code>
6003override similarly-named ones in B<-src>, hence the name "cascading."
6004
6005You may also specify the type of the stylesheet by adding the optional
6006B<-type> parameter to the hash pointed to by B<-style>. If not
6007specified, the style defaults to 'text/css'.
6008
6009To refer to a style within the body of your document, add the
6010B<-class> parameter to any HTML element:
6011
6012 print h1({-class=>'Fancy'},'Welcome to the Party');
6013
6014Or define styles on the fly with the B<-style> parameter:
6015
6016 print h1({-style=>'Color: red;'},'Welcome to Hell');
6017
6018You may also use the new B<span()> element to apply a style to a
6019section of text:
6020
6021 print span({-style=>'Color: red;'},
6022 h1('Welcome to Hell'),
6023 "Where did that handbasket get to?"
6024 );
6025
6026Note that you must import the ":html3" definitions to have the
6027B<span()> method available. Here's a quick and dirty example of using
6028CSS's. See the CSS specification at
6029http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
6030
6031 use CGI qw/:standard :html3/;
6032
6033 #here's a stylesheet incorporated directly into the page
6034 $newStyle=<<END;
6035 <!--
6036 P.Tip {
6037 margin-right: 50pt;
6038 margin-left: 50pt;
6039 color: red;
6040 }
6041 P.Alert {
6042 font-size: 30pt;
6043 font-family: sans-serif;
6044 color: red;
6045 }
6046 -->
6047 END
6048 print header();
6049 print start_html( -title=>'CGI with Style',
6050 -style=>{-src=>'http://www.capricorn.com/style/st1.css',
6051 -code=>$newStyle}
6052 );
6053 print h1('CGI with Style'),
6054 p({-class=>'Tip'},
6055 "Better read the cascading style sheet spec before playing with this!"),
6056 span({-style=>'color: magenta'},
6057 "Look Mom, no hands!",
6058 p(),
6059 "Whooo wee!"
6060 );
6061 print end_html;
6062
6063Pass an array reference to B<-style> in order to incorporate multiple
6064stylesheets into your document.
6065
6066=head1 DEBUGGING
6067
6068If you are running the script from the command line or in the perl
6069debugger, you can pass the script a list of keywords or
6070parameter=value pairs on the command line or from standard input (you
6071don't have to worry about tricking your script into reading from
6072environment variables). You can pass keywords like this:
6073
6074 your_script.pl keyword1 keyword2 keyword3
6075
6076or this:
6077
6078 your_script.pl keyword1+keyword2+keyword3
6079
6080or this:
6081
6082 your_script.pl name1=value1 name2=value2
6083
6084or this:
6085
6086 your_script.pl name1=value1&name2=value2
6087
6088To turn off this feature, use the -no_debug pragma.
6089
6090To test the POST method, you may enable full debugging with the -debug
6091pragma. This will allow you to feed newline-delimited name=value
6092pairs to the script on standard input.
6093
6094When debugging, you can use quotes and backslashes to escape
6095characters in the familiar shell manner, letting you place
6096spaces and other funny characters in your parameter=value
6097pairs:
6098
6099 your_script.pl "name1='I am a long value'" "name2=two\ words"
6100
6101=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
6102
6103The Dump() method produces a string consisting of all the query's
6104name/value pairs formatted nicely as a nested list. This is useful
6105for debugging purposes:
6106
6107 print $query->Dump
6108
6109
6110Produces something that looks like:
6111
6112 <ul>
6113 <li>name1
6114 <ul>
6115 <li>value1
6116 <li>value2
6117 </ul>
6118 <li>name2
6119 <ul>
6120 <li>value1
6121 </ul>
6122 </ul>
6123
6124As a shortcut, you can interpolate the entire CGI object into a string
6125and it will be replaced with the a nice HTML dump shown above:
6126
6127 $query=new CGI;
6128 print "<h2>Current Values</h2> $query\n";
6129
6130=head1 FETCHING ENVIRONMENT VARIABLES
6131
6132Some of the more useful environment variables can be fetched
6133through this interface. The methods are as follows:
6134
6135=over 4
6136
6137=item B<Accept()>
6138
6139Return a list of MIME types that the remote browser accepts. If you
6140give this method a single argument corresponding to a MIME type, as in
6141$query->Accept('text/html'), it will return a floating point value
6142corresponding to the browser's preference for this type from 0.0
6143(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept
6144list are handled correctly.
6145
6146Note that the capitalization changed between version 2.43 and 2.44 in
6147order to avoid conflict with Perl's accept() function.
6148
6149=item B<raw_cookie()>
6150
6151Returns the HTTP_COOKIE variable, an HTTP extension implemented by
6152Netscape browsers version 1.1 and higher, and all versions of Internet
6153Explorer. Cookies have a special format, and this method call just
6154returns the raw form (?cookie dough). See cookie() for ways of
6155setting and retrieving cooked cookies.
6156
6157Called with no parameters, raw_cookie() returns the packed cookie
6158structure. You can separate it into individual cookies by splitting
6159on the character sequence "; ". Called with the name of a cookie,
6160retrieves the B<unescaped> form of the cookie. You can use the
6161regular cookie() method to get the names, or use the raw_fetch()
6162method from the CGI::Cookie module.
6163
6164=item B<user_agent()>
6165
6166Returns the HTTP_USER_AGENT variable. If you give
6167this method a single argument, it will attempt to
6168pattern match on it, allowing you to do something
6169like $query->user_agent(netscape);
6170
6171=item B<path_info()>
6172
6173Returns additional path information from the script URL.
6174E.G. fetching /cgi-bin/your_script/additional/stuff will result in
6175$query->path_info() returning "/additional/stuff".
6176
6177NOTE: The Microsoft Internet Information Server
6178is broken with respect to additional path information. If
6179you use the Perl DLL library, the IIS server will attempt to
6180execute the additional path information as a Perl script.
6181If you use the ordinary file associations mapping, the
6182path information will be present in the environment,
6183but incorrect. The best thing to do is to avoid using additional
6184path information in CGI scripts destined for use with IIS.
6185
6186=item B<path_translated()>
6187
6188As per path_info() but returns the additional
6189path information translated into a physical path, e.g.
6190"/usr/local/etc/httpd/htdocs/additional/stuff".
6191
6192The Microsoft IIS is broken with respect to the translated
6193path as well.
6194
6195=item B<remote_host()>
6196
6197Returns either the remote host name or IP address.
6198if the former is unavailable.
6199
6200=item B<script_name()>
6201
6202Return the script name as a partial URL, for self-refering
6203scripts.
6204
6205=item B<referer()>
6206
6207Return the URL of the page the browser was viewing
6208prior to fetching your script. Not available for all
6209browsers.
6210
6211=item B<auth_type ()>
6212
6213Return the authorization/verification method in use for this
6214script, if any.
6215
6216=item B<server_name ()>
6217
6218Returns the name of the server, usually the machine's host
6219name.
6220
6221=item B<virtual_host ()>
6222
6223When using virtual hosts, returns the name of the host that
6224the browser attempted to contact
6225
6226=item B<server_port ()>
6227
6228Return the port that the server is listening on.
6229
6230=item B<server_software ()>
6231
6232Returns the server software and version number.
6233
6234=item B<remote_user ()>
6235
6236Return the authorization/verification name used for user
6237verification, if this script is protected.
6238
6239=item B<user_name ()>
6240
6241Attempt to obtain the remote user's name, using a variety of different
6242techniques. This only works with older browsers such as Mosaic.
6243Newer browsers do not report the user name for privacy reasons!
6244
6245=item B<request_method()>
6246
6247Returns the method used to access your script, usually
6248one of 'POST', 'GET' or 'HEAD'.
6249
6250=item B<content_type()>
6251
6252Returns the content_type of data submitted in a POST, generally
6253multipart/form-data or application/x-www-form-urlencoded
6254
6255=item B<http()>
6256
6257Called with no arguments returns the list of HTTP environment
6258variables, including such things as HTTP_USER_AGENT,
6259HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the
6260like-named HTTP header fields in the request. Called with the name of
6261an HTTP header field, returns its value. Capitalization and the use
6262of hyphens versus underscores are not significant.
6263
6264For example, all three of these examples are equivalent:
6265
6266 $requested_language = $q->http('Accept-language');
6267 $requested_language = $q->http('Accept_language');
6268 $requested_language = $q->http('HTTP_ACCEPT_LANGUAGE');
6269
6270=item B<https()>
6271
6272The same as I<http()>, but operates on the HTTPS environment variables
6273present when the SSL protocol is in effect. Can be used to determine
6274whether SSL is turned on.
6275
6276=back
6277
6278=head1 USING NPH SCRIPTS
6279
6280NPH, or "no-parsed-header", scripts bypass the server completely by
6281sending the complete HTTP header directly to the browser. This has
6282slight performance benefits, but is of most use for taking advantage
6283of HTTP extensions that are not directly supported by your server,
6284such as server push and PICS headers.
6285
6286Servers use a variety of conventions for designating CGI scripts as
6287NPH. Many Unix servers look at the beginning of the script's name for
6288the prefix "nph-". The Macintosh WebSTAR server and Microsoft's
6289Internet Information Server, in contrast, try to decide whether a
6290program is an NPH script by examining the first line of script output.
6291
6292
6293CGI.pm supports NPH scripts with a special NPH mode. When in this
6294mode, CGI.pm will output the necessary extra header information when
6295the header() and redirect() methods are
6296called.
6297
6298The Microsoft Internet Information Server requires NPH mode. As of
6299version 2.30, CGI.pm will automatically detect when the script is
6300running under IIS and put itself into this mode. You do not need to
6301do this manually, although it won't hurt anything if you do. However,
6302note that if you have applied Service Pack 6, much of the
6303functionality of NPH scripts, including the ability to redirect while
6304setting a cookie, b<do not work at all> on IIS without a special patch
6305from Microsoft. See
6306http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP:
6307Non-Parsed Headers Stripped From CGI Applications That Have nph-
6308Prefix in Name.
6309
6310=over 4
6311
6312=item In the B<use> statement
6313
6314Simply add the "-nph" pragmato the list of symbols to be imported into
6315your script:
6316
6317 use CGI qw(:standard -nph)
6318
6319=item By calling the B<nph()> method:
6320
6321Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
6322
6323 CGI->nph(1)
6324
6325=item By using B<-nph> parameters
6326
6327in the B<header()> and B<redirect()> statements:
6328
6329 print $q->header(-nph=>1);
6330
6331=back
6332
6333=head1 Server Push
6334
6335CGI.pm provides four simple functions for producing multipart
6336documents of the type needed to implement server push. These
6337functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To
6338import these into your namespace, you must import the ":push" set.
6339You are also advised to put the script into NPH mode and to set $| to
63401 to avoid buffering problems.
6341
6342Here is a simple script that demonstrates server push:
6343
6344 #!/usr/local/bin/perl
6345 use CGI qw/:push -nph/;
6346 $| = 1;
6347 print multipart_init(-boundary=>'----here we go!');
6348 foreach (0 .. 4) {
6349 print multipart_start(-type=>'text/plain'),
6350 "The current time is ",scalar(localtime),"\n";
6351 if ($_ < 4) {
6352 print multipart_end;
6353 } else {
6354 print multipart_final;
6355 }
6356 sleep 1;
6357 }
6358
6359This script initializes server push by calling B<multipart_init()>.
6360It then enters a loop in which it begins a new multipart section by
6361calling B<multipart_start()>, prints the current local time,
6362and ends a multipart section with B<multipart_end()>. It then sleeps
6363a second, and begins again. On the final iteration, it ends the
6364multipart section with B<multipart_final()> rather than with
6365B<multipart_end()>.
6366
6367=over 4
6368
6369=item multipart_init()
6370
6371 multipart_init(-boundary=>$boundary);
6372
6373Initialize the multipart system. The -boundary argument specifies
6374what MIME boundary string to use to separate parts of the document.
6375If not provided, CGI.pm chooses a reasonable boundary for you.
6376
6377=item multipart_start()
6378
6379 multipart_start(-type=>$type)
6380
6381Start a new part of the multipart document using the specified MIME
6382type. If not specified, text/html is assumed.
6383
6384=item multipart_end()
6385
6386 multipart_end()
6387
6388End a part. You must remember to call multipart_end() once for each
6389multipart_start(), except at the end of the last part of the multipart
6390document when multipart_final() should be called instead of multipart_end().
6391
6392=item multipart_final()
6393
6394 multipart_final()
6395
6396End all parts. You should call multipart_final() rather than
6397multipart_end() at the end of the last part of the multipart document.
6398
6399=back
6400
6401Users interested in server push applications should also have a look
6402at the CGI::Push module.
6403
6404Only Netscape Navigator supports server push. Internet Explorer
6405browsers do not.
6406
6407=head1 Avoiding Denial of Service Attacks
6408
6409A potential problem with CGI.pm is that, by default, it attempts to
6410process form POSTings no matter how large they are. A wily hacker
6411could attack your site by sending a CGI script a huge POST of many
6412megabytes. CGI.pm will attempt to read the entire POST into a
6413variable, growing hugely in size until it runs out of memory. While
6414the script attempts to allocate the memory the system may slow down
6415dramatically. This is a form of denial of service attack.
6416
6417Another possible attack is for the remote user to force CGI.pm to
6418accept a huge file upload. CGI.pm will accept the upload and store it
6419in a temporary directory even if your script doesn't expect to receive
6420an uploaded file. CGI.pm will delete the file automatically when it
6421terminates, but in the meantime the remote user may have filled up the
6422server's disk space, causing problems for other programs.
6423
6424The best way to avoid denial of service attacks is to limit the amount
6425of memory, CPU time and disk space that CGI scripts can use. Some Web
6426servers come with built-in facilities to accomplish this. In other
6427cases, you can use the shell I<limit> or I<ulimit>
6428commands to put ceilings on CGI resource usage.
6429
6430
6431CGI.pm also has some simple built-in protections against denial of
6432service attacks, but you must activate them before you can use them.
6433These take the form of two global variables in the CGI name space:
6434
6435=over 4
6436
6437=item B<$CGI::POST_MAX>
6438
6439If set to a non-negative integer, this variable puts a ceiling
6440on the size of POSTings, in bytes. If CGI.pm detects a POST
6441that is greater than the ceiling, it will immediately exit with an error
6442message. This value will affect both ordinary POSTs and
6443multipart POSTs, meaning that it limits the maximum size of file
6444uploads as well. You should set this to a reasonably high
6445value, such as 1 megabyte.
6446
6447=item B<$CGI::DISABLE_UPLOADS>
6448
6449If set to a non-zero value, this will disable file uploads
6450completely. Other fill-out form values will work as usual.
6451
6452=back
6453
6454You can use these variables in either of two ways.
6455
6456=over 4
6457
6458=item B<1. On a script-by-script basis>
6459
6460Set the variable at the top of the script, right after the "use" statement:
6461
6462 use CGI qw/:standard/;
6463 use CGI::Carp 'fatalsToBrowser';
6464 $CGI::POST_MAX=1024 * 100; # max 100K posts
6465 $CGI::DISABLE_UPLOADS = 1; # no uploads
6466
6467=item B<2. Globally for all scripts>
6468
6469Open up CGI.pm, find the definitions for $POST_MAX and
6470$DISABLE_UPLOADS, and set them to the desired values. You'll
6471find them towards the top of the file in a subroutine named
6472initialize_globals().
6473
6474=back
6475
6476An attempt to send a POST larger than $POST_MAX bytes will cause
6477I<param()> to return an empty CGI parameter list. You can test for
6478this event by checking I<cgi_error()>, either after you create the CGI
6479object or, if you are using the function-oriented interface, call
6480<param()> for the first time. If the POST was intercepted, then
6481cgi_error() will return the message "413 POST too large".
6482
6483This error message is actually defined by the HTTP protocol, and is
6484designed to be returned to the browser as the CGI script's status
6485 code. For example:
6486
6487 $uploaded_file = param('upload');
6488 if (!$uploaded_file && cgi_error()) {
6489 print header(-status=>cgi_error());
6490 exit 0;
6491 }
6492
6493However it isn't clear that any browser currently knows what to do
6494with this status code. It might be better just to create an
6495HTML page that warns the user of the problem.
6496
6497=head1 COMPATIBILITY WITH CGI-LIB.PL
6498
6499To make it easier to port existing programs that use cgi-lib.pl the
6500compatibility routine "ReadParse" is provided. Porting is simple:
6501
6502OLD VERSION
6503 require "cgi-lib.pl";
6504 &ReadParse;
6505 print "The value of the antique is $in{antique}.\n";
6506
6507NEW VERSION
6508 use CGI;
6509 CGI::ReadParse
6510 print "The value of the antique is $in{antique}.\n";
6511
6512CGI.pm's ReadParse() routine creates a tied variable named %in,
6513which can be accessed to obtain the query variables. Like
6514ReadParse, you can also provide your own variable. Infrequently
6515used features of ReadParse, such as the creation of @in and $in
6516variables, are not supported.
6517
6518Once you use ReadParse, you can retrieve the query object itself
6519this way:
6520
6521 $q = $in{CGI};
6522 print $q->textfield(-name=>'wow',
6523 -value=>'does this really work?');
6524
6525This allows you to start using the more interesting features
6526of CGI.pm without rewriting your old scripts from scratch.
6527
6528=head1 AUTHOR INFORMATION
6529
6530Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
6531
6532This library is free software; you can redistribute it and/or modify
6533it under the same terms as Perl itself.
6534
6535Address bug reports and comments to: lstein@cshl.org. When sending
6536bug reports, please provide the version of CGI.pm, the version of
6537Perl, the name and version of your Web server, and the name and
6538version of the operating system you are using. If the problem is even
6539remotely browser dependent, please provide information about the
6540affected browers as well.
6541
6542=head1 CREDITS
6543
6544Thanks very much to:
6545
6546=over 4
6547
6548=item Matt Heffron (heffron@falstaff.css.beckman.com)
6549
6550=item James Taylor (james.taylor@srs.gov)
6551
6552=item Scott Anguish <sanguish@digifix.com>
6553
6554=item Mike Jewell (mlj3u@virginia.edu)
6555
6556=item Timothy Shimmin (tes@kbs.citri.edu.au)
6557
6558=item Joergen Haegg (jh@axis.se)
6559
6560=item Laurent Delfosse (delfosse@delfosse.com)
6561
6562=item Richard Resnick (applepi1@aol.com)
6563
6564=item Craig Bishop (csb@barwonwater.vic.gov.au)
6565
6566=item Tony Curtis (tc@vcpc.univie.ac.at)
6567
6568=item Tim Bunce (Tim.Bunce@ig.co.uk)
6569
6570=item Tom Christiansen (tchrist@convex.com)
6571
6572=item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
6573
6574=item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
6575
6576=item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
6577
6578=item Stephen Dahmen (joyfire@inxpress.net)
6579
6580=item Ed Jordan (ed@fidalgo.net)
6581
6582=item David Alan Pisoni (david@cnation.com)
6583
6584=item Doug MacEachern (dougm@opengroup.org)
6585
6586=item Robin Houston (robin@oneworld.org)
6587
6588=item ...and many many more...
6589
6590for suggestions and bug fixes.
6591
6592=back
6593
6594=head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
6595
6596
6597 #!/usr/local/bin/perl
6598
6599 use CGI;
6600
6601 $query = new CGI;
6602
6603 print $query->header;
6604 print $query->start_html("Example CGI.pm Form");
6605 print "<h1> Example CGI.pm Form</h1>\n";
6606 &print_prompt($query);
6607 &do_work($query);
6608 &print_tail;
6609 print $query->end_html;
6610
6611 sub print_prompt {
6612 my($query) = @_;
6613
6614 print $query->start_form;
6615 print "<em>What's your name?</em><br>";
6616 print $query->textfield('name');
6617 print $query->checkbox('Not my real name');
6618
6619 print "<p><em>Where can you find English Sparrows?</em><br>";
6620 print $query->checkbox_group(
6621 -name=>'Sparrow locations',
6622 -values=>[England,France,Spain,Asia,Hoboken],
6623 -linebreak=>'yes',
6624 -defaults=>[England,Asia]);
6625
6626 print "<p><em>How far can they fly?</em><br>",
6627 $query->radio_group(
6628 -name=>'how far',
6629 -values=>['10 ft','1 mile','10 miles','real far'],
6630 -default=>'1 mile');
6631
6632 print "<p><em>What's your favorite color?</em> ";
6633 print $query->popup_menu(-name=>'Color',
6634 -values=>['black','brown','red','yellow'],
6635 -default=>'red');
6636
6637 print $query->hidden('Reference','Monty Python and the Holy Grail');
6638
6639 print "<p><em>What have you got there?</em><br>";
6640 print $query->scrolling_list(
6641 -name=>'possessions',
6642 -values=>['A Coconut','A Grail','An Icon',
6643 'A Sword','A Ticket'],
6644 -size=>5,
6645 -multiple=>'true');
6646
6647 print "<p><em>Any parting comments?</em><br>";
6648 print $query->textarea(-name=>'Comments',
6649 -rows=>10,
6650 -columns=>50);
6651
6652 print "<p>",$query->reset;
6653 print $query->submit('Action','Shout');
6654 print $query->submit('Action','Scream');
6655 print $query->endform;
6656 print "<hr>\n";
6657 }
6658
6659 sub do_work {
6660 my($query) = @_;
6661 my(@values,$key);
6662
6663 print "<h2>Here are the current settings in this form</h2>";
6664
6665 foreach $key ($query->param) {
6666 print "<strong>$key</strong> -> ";
6667 @values = $query->param($key);
6668 print join(", ",@values),"<br>\n";
6669 }
6670 }
6671
6672 sub print_tail {
6673 print <<END;
6674 <hr>
6675 <address>Lincoln D. Stein</address><br>
6676 <a href="/">Home Page</a>
6677 END
6678 }
6679
6680=head1 BUGS
6681
6682This module has grown large and monolithic. Furthermore it's doing many
6683things, such as handling URLs, parsing CGI input, writing HTML, etc., that
6684are also done in the LWP modules. It should be discarded in favor of
6685the CGI::* modules, but somehow I continue to work on it.
6686
6687Note that the code is truly contorted in order to avoid spurious
6688warnings when programs are run with the B<-w> switch.
6689
6690=head1 SEE ALSO
6691
6692L<CGI::Carp>, L<CGI::Fast>, L<CGI::Pretty>
6693
6694=cut
6695
Full OpenSPARC design & verification tarball including full HDL.