source: main/trunk/greenstone2/common-src/cgi-bin/CGI.pm@ 31960

Last change on this file since 31960 was 7767, checked in by davidb, 20 years ago

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