This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline
[perl5.git] / lib / CGI.pm
CommitLineData
54310121 1package CGI;
424ec8fa 2require 5.004;
54310121
PP
3
4# See the bottom of this file for the POD documentation. Search for the
5# string '=head'.
6
7# You can run this file through either pod2man or pod2html to produce pretty
8# documentation in manual or html file format (these utilities are part of the
9# Perl 5 distribution).
10
424ec8fa 11# Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
54310121
PP
12# It may be used and modified freely, but I do request that this copyright
13# notice remain attached to the file. You may modify this module as you
14# wish, but if you redistribute a modified version, please attach a note
15# listing the modifications you have made.
16
17# The most recent version and complete docs are available at:
71f3e297 18# http://stein.cshl.org/WWW/software/CGI/
54310121 19
03b9648d
JH
20$CGI::revision = '$Id: CGI.pm,v 1.45 2000/09/13 02:55:41 lstein Exp $';
21$CGI::VERSION='2.74';
54310121
PP
22
23# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
24# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
25# $TempFile::TMPDIRECTORY = '/usr/tmp';
3d1a2ec4 26use CGI::Util qw(rearrange make_attributes unescape escape expires);
54310121 27
6b4ac661
JH
28use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
29 'DTD/xhtml1-transitional.dtd'];
30
424ec8fa
GS
31# >>>>> Here are some globals that you might want to adjust <<<<<<
32sub initialize_globals {
33 # Set this to 1 to enable copious autoloader debugging messages
34 $AUTOLOAD_DEBUG = 0;
6b4ac661
JH
35
36 # Set this to 1 to generate XTML-compatible output
37 $XHTML = 1;
424ec8fa
GS
38
39 # Change this to the preferred DTD to print in start_html()
40 # or use default_dtd('text of DTD to use');
3d1a2ec4
GS
41 $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
42 'http://www.w3.org/TR/html4/loose.dtd' ] ;
43
44 # Set this to 1 to enable NOSTICKY scripts
45 # or:
46 # 1) use CGI qw(-nosticky)
47 # 2) $CGI::nosticky(1)
48 $NOSTICKY = 0;
424ec8fa
GS
49
50 # Set this to 1 to enable NPH scripts
51 # or:
52 # 1) use CGI qw(-nph)
3d1a2ec4 53 # 2) CGI::nph(1)
424ec8fa
GS
54 # 3) print header(-nph=>1)
55 $NPH = 0;
56
3d1a2ec4
GS
57 # Set this to 1 to enable debugging from @ARGV
58 # Set to 2 to enable debugging from STDIN
59 $DEBUG = 1;
424ec8fa
GS
60
61 # Set this to 1 to make the temporary files created
62 # during file uploads safe from prying eyes
63 # or do...
64 # 1) use CGI qw(:private_tempfiles)
3d1a2ec4 65 # 2) CGI::private_tempfiles(1);
424ec8fa
GS
66 $PRIVATE_TEMPFILES = 0;
67
68 # Set this to a positive value to limit the size of a POSTing
69 # to a certain number of bytes:
70 $POST_MAX = -1;
71
72 # Change this to 1 to disable uploads entirely:
73 $DISABLE_UPLOADS = 0;
74
3538e1d5
GS
75 # Automatically determined -- don't change
76 $EBCDIC = 0;
77
71f3e297
JH
78 # Change this to 1 to suppress redundant HTTP headers
79 $HEADERS_ONCE = 0;
80
81 # separate the name=value pairs by semicolons rather than ampersands
3d1a2ec4 82 $USE_PARAM_SEMICOLONS = 1;
71f3e297 83
424ec8fa
GS
84 # Other globals that you shouldn't worry about.
85 undef $Q;
86 $BEEN_THERE = 0;
87 undef @QUERY_PARAM;
88 undef %EXPORT;
d45d855d
JH
89 undef $QUERY_CHARSET;
90 undef %QUERY_FIELDNAMES;
424ec8fa
GS
91
92 # prevent complaints by mod_perl
93 1;
94}
95
54310121
PP
96# ------------------ START OF THE LIBRARY ------------
97
424ec8fa
GS
98# make mod_perlhappy
99initialize_globals();
100
54310121
PP
101# FIGURE OUT THE OS WE'RE RUNNING UNDER
102# Some systems support the $^O variable. If not
103# available then require() the Config library
104unless ($OS) {
105 unless ($OS = $^O) {
106 require Config;
107 $OS = $Config::Config{'osname'};
108 }
109}
360eb788 110if ($OS =~ /^MSWin/i) {
3538e1d5 111 $OS = 'WINDOWS';
360eb788 112} elsif ($OS =~ /^VMS/i) {
3538e1d5 113 $OS = 'VMS';
360eb788 114} elsif ($OS =~ /^dos/i) {
3538e1d5 115 $OS = 'DOS';
360eb788 116} elsif ($OS =~ /^MacOS/i) {
54310121 117 $OS = 'MACINTOSH';
360eb788 118} elsif ($OS =~ /^os2/i) {
54310121 119 $OS = 'OS2';
360eb788 120} elsif ($OS =~ /^epoc/i) {
fa6a1c44 121 $OS = 'EPOC';
54310121
PP
122} else {
123 $OS = 'UNIX';
124}
125
126# Some OS logic. Binary mode enabled on DOS, NT and VMS
3538e1d5 127$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/;
54310121
PP
128
129# This is the default class for the CGI object to use when all else fails.
130$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
424ec8fa 131
54310121
PP
132# This is where to look for autoloaded routines.
133$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
134
135# The path separator is a slash, backslash or semicolon, depending
136# on the paltform.
137$SL = {
fa6a1c44 138 UNIX=>'/', EPOC=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
54310121
PP
139 }->{$OS};
140
424ec8fa 141# This no longer seems to be necessary
54310121 142# Turn on NPH scripts by default when running under IIS server!
424ec8fa
GS
143# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
144$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
54310121
PP
145
146# Turn on special checking for Doug MacEachern's modperl
71f3e297
JH
147if (exists $ENV{'GATEWAY_INTERFACE'}
148 &&
3538e1d5 149 ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
424ec8fa 150{
54310121 151 $| = 1;
424ec8fa
GS
152 require Apache;
153}
154# Turn on special checking for ActiveState's PerlEx
155$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
156
157# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
158# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
159# and sometimes CR). The most popular VMS web server
160# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
161# use ASCII, so \015\012 means something different. I find this all
162# really annoying.
163$EBCDIC = "\t" ne "\011";
164if ($OS eq 'VMS') {
3538e1d5 165 $CRLF = "\n";
424ec8fa 166} elsif ($EBCDIC) {
3538e1d5 167 $CRLF= "\r\n";
424ec8fa 168} else {
3538e1d5
GS
169 $CRLF = "\015\012";
170}
171
54310121
PP
172if ($needs_binmode) {
173 $CGI::DefaultClass->binmode(main::STDOUT);
174 $CGI::DefaultClass->binmode(main::STDIN);
175 $CGI::DefaultClass->binmode(main::STDERR);
176}
177
54310121 178%EXPORT_TAGS = (
424ec8fa
GS
179 ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
180 tt u i b blockquote pre img a address cite samp dfn html head
181 base body Link nextid title meta kbd start_html end_html
3d1a2ec4 182 input Select option comment charset escapeHTML/],
71f3e297 183 ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param
424ec8fa
GS
184 embed basefont style span layer ilayer font frameset frame script small big/],
185 ':netscape'=>[qw/blink fontsize center/],
186 ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
187 submit reset defaults radio_group popup_menu button autoEscape
188 scrolling_list image_button start_form end_form startform endform
71f3e297 189 start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
3538e1d5
GS
190 ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump
191 raw_cookie request_method query_string Accept user_agent remote_host content_type
424ec8fa 192 remote_addr referer server_name server_software server_port server_protocol
3d1a2ec4 193 virtual_host remote_ident auth_type http
424ec8fa 194 save_parameters restore_parameters param_fetch
3538e1d5
GS
195 remote_user user_name header redirect import_names put
196 Delete Delete_all url_param cgi_error/],
424ec8fa 197 ':ssl' => [qw/https/],
71f3e297 198 ':imagemap' => [qw/Area Map/],
3538e1d5 199 ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
424ec8fa
GS
200 ':html' => [qw/:html2 :html3 :netscape/],
201 ':standard' => [qw/:html2 :html3 :form :cgi/],
202 ':push' => [qw/multipart_init multipart_start multipart_end/],
203 ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/]
204 );
54310121
PP
205
206# to import symbols into caller
207sub import {
208 my $self = shift;
424ec8fa
GS
209
210# This causes modules to clash.
211# undef %EXPORT_OK;
212# undef %EXPORT;
213
214 $self->_setup_symbols(@_);
54310121 215 my ($callpack, $callfile, $callline) = caller;
424ec8fa 216
54310121
PP
217 # To allow overriding, search through the packages
218 # Till we find one in which the correct subroutine is defined.
219 my @packages = ($self,@{"$self\:\:ISA"});
220 foreach $sym (keys %EXPORT) {
221 my $pck;
222 my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
223 foreach $pck (@packages) {
224 if (defined(&{"$pck\:\:$sym"})) {
225 $def = $pck;
226 last;
227 }
228 }
229 *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
230 }
231}
232
424ec8fa
GS
233sub compile {
234 my $pack = shift;
235 $pack->_setup_symbols('-compile',@_);
236}
237
54310121
PP
238sub expand_tags {
239 my($tag) = @_;
71f3e297 240 return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
54310121
PP
241 my(@r);
242 return ($tag) unless $EXPORT_TAGS{$tag};
243 foreach (@{$EXPORT_TAGS{$tag}}) {
244 push(@r,&expand_tags($_));
245 }
246 return @r;
247}
248
249#### Method: new
250# The new routine. This will check the current environment
251# for an existing query string, and initialize itself, if so.
252####
253sub new {
254 my($class,$initializer) = @_;
255 my $self = {};
256 bless $self,ref $class || $class || $DefaultClass;
3d1a2ec4
GS
257 if ($MOD_PERL && defined Apache->request) {
258 Apache->request->register_cleanup(\&CGI::_reset_globals);
259 undef $NPH;
424ec8fa
GS
260 }
261 $self->_reset_globals if $PERLEX;
54310121
PP
262 $self->init($initializer);
263 return $self;
264}
265
266# We provide a DESTROY method so that the autoloader
267# doesn't bother trying to find it.
268sub DESTROY { }
269
270#### Method: param
271# Returns the value(s)of a named parameter.
272# If invoked in a list context, returns the
273# entire list. Otherwise returns the first
274# member of the list.
275# If name is not provided, return a list of all
276# the known parameters names available.
277# If more than one argument is provided, the
278# second and subsequent arguments are used to
279# set the value of the parameter.
280####
281sub param {
282 my($self,@p) = self_or_default(@_);
283 return $self->all_parameters unless @p;
284 my($name,$value,@other);
285
286 # For compatibility between old calling style and use_named_parameters() style,
287 # we have to special case for a single parameter present.
288 if (@p > 1) {
3d1a2ec4 289 ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
54310121
PP
290 my(@values);
291
3d1a2ec4 292 if (substr($p[0],0,1) eq '-') {
54310121
PP
293 @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
294 } else {
295 foreach ($value,@other) {
296 push(@values,$_) if defined($_);
297 }
298 }
299 # If values is provided, then we set it.
300 if (@values) {
301 $self->add_parameter($name);
302 $self->{$name}=[@values];
303 }
304 } else {
305 $name = $p[0];
306 }
307
71f3e297 308 return unless defined($name) && $self->{$name};
54310121
PP
309 return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
310}
311
54310121 312sub self_or_default {
424ec8fa 313 return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
54310121 314 unless (defined($_[0]) &&
424ec8fa
GS
315 (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
316 ) {
54310121
PP
317 $Q = $CGI::DefaultClass->new unless defined($Q);
318 unshift(@_,$Q);
319 }
3d1a2ec4 320 return wantarray ? @_ : $Q;
54310121
PP
321}
322
54310121
PP
323sub self_or_CGI {
324 local $^W=0; # prevent a warning
325 if (defined($_[0]) &&
326 (substr(ref($_[0]),0,3) eq 'CGI'
424ec8fa 327 || UNIVERSAL::isa($_[0],'CGI'))) {
54310121
PP
328 return @_;
329 } else {
330 return ($DefaultClass,@_);
331 }
332}
333
54310121
PP
334########################################
335# THESE METHODS ARE MORE OR LESS PRIVATE
336# GO TO THE __DATA__ SECTION TO SEE MORE
337# PUBLIC METHODS
338########################################
339
340# Initialize the query object from the environment.
341# If a parameter list is found, this object will be set
342# to an associative array in which parameter names are keys
343# and the values are stored as lists
344# If a keyword list is found, this method creates a bogus
345# parameter list with the single parameter 'keywords'.
346
347sub init {
348 my($self,$initializer) = @_;
424ec8fa 349 my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
71f3e297 350 local($/) = "\n";
54310121
PP
351
352 # if we get called more than once, we want to initialize
353 # ourselves from the original query (which may be gone
354 # if it was read from STDIN originally.)
d45d855d 355 if (defined(@QUERY_PARAM) && !defined($initializer)) {
54310121
PP
356 foreach (@QUERY_PARAM) {
357 $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
358 }
d45d855d
JH
359 $self->charset($QUERY_CHARSET);
360 $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
54310121
PP
361 return;
362 }
363
364 $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
424ec8fa 365 $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
3538e1d5 366
424ec8fa 367 $fh = to_filehandle($initializer) if $initializer;
54310121 368
a3b3a725
JH
369 # set charset to the safe ISO-8859-1
370 $self->charset('ISO-8859-1');
371
54310121 372 METHOD: {
54310121 373
3538e1d5
GS
374 # avoid unreasonably large postings
375 if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
376 $self->cgi_error("413 Request entity too large");
377 last METHOD;
378 }
379
424ec8fa
GS
380 # Process multipart postings, but only if the initializer is
381 # not defined.
382 if ($meth eq 'POST'
383 && defined($ENV{'CONTENT_TYPE'})
384 && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
385 && !defined($initializer)
386 ) {
71f3e297 387 my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
424ec8fa
GS
388 $self->read_multipart($boundary,$content_length);
389 last METHOD;
390 }
391
392 # If initializer is defined, then read parameters
393 # from it.
394 if (defined($initializer)) {
395 if (UNIVERSAL::isa($initializer,'CGI')) {
396 $query_string = $initializer->query_string;
397 last METHOD;
398 }
54310121
PP
399 if (ref($initializer) && ref($initializer) eq 'HASH') {
400 foreach (keys %$initializer) {
401 $self->param('-name'=>$_,'-value'=>$initializer->{$_});
402 }
403 last METHOD;
404 }
405
424ec8fa
GS
406 if (defined($fh) && ($fh ne '')) {
407 while (<$fh>) {
54310121
PP
408 chomp;
409 last if /^=/;
410 push(@lines,$_);
411 }
412 # massage back into standard format
413 if ("@lines" =~ /=/) {
414 $query_string=join("&",@lines);
415 } else {
416 $query_string=join("+",@lines);
417 }
418 last METHOD;
419 }
424ec8fa
GS
420
421 # last chance -- treat it as a string
422 $initializer = $$initializer if ref($initializer) eq 'SCALAR';
54310121 423 $query_string = $initializer;
424ec8fa 424
54310121
PP
425 last METHOD;
426 }
54310121 427
424ec8fa
GS
428 # If method is GET or HEAD, fetch the query from
429 # the environment.
430 if ($meth=~/^(GET|HEAD)$/) {
3538e1d5
GS
431 if ($MOD_PERL) {
432 $query_string = Apache->request->args;
433 } else {
434 $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
3d1a2ec4 435 $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
3538e1d5 436 }
424ec8fa
GS
437 last METHOD;
438 }
54310121 439
424ec8fa
GS
440 if ($meth eq 'POST') {
441 $self->read_from_client(\*STDIN,\$query_string,$content_length,0)
442 if $content_length > 0;
54310121
PP
443 # Some people want to have their cake and eat it too!
444 # Uncomment this line to have the contents of the query string
445 # APPENDED to the POST data.
424ec8fa 446 # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
54310121
PP
447 last METHOD;
448 }
424ec8fa
GS
449
450 # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
54310121
PP
451 # Check the command line and then the standard input for data.
452 # We use the shellwords package in order to behave the way that
453 # UN*X programmers expect.
3d1a2ec4 454 $query_string = read_from_cmdline() if $DEBUG;
54310121 455 }
424ec8fa 456
54310121
PP
457 # We now have the query string in hand. We do slightly
458 # different things for keyword lists and parameter lists.
ffd2dff2 459 if (defined $query_string && $query_string) {
3d1a2ec4 460 if ($query_string =~ /[&=;]/) {
54310121
PP
461 $self->parse_params($query_string);
462 } else {
463 $self->add_parameter('keywords');
464 $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
465 }
466 }
467
468 # Special case. Erase everything if there is a field named
469 # .defaults.
470 if ($self->param('.defaults')) {
471 undef %{$self};
472 }
473
474 # Associative array containing our defined fieldnames
475 $self->{'.fieldnames'} = {};
476 foreach ($self->param('.cgifields')) {
477 $self->{'.fieldnames'}->{$_}++;
478 }
479
480 # Clear out our default submission button flag if present
481 $self->delete('.submit');
482 $self->delete('.cgifields');
3d1a2ec4 483
54310121 484 $self->save_request unless $initializer;
54310121
PP
485}
486
54310121 487# FUNCTIONS TO OVERRIDE:
54310121
PP
488# Turn a string into a filehandle
489sub to_filehandle {
424ec8fa
GS
490 my $thingy = shift;
491 return undef unless $thingy;
492 return $thingy if UNIVERSAL::isa($thingy,'GLOB');
493 return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
494 if (!ref($thingy)) {
495 my $caller = 1;
496 while (my $package = caller($caller++)) {
497 my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
498 return $tmp if defined(fileno($tmp));
499 }
54310121 500 }
424ec8fa 501 return undef;
54310121
PP
502}
503
504# send output to the browser
505sub put {
506 my($self,@p) = self_or_default(@_);
507 $self->print(@p);
508}
509
510# print to standard output (for overriding in mod_perl)
511sub print {
512 shift;
513 CORE::print(@_);
514}
515
3538e1d5
GS
516# get/set last cgi_error
517sub cgi_error {
518 my ($self,$err) = self_or_default(@_);
519 $self->{'.cgi_error'} = $err if defined $err;
520 return $self->{'.cgi_error'};
521}
522
54310121
PP
523sub save_request {
524 my($self) = @_;
525 # We're going to play with the package globals now so that if we get called
526 # again, we initialize ourselves in exactly the same way. This allows
527 # us to have several of these objects.
528 @QUERY_PARAM = $self->param; # save list of parameters
529 foreach (@QUERY_PARAM) {
3d1a2ec4
GS
530 next unless defined $_;
531 $QUERY_PARAM{$_}=$self->{$_};
54310121 532 }
d45d855d
JH
533 $QUERY_CHARSET = $self->charset;
534 %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
54310121
PP
535}
536
54310121
PP
537sub parse_params {
538 my($self,$tosplit) = @_;
71f3e297 539 my(@pairs) = split(/[&;]/,$tosplit);
54310121
PP
540 my($param,$value);
541 foreach (@pairs) {
424ec8fa 542 ($param,$value) = split('=',$_,2);
3d1a2ec4 543 $value = '' unless defined $value;
424ec8fa
GS
544 $param = unescape($param);
545 $value = unescape($value);
54310121
PP
546 $self->add_parameter($param);
547 push (@{$self->{$param}},$value);
548 }
549}
550
551sub add_parameter {
552 my($self,$param)=@_;
3d1a2ec4 553 return unless defined $param;
54310121
PP
554 push (@{$self->{'.parameters'}},$param)
555 unless defined($self->{$param});
556}
557
558sub all_parameters {
559 my $self = shift;
560 return () unless defined($self) && $self->{'.parameters'};
561 return () unless @{$self->{'.parameters'}};
562 return @{$self->{'.parameters'}};
563}
564
424ec8fa
GS
565# put a filehandle into binary mode (DOS)
566sub binmode {
567 CORE::binmode($_[1]);
568}
569
570sub _make_tag_func {
71f3e297 571 my ($self,$tagname) = @_;
3538e1d5 572 my $func = qq(
3d1a2ec4
GS
573 sub $tagname {
574 shift if \$_[0] &&
575 (ref(\$_[0]) &&
576 (substr(ref(\$_[0]),0,3) eq 'CGI' ||
577 UNIVERSAL::isa(\$_[0],'CGI')));
424ec8fa
GS
578 my(\$attr) = '';
579 if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') {
3d1a2ec4 580 my(\@attr) = make_attributes(shift()||undef,1);
424ec8fa
GS
581 \$attr = " \@attr" if \@attr;
582 }
3538e1d5 583 );
71f3e297 584 if ($tagname=~/start_(\w+)/i) {
6b4ac661 585 $func .= qq! return "<\L$1\E\$attr>";} !;
71f3e297 586 } elsif ($tagname=~/end_(\w+)/i) {
6b4ac661 587 $func .= qq! return "<\L/$1\E>"; } !;
71f3e297
JH
588 } else {
589 $func .= qq#
6b4ac661
JH
590 return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@_;
591 my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
3d1a2ec4
GS
592 my \@result = map { "\$tag\$_\$untag" }
593 (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
424ec8fa 594 return "\@result";
71f3e297
JH
595 }#;
596 }
597return $func;
54310121
PP
598}
599
600sub AUTOLOAD {
601 print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
424ec8fa
GS
602 my $func = &_compile;
603 goto &$func;
54310121
PP
604}
605
424ec8fa
GS
606sub _compile {
607 my($func) = $AUTOLOAD;
608 my($pack,$func_name);
609 {
610 local($1,$2); # this fixes an obscure variable suicide problem.
611 $func=~/(.+)::([^:]+)$/;
612 ($pack,$func_name) = ($1,$2);
613 $pack=~s/::SUPER$//; # fix another obscure problem
614 $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
615 unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
616
617 my($sub) = \%{"$pack\:\:SUBS"};
618 unless (%$sub) {
619 my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
620 eval "package $pack; $$auto";
621 die $@ if $@;
622 $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
623 }
624 my($code) = $sub->{$func_name};
625
626 $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
627 if (!$code) {
71f3e297 628 (my $base = $func_name) =~ s/^(start_|end_)//i;
424ec8fa
GS
629 if ($EXPORT{':any'} ||
630 $EXPORT{'-any'} ||
71f3e297 631 $EXPORT{$base} ||
424ec8fa 632 (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
71f3e297
JH
633 && $EXPORT_OK{$base}) {
634 $code = $CGI::DefaultClass->_make_tag_func($func_name);
424ec8fa
GS
635 }
636 }
637 die "Undefined subroutine $AUTOLOAD\n" unless $code;
638 eval "package $pack; $code";
639 if ($@) {
640 $@ =~ s/ at .*\n//;
641 die $@;
642 }
643 }
3538e1d5 644 CORE::delete($sub->{$func_name}); #free storage
424ec8fa
GS
645 return "$pack\:\:$func_name";
646}
647
648sub _reset_globals { initialize_globals(); }
649
650sub _setup_symbols {
651 my $self = shift;
652 my $compile = 0;
653 foreach (@_) {
71f3e297
JH
654 $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
655 $NPH++, next if /^[:-]nph$/;
3d1a2ec4
GS
656 $NOSTICKY++, next if /^[:-]nosticky$/;
657 $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
658 $DEBUG=2, next if /^[:-][Dd]ebug$/;
71f3e297 659 $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
6b4ac661
JH
660 $XHTML++, next if /^[:-]xhtml$/;
661 $XHTML=0, next if /^[:-]no_?xhtml$/;
3d1a2ec4 662 $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
71f3e297
JH
663 $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
664 $EXPORT{$_}++, next if /^[:-]any$/;
665 $compile++, next if /^[:-]compile$/;
424ec8fa 666
71f3e297 667 # This is probably extremely evil code -- to be deleted some day.
424ec8fa
GS
668 if (/^[-]autoload$/) {
669 my($pkg) = caller(1);
670 *{"${pkg}::AUTOLOAD"} = sub {
671 my($routine) = $AUTOLOAD;
672 $routine =~ s/^.*::/CGI::/;
673 &$routine;
674 };
675 next;
676 }
677
678 foreach (&expand_tags($_)) {
679 tr/a-zA-Z0-9_//cd; # don't allow weird function names
680 $EXPORT{$_}++;
54310121 681 }
54310121 682 }
424ec8fa 683 _compile_all(keys %EXPORT) if $compile;
54310121
PP
684}
685
3d1a2ec4
GS
686sub charset {
687 my ($self,$charset) = self_or_default(@_);
688 $self->{'.charset'} = $charset if defined $charset;
689 $self->{'.charset'};
690}
691
54310121
PP
692###############################################################################
693################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
694###############################################################################
695$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
696$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
697
698%SUBS = (
699
700'URL_ENCODED'=> <<'END_OF_FUNC',
701sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
702END_OF_FUNC
703
704'MULTIPART' => <<'END_OF_FUNC',
705sub MULTIPART { 'multipart/form-data'; }
706END_OF_FUNC
707
424ec8fa
GS
708'SERVER_PUSH' => <<'END_OF_FUNC',
709sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; }
710END_OF_FUNC
711
424ec8fa
GS
712'new_MultipartBuffer' => <<'END_OF_FUNC',
713# Create a new multipart buffer
714sub new_MultipartBuffer {
715 my($self,$boundary,$length,$filehandle) = @_;
716 return MultipartBuffer->new($self,$boundary,$length,$filehandle);
717}
718END_OF_FUNC
719
720'read_from_client' => <<'END_OF_FUNC',
721# Read data from a file handle
722sub read_from_client {
723 my($self, $fh, $buff, $len, $offset) = @_;
724 local $^W=0; # prevent a warning
725 return undef unless defined($fh);
726 return read($fh, $$buff, $len, $offset);
727}
728END_OF_FUNC
729
730'delete' => <<'END_OF_FUNC',
731#### Method: delete
732# Deletes the named parameter entirely.
733####
734sub delete {
6b4ac661
JH
735 my($self,@p) = self_or_default(@_);
736 my($name) = rearrange([NAME],@p);
3538e1d5
GS
737 CORE::delete $self->{$name};
738 CORE::delete $self->{'.fieldnames'}->{$name};
424ec8fa
GS
739 @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
740 return wantarray ? () : undef;
741}
742END_OF_FUNC
743
744#### Method: import_names
745# Import all parameters into the given namespace.
746# Assumes namespace 'Q' if not specified
747####
748'import_names' => <<'END_OF_FUNC',
749sub import_names {
750 my($self,$namespace,$delete) = self_or_default(@_);
751 $namespace = 'Q' unless defined($namespace);
752 die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
3538e1d5 753 if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
424ec8fa
GS
754 # can anyone find an easier way to do this?
755 foreach (keys %{"${namespace}::"}) {
756 local *symbol = "${namespace}::${_}";
757 undef $symbol;
758 undef @symbol;
759 undef %symbol;
54310121 760 }
424ec8fa
GS
761 }
762 my($param,@value,$var);
763 foreach $param ($self->param) {
764 # protect against silly names
765 ($var = $param)=~tr/a-zA-Z0-9_/_/c;
766 $var =~ s/^(?=\d)/_/;
767 local *symbol = "${namespace}::$var";
768 @value = $self->param($param);
769 @symbol = @value;
770 $symbol = $value[0];
54310121
PP
771 }
772}
773END_OF_FUNC
774
775#### Method: keywords
776# Keywords acts a bit differently. Calling it in a list context
777# returns the list of keywords.
778# Calling it in a scalar context gives you the size of the list.
779####
780'keywords' => <<'END_OF_FUNC',
781sub keywords {
782 my($self,@values) = self_or_default(@_);
783 # If values is provided, then we set it.
475342a6 784 $self->{'keywords'}=[@values] if @values;
424ec8fa 785 my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
54310121
PP
786 @result;
787}
788END_OF_FUNC
789
790# These are some tie() interfaces for compatibility
791# with Steve Brenner's cgi-lib.pl routines
3538e1d5
GS
792'Vars' => <<'END_OF_FUNC',
793sub Vars {
ffd2dff2 794 my $q = shift;
3538e1d5 795 my %in;
ffd2dff2 796 tie(%in,CGI,$q);
3538e1d5
GS
797 return %in if wantarray;
798 return \%in;
799}
800END_OF_FUNC
801
802# These are some tie() interfaces for compatibility
803# with Steve Brenner's cgi-lib.pl routines
54310121
PP
804'ReadParse' => <<'END_OF_FUNC',
805sub ReadParse {
806 local(*in);
807 if (@_) {
808 *in = $_[0];
809 } else {
810 my $pkg = caller();
811 *in=*{"${pkg}::in"};
812 }
813 tie(%in,CGI);
424ec8fa 814 return scalar(keys %in);
54310121
PP
815}
816END_OF_FUNC
817
818'PrintHeader' => <<'END_OF_FUNC',
819sub PrintHeader {
820 my($self) = self_or_default(@_);
821 return $self->header();
822}
823END_OF_FUNC
824
825'HtmlTop' => <<'END_OF_FUNC',
826sub HtmlTop {
827 my($self,@p) = self_or_default(@_);
828 return $self->start_html(@p);
829}
830END_OF_FUNC
831
832'HtmlBot' => <<'END_OF_FUNC',
833sub HtmlBot {
834 my($self,@p) = self_or_default(@_);
835 return $self->end_html(@p);
836}
837END_OF_FUNC
838
839'SplitParam' => <<'END_OF_FUNC',
840sub SplitParam {
841 my ($param) = @_;
842 my (@params) = split ("\0", $param);
843 return (wantarray ? @params : $params[0]);
844}
845END_OF_FUNC
846
847'MethGet' => <<'END_OF_FUNC',
848sub MethGet {
849 return request_method() eq 'GET';
850}
851END_OF_FUNC
852
853'MethPost' => <<'END_OF_FUNC',
854sub MethPost {
855 return request_method() eq 'POST';
856}
857END_OF_FUNC
858
859'TIEHASH' => <<'END_OF_FUNC',
860sub TIEHASH {
ffd2dff2 861 return $_[1] if defined $_[1];
3d1a2ec4 862 return $Q ||= new shift;
54310121
PP
863}
864END_OF_FUNC
865
866'STORE' => <<'END_OF_FUNC',
867sub STORE {
3d1a2ec4
GS
868 my $self = shift;
869 my $tag = shift;
6b4ac661
JH
870 my $vals = shift;
871 my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
3d1a2ec4 872 $self->param(-name=>$tag,-value=>\@vals);
54310121
PP
873}
874END_OF_FUNC
875
876'FETCH' => <<'END_OF_FUNC',
877sub FETCH {
878 return $_[0] if $_[1] eq 'CGI';
879 return undef unless defined $_[0]->param($_[1]);
880 return join("\0",$_[0]->param($_[1]));
881}
882END_OF_FUNC
883
884'FIRSTKEY' => <<'END_OF_FUNC',
885sub FIRSTKEY {
886 $_[0]->{'.iterator'}=0;
887 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
888}
889END_OF_FUNC
890
891'NEXTKEY' => <<'END_OF_FUNC',
892sub NEXTKEY {
893 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
894}
895END_OF_FUNC
896
897'EXISTS' => <<'END_OF_FUNC',
898sub EXISTS {
899 exists $_[0]->{$_[1]};
900}
901END_OF_FUNC
902
903'DELETE' => <<'END_OF_FUNC',
904sub DELETE {
905 $_[0]->delete($_[1]);
906}
907END_OF_FUNC
908
909'CLEAR' => <<'END_OF_FUNC',
910sub CLEAR {
911 %{$_[0]}=();
912}
913####
914END_OF_FUNC
915
916####
917# Append a new value to an existing query
918####
919'append' => <<'EOF',
920sub append {
921 my($self,@p) = @_;
3d1a2ec4 922 my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
54310121
PP
923 my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
924 if (@values) {
925 $self->add_parameter($name);
926 push(@{$self->{$name}},@values);
927 }
928 return $self->param($name);
929}
930EOF
931
932#### Method: delete_all
933# Delete all parameters
934####
935'delete_all' => <<'EOF',
936sub delete_all {
937 my($self) = self_or_default(@_);
938 undef %{$self};
939}
940EOF
941
424ec8fa
GS
942'Delete' => <<'EOF',
943sub Delete {
944 my($self,@p) = self_or_default(@_);
945 $self->delete(@p);
946}
947EOF
948
949'Delete_all' => <<'EOF',
950sub Delete_all {
951 my($self,@p) = self_or_default(@_);
952 $self->delete_all(@p);
953}
954EOF
955
54310121
PP
956#### Method: autoescape
957# If you want to turn off the autoescaping features,
958# call this method with undef as the argument
959'autoEscape' => <<'END_OF_FUNC',
960sub autoEscape {
961 my($self,$escape) = self_or_default(@_);
962 $self->{'dontescape'}=!$escape;
963}
964END_OF_FUNC
965
966
967#### Method: version
968# Return the current version
969####
970'version' => <<'END_OF_FUNC',
971sub version {
972 return $VERSION;
973}
974END_OF_FUNC
975
424ec8fa
GS
976#### Method: url_param
977# Return a parameter in the QUERY_STRING, regardless of
978# whether this was a POST or a GET
979####
980'url_param' => <<'END_OF_FUNC',
981sub url_param {
982 my ($self,@p) = self_or_default(@_);
983 my $name = shift(@p);
984 return undef unless exists($ENV{QUERY_STRING});
985 unless (exists($self->{'.url_param'})) {
986 $self->{'.url_param'}={}; # empty hash
987 if ($ENV{QUERY_STRING} =~ /=/) {
71f3e297 988 my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
424ec8fa
GS
989 my($param,$value);
990 foreach (@pairs) {
991 ($param,$value) = split('=',$_,2);
992 $param = unescape($param);
993 $value = unescape($value);
994 push(@{$self->{'.url_param'}->{$param}},$value);
995 }
996 } else {
997 $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
998 }
999 }
1000 return keys %{$self->{'.url_param'}} unless defined($name);
1001 return () unless $self->{'.url_param'}->{$name};
1002 return wantarray ? @{$self->{'.url_param'}->{$name}}
1003 : $self->{'.url_param'}->{$name}->[0];
1004}
1005END_OF_FUNC
1006
3d1a2ec4 1007#### Method: Dump
54310121
PP
1008# Returns a string in which all the known parameter/value
1009# pairs are represented as nested lists, mainly for the purposes
1010# of debugging.
1011####
3d1a2ec4
GS
1012'Dump' => <<'END_OF_FUNC',
1013sub Dump {
54310121
PP
1014 my($self) = self_or_default(@_);
1015 my($param,$value,@result);
1016 return '<UL></UL>' unless $self->param;
1017 push(@result,"<UL>");
1018 foreach $param ($self->param) {
1019 my($name)=$self->escapeHTML($param);
1020 push(@result,"<LI><STRONG>$param</STRONG>");
1021 push(@result,"<UL>");
1022 foreach $value ($self->param($param)) {
1023 $value = $self->escapeHTML($value);
3538e1d5 1024 $value =~ s/\n/<BR>\n/g;
54310121
PP
1025 push(@result,"<LI>$value");
1026 }
1027 push(@result,"</UL>");
1028 }
1029 push(@result,"</UL>\n");
1030 return join("\n",@result);
1031}
1032END_OF_FUNC
1033
424ec8fa
GS
1034#### Method as_string
1035#
1036# synonym for "dump"
1037####
1038'as_string' => <<'END_OF_FUNC',
1039sub as_string {
3d1a2ec4 1040 &Dump(@_);
424ec8fa
GS
1041}
1042END_OF_FUNC
1043
1044#### Method: save
1045# Write values out to a filehandle in such a way that they can
1046# be reinitialized by the filehandle form of the new() method
54310121
PP
1047####
1048'save' => <<'END_OF_FUNC',
1049sub save {
1050 my($self,$filehandle) = self_or_default(@_);
54310121 1051 $filehandle = to_filehandle($filehandle);
424ec8fa
GS
1052 my($param);
1053 local($,) = ''; # set print field separator back to a sane value
71f3e297 1054 local($\) = ''; # set output line separator to a sane value
54310121 1055 foreach $param ($self->param) {
424ec8fa 1056 my($escaped_param) = escape($param);
54310121
PP
1057 my($value);
1058 foreach $value ($self->param($param)) {
3538e1d5 1059 print $filehandle "$escaped_param=",escape("$value"),"\n";
54310121
PP
1060 }
1061 }
d45d855d
JH
1062 foreach (keys %{$self->{'.fieldnames'}}) {
1063 print $filehandle ".cgifields=",escape("$_"),"\n";
1064 }
54310121
PP
1065 print $filehandle "=\n"; # end of record
1066}
1067END_OF_FUNC
1068
1069
424ec8fa
GS
1070#### Method: save_parameters
1071# An alias for save() that is a better name for exportation.
1072# Only intended to be used with the function (non-OO) interface.
1073####
1074'save_parameters' => <<'END_OF_FUNC',
1075sub save_parameters {
1076 my $fh = shift;
1077 return save(to_filehandle($fh));
1078}
1079END_OF_FUNC
1080
1081#### Method: restore_parameters
1082# A way to restore CGI parameters from an initializer.
1083# Only intended to be used with the function (non-OO) interface.
1084####
1085'restore_parameters' => <<'END_OF_FUNC',
1086sub restore_parameters {
1087 $Q = $CGI::DefaultClass->new(@_);
1088}
1089END_OF_FUNC
1090
1091#### Method: multipart_init
1092# Return a Content-Type: style header for server-push
1093# This has to be NPH, and it is advisable to set $| = 1
1094#
1095# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1096# contribution
1097####
1098'multipart_init' => <<'END_OF_FUNC',
1099sub multipart_init {
1100 my($self,@p) = self_or_default(@_);
3d1a2ec4 1101 my($boundary,@other) = rearrange([BOUNDARY],@p);
424ec8fa
GS
1102 $boundary = $boundary || '------- =_aaaaaaaaaa0';
1103 $self->{'separator'} = "\n--$boundary\n";
1104 $type = SERVER_PUSH($boundary);
1105 return $self->header(
1106 -nph => 1,
1107 -type => $type,
1108 (map { split "=", $_, 2 } @other),
1109 ) . $self->multipart_end;
1110}
1111END_OF_FUNC
1112
1113
1114#### Method: multipart_start
1115# Return a Content-Type: style header for server-push, start of section
1116#
1117# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1118# contribution
1119####
1120'multipart_start' => <<'END_OF_FUNC',
1121sub multipart_start {
1122 my($self,@p) = self_or_default(@_);
3d1a2ec4 1123 my($type,@other) = rearrange([TYPE],@p);
424ec8fa
GS
1124 $type = $type || 'text/html';
1125 return $self->header(
1126 -type => $type,
1127 (map { split "=", $_, 2 } @other),
1128 );
1129}
1130END_OF_FUNC
1131
1132
1133#### Method: multipart_end
1134# Return a Content-Type: style header for server-push, end of section
1135#
1136# Many thanks to Ed Jordan <ed@fidalgo.net> for this
1137# contribution
1138####
1139'multipart_end' => <<'END_OF_FUNC',
1140sub multipart_end {
1141 my($self,@p) = self_or_default(@_);
1142 return $self->{'separator'};
1143}
1144END_OF_FUNC
1145
1146
54310121
PP
1147#### Method: header
1148# Return a Content-Type: style header
1149#
1150####
1151'header' => <<'END_OF_FUNC',
1152sub header {
1153 my($self,@p) = self_or_default(@_);
1154 my(@header);
1155
71f3e297
JH
1156 return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
1157
6b4ac661 1158 my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,@other) =
3d1a2ec4
GS
1159 rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
1160 'STATUS',['COOKIE','COOKIES'],'TARGET',
6b4ac661
JH
1161 'EXPIRES','NPH','CHARSET',
1162 'ATTACHMENT'],@p);
3d1a2ec4
GS
1163
1164 $nph ||= $NPH;
1165 if (defined $charset) {
1166 $self->charset($charset);
1167 } else {
1168 $charset = $self->charset;
1169 }
54310121
PP
1170
1171 # rearrange() was designed for the HTML portion, so we
1172 # need to fix it up a little.
1173 foreach (@other) {
71f3e297 1174 next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
a3b3a725 1175 ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
54310121
PP
1176 }
1177
71f3e297 1178 $type ||= 'text/html' unless defined($type);
6b4ac661 1179 $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/;
54310121 1180
424ec8fa
GS
1181 # Maybe future compatibility. Maybe not.
1182 my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
1183 push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
1184
54310121 1185 push(@header,"Status: $status") if $status;
424ec8fa 1186 push(@header,"Window-Target: $target") if $target;
54310121
PP
1187 # push all the cookies -- there may be several
1188 if ($cookie) {
424ec8fa 1189 my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
54310121 1190 foreach (@cookie) {
71f3e297
JH
1191 my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
1192 push(@header,"Set-Cookie: $cs") if $cs ne '';
54310121
PP
1193 }
1194 }
1195 # if the user indicates an expiration time, then we need
1196 # both an Expires and a Date header (so that the browser is
1197 # uses OUR clock)
424ec8fa 1198 push(@header,"Expires: " . expires($expires,'http'))
7d37aa8e 1199 if $expires;
424ec8fa 1200 push(@header,"Date: " . expires(0,'http')) if $expires || $cookie;
54310121 1201 push(@header,"Pragma: no-cache") if $self->cache();
6b4ac661 1202 push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
54310121 1203 push(@header,@other);
71f3e297 1204 push(@header,"Content-Type: $type") if $type ne '';
54310121 1205
424ec8fa
GS
1206 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
1207 if ($MOD_PERL and not $nph) {
1208 my $r = Apache->request;
1209 $r->send_cgi_header($header);
1210 return '';
1211 }
1212 return $header;
54310121
PP
1213}
1214END_OF_FUNC
1215
1216
1217#### Method: cache
1218# Control whether header() will produce the no-cache
1219# Pragma directive.
1220####
1221'cache' => <<'END_OF_FUNC',
1222sub cache {
1223 my($self,$new_value) = self_or_default(@_);
1224 $new_value = '' unless $new_value;
1225 if ($new_value ne '') {
1226 $self->{'cache'} = $new_value;
1227 }
1228 return $self->{'cache'};
1229}
1230END_OF_FUNC
1231
1232
1233#### Method: redirect
1234# Return a Location: style header
1235#
1236####
1237'redirect' => <<'END_OF_FUNC',
1238sub redirect {
1239 my($self,@p) = self_or_default(@_);
3d1a2ec4 1240 my($url,$target,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p);
6b4ac661 1241 $url ||= $self->self_url;
54310121 1242 my(@o);
424ec8fa
GS
1243 foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
1244 unshift(@o,
1245 '-Status'=>'302 Moved',
54310121 1246 '-Location'=>$url,
424ec8fa
GS
1247 '-nph'=>$nph);
1248 unshift(@o,'-Target'=>$target) if $target;
1249 unshift(@o,'-Cookie'=>$cookie) if $cookie;
71f3e297 1250 unshift(@o,'-Type'=>'');
54310121
PP
1251 return $self->header(@o);
1252}
1253END_OF_FUNC
1254
1255
1256#### Method: start_html
1257# Canned HTML header
1258#
1259# Parameters:
1260# $title -> (optional) The title for this HTML document (-title)
1261# $author -> (optional) e-mail address of the author (-author)
1262# $base -> (optional) if set to true, will enter the BASE address of this document
1263# for resolving relative references (-base)
1264# $xbase -> (optional) alternative base at some remote location (-xbase)
1265# $target -> (optional) target window to load all links into (-target)
1266# $script -> (option) Javascript code (-script)
47e3cabd 1267# $no_script -> (option) Javascript <noscript> tag (-noscript)
54310121 1268# $meta -> (optional) Meta information tags
7d37aa8e
LS
1269# $head -> (optional) any other elements you'd like to incorporate into the <HEAD> tag
1270# (a scalar or array ref)
1271# $style -> (optional) reference to an external style sheet
54310121
PP
1272# @other -> (optional) any other named parameters you'd like to incorporate into
1273# the <BODY> tag.
1274####
1275'start_html' => <<'END_OF_FUNC',
1276sub start_html {
1277 my($self,@p) = &self_or_default(@_);
6b4ac661
JH
1278 my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,$lang,@other) =
1279 rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD,LANG],@p);
54310121
PP
1280
1281 # strangely enough, the title needs to be escaped as HTML
1282 # while the author needs to be escaped as a URL
1283 $title = $self->escapeHTML($title || 'Untitled Document');
424ec8fa 1284 $author = $self->escape($author);
6b4ac661 1285 $lang ||= 'en-US';
54310121 1286 my(@result);
3d1a2ec4 1287 if ($dtd) {
6b4ac661 1288 if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
3d1a2ec4
GS
1289 $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
1290 } else {
1291 $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
1292 }
1293 } else {
6b4ac661 1294 $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
3d1a2ec4
GS
1295 }
1296 if (ref($dtd) && ref($dtd) eq 'ARRAY') {
03b9648d 1297 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t"$dtd->[1]">));
3d1a2ec4 1298 } else {
03b9648d 1299 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
3d1a2ec4 1300 }
6b4ac661
JH
1301 push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml" lang="$lang"><head><title>$title</title>)
1302 : qq(<html lang="$lang"><head><title>$title</title>));
1303 if (defined $author) {
1304 push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
03b9648d 1305 : "<link rev=\"made\" href=\"mailto:$author\">");
6b4ac661 1306 }
54310121
PP
1307
1308 if ($base || $xbase || $target) {
424ec8fa 1309 my $href = $xbase || $self->url('-path'=>1);
6b4ac661
JH
1310 my $t = $target ? qq/ target="$target"/ : '';
1311 push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
54310121
PP
1312 }
1313
1314 if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
6b4ac661
JH
1315 foreach (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
1316 : qq(<meta name="$_" content="$meta->{$_}">)); }
54310121 1317 }
7d37aa8e
LS
1318
1319 push(@result,ref($head) ? @$head : $head) if $head;
1320
424ec8fa
GS
1321 # handle the infrequently-used -style and -script parameters
1322 push(@result,$self->_style($style)) if defined $style;
1323 push(@result,$self->_script($script)) if defined $script;
1324
1325 # handle -noscript parameter
1326 push(@result,<<END) if $noscript;
6b4ac661 1327<noscript>
424ec8fa 1328$noscript
6b4ac661 1329</noscript>
424ec8fa
GS
1330END
1331 ;
1332 my($other) = @other ? " @other" : '';
6b4ac661 1333 push(@result,"</head><body$other>");
424ec8fa
GS
1334 return join("\n",@result);
1335}
1336END_OF_FUNC
1337
1338### Method: _style
1339# internal method for generating a CSS style section
1340####
1341'_style' => <<'END_OF_FUNC',
1342sub _style {
1343 my ($self,$style) = @_;
1344 my (@result);
1345 my $type = 'text/css';
a3b3a725
JH
1346
1347 my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
1348 my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
1349
424ec8fa 1350 if (ref($style)) {
6b4ac661
JH
1351 my($src,$code,$stype,@other) =
1352 rearrange([SRC,CODE,TYPE],
1353 '-foo'=>'bar', # a trick to allow the '-' to be omitted
1354 ref($style) eq 'ARRAY' ? @$style : %$style);
1355 $type = $stype if $stype;
6b4ac661
JH
1356 if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
1357 { # If it is, push a LINK tag for each one.
1358 foreach $src (@$src)
1359 {
1360 push(@result,qq/<link rel="stylesheet" type="$type" href="$src">/) if $src;
1361 }
1362 }
1363 else
1364 { # Otherwise, push the single -src, if it exists.
1365 push(@result,qq/<link rel="stylesheet" type="$type" href="$src">/) if $src;
1366 }
a3b3a725 1367 push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code;
424ec8fa 1368 } else {
a3b3a725 1369 push(@result,style({'type'=>$type},"$cdata_start\n$style\n$cdata_end"));
7d37aa8e 1370 }
424ec8fa
GS
1371 @result;
1372}
1373END_OF_FUNC
1374
424ec8fa
GS
1375'_script' => <<'END_OF_FUNC',
1376sub _script {
1377 my ($self,$script) = @_;
1378 my (@result);
a3b3a725 1379
424ec8fa
GS
1380 my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
1381 foreach $script (@scripts) {
7d37aa8e
LS
1382 my($src,$code,$language);
1383 if (ref($script)) { # script is a hash
3d1a2ec4
GS
1384 ($src,$code,$language, $type) =
1385 rearrange([SRC,CODE,LANGUAGE,TYPE],
7d37aa8e 1386 '-foo'=>'bar', # a trick to allow the '-' to be omitted
3538e1d5 1387 ref($script) eq 'ARRAY' ? @$script : %$script);
3d1a2ec4
GS
1388 # User may not have specified language
1389 $language ||= 'JavaScript';
1390 unless (defined $type) {
1391 $type = lc $language;
1392 # strip '1.2' from 'javascript1.2'
1393 $type =~ s/^(\D+).*$/text\/$1/;
1394 }
7d37aa8e 1395 } else {
3d1a2ec4 1396 ($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript');
7d37aa8e 1397 }
a3b3a725
JH
1398
1399 my $comment = '//'; # javascript by default
1400 $comment = '#' if $type=~/perl|tcl/i;
1401 $comment = "'" if $type=~/vbscript/i;
1402
1403 my $cdata_start = "\n<!-- Hide script\n";
1404 $cdata_start .= "$comment<![CDATA[\n" if $XHTML;
1405 my $cdata_end = $XHTML ? "\n$comment]]>" : $comment;
1406 $cdata_end .= " End script hiding -->\n";
1407
7d37aa8e
LS
1408 my(@satts);
1409 push(@satts,'src'=>$src) if $src;
3d1a2ec4
GS
1410 push(@satts,'language'=>$language);
1411 push(@satts,'type'=>$type);
a3b3a725 1412 $code = "$cdata_start$code$cdata_end";
3538e1d5 1413 push(@result,script({@satts},$code || ''));
7d37aa8e 1414 }
424ec8fa 1415 @result;
54310121
PP
1416}
1417END_OF_FUNC
1418
54310121
PP
1419#### Method: end_html
1420# End an HTML document.
1421# Trivial method for completeness. Just returns "</BODY>"
1422####
1423'end_html' => <<'END_OF_FUNC',
1424sub end_html {
6b4ac661 1425 return "</body></html>";
54310121
PP
1426}
1427END_OF_FUNC
1428
1429
1430################################
1431# METHODS USED IN BUILDING FORMS
1432################################
1433
1434#### Method: isindex
1435# Just prints out the isindex tag.
1436# Parameters:
1437# $action -> optional URL of script to run
1438# Returns:
1439# A string containing a <ISINDEX> tag
1440'isindex' => <<'END_OF_FUNC',
1441sub isindex {
1442 my($self,@p) = self_or_default(@_);
3d1a2ec4 1443 my($action,@other) = rearrange([ACTION],@p);
6b4ac661 1444 $action = qq/action="$action"/ if $action;
54310121 1445 my($other) = @other ? " @other" : '';
6b4ac661 1446 return $XHTML ? "<isindex $action$other />" : "<isindex $action$other>";
54310121
PP
1447}
1448END_OF_FUNC
1449
1450
1451#### Method: startform
1452# Start a form
1453# Parameters:
1454# $method -> optional submission method to use (GET or POST)
1455# $action -> optional URL of script to run
1456# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
1457'startform' => <<'END_OF_FUNC',
1458sub startform {
1459 my($self,@p) = self_or_default(@_);
1460
1461 my($method,$action,$enctype,@other) =
3d1a2ec4 1462 rearrange([METHOD,ACTION,ENCTYPE],@p);
54310121 1463
03b9648d 1464 $method = lc($method) || 'post';
54310121 1465 $enctype = $enctype || &URL_ENCODED;
03b9648d
JH
1466 unless (defined $action) {
1467 $action = $self->url(-absolute=>1,-path=>1);
1468 $action .= "?$ENV{QUERY_STRING}" if $ENV{QUERY_STRING};
1469 }
1470 $action = qq(action="$action");
54310121
PP
1471 my($other) = @other ? " @other" : '';
1472 $self->{'.parametersToAdd'}={};
6b4ac661 1473 return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
54310121
PP
1474}
1475END_OF_FUNC
1476
1477
1478#### Method: start_form
1479# synonym for startform
1480'start_form' => <<'END_OF_FUNC',
1481sub start_form {
1482 &startform;
1483}
1484END_OF_FUNC
1485
71f3e297
JH
1486'end_multipart_form' => <<'END_OF_FUNC',
1487sub end_multipart_form {
1488 &endform;
1489}
1490END_OF_FUNC
54310121
PP
1491
1492#### Method: start_multipart_form
1493# synonym for startform
1494'start_multipart_form' => <<'END_OF_FUNC',
1495sub start_multipart_form {
1496 my($self,@p) = self_or_default(@_);
3d1a2ec4 1497 if (defined($param[0]) && substr($param[0],0,1) eq '-') {
54310121
PP
1498 my(%p) = @p;
1499 $p{'-enctype'}=&MULTIPART;
1500 return $self->startform(%p);
1501 } else {
1502 my($method,$action,@other) =
3d1a2ec4 1503 rearrange([METHOD,ACTION],@p);
54310121
PP
1504 return $self->startform($method,$action,&MULTIPART,@other);
1505 }
1506}
1507END_OF_FUNC
1508
1509
1510#### Method: endform
1511# End a form
1512'endform' => <<'END_OF_FUNC',
1513sub endform {
1514 my($self,@p) = self_or_default(@_);
3d1a2ec4 1515 if ( $NOSTICKY ) {
6b4ac661 1516 return wantarray ? ("</form>") : "\n</form>";
3d1a2ec4 1517 } else {
6b4ac661
JH
1518 return wantarray ? ($self->get_fields,"</form>") :
1519 $self->get_fields ."\n</form>";
3d1a2ec4 1520 }
54310121
PP
1521}
1522END_OF_FUNC
1523
1524
1525#### Method: end_form
1526# synonym for endform
1527'end_form' => <<'END_OF_FUNC',
1528sub end_form {
1529 &endform;
1530}
1531END_OF_FUNC
1532
1533
424ec8fa
GS
1534'_textfield' => <<'END_OF_FUNC',
1535sub _textfield {
1536 my($self,$tag,@p) = self_or_default(@_);
1537 my($name,$default,$size,$maxlength,$override,@other) =
3d1a2ec4 1538 rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
424ec8fa
GS
1539
1540 my $current = $override ? $default :
1541 (defined($self->param($name)) ? $self->param($name) : $default);
1542
a3b3a725 1543 $current = defined($current) ? $self->escapeHTML($current,1) : '';
424ec8fa 1544 $name = defined($name) ? $self->escapeHTML($name) : '';
6b4ac661
JH
1545 my($s) = defined($size) ? qq/ size=$size/ : '';
1546 my($m) = defined($maxlength) ? qq/ maxlength=$maxlength/ : '';
71f3e297
JH
1547 my($other) = @other ? " @other" : '';
1548 # this entered at cristy's request to fix problems with file upload fields
1549 # and WebTV -- not sure it won't break stuff
6b4ac661
JH
1550 my($value) = $current ne '' ? qq(value="$current") : '';
1551 return $XHTML ? qq(<input type="$tag" name="$name" $value$s$m$other />)
1552 : qq/<input type="$tag" name="$name" $value$s$m$other>/;
424ec8fa
GS
1553}
1554END_OF_FUNC
1555
54310121
PP
1556#### Method: textfield
1557# Parameters:
1558# $name -> Name of the text field
1559# $default -> Optional default value of the field if not
1560# already defined.
1561# $size -> Optional width of field in characaters.
1562# $maxlength -> Optional maximum number of characters.
1563# Returns:
1564# A string containing a <INPUT TYPE="text"> field
1565#
1566'textfield' => <<'END_OF_FUNC',
1567sub textfield {
1568 my($self,@p) = self_or_default(@_);
424ec8fa 1569 $self->_textfield('text',@p);
54310121
PP
1570}
1571END_OF_FUNC
1572
1573
1574#### Method: filefield
1575# Parameters:
1576# $name -> Name of the file upload field
1577# $size -> Optional width of field in characaters.
1578# $maxlength -> Optional maximum number of characters.
1579# Returns:
1580# A string containing a <INPUT TYPE="text"> field
1581#
1582'filefield' => <<'END_OF_FUNC',
1583sub filefield {
1584 my($self,@p) = self_or_default(@_);
424ec8fa 1585 $self->_textfield('file',@p);
54310121
PP
1586}
1587END_OF_FUNC
1588
1589
1590#### Method: password
1591# Create a "secret password" entry field
1592# Parameters:
1593# $name -> Name of the field
1594# $default -> Optional default value of the field if not
1595# already defined.
1596# $size -> Optional width of field in characters.
1597# $maxlength -> Optional maximum characters that can be entered.
1598# Returns:
1599# A string containing a <INPUT TYPE="password"> field
1600#
1601'password_field' => <<'END_OF_FUNC',
1602sub password_field {
1603 my ($self,@p) = self_or_default(@_);
424ec8fa 1604 $self->_textfield('password',@p);
54310121
PP
1605}
1606END_OF_FUNC
1607
54310121
PP
1608#### Method: textarea
1609# Parameters:
1610# $name -> Name of the text field
1611# $default -> Optional default value of the field if not
1612# already defined.
1613# $rows -> Optional number of rows in text area
1614# $columns -> Optional number of columns in text area
1615# Returns:
1616# A string containing a <TEXTAREA></TEXTAREA> tag
1617#
1618'textarea' => <<'END_OF_FUNC',
1619sub textarea {
1620 my($self,@p) = self_or_default(@_);
1621
1622 my($name,$default,$rows,$cols,$override,@other) =
3d1a2ec4 1623 rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
54310121
PP
1624
1625 my($current)= $override ? $default :
1626 (defined($self->param($name)) ? $self->param($name) : $default);
1627
1628 $name = defined($name) ? $self->escapeHTML($name) : '';
1629 $current = defined($current) ? $self->escapeHTML($current) : '';
6b4ac661
JH
1630 my($r) = $rows ? " rows=$rows" : '';
1631 my($c) = $cols ? " cols=$cols" : '';
54310121 1632 my($other) = @other ? " @other" : '';
6b4ac661 1633 return qq{<textarea name="$name"$r$c$other>$current</textarea>};
54310121
PP
1634}
1635END_OF_FUNC
1636
1637
1638#### Method: button
1639# Create a javascript button.
1640# Parameters:
1641# $name -> (optional) Name for the button. (-name)
1642# $value -> (optional) Value of the button when selected (and visible name) (-value)
1643# $onclick -> (optional) Text of the JavaScript to run when the button is
1644# clicked.
1645# Returns:
1646# A string containing a <INPUT TYPE="button"> tag
1647####
1648'button' => <<'END_OF_FUNC',
1649sub button {
1650 my($self,@p) = self_or_default(@_);
1651
3d1a2ec4 1652 my($label,$value,$script,@other) = rearrange([NAME,[VALUE,LABEL],
54310121
PP
1653 [ONCLICK,SCRIPT]],@p);
1654
1655 $label=$self->escapeHTML($label);
a3b3a725 1656 $value=$self->escapeHTML($value,1);
54310121
PP
1657 $script=$self->escapeHTML($script);
1658
1659 my($name) = '';
1660 $name = qq/ NAME="$label"/ if $label;
1661 $value = $value || $label;
1662 my($val) = '';
6b4ac661
JH
1663 $val = qq/ value="$value"/ if $value;
1664 $script = qq/ onclick="$script"/ if $script;
54310121 1665 my($other) = @other ? " @other" : '';
6b4ac661
JH
1666 return $XHTML ? qq(<input type="button"$name$val$script$other />)
1667 : qq/<input type="button"$name$val$script$other>/;
54310121
PP
1668}
1669END_OF_FUNC
1670
1671
1672#### Method: submit
1673# Create a "submit query" button.
1674# Parameters:
1675# $name -> (optional) Name for the button.
1676# $value -> (optional) Value of the button when selected (also doubles as label).
1677# $label -> (optional) Label printed on the button(also doubles as the value).
1678# Returns:
1679# A string containing a <INPUT TYPE="submit"> tag
1680####
1681'submit' => <<'END_OF_FUNC',
1682sub submit {
1683 my($self,@p) = self_or_default(@_);
1684
3d1a2ec4 1685 my($label,$value,@other) = rearrange([NAME,[VALUE,LABEL]],@p);
54310121
PP
1686
1687 $label=$self->escapeHTML($label);
a3b3a725 1688 $value=$self->escapeHTML($value,1);
54310121 1689
6b4ac661
JH
1690 my($name) = ' name=".submit"' unless $NOSTICKY;
1691 $name = qq/ name="$label"/ if defined($label);
424ec8fa 1692 $value = defined($value) ? $value : $label;
54310121 1693 my($val) = '';
6b4ac661 1694 $val = qq/ value="$value"/ if defined($value);
54310121 1695 my($other) = @other ? " @other" : '';
6b4ac661
JH
1696 return $XHTML ? qq(<input type="submit"$name$val$other />)
1697 : qq/<input type="submit"$name$val$other>/;
54310121
PP
1698}
1699END_OF_FUNC
1700
1701
1702#### Method: reset
1703# Create a "reset" button.
1704# Parameters:
1705# $name -> (optional) Name for the button.
1706# Returns:
1707# A string containing a <INPUT TYPE="reset"> tag
1708####
1709'reset' => <<'END_OF_FUNC',
1710sub reset {
1711 my($self,@p) = self_or_default(@_);
3d1a2ec4 1712 my($label,@other) = rearrange([NAME],@p);
54310121 1713 $label=$self->escapeHTML($label);
6b4ac661 1714 my($value) = defined($label) ? qq/ value="$label"/ : '';
54310121 1715 my($other) = @other ? " @other" : '';
6b4ac661
JH
1716 return $XHTML ? qq(<input type="reset"$value$other />)
1717 : qq/<input type="reset"$value$other>/;
54310121
PP
1718}
1719END_OF_FUNC
1720
1721
1722#### Method: defaults
1723# Create a "defaults" button.
1724# Parameters:
1725# $name -> (optional) Name for the button.
1726# Returns:
1727# A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
1728#
1729# Note: this button has a special meaning to the initialization script,
1730# and tells it to ERASE the current query string so that your defaults
1731# are used again!
1732####
1733'defaults' => <<'END_OF_FUNC',
1734sub defaults {
1735 my($self,@p) = self_or_default(@_);
1736
3d1a2ec4 1737 my($label,@other) = rearrange([[NAME,VALUE]],@p);
54310121 1738
a3b3a725 1739 $label=$self->escapeHTML($label,1);
54310121 1740 $label = $label || "Defaults";
6b4ac661 1741 my($value) = qq/ value="$label"/;
54310121 1742 my($other) = @other ? " @other" : '';
d45d855d 1743 return $XHTML ? qq(<input type="submit" name=".defaults"$value$other />)
6b4ac661 1744 : qq/<input type="submit" NAME=".defaults"$value$other>/;
54310121
PP
1745}
1746END_OF_FUNC
1747
1748
424ec8fa
GS
1749#### Method: comment
1750# Create an HTML <!-- comment -->
1751# Parameters: a string
1752'comment' => <<'END_OF_FUNC',
1753sub comment {
1754 my($self,@p) = self_or_CGI(@_);
1755 return "<!-- @p -->";
1756}
1757END_OF_FUNC
1758
54310121
PP
1759#### Method: checkbox
1760# Create a checkbox that is not logically linked to any others.
1761# The field value is "on" when the button is checked.
1762# Parameters:
1763# $name -> Name of the checkbox
1764# $checked -> (optional) turned on by default if true
1765# $value -> (optional) value of the checkbox, 'on' by default
1766# $label -> (optional) a user-readable label printed next to the box.
1767# Otherwise the checkbox name is used.
1768# Returns:
1769# A string containing a <INPUT TYPE="checkbox"> field
1770####
1771'checkbox' => <<'END_OF_FUNC',
1772sub checkbox {
1773 my($self,@p) = self_or_default(@_);
1774
1775 my($name,$checked,$value,$label,$override,@other) =
3d1a2ec4 1776 rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
54310121 1777
424ec8fa
GS
1778 $value = defined $value ? $value : 'on';
1779
1780 if (!$override && ($self->{'.fieldnames'}->{$name} ||
1781 defined $self->param($name))) {
03b9648d 1782 $checked = grep($_ eq $value,$self->param($name)) ? ' checked' : '';
54310121 1783 } else {
03b9648d 1784 $checked = $checked ? qq/ checked/ : '';
54310121
PP
1785 }
1786 my($the_label) = defined $label ? $label : $name;
1787 $name = $self->escapeHTML($name);
a3b3a725 1788 $value = $self->escapeHTML($value,1);
54310121
PP
1789 $the_label = $self->escapeHTML($the_label);
1790 my($other) = @other ? " @other" : '';
1791 $self->register_parameter($name);
6b4ac661
JH
1792 return $XHTML ? qq{<input type="checkbox" name="$name" value="$value"$checked$other />$the_label}
1793 : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
54310121
PP
1794}
1795END_OF_FUNC
1796
1797
1798#### Method: checkbox_group
1799# Create a list of logically-linked checkboxes.
1800# Parameters:
1801# $name -> Common name for all the check boxes
1802# $values -> A pointer to a regular array containing the
1803# values for each checkbox in the group.
1804# $defaults -> (optional)
1805# 1. If a pointer to a regular array of checkbox values,
1806# then this will be used to decide which
1807# checkboxes to turn on by default.
1808# 2. If a scalar, will be assumed to hold the
1809# value of a single checkbox in the group to turn on.
1810# $linebreak -> (optional) Set to true to place linebreaks
1811# between the buttons.
1812# $labels -> (optional)
1813# A pointer to an associative array of labels to print next to each checkbox
1814# in the form $label{'value'}="Long explanatory label".
1815# Otherwise the provided values are used as the labels.
1816# Returns:
1817# An ARRAY containing a series of <INPUT TYPE="checkbox"> fields
1818####
1819'checkbox_group' => <<'END_OF_FUNC',
1820sub checkbox_group {
1821 my($self,@p) = self_or_default(@_);
1822
1823 my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
1824 $rowheaders,$colheaders,$override,$nolabels,@other) =
3d1a2ec4 1825 rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
54310121
PP
1826 LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
1827 ROWHEADERS,COLHEADERS,
1828 [OVERRIDE,FORCE],NOLABELS],@p);
1829
1830 my($checked,$break,$result,$label);
1831
1832 my(%checked) = $self->previous_or_default($name,$defaults,$override);
1833
6b4ac661
JH
1834 if ($linebreak) {
1835 $break = $XHTML ? "<br />" : "<br>";
1836 }
1837 else {
1838 $break = '';
1839 }
54310121
PP
1840 $name=$self->escapeHTML($name);
1841
1842 # Create the elements
424ec8fa
GS
1843 my(@elements,@values);
1844
1845 @values = $self->_set_values_and_labels($values,\$labels,$name);
1846
54310121
PP
1847 my($other) = @other ? " @other" : '';
1848 foreach (@values) {
03b9648d 1849 $checked = $checked{$_} ? qq/ checked/ : '';
54310121
PP
1850 $label = '';
1851 unless (defined($nolabels) && $nolabels) {
1852 $label = $_;
424ec8fa 1853 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
54310121
PP
1854 $label = $self->escapeHTML($label);
1855 }
a3b3a725 1856 $_ = $self->escapeHTML($_,1);
6b4ac661
JH
1857 push(@elements,$XHTML ? qq(<input type="checkbox" name="$name" value="$_"$checked$other />${label}${break})
1858 : qq/<input type="checkbox" name="$name" value="$_"$checked$other>${label}${break}/);
54310121
PP
1859 }
1860 $self->register_parameter($name);
424ec8fa
GS
1861 return wantarray ? @elements : join(' ',@elements)
1862 unless defined($columns) || defined($rows);
54310121
PP
1863 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1864}
1865END_OF_FUNC
1866
54310121
PP
1867# Escape HTML -- used internally
1868'escapeHTML' => <<'END_OF_FUNC',
1869sub escapeHTML {
a3b3a725 1870 my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
6b4ac661
JH
1871 return undef unless defined($toencode);
1872 return $toencode if ref($self) && $self->{'dontescape'};
1873 $toencode =~ s{&}{&amp;}gso;
1874 $toencode =~ s{<}{&lt;}gso;
1875 $toencode =~ s{>}{&gt;}gso;
1876 $toencode =~ s{"}{&quot;}gso;
a3b3a725
JH
1877 my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' ||
1878 uc $self->{'.charset'} eq 'WINDOWS-1252';
1879 if ($latin) { # bug in some browsers
6b4ac661
JH
1880 $toencode =~ s{\x8b}{&#139;}gso;
1881 $toencode =~ s{\x9b}{&#155;}gso;
a3b3a725
JH
1882 if (defined $newlinestoo && $newlinestoo) {
1883 $toencode =~ s{\012}{&#10;}gso;
1884 $toencode =~ s{\015}{&#13;}gso;
1885 }
1886 }
6b4ac661 1887 return $toencode;
54310121
PP
1888}
1889END_OF_FUNC
1890
424ec8fa
GS
1891# unescape HTML -- used internally
1892'unescapeHTML' => <<'END_OF_FUNC',
1893sub unescapeHTML {
6b4ac661 1894 my ($self,$string) = CGI::self_or_default(@_);
424ec8fa 1895 return undef unless defined($string);
a3b3a725
JH
1896 my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
1897 : 1;
71f3e297
JH
1898 # thanks to Randal Schwartz for the correct solution to this one
1899 $string=~ s[&(.*?);]{
1900 local $_ = $1;
1901 /^amp$/i ? "&" :
1902 /^quot$/i ? '"' :
1903 /^gt$/i ? ">" :
1904 /^lt$/i ? "<" :
6b4ac661
JH
1905 /^#(\d+)$/ && $latin ? chr($1) :
1906 /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
71f3e297
JH
1907 $_
1908 }gex;
424ec8fa
GS
1909 return $string;
1910}
1911END_OF_FUNC
54310121
PP
1912
1913# Internal procedure - don't use
1914'_tableize' => <<'END_OF_FUNC',
1915sub _tableize {
1916 my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
6b4ac661
JH
1917 $rowheaders = [] unless defined $rowheaders;
1918 $colheaders = [] unless defined $colheaders;
54310121
PP
1919 my($result);
1920
424ec8fa
GS
1921 if (defined($columns)) {
1922 $rows = int(0.99 + @elements/$columns) unless defined($rows);
1923 }
1924 if (defined($rows)) {
1925 $columns = int(0.99 + @elements/$rows) unless defined($columns);
1926 }
1927
54310121 1928 # rearrange into a pretty table
6b4ac661 1929 $result = "<table>";
54310121 1930 my($row,$column);
475342a6 1931 unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
6b4ac661 1932 $result .= "<tr>" if @{$colheaders};
54310121 1933 foreach (@{$colheaders}) {
6b4ac661 1934 $result .= "<th>$_</th>";
54310121
PP
1935 }
1936 for ($row=0;$row<$rows;$row++) {
6b4ac661
JH
1937 $result .= "<tr>";
1938 $result .= "<th>$rowheaders->[$row]</th>" if @$rowheaders;
54310121 1939 for ($column=0;$column<$columns;$column++) {
6b4ac661 1940 $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
424ec8fa 1941 if defined($elements[$column*$rows + $row]);
54310121 1942 }
6b4ac661 1943 $result .= "</tr>";
54310121 1944 }
6b4ac661 1945 $result .= "</table>";
54310121
PP
1946 return $result;
1947}
1948END_OF_FUNC
1949
1950
1951#### Method: radio_group
1952# Create a list of logically-linked radio buttons.
1953# Parameters:
1954# $name -> Common name for all the buttons.
1955# $values -> A pointer to a regular array containing the
1956# values for each button in the group.
1957# $default -> (optional) Value of the button to turn on by default. Pass '-'
1958# to turn _nothing_ on.
1959# $linebreak -> (optional) Set to true to place linebreaks
1960# between the buttons.
1961# $labels -> (optional)
1962# A pointer to an associative array of labels to print next to each checkbox
1963# in the form $label{'value'}="Long explanatory label".
1964# Otherwise the provided values are used as the labels.
1965# Returns:
1966# An ARRAY containing a series of <INPUT TYPE="radio"> fields
1967####
1968'radio_group' => <<'END_OF_FUNC',
1969sub radio_group {
1970 my($self,@p) = self_or_default(@_);
1971
1972 my($name,$values,$default,$linebreak,$labels,
1973 $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
3d1a2ec4 1974 rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
54310121
PP
1975 ROWS,[COLUMNS,COLS],
1976 ROWHEADERS,COLHEADERS,
1977 [OVERRIDE,FORCE],NOLABELS],@p);
1978 my($result,$checked);
1979
1980 if (!$override && defined($self->param($name))) {
1981 $checked = $self->param($name);
1982 } else {
1983 $checked = $default;
1984 }
424ec8fa 1985 my(@elements,@values);
424ec8fa
GS
1986 @values = $self->_set_values_and_labels($values,\$labels,$name);
1987
71f3e297
JH
1988 # If no check array is specified, check the first by default
1989 $checked = $values[0] unless defined($checked) && $checked ne '';
1990 $name=$self->escapeHTML($name);
1991
54310121
PP
1992 my($other) = @other ? " @other" : '';
1993 foreach (@values) {
03b9648d 1994 my($checkit) = $checked eq $_ ? qq/ checked/ : '';
6b4ac661
JH
1995 my($break);
1996 if ($linebreak) {
1997 $break = $XHTML ? "<br />" : "<br>";
1998 }
1999 else {
2000 $break = '';
2001 }
54310121
PP
2002 my($label)='';
2003 unless (defined($nolabels) && $nolabels) {
2004 $label = $_;
424ec8fa 2005 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
a3b3a725 2006 $label = $self->escapeHTML($label,1);
54310121
PP
2007 }
2008 $_=$self->escapeHTML($_);
6b4ac661
JH
2009 push(@elements,$XHTML ? qq(<input type="radio" name="$name" value="$_"$checkit$other />${label}${break})
2010 : qq/<input type="radio" name="$name" value="$_"$checkit$other>${label}${break}/);
54310121
PP
2011 }
2012 $self->register_parameter($name);
424ec8fa
GS
2013 return wantarray ? @elements : join(' ',@elements)
2014 unless defined($columns) || defined($rows);
54310121
PP
2015 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
2016}
2017END_OF_FUNC
2018
2019
2020#### Method: popup_menu
2021# Create a popup menu.
2022# Parameters:
2023# $name -> Name for all the menu
2024# $values -> A pointer to a regular array containing the
2025# text of each menu item.
2026# $default -> (optional) Default item to display
2027# $labels -> (optional)
2028# A pointer to an associative array of labels to print next to each checkbox
2029# in the form $label{'value'}="Long explanatory label".
2030# Otherwise the provided values are used as the labels.
2031# Returns:
2032# A string containing the definition of a popup menu.
2033####
2034'popup_menu' => <<'END_OF_FUNC',
2035sub popup_menu {
2036 my($self,@p) = self_or_default(@_);
2037
2038 my($name,$values,$default,$labels,$override,@other) =
3d1a2ec4 2039 rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
54310121
PP
2040 my($result,$selected);
2041
2042 if (!$override && defined($self->param($name))) {
2043 $selected = $self->param($name);
2044 } else {
2045 $selected = $default;
2046 }
2047 $name=$self->escapeHTML($name);
2048 my($other) = @other ? " @other" : '';
2049
424ec8fa
GS
2050 my(@values);
2051 @values = $self->_set_values_and_labels($values,\$labels,$name);
2052
6b4ac661 2053 $result = qq/<select name="$name"$other>\n/;
54310121 2054 foreach (@values) {
03b9648d 2055 my($selectit) = defined($selected) ? ($selected eq $_ ? qq/selected/ : '' ) : '';
54310121 2056 my($label) = $_;
424ec8fa 2057 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
54310121 2058 my($value) = $self->escapeHTML($_);
a3b3a725 2059 $label=$self->escapeHTML($label,1);
6b4ac661 2060 $result .= "<option $selectit value=\"$value\">$label</option>\n";
54310121
PP
2061 }
2062
6b4ac661 2063 $result .= "</select>\n";
54310121
PP
2064 return $result;
2065}
2066END_OF_FUNC
2067
2068
2069#### Method: scrolling_list
2070# Create a scrolling list.
2071# Parameters:
2072# $name -> name for the list
2073# $values -> A pointer to a regular array containing the
2074# values for each option line in the list.
2075# $defaults -> (optional)
2076# 1. If a pointer to a regular array of options,
2077# then this will be used to decide which
2078# lines to turn on by default.
2079# 2. Otherwise holds the value of the single line to turn on.
2080# $size -> (optional) Size of the list.
2081# $multiple -> (optional) If set, allow multiple selections.
2082# $labels -> (optional)
2083# A pointer to an associative array of labels to print next to each checkbox
2084# in the form $label{'value'}="Long explanatory label".
2085# Otherwise the provided values are used as the labels.
2086# Returns:
2087# A string containing the definition of a scrolling list.
2088####
2089'scrolling_list' => <<'END_OF_FUNC',
2090sub scrolling_list {
2091 my($self,@p) = self_or_default(@_);
2092 my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
3d1a2ec4 2093 = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
54310121
PP
2094 SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
2095
424ec8fa
GS
2096 my($result,@values);
2097 @values = $self->_set_values_and_labels($values,\$labels,$name);
2098
54310121
PP
2099 $size = $size || scalar(@values);
2100
2101 my(%selected) = $self->previous_or_default($name,$defaults,$override);
03b9648d 2102 my($is_multiple) = $multiple ? qq/ multiple/ : '';
6b4ac661 2103 my($has_size) = $size ? qq/ size="$size"/: '';
54310121
PP
2104 my($other) = @other ? " @other" : '';
2105
2106 $name=$self->escapeHTML($name);
6b4ac661 2107 $result = qq/<select name="$name"$has_size$is_multiple$other>\n/;
54310121 2108 foreach (@values) {
03b9648d 2109 my($selectit) = $selected{$_} ? qq/selected/ : '';
54310121 2110 my($label) = $_;
424ec8fa 2111 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
54310121 2112 $label=$self->escapeHTML($label);
a3b3a725 2113 my($value)=$self->escapeHTML($_,1);
6b4ac661 2114 $result .= "<option $selectit value=\"$value\">$label</option>\n";
54310121 2115 }
6b4ac661 2116 $result .= "</select>\n";
54310121
PP
2117 $self->register_parameter($name);
2118 return $result;
2119}
2120END_OF_FUNC
2121
2122
2123#### Method: hidden
2124# Parameters:
2125# $name -> Name of the hidden field
2126# @default -> (optional) Initial values of field (may be an array)
2127# or
2128# $default->[initial values of field]
2129# Returns:
2130# A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
2131####
2132'hidden' => <<'END_OF_FUNC',
2133sub hidden {
2134 my($self,@p) = self_or_default(@_);
2135
2136 # this is the one place where we departed from our standard
2137 # calling scheme, so we have to special-case (darn)
2138 my(@result,@value);
2139 my($name,$default,$override,@other) =
3d1a2ec4 2140 rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
54310121
PP
2141
2142 my $do_override = 0;
3d1a2ec4 2143 if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
54310121
PP
2144 @value = ref($default) ? @{$default} : $default;
2145 $do_override = $override;
2146 } else {
2147 foreach ($default,$override,@other) {
2148 push(@value,$_) if defined($_);
2149 }
2150 }
2151
2152 # use previous values if override is not set
2153 my @prev = $self->param($name);
2154 @value = @prev if !$do_override && @prev;
2155
2156 $name=$self->escapeHTML($name);
2157 foreach (@value) {
a3b3a725 2158 $_ = defined($_) ? $self->escapeHTML($_,1) : '';
03b9648d
JH
2159 push @result,$XHTMl ? qq(<input type="hidden" name="$name" value="$_" />)
2160 : qq(<input type="hidden" name="$name" value="$_">);
54310121
PP
2161 }
2162 return wantarray ? @result : join('',@result);
2163}
2164END_OF_FUNC
2165
2166
2167#### Method: image_button
2168# Parameters:
2169# $name -> Name of the button
2170# $src -> URL of the image source
2171# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
2172# Returns:
2173# A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment">
2174####
2175'image_button' => <<'END_OF_FUNC',
2176sub image_button {
2177 my($self,@p) = self_or_default(@_);
2178
2179 my($name,$src,$alignment,@other) =
3d1a2ec4 2180 rearrange([NAME,SRC,ALIGN],@p);
54310121 2181
6b4ac661 2182 my($align) = $alignment ? " align=\U$alignment" : '';
54310121
PP
2183 my($other) = @other ? " @other" : '';
2184 $name=$self->escapeHTML($name);
6b4ac661
JH
2185 return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
2186 : qq/<input type="image" name="$name" src="$src"$align$other>/;
54310121
PP
2187}
2188END_OF_FUNC
2189
2190
2191#### Method: self_url
2192# Returns a URL containing the current script and all its
2193# param/value pairs arranged as a query. You can use this
2194# to create a link that, when selected, will reinvoke the
2195# script with all its state information preserved.
2196####
2197'self_url' => <<'END_OF_FUNC',
2198sub self_url {
424ec8fa
GS
2199 my($self,@p) = self_or_default(@_);
2200 return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
54310121
PP
2201}
2202END_OF_FUNC
2203
2204
2205# This is provided as a synonym to self_url() for people unfortunate
2206# enough to have incorporated it into their programs already!
2207'state' => <<'END_OF_FUNC',
2208sub state {
2209 &self_url;
2210}
2211END_OF_FUNC
2212
2213
2214#### Method: url
2215# Like self_url, but doesn't return the query string part of
2216# the URL.
2217####
2218'url' => <<'END_OF_FUNC',
2219sub url {
424ec8fa 2220 my($self,@p) = self_or_default(@_);
03b9648d
JH
2221 my ($relative,$absolute,$full,$path_info,$query,$base) =
2222 rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE'],@p);
424ec8fa 2223 my $url;
03b9648d 2224 $full++ if $base || !($relative || $absolute);
424ec8fa 2225
3538e1d5 2226 my $path = $self->path_info;
d45d855d
JH
2227 my $script_name = $self->script_name;
2228
2229# If anybody knows why I ever wrote this please tell me!
2230# if (exists($ENV{REQUEST_URI})) {
2231# my $index;
2232# $script_name = $ENV{REQUEST_URI};
2233# # strip query string
2234# substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0;
2235# # and path
2236# if (exists($ENV{PATH_INFO})) {
2237# (my $encoded_path = $ENV{PATH_INFO}) =~ s!([^a-zA-Z0-9_./-])!uc sprintf("%%%02x",ord($1))!eg;;
2238# substr($script_name,$index) = '' if ($index = rindex($script_name,$encoded_path)) >= 0;
2239# }
2240# } else {
2241# $script_name = $self->script_name;
2242# }
3538e1d5 2243
424ec8fa
GS
2244 if ($full) {
2245 my $protocol = $self->protocol();
2246 $url = "$protocol://";
2247 my $vh = http('host');
2248 if ($vh) {
2249 $url .= $vh;
2250 } else {
2251 $url .= server_name();
2252 my $port = $self->server_port;
2253 $url .= ":" . $port
2254 unless (lc($protocol) eq 'http' && $port == 80)
2255 || (lc($protocol) eq 'https' && $port == 443);
2256 }
03b9648d 2257 return $url if $base;
3538e1d5 2258 $url .= $script_name;
424ec8fa 2259 } elsif ($relative) {
3538e1d5 2260 ($url) = $script_name =~ m!([^/]+)$!;
424ec8fa 2261 } elsif ($absolute) {
3538e1d5 2262 $url = $script_name;
424ec8fa 2263 }
03b9648d 2264
3538e1d5 2265 $url .= $path if $path_info and defined $path;
424ec8fa 2266 $url .= "?" . $self->query_string if $query and $self->query_string;
3d1a2ec4
GS
2267 $url = '' unless defined $url;
2268 $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/uc sprintf("%%%02x",ord($1))/eg;
424ec8fa 2269 return $url;
54310121
PP
2270}
2271
2272END_OF_FUNC
2273
2274#### Method: cookie
2275# Set or read a cookie from the specified name.
2276# Cookie can then be passed to header().
2277# Usual rules apply to the stickiness of -value.
2278# Parameters:
2279# -name -> name for this cookie (optional)
2280# -value -> value of this cookie (scalar, array or hash)
2281# -path -> paths for which this cookie is valid (optional)
2282# -domain -> internet domain in which this cookie is valid (optional)
2283# -secure -> if true, cookie only passed through secure channel (optional)
7d37aa8e 2284# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
54310121
PP
2285####
2286'cookie' => <<'END_OF_FUNC',
54310121
PP
2287sub cookie {
2288 my($self,@p) = self_or_default(@_);
2289 my($name,$value,$path,$domain,$secure,$expires) =
3d1a2ec4 2290 rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
54310121 2291
424ec8fa 2292 require CGI::Cookie;
54310121
PP
2293
2294 # if no value is supplied, then we retrieve the
2295 # value of the cookie, if any. For efficiency, we cache the parsed
424ec8fa
GS
2296 # cookies in our state variables.
2297 unless ( defined($value) ) {
2298 $self->{'.cookies'} = CGI::Cookie->fetch
2299 unless $self->{'.cookies'};
54310121
PP
2300
2301 # If no name is supplied, then retrieve the names of all our cookies.
2302 return () unless $self->{'.cookies'};
424ec8fa
GS
2303 return keys %{$self->{'.cookies'}} unless $name;
2304 return () unless $self->{'.cookies'}->{$name};
2305 return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
54310121 2306 }
54310121 2307
424ec8fa
GS
2308 # If we get here, we're creating a new cookie
2309 return undef unless $name; # this is an error
54310121 2310
424ec8fa
GS
2311 my @param;
2312 push(@param,'-name'=>$name);
2313 push(@param,'-value'=>$value);
2314 push(@param,'-domain'=>$domain) if $domain;
2315 push(@param,'-path'=>$path) if $path;
2316 push(@param,'-expires'=>$expires) if $expires;
2317 push(@param,'-secure'=>$secure) if $secure;
54310121 2318
6b4ac661 2319 return new CGI::Cookie(@param);
54310121
PP
2320}
2321END_OF_FUNC
2322
424ec8fa
GS
2323'parse_keywordlist' => <<'END_OF_FUNC',
2324sub parse_keywordlist {
2325 my($self,$tosplit) = @_;
2326 $tosplit = unescape($tosplit); # unescape the keywords
2327 $tosplit=~tr/+/ /; # pluses to spaces
2328 my(@keywords) = split(/\s+/,$tosplit);
2329 return @keywords;
2330}
2331END_OF_FUNC
2332
2333'param_fetch' => <<'END_OF_FUNC',
2334sub param_fetch {
2335 my($self,@p) = self_or_default(@_);
3d1a2ec4 2336 my($name) = rearrange([NAME],@p);
424ec8fa
GS
2337 unless (exists($self->{$name})) {
2338 $self->add_parameter($name);
2339 $self->{$name} = [];
2340 }
2341
2342 return $self->{$name};
2343}
2344END_OF_FUNC
2345
54310121
PP
2346###############################################
2347# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
2348###############################################
2349
2350#### Method: path_info
2351# Return the extra virtual path information provided
2352# after the URL (if any)
2353####
2354'path_info' => <<'END_OF_FUNC',
2355sub path_info {
424ec8fa
GS
2356 my ($self,$info) = self_or_default(@_);
2357 if (defined($info)) {
2358 $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
2359 $self->{'.path_info'} = $info;
2360 } elsif (! defined($self->{'.path_info'}) ) {
2361 $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ?
2362 $ENV{'PATH_INFO'} : '';
2363
2364 # hack to fix broken path info in IIS
2365 $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
2366
2367 }
2368 return $self->{'.path_info'};
54310121
PP
2369}
2370END_OF_FUNC
2371
2372
2373#### Method: request_method
2374# Returns 'POST', 'GET', 'PUT' or 'HEAD'
2375####
2376'request_method' => <<'END_OF_FUNC',
2377sub request_method {
2378 return $ENV{'REQUEST_METHOD'};
2379}
2380END_OF_FUNC
2381
3538e1d5
GS
2382#### Method: content_type
2383# Returns the content_type string
2384####
2385'content_type' => <<'END_OF_FUNC',
2386sub content_type {
2387 return $ENV{'CONTENT_TYPE'};
2388}
2389END_OF_FUNC
2390
54310121
PP
2391#### Method: path_translated
2392# Return the physical path information provided
2393# by the URL (if any)
2394####
2395'path_translated' => <<'END_OF_FUNC',
2396sub path_translated {
2397 return $ENV{'PATH_TRANSLATED'};
2398}
2399END_OF_FUNC
2400
2401
2402#### Method: query_string
2403# Synthesize a query string from our current
2404# parameters
2405####
2406'query_string' => <<'END_OF_FUNC',
2407sub query_string {
2408 my($self) = self_or_default(@_);
2409 my($param,$value,@pairs);
2410 foreach $param ($self->param) {
424ec8fa 2411 my($eparam) = escape($param);
54310121 2412 foreach $value ($self->param($param)) {
424ec8fa 2413 $value = escape($value);
3538e1d5 2414 next unless defined $value;
54310121
PP
2415 push(@pairs,"$eparam=$value");
2416 }
2417 }
d45d855d
JH
2418 foreach (keys %{$self->{'.fieldnames'}}) {
2419 push(@pairs,".cgifields=".escape("$_"));
2420 }
71f3e297 2421 return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
54310121
PP
2422}
2423END_OF_FUNC
2424
2425
2426#### Method: accept
2427# Without parameters, returns an array of the
2428# MIME types the browser accepts.
2429# With a single parameter equal to a MIME
2430# type, will return undef if the browser won't
2431# accept it, 1 if the browser accepts it but
2432# doesn't give a preference, or a floating point
2433# value between 0.0 and 1.0 if the browser
2434# declares a quantitative score for it.
2435# This handles MIME type globs correctly.
2436####
71f3e297
JH
2437'Accept' => <<'END_OF_FUNC',
2438sub Accept {
54310121
PP
2439 my($self,$search) = self_or_CGI(@_);
2440 my(%prefs,$type,$pref,$pat);
2441
2442 my(@accept) = split(',',$self->http('accept'));
2443
2444 foreach (@accept) {
2445 ($pref) = /q=(\d\.\d+|\d+)/;
2446 ($type) = m#(\S+/[^;]+)#;
2447 next unless $type;
2448 $prefs{$type}=$pref || 1;
2449 }
2450
2451 return keys %prefs unless $search;
2452
2453 # if a search type is provided, we may need to
2454 # perform a pattern matching operation.
2455 # The MIME types use a glob mechanism, which
2456 # is easily translated into a perl pattern match
2457
2458 # First return the preference for directly supported
2459 # types:
2460 return $prefs{$search} if $prefs{$search};
2461
2462 # Didn't get it, so try pattern matching.
2463 foreach (keys %prefs) {
2464 next unless /\*/; # not a pattern match
2465 ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2466 $pat =~ s/\*/.*/g; # turn it into a pattern
2467 return $prefs{$_} if $search=~/$pat/;
2468 }
2469}
2470END_OF_FUNC
2471
2472
2473#### Method: user_agent
2474# If called with no parameters, returns the user agent.
2475# If called with one parameter, does a pattern match (case
2476# insensitive) on the user agent.
2477####
2478'user_agent' => <<'END_OF_FUNC',
2479sub user_agent {
2480 my($self,$match)=self_or_CGI(@_);
2481 return $self->http('user_agent') unless $match;
2482 return $self->http('user_agent') =~ /$match/i;
2483}
2484END_OF_FUNC
2485
2486
424ec8fa
GS
2487#### Method: raw_cookie
2488# Returns the magic cookies for the session.
2489# The cookies are not parsed or altered in any way, i.e.
2490# cookies are returned exactly as given in the HTTP
2491# headers. If a cookie name is given, only that cookie's
2492# value is returned, otherwise the entire raw cookie
2493# is returned.
54310121
PP
2494####
2495'raw_cookie' => <<'END_OF_FUNC',
2496sub raw_cookie {
424ec8fa
GS
2497 my($self,$key) = self_or_CGI(@_);
2498
2499 require CGI::Cookie;
2500
2501 if (defined($key)) {
2502 $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
2503 unless $self->{'.raw_cookies'};
2504
2505 return () unless $self->{'.raw_cookies'};
2506 return () unless $self->{'.raw_cookies'}->{$key};
2507 return $self->{'.raw_cookies'}->{$key};
2508 }
54310121
PP
2509 return $self->http('cookie') || $ENV{'COOKIE'} || '';
2510}
2511END_OF_FUNC
2512
2513#### Method: virtual_host
2514# Return the name of the virtual_host, which
2515# is not always the same as the server
2516######
2517'virtual_host' => <<'END_OF_FUNC',
2518sub virtual_host {
424ec8fa
GS
2519 my $vh = http('host') || server_name();
2520 $vh =~ s/:\d+$//; # get rid of port number
2521 return $vh;
54310121
PP
2522}
2523END_OF_FUNC
2524
2525#### Method: remote_host
2526# Return the name of the remote host, or its IP
2527# address if unavailable. If this variable isn't
2528# defined, it returns "localhost" for debugging
2529# purposes.
2530####
2531'remote_host' => <<'END_OF_FUNC',
2532sub remote_host {
2533 return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
2534 || 'localhost';
2535}
2536END_OF_FUNC
2537
2538
2539#### Method: remote_addr
2540# Return the IP addr of the remote host.
2541####
2542'remote_addr' => <<'END_OF_FUNC',
2543sub remote_addr {
2544 return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
2545}
2546END_OF_FUNC
2547
2548
2549#### Method: script_name
2550# Return the partial URL to this script for
2551# self-referencing scripts. Also see
2552# self_url(), which returns a URL with all state information
2553# preserved.
2554####
2555'script_name' => <<'END_OF_FUNC',
2556sub script_name {
424ec8fa 2557 return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'});
54310121
PP
2558 # These are for debugging
2559 return "/$0" unless $0=~/^\//;
2560 return $0;
2561}
2562END_OF_FUNC
2563
2564
2565#### Method: referer
2566# Return the HTTP_REFERER: useful for generating
2567# a GO BACK button.
2568####
2569'referer' => <<'END_OF_FUNC',
2570sub referer {
2571 my($self) = self_or_CGI(@_);
2572 return $self->http('referer');
2573}
2574END_OF_FUNC
2575
2576
2577#### Method: server_name
2578# Return the name of the server
2579####
2580'server_name' => <<'END_OF_FUNC',
2581sub server_name {
2582 return $ENV{'SERVER_NAME'} || 'localhost';
2583}
2584END_OF_FUNC
2585
2586#### Method: server_software
2587# Return the name of the server software
2588####
2589'server_software' => <<'END_OF_FUNC',
2590sub server_software {
2591 return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
2592}
2593END_OF_FUNC
2594
2595#### Method: server_port
2596# Return the tcp/ip port the server is running on
2597####
2598'server_port' => <<'END_OF_FUNC',
2599sub server_port {
2600 return $ENV{'SERVER_PORT'} || 80; # for debugging
2601}
2602END_OF_FUNC
2603
2604#### Method: server_protocol
2605# Return the protocol (usually HTTP/1.0)
2606####
2607'server_protocol' => <<'END_OF_FUNC',
2608sub server_protocol {
2609 return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
2610}
2611END_OF_FUNC
2612
2613#### Method: http
2614# Return the value of an HTTP variable, or
2615# the list of variables if none provided
2616####
2617'http' => <<'END_OF_FUNC',
2618sub http {
2619 my ($self,$parameter) = self_or_CGI(@_);
2620 return $ENV{$parameter} if $parameter=~/^HTTP/;
3538e1d5 2621 $parameter =~ tr/-/_/;
54310121
PP
2622 return $ENV{"HTTP_\U$parameter\E"} if $parameter;
2623 my(@p);
2624 foreach (keys %ENV) {
2625 push(@p,$_) if /^HTTP/;
2626 }
2627 return @p;
2628}
2629END_OF_FUNC
2630
2631#### Method: https
2632# Return the value of HTTPS
2633####
2634'https' => <<'END_OF_FUNC',
2635sub https {
2636 local($^W)=0;
2637 my ($self,$parameter) = self_or_CGI(@_);
2638 return $ENV{HTTPS} unless $parameter;
2639 return $ENV{$parameter} if $parameter=~/^HTTPS/;
3538e1d5 2640 $parameter =~ tr/-/_/;
54310121
PP
2641 return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
2642 my(@p);
2643 foreach (keys %ENV) {
2644 push(@p,$_) if /^HTTPS/;
2645 }
2646 return @p;
2647}
2648END_OF_FUNC
2649
2650#### Method: protocol
2651# Return the protocol (http or https currently)
2652####
2653'protocol' => <<'END_OF_FUNC',
2654sub protocol {
2655 local($^W)=0;
2656 my $self = shift;
424ec8fa 2657 return 'https' if uc($self->https()) eq 'ON';
54310121
PP
2658 return 'https' if $self->server_port == 443;
2659 my $prot = $self->server_protocol;
2660 my($protocol,$version) = split('/',$prot);
2661 return "\L$protocol\E";
2662}
2663END_OF_FUNC
2664
2665#### Method: remote_ident
2666# Return the identity of the remote user
2667# (but only if his host is running identd)
2668####
2669'remote_ident' => <<'END_OF_FUNC',
2670sub remote_ident {
2671 return $ENV{'REMOTE_IDENT'};
2672}
2673END_OF_FUNC
2674
2675
2676#### Method: auth_type
2677# Return the type of use verification/authorization in use, if any.
2678####
2679'auth_type' => <<'END_OF_FUNC',
2680sub auth_type {
2681 return $ENV{'AUTH_TYPE'};
2682}
2683END_OF_FUNC
2684
2685
2686#### Method: remote_user
2687# Return the authorization name used for user
2688# verification.
2689####
2690'remote_user' => <<'END_OF_FUNC',
2691sub remote_user {
2692 return $ENV{'REMOTE_USER'};
2693}
2694END_OF_FUNC
2695
2696
2697#### Method: user_name
2698# Try to return the remote user's name by hook or by
2699# crook
2700####
2701'user_name' => <<'END_OF_FUNC',
2702sub user_name {
2703 my ($self) = self_or_CGI(@_);
2704 return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
2705}
2706END_OF_FUNC
2707
3d1a2ec4
GS
2708#### Method: nosticky
2709# Set or return the NOSTICKY global flag
2710####
2711'nosticky' => <<'END_OF_FUNC',
2712sub nosticky {
2713 my ($self,$param) = self_or_CGI(@_);
2714 $CGI::NOSTICKY = $param if defined($param);
2715 return $CGI::NOSTICKY;
2716}
2717END_OF_FUNC
2718
54310121
PP
2719#### Method: nph
2720# Set or return the NPH global flag
2721####
2722'nph' => <<'END_OF_FUNC',
2723sub nph {
2724 my ($self,$param) = self_or_CGI(@_);
7d37aa8e
LS
2725 $CGI::NPH = $param if defined($param);
2726 return $CGI::NPH;
2727}
2728END_OF_FUNC
2729
2730#### Method: private_tempfiles
2731# Set or return the private_tempfiles global flag
2732####
2733'private_tempfiles' => <<'END_OF_FUNC',
2734sub private_tempfiles {
2735 my ($self,$param) = self_or_CGI(@_);
424ec8fa 2736 $CGI::PRIVATE_TEMPFILES = $param if defined($param);
7d37aa8e 2737 return $CGI::PRIVATE_TEMPFILES;
54310121
PP
2738}
2739END_OF_FUNC
2740
424ec8fa
GS
2741#### Method: default_dtd
2742# Set or return the default_dtd global
2743####
2744'default_dtd' => <<'END_OF_FUNC',
2745sub default_dtd {
3d1a2ec4
GS
2746 my ($self,$param,$param2) = self_or_CGI(@_);
2747 if (defined $param2 && defined $param) {
2748 $CGI::DEFAULT_DTD = [ $param, $param2 ];
2749 } elsif (defined $param) {
2750 $CGI::DEFAULT_DTD = $param;
2751 }
424ec8fa
GS
2752 return $CGI::DEFAULT_DTD;
2753}
2754END_OF_FUNC
2755
54310121
PP
2756# -------------- really private subroutines -----------------
2757'previous_or_default' => <<'END_OF_FUNC',
2758sub previous_or_default {
2759 my($self,$name,$defaults,$override) = @_;
2760 my(%selected);
2761
2762 if (!$override && ($self->{'.fieldnames'}->{$name} ||
2763 defined($self->param($name)) ) ) {
2764 grep($selected{$_}++,$self->param($name));
2765 } elsif (defined($defaults) && ref($defaults) &&
2766 (ref($defaults) eq 'ARRAY')) {
2767 grep($selected{$_}++,@{$defaults});
2768 } else {
2769 $selected{$defaults}++ if defined($defaults);
2770 }
2771
2772 return %selected;
2773}
2774END_OF_FUNC
2775
2776'register_parameter' => <<'END_OF_FUNC',
2777sub register_parameter {
2778 my($self,$param) = @_;
2779 $self->{'.parametersToAdd'}->{$param}++;
2780}
2781END_OF_FUNC
2782
2783'get_fields' => <<'END_OF_FUNC',
2784sub get_fields {
2785 my($self) = @_;
424ec8fa
GS
2786 return $self->CGI::hidden('-name'=>'.cgifields',
2787 '-values'=>[keys %{$self->{'.parametersToAdd'}}],
2788 '-override'=>1);
54310121
PP
2789}
2790END_OF_FUNC
2791
2792'read_from_cmdline' => <<'END_OF_FUNC',
2793sub read_from_cmdline {
54310121
PP
2794 my($input,@words);
2795 my($query_string);
3d1a2ec4 2796 if ($DEBUG && @ARGV) {
424ec8fa 2797 @words = @ARGV;
3d1a2ec4 2798 } elsif ($DEBUG > 1) {
424ec8fa 2799 require "shellwords.pl";
54310121 2800 print STDERR "(offline mode: enter name=value pairs on standard input)\n";
424ec8fa 2801 chomp(@lines = <STDIN>); # remove newlines
54310121 2802 $input = join(" ",@lines);
424ec8fa
GS
2803 @words = &shellwords($input);
2804 }
2805 foreach (@words) {
2806 s/\\=/%3D/g;
2807 s/\\&/%26/g;
54310121
PP
2808 }
2809
54310121
PP
2810 if ("@words"=~/=/) {
2811 $query_string = join('&',@words);
2812 } else {
2813 $query_string = join('+',@words);
2814 }
2815 return $query_string;
2816}
2817END_OF_FUNC
2818
2819#####
2820# subroutine: read_multipart
2821#
2822# Read multipart data and store it into our parameters.
2823# An interesting feature is that if any of the parts is a file, we
2824# create a temporary file and open up a filehandle on it so that the
2825# caller can read from it if necessary.
2826#####
2827'read_multipart' => <<'END_OF_FUNC',
2828sub read_multipart {
424ec8fa
GS
2829 my($self,$boundary,$length,$filehandle) = @_;
2830 my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle);
54310121
PP
2831 return unless $buffer;
2832 my(%header,$body);
424ec8fa 2833 my $filenumber = 0;
54310121
PP
2834 while (!$buffer->eof) {
2835 %header = $buffer->readHeader;
3538e1d5
GS
2836
2837 unless (%header) {
2838 $self->cgi_error("400 Bad request (malformed multipart POST)");
2839 return;
2840 }
54310121 2841
424ec8fa 2842 my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
54310121 2843
424ec8fa 2844 # Bug: Netscape doesn't escape quotation marks in file names!!!
6b4ac661 2845 my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\"]*)"?/;
54310121
PP
2846
2847 # add this parameter to our list
2848 $self->add_parameter($param);
2849
2850 # If no filename specified, then just read the data and assign it
2851 # to our parameter list.
ffd2dff2 2852 if ( !defined($filename) || $filename eq '' ) {
54310121
PP
2853 my($value) = $buffer->readBody;
2854 push(@{$self->{$param}},$value);
2855 next;
2856 }
2857
424ec8fa
GS
2858 my ($tmpfile,$tmp,$filehandle);
2859 UPLOADS: {
2860 # If we get here, then we are dealing with a potentially large
2861 # uploaded form. Save the data to a temporary file, then open
2862 # the file for reading.
54310121 2863
424ec8fa
GS
2864 # skip the file if uploads disabled
2865 if ($DISABLE_UPLOADS) {
2866 while (defined($data = $buffer->read)) { }
2867 last UPLOADS;
2868 }
7d37aa8e 2869
3538e1d5
GS
2870 # choose a relatively unpredictable tmpfile sequence number
2871 my $seqno = unpack("%16C*",join('',localtime,values %ENV));
2872 for (my $cnt=10;$cnt>0;$cnt--) {
2873 next unless $tmpfile = new TempFile($seqno);
2874 $tmp = $tmpfile->as_string;
ffd2dff2 2875 last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
3538e1d5
GS
2876 $seqno += int rand(100);
2877 }
2878 die "CGI open of tmpfile: $!\n" unless $filehandle;
424ec8fa 2879 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
424ec8fa
GS
2880
2881 my ($data);
71f3e297 2882 local($\) = '';
424ec8fa
GS
2883 while (defined($data = $buffer->read)) {
2884 print $filehandle $data;
2885 }
2886
2887 # back up to beginning of file
2888 seek($filehandle,0,0);
2889 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2890
2891 # Save some information about the uploaded file where we can get
2892 # at it later.
ffd2dff2 2893 $self->{'.tmpfiles'}->{fileno($filehandle)}= {
424ec8fa
GS
2894 name => $tmpfile,
2895 info => {%header},
2896 };
2897 push(@{$self->{$param}},$filehandle);
2898 }
54310121
PP
2899 }
2900}
2901END_OF_FUNC
2902
3538e1d5
GS
2903'upload' =><<'END_OF_FUNC',
2904sub upload {
2905 my($self,$param_name) = self_or_default(@_);
2906 my $param = $self->param($param_name);
2907 return unless $param;
2908 return unless ref($param) && fileno($param);
2909 return $param;
2910}
2911END_OF_FUNC
2912
54310121
PP
2913'tmpFileName' => <<'END_OF_FUNC',
2914sub tmpFileName {
2915 my($self,$filename) = self_or_default(@_);
ffd2dff2
GS
2916 return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ?
2917 $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string
7d37aa8e 2918 : '';
54310121
PP
2919}
2920END_OF_FUNC
2921
424ec8fa 2922'uploadInfo' => <<'END_OF_FUNC',
54310121
PP
2923sub uploadInfo {
2924 my($self,$filename) = self_or_default(@_);
ffd2dff2 2925 return $self->{'.tmpfiles'}->{fileno($filename)}->{info};
54310121
PP
2926}
2927END_OF_FUNC
2928
424ec8fa
GS
2929# internal routine, don't use
2930'_set_values_and_labels' => <<'END_OF_FUNC',
2931sub _set_values_and_labels {
2932 my $self = shift;
2933 my ($v,$l,$n) = @_;
2934 $$l = $v if ref($v) eq 'HASH' && !ref($$l);
2935 return $self->param($n) if !defined($v);
2936 return $v if !ref($v);
2937 return ref($v) eq 'HASH' ? keys %$v : @$v;
2938}
2939END_OF_FUNC
2940
2941'_compile_all' => <<'END_OF_FUNC',
2942sub _compile_all {
2943 foreach (@_) {
2944 next if defined(&$_);
2945 $AUTOLOAD = "CGI::$_";
2946 _compile();
2947 }
2948}
2949END_OF_FUNC
2950
54310121
PP
2951);
2952END_OF_AUTOLOAD
2953;
2954
424ec8fa
GS
2955#########################################################
2956# Globals and stubs for other packages that we use.
2957#########################################################
2958
2959################### Fh -- lightweight filehandle ###############
2960package Fh;
2961use overload
2962 '""' => \&asString,
2963 'cmp' => \&compare,
2964 'fallback'=>1;
2965
2966$FH='fh00000';
2967
2968*Fh::AUTOLOAD = \&CGI::AUTOLOAD;
2969
2970$AUTOLOADED_ROUTINES = ''; # prevent -w error
2971$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
2972%SUBS = (
2973'asString' => <<'END_OF_FUNC',
2974sub asString {
2975 my $self = shift;
71f3e297 2976 # get rid of package name
ffd2dff2 2977 (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
424ec8fa
GS
2978 $i =~ s/\\(.)/$1/g;
2979 return $i;
71f3e297
JH
2980# BEGIN DEAD CODE
2981# This was an extremely clever patch that allowed "use strict refs".
2982# Unfortunately it relied on another bug that caused leaky file descriptors.
2983# The underlying bug has been fixed, so this no longer works. However
2984# "strict refs" still works for some reason.
2985# my $self = shift;
2986# return ${*{$self}{SCALAR}};
2987# END DEAD CODE
424ec8fa
GS
2988}
2989END_OF_FUNC
2990
2991'compare' => <<'END_OF_FUNC',
2992sub compare {
2993 my $self = shift;
2994 my $value = shift;
2995 return "$self" cmp $value;
2996}
2997END_OF_FUNC
2998
2999'new' => <<'END_OF_FUNC',
3000sub new {
3001 my($pack,$name,$file,$delete) = @_;
3002 require Fcntl unless defined &Fcntl::O_RDWR;
6b4ac661 3003 my $fv = ++$FH . quotemeta($name);
6b4ac661 3004 my $ref = \*{"Fh::$fv"};
3538e1d5 3005 sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
424ec8fa 3006 unlink($file) if $delete;
6b4ac661 3007 CORE::delete $Fh::{$fv};
71f3e297 3008 return bless $ref,$pack;
424ec8fa
GS
3009}
3010END_OF_FUNC
3011
3012'DESTROY' => <<'END_OF_FUNC',
3013sub DESTROY {
3014 my $self = shift;
3015 close $self;
3016}
3017END_OF_FUNC
3018
3019);
3020END_OF_AUTOLOAD
3021
3022######################## MultipartBuffer ####################
54310121
PP
3023package MultipartBuffer;
3024
3025# how many bytes to read at a time. We use
71f3e297
JH
3026# a 4K buffer by default.
3027$INITIAL_FILLUNIT = 1024 * 4;
3028$TIMEOUT = 240*60; # 4 hour timeout for big files
3029$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
54310121
PP
3030$CRLF=$CGI::CRLF;
3031
3032#reuse the autoload function
3033*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
3034
424ec8fa
GS
3035# avoid autoloader warnings
3036sub DESTROY {}
3037
54310121
PP
3038###############################################################################
3039################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3040###############################################################################
3041$AUTOLOADED_ROUTINES = ''; # prevent -w error
3042$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3043%SUBS = (
3044
3045'new' => <<'END_OF_FUNC',
3046sub new {
3047 my($package,$interface,$boundary,$length,$filehandle) = @_;
424ec8fa 3048 $FILLUNIT = $INITIAL_FILLUNIT;
54310121
PP
3049 my $IN;
3050 if ($filehandle) {
3051 my($package) = caller;
3052 # force into caller's package if necessary
3053 $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
3054 }
3055 $IN = "main::STDIN" unless $IN;
3056
3057 $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
3058
3059 # If the user types garbage into the file upload field,
3060 # then Netscape passes NOTHING to the server (not good).
3061 # We may hang on this read in that case. So we implement
3062 # a read timeout. If nothing is ready to read
3063 # by then, we return.
3064
3065 # Netscape seems to be a little bit unreliable
3066 # about providing boundary strings.
3d1a2ec4 3067 my $boundary_read = 0;
54310121
PP
3068 if ($boundary) {
3069
3070 # Under the MIME spec, the boundary consists of the
3071 # characters "--" PLUS the Boundary string
424ec8fa
GS
3072
3073 # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
71f3e297 3074 # the two extra hyphens. We do a special case here on the user-agent!!!!
3538e1d5 3075 $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac');
424ec8fa 3076
54310121
PP
3077 } else { # otherwise we find it ourselves
3078 my($old);
3079 ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
3080 $boundary = <$IN>; # BUG: This won't work correctly under mod_perl
3081 $length -= length($boundary);
3082 chomp($boundary); # remove the CRLF
3083 $/ = $old; # restore old line separator
3d1a2ec4 3084 $boundary_read++;
54310121
PP
3085 }
3086
3087 my $self = {LENGTH=>$length,
3088 BOUNDARY=>$boundary,
3089 IN=>$IN,
3090 INTERFACE=>$interface,
3091 BUFFER=>'',
3092 };
3093
3094 $FILLUNIT = length($boundary)
3095 if length($boundary) > $FILLUNIT;
3096
424ec8fa
GS
3097 my $retval = bless $self,ref $package || $package;
3098
3099 # Read the preamble and the topmost (boundary) line plus the CRLF.
3d1a2ec4
GS
3100 unless ($boundary_read) {
3101 while ($self->read(0)) { }
3102 }
424ec8fa
GS
3103 die "Malformed multipart POST\n" if $self->eof;
3104
3105 return $retval;
54310121
PP
3106}
3107END_OF_FUNC
3108
3109'readHeader' => <<'END_OF_FUNC',
3110sub readHeader {
3111 my($self) = @_;
3112 my($end);
3113 my($ok) = 0;
47e3cabd 3114 my($bad) = 0;
424ec8fa 3115
3d1a2ec4 3116 local($CRLF) = "\015\012" if $CGI::OS eq 'VMS';
424ec8fa 3117
54310121
PP
3118 do {
3119 $self->fillBuffer($FILLUNIT);
3120 $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
3121 $ok++ if $self->{BUFFER} eq '';
47e3cabd 3122 $bad++ if !$ok && $self->{LENGTH} <= 0;
424ec8fa
GS
3123 # this was a bad idea
3124 # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
47e3cabd
LS
3125 } until $ok || $bad;
3126 return () if $bad;
54310121
PP
3127
3128 my($header) = substr($self->{BUFFER},0,$end+2);
3129 substr($self->{BUFFER},0,$end+4) = '';
3130 my %return;
424ec8fa
GS
3131
3132
3133 # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
3134 # (Folding Long Header Fields), 3.4.3 (Comments)
3135 # and 3.4.5 (Quoted-Strings).
3136
3137 my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
3138 $header=~s/$CRLF\s+/ /og; # merge continuation lines
3139 while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
3140 my ($field_name,$field_value) = ($1,$2); # avoid taintedness
3141 $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
3142 $return{$field_name}=$field_value;
54310121
PP
3143 }
3144 return %return;
3145}
3146END_OF_FUNC
3147
3148# This reads and returns the body as a single scalar value.
3149'readBody' => <<'END_OF_FUNC',
3150sub readBody {
3151 my($self) = @_;
3152 my($data);
3153 my($returnval)='';
3154 while (defined($data = $self->read)) {
3155 $returnval .= $data;
3156 }
3157 return $returnval;
3158}
3159END_OF_FUNC
3160
3161# This will read $bytes or until the boundary is hit, whichever happens
3162# first. After the boundary is hit, we return undef. The next read will
3163# skip over the boundary and begin reading again;
3164'read' => <<'END_OF_FUNC',
3165sub read {
3166 my($self,$bytes) = @_;
3167
3168 # default number of bytes to read
3169 $bytes = $bytes || $FILLUNIT;
3170
3171 # Fill up our internal buffer in such a way that the boundary
3172 # is never split between reads.
3173 $self->fillBuffer($bytes);
3174
3175 # Find the boundary in the buffer (it may not be there).
3176 my $start = index($self->{BUFFER},$self->{BOUNDARY});
47e3cabd
LS
3177 # protect against malformed multipart POST operations
3178 die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
54310121
PP
3179
3180 # If the boundary begins the data, then skip past it
03b9648d 3181 # and return undef.
54310121
PP
3182 if ($start == 0) {
3183
3184 # clear us out completely if we've hit the last boundary.
3185 if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
3186 $self->{BUFFER}='';
3187 $self->{LENGTH}=0;
3188 return undef;
3189 }
3190
3191 # just remove the boundary.
03b9648d
JH
3192 substr($self->{BUFFER},0,length($self->{BOUNDARY}))='';
3193 $self->{BUFFER} =~ s/^\012\015?//;
54310121
PP
3194 return undef;
3195 }
3196
3197 my $bytesToReturn;
3198 if ($start > 0) { # read up to the boundary
3199 $bytesToReturn = $start > $bytes ? $bytes : $start;
3200 } else { # read the requested number of bytes
3201 # leave enough bytes in the buffer to allow us to read
3202 # the boundary. Thanks to Kevin Hendrick for finding
3203 # this one.
3204 $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
3205 }
3206
3207 my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
3208 substr($self->{BUFFER},0,$bytesToReturn)='';
3209
3210 # If we hit the boundary, remove the CRLF from the end.
3211 return ($start > 0) ? substr($returnval,0,-2) : $returnval;
3212}
3213END_OF_FUNC
3214
3215
3216# This fills up our internal buffer in such a way that the
3217# boundary is never split between reads
3218'fillBuffer' => <<'END_OF_FUNC',
3219sub fillBuffer {
3220 my($self,$bytes) = @_;
3221 return unless $self->{LENGTH};
3222
3223 my($boundaryLength) = length($self->{BOUNDARY});
3224 my($bufferLength) = length($self->{BUFFER});
3225 my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
3226 $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
3227
3228 # Try to read some data. We may hang here if the browser is screwed up.
3229 my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN},
3230 \$self->{BUFFER},
3231 $bytesToRead,
3232 $bufferLength);
71f3e297 3233 $self->{BUFFER} = '' unless defined $self->{BUFFER};
54310121 3234
47e3cabd 3235 # An apparent bug in the Apache server causes the read()
54310121
PP
3236 # to return zero bytes repeatedly without blocking if the
3237 # remote user aborts during a file transfer. I don't know how
3238 # they manage this, but the workaround is to abort if we get
3239 # more than SPIN_LOOP_MAX consecutive zero reads.
3240 if ($bytesRead == 0) {
3241 die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
3242 if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
3243 } else {
3244 $self->{ZERO_LOOP_COUNTER}=0;
3245 }
3246
3247 $self->{LENGTH} -= $bytesRead;
3248}
3249END_OF_FUNC
3250
3251
3252# Return true when we've finished reading
3253'eof' => <<'END_OF_FUNC'
3254sub eof {
3255 my($self) = @_;
3256 return 1 if (length($self->{BUFFER}) == 0)
3257 && ($self->{LENGTH} <= 0);
3258 undef;
3259}
3260END_OF_FUNC
3261
3262);
3263END_OF_AUTOLOAD
3264
3265####################################################################################
3266################################## TEMPORARY FILES #################################
3267####################################################################################
3268package TempFile;
3269
3270$SL = $CGI::SL;
424ec8fa
GS
3271$MAC = $CGI::OS eq 'MACINTOSH';
3272my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
54310121 3273unless ($TMPDIRECTORY) {
424ec8fa 3274 @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
3538e1d5 3275 "C:${SL}temp","${SL}tmp","${SL}temp",
3d1a2ec4 3276 "${vol}${SL}Temporary Items",
fa6a1c44 3277 "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH", "C:${SL}system${SL}temp");
3538e1d5
GS
3278 unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'};
3279
3d1a2ec4
GS
3280 # this feature was supposed to provide per-user tmpfiles, but
3281 # it is problematic.
3538e1d5
GS
3282 # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
3283 # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
3284 # : can generate a 'getpwuid() not implemented' exception, even though
3285 # : it's never called. Found under DOS/Win with the DJGPP perl port.
3286 # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
3d1a2ec4 3287 # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
3538e1d5 3288
54310121
PP
3289 foreach (@TEMP) {
3290 do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
3291 }
3292}
3293
424ec8fa 3294$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
424ec8fa 3295$MAXTRIES = 5000;
54310121
PP
3296
3297# cute feature, but overload implementation broke it
3298# %OVERLOAD = ('""'=>'as_string');
3299*TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
3300
3301###############################################################################
3302################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
3303###############################################################################
3304$AUTOLOADED_ROUTINES = ''; # prevent -w error
3305$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
3306%SUBS = (
3307
3308'new' => <<'END_OF_FUNC',
3309sub new {
3538e1d5
GS
3310 my($package,$sequence) = @_;
3311 my $filename;
3312 for (my $i = 0; $i < $MAXTRIES; $i++) {
3313 last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
424ec8fa 3314 }
3538e1d5 3315 # untaint the darn thing
3d1a2ec4 3316 return unless $filename =~ m!^([a-zA-Z0-9_ '":/.\$\\]+)$!;
3538e1d5
GS
3317 $filename = $1;
3318 return bless \$filename;
54310121
PP
3319}
3320END_OF_FUNC
3321
3322'DESTROY' => <<'END_OF_FUNC',
3323sub DESTROY {
3324 my($self) = @_;
3325 unlink $$self; # get rid of the file
3326}
3327END_OF_FUNC
3328
3329'as_string' => <<'END_OF_FUNC'
3330sub as_string {
3331 my($self) = @_;
3332 return $$self;
3333}
3334END_OF_FUNC
3335
3336);
3337END_OF_AUTOLOAD
3338
3339package CGI;
3340
3341# We get a whole bunch of warnings about "possibly uninitialized variables"
3342# when running with the -w switch. Touch them all once to get rid of the
3343# warnings. This is ugly and I hate it.
3344if ($^W) {
3345 $CGI::CGI = '';
3346 $CGI::CGI=<<EOF;
3347 $CGI::VERSION;
3348 $MultipartBuffer::SPIN_LOOP_MAX;
3349 $MultipartBuffer::CRLF;
3350 $MultipartBuffer::TIMEOUT;
424ec8fa 3351 $MultipartBuffer::INITIAL_FILLUNIT;
54310121
PP
3352EOF
3353 ;
3354}
3355
424ec8fa 33561;
54310121
PP
3357
3358__END__
3359
3360=head1 NAME
3361
3362CGI - Simple Common Gateway Interface Class
3363
dc848c6f
PP
3364=head1 SYNOPSIS
3365
424ec8fa
GS
3366 # CGI script that creates a fill-out form
3367 # and echoes back its values.
3368
3369 use CGI qw/:standard/;
3370 print header,
3371 start_html('A Simple Example'),
3372 h1('A Simple Example'),
3373 start_form,
3374 "What's your name? ",textfield('name'),p,
3375 "What's the combination?", p,
3376 checkbox_group(-name=>'words',
3377 -values=>['eenie','meenie','minie','moe'],
3378 -defaults=>['eenie','minie']), p,
3379 "What's your favorite color? ",
3380 popup_menu(-name=>'color',
3381 -values=>['red','green','blue','chartreuse']),p,
3382 submit,
3383 end_form,
3384 hr;
3385
3386 if (param()) {
3387 print "Your name is",em(param('name')),p,
3388 "The keywords are: ",em(join(", ",param('words'))),p,
3389 "Your favorite color is ",em(param('color')),
3390 hr;
3391 }
dc848c6f 3392
54310121
PP
3393=head1 ABSTRACT
3394
424ec8fa
GS
3395This perl library uses perl5 objects to make it easy to create Web
3396fill-out forms and parse their contents. This package defines CGI
3397objects, entities that contain the values of the current query string
3398and other state variables. Using a CGI object's methods, you can
3399examine keywords and parameters passed to your script, and create
3400forms whose initial values are taken from the current query (thereby
3401preserving state information). The module provides shortcut functions
3402that produce boilerplate HTML, reducing typing and coding errors. It
3403also provides functionality for some of the more advanced features of
3404CGI scripting, including support for file uploads, cookies, cascading
3405style sheets, server push, and frames.
3406
3407CGI.pm also provides a simple function-oriented programming style for
3408those who don't need its object-oriented features.
54310121
PP
3409
3410The current version of CGI.pm is available at
3411
3412 http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
3413 ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
3414
424ec8fa 3415=head1 DESCRIPTION
47e3cabd 3416
424ec8fa
GS
3417=head2 PROGRAMMING STYLE
3418
3419There are two styles of programming with CGI.pm, an object-oriented
3420style and a function-oriented style. In the object-oriented style you
3421create one or more CGI objects and then use object methods to create
3422the various elements of the page. Each CGI object starts out with the
3423list of named parameters that were passed to your CGI script by the
3424server. You can modify the objects, save them to a file or database
3425and recreate them. Because each object corresponds to the "state" of
3426the CGI script, and because each object's parameter list is
3427independent of the others, this allows you to save the state of the
3428script and restore it later.
3429
f610777f 3430For example, using the object oriented style, here is how you create
424ec8fa
GS
3431a simple "Hello World" HTML page:
3432
3538e1d5 3433 #!/usr/local/bin/perl -w
424ec8fa
GS
3434 use CGI; # load CGI routines
3435 $q = new CGI; # create new CGI object
3436 print $q->header, # create the HTTP header
3437 $q->start_html('hello world'), # start the HTML
3438 $q->h1('hello world'), # level 1 header
3439 $q->end_html; # end the HTML
3440
3441In the function-oriented style, there is one default CGI object that
3442you rarely deal with directly. Instead you just call functions to
3443retrieve CGI parameters, create HTML tags, manage cookies, and so
3444on. This provides you with a cleaner programming interface, but
3445limits you to using one CGI object at a time. The following example
3446prints the same page, but uses the function-oriented interface.
3447The main differences are that we now need to import a set of functions
3448into our name space (usually the "standard" functions), and we don't
3449need to create the CGI object.
3450
71f3e297 3451 #!/usr/local/bin/perl
424ec8fa
GS
3452 use CGI qw/:standard/; # load standard CGI routines
3453 print header, # create the HTTP header
3454 start_html('hello world'), # start the HTML
3455 h1('hello world'), # level 1 header
3456 end_html; # end the HTML
3457
3458The examples in this document mainly use the object-oriented style.
3459See HOW TO IMPORT FUNCTIONS for important information on
3460function-oriented programming in CGI.pm
3461
3462=head2 CALLING CGI.PM ROUTINES
3463
3464Most CGI.pm routines accept several arguments, sometimes as many as 20
3465optional ones! To simplify this interface, all routines use a named
3466argument calling style that looks like this:
3467
3468 print $q->header(-type=>'image/gif',-expires=>'+3d');
3469
3470Each argument name is preceded by a dash. Neither case nor order
3471matters in the argument list. -type, -Type, and -TYPE are all
3472acceptable. In fact, only the first argument needs to begin with a
3473dash. If a dash is present in the first argument, CGI.pm assumes
3474dashes for the subsequent ones.
3475
424ec8fa
GS
3476Several routines are commonly called with just one argument. In the
3477case of these routines you can provide the single argument without an
3478argument name. header() happens to be one of these routines. In this
3479case, the single argument is the document type.
3480
3481 print $q->header('text/html');
3482
3483Other such routines are documented below.
3484
3485Sometimes named arguments expect a scalar, sometimes a reference to an
3486array, and sometimes a reference to a hash. Often, you can pass any
3487type of argument and the routine will do whatever is most appropriate.
3488For example, the param() routine is used to set a CGI parameter to a
3489single or a multi-valued value. The two cases are shown below:
3490
3491 $q->param(-name=>'veggie',-value=>'tomato');
3d1a2ec4 3492 $q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']);
424ec8fa
GS
3493
3494A large number of routines in CGI.pm actually aren't specifically
3495defined in the module, but are generated automatically as needed.
3496These are the "HTML shortcuts," routines that generate HTML tags for
3497use in dynamically-generated pages. HTML tags have both attributes
3498(the attribute="value" pairs within the tag itself) and contents (the
3499part between the opening and closing pairs.) To distinguish between
3500attributes and contents, CGI.pm uses the convention of passing HTML
3501attributes as a hash reference as the first argument, and the
3502contents, if any, as any subsequent arguments. It works out like
3503this:
3504
3505 Code Generated HTML
3506 ---- --------------
3507 h1() <H1>
3508 h1('some','contents'); <H1>some contents</H1>
3509 h1({-align=>left}); <H1 ALIGN="LEFT">
3510 h1({-align=>left},'contents'); <H1 ALIGN="LEFT">contents</H1>
3511
3512HTML tags are described in more detail later.
3513
3514Many newcomers to CGI.pm are puzzled by the difference between the
3515calling conventions for the HTML shortcuts, which require curly braces
3516around the HTML tag attributes, and the calling conventions for other
3517routines, which manage to generate attributes without the curly
3518brackets. Don't be confused. As a convenience the curly braces are
3519optional in all but the HTML shortcuts. If you like, you can use
3520curly braces when calling any routine that takes named arguments. For
3521example:
3522
3523 print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
3524
3525If you use the B<-w> switch, you will be warned that some CGI.pm argument
3526names conflict with built-in Perl functions. The most frequent of
3527these is the -values argument, used to create multi-valued menus,
3528radio button clusters and the like. To get around this warning, you
3529have several choices:
54310121 3530
424ec8fa 3531=over 4
54310121 3532
424ec8fa
GS
3533=item 1. Use another name for the argument, if one is available. For
3534example, -value is an alias for -values.
54310121 3535
424ec8fa 3536=item 2. Change the capitalization, e.g. -Values
54310121 3537
424ec8fa 3538=item 3. Put quotes around the argument name, e.g. '-values'
54310121 3539
424ec8fa 3540=back
54310121 3541
424ec8fa
GS
3542Many routines will do something useful with a named argument that it
3543doesn't recognize. For example, you can produce non-standard HTTP
3544header fields by providing them as named arguments:
54310121 3545
424ec8fa
GS
3546 print $q->header(-type => 'text/html',
3547 -cost => 'Three smackers',
3548 -annoyance_level => 'high',
3549 -complaints_to => 'bit bucket');
54310121 3550
424ec8fa
GS
3551This will produce the following nonstandard HTTP header:
3552
3553 HTTP/1.0 200 OK
3554 Cost: Three smackers
3555 Annoyance-level: high
3556 Complaints-to: bit bucket
3557 Content-type: text/html
3558
3559Notice the way that underscores are translated automatically into
3560hyphens. HTML-generating routines perform a different type of
3561translation.
3562
3563This feature allows you to keep up with the rapidly changing HTTP and
3564HTML "standards".
54310121 3565
424ec8fa 3566=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
54310121
PP
3567
3568 $query = new CGI;
3569
3570This will parse the input (from both POST and GET methods) and store
3571it into a perl5 object called $query.
3572
3573=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
3574
3575 $query = new CGI(INPUTFILE);
3576
424ec8fa
GS
3577If you provide a file handle to the new() method, it will read
3578parameters from the file (or STDIN, or whatever). The file can be in
3579any of the forms describing below under debugging (i.e. a series of
3580newline delimited TAG=VALUE pairs will work). Conveniently, this type
3581of file is created by the save() method (see below). Multiple records
3582can be saved and restored.
54310121
PP
3583
3584Perl purists will be pleased to know that this syntax accepts
3585references to file handles, or even references to filehandle globs,
3586which is the "official" way to pass a filehandle:
3587
3588 $query = new CGI(\*STDIN);
3589
424ec8fa
GS
3590You can also initialize the CGI object with a FileHandle or IO::File
3591object.
3592
3593If you are using the function-oriented interface and want to
3594initialize CGI state from a file handle, the way to do this is with
3595B<restore_parameters()>. This will (re)initialize the
3596default CGI object from the indicated file handle.
3597
3598 open (IN,"test.in") || die;
3599 restore_parameters(IN);
3600 close IN;
3601
54310121
PP
3602You can also initialize the query object from an associative array
3603reference:
3604
3605 $query = new CGI( {'dinosaur'=>'barney',
3606 'song'=>'I love you',
3607 'friends'=>[qw/Jessica George Nancy/]}
3608 );
3609
3610or from a properly formatted, URL-escaped query string:
3611
3612 $query = new CGI('dinosaur=barney&color=purple');
3613
424ec8fa
GS
3614or from a previously existing CGI object (currently this clones the
3615parameter list, but none of the other object-specific fields, such as
3616autoescaping):
3617
3618 $old_query = new CGI;
3619 $new_query = new CGI($old_query);
3620
54310121
PP
3621To create an empty query, initialize it from an empty string or hash:
3622
424ec8fa
GS
3623 $empty_query = new CGI("");
3624
3625 -or-
3626
3627 $empty_query = new CGI({});
54310121
PP
3628
3629=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
3630
3631 @keywords = $query->keywords
3632
3633If the script was invoked as the result of an <ISINDEX> search, the
3634parsed keywords can be obtained as an array using the keywords() method.
3635
3636=head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
3637
3638 @names = $query->param
3639
3640If the script was invoked with a parameter list
3d1a2ec4
GS
3641(e.g. "name1=value1&name2=value2&name3=value3"), the param() method
3642will return the parameter names as a list. If the script was invoked
3643as an <ISINDEX> script and contains a string without ampersands
3644(e.g. "value1+value2+value3") , there will be a single parameter named
3645"keywords" containing the "+"-delimited keywords.
54310121
PP
3646
3647NOTE: As of version 1.5, the array of parameter names returned will
3648be in the same order as they were submitted by the browser.
3649Usually this order is the same as the order in which the
3650parameters are defined in the form (however, this isn't part
3651of the spec, and so isn't guaranteed).
3652
3653=head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
3654
3655 @values = $query->param('foo');
3656
3657 -or-
3658
3659 $value = $query->param('foo');
3660
3661Pass the param() method a single argument to fetch the value of the
3662named parameter. If the parameter is multivalued (e.g. from multiple
3663selections in a scrolling list), you can ask to receive an array. Otherwise
3664the method will return a single value.
3665
3d1a2ec4
GS
3666If a value is not given in the query string, as in the queries
3667"name1=&name2=" or "name1&name2", it will be returned as an empty
3668string. This feature is new in 2.63.
3669
54310121
PP
3670=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
3671
3672 $query->param('foo','an','array','of','values');
3673
3674This sets the value for the named parameter 'foo' to an array of
3675values. This is one way to change the value of a field AFTER
3676the script has been invoked once before. (Another way is with
3677the -override parameter accepted by all methods that generate
3678form elements.)
3679
3680param() also recognizes a named parameter style of calling described
3681in more detail later:
3682
3683 $query->param(-name=>'foo',-values=>['an','array','of','values']);
3684
3685 -or-
3686
3687 $query->param(-name=>'foo',-value=>'the value');
3688
3689=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
3690
424ec8fa 3691 $query->append(-name=>'foo',-values=>['yet','more','values']);
54310121
PP
3692
3693This adds a value or list of values to the named parameter. The
3694values are appended to the end of the parameter if it already exists.
3695Otherwise the parameter is created. Note that this method only
3696recognizes the named argument calling syntax.
3697
3698=head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
3699
3700 $query->import_names('R');
3701
3702This creates a series of variables in the 'R' namespace. For example,
3703$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
3704If no namespace is given, this method will assume 'Q'.
3705WARNING: don't import anything into 'main'; this is a major security
3706risk!!!!
3707
3708In older versions, this method was called B<import()>. As of version 2.20,
3709this name has been removed completely to avoid conflict with the built-in
3710Perl module B<import> operator.
3711
3712=head2 DELETING A PARAMETER COMPLETELY:
3713
3714 $query->delete('foo');
3715
3716This completely clears a parameter. It sometimes useful for
3717resetting parameters that you don't want passed down between
3718script invocations.
3719
424ec8fa
GS
3720If you are using the function call interface, use "Delete()" instead
3721to avoid conflicts with Perl's built-in delete operator.
3722
54310121
PP
3723=head2 DELETING ALL PARAMETERS:
3724
424ec8fa 3725 $query->delete_all();
54310121
PP
3726
3727This clears the CGI object completely. It might be useful to ensure
3728that all the defaults are taken when you create a fill-out form.
3729
424ec8fa
GS
3730Use Delete_all() instead if you are using the function call interface.
3731
3732=head2 DIRECT ACCESS TO THE PARAMETER LIST:
3733
3734 $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
3735 unshift @{$q->param_fetch(-name=>'address')},'George Munster';
3736
3737If you need access to the parameter list in a way that isn't covered
3738by the methods above, you can obtain a direct reference to it by
3739calling the B<param_fetch()> method with the name of the . This
3740will return an array reference to the named parameters, which you then
3741can manipulate in any way you like.
3742
3743You can also use a named argument style using the B<-name> argument.
3744
3538e1d5
GS
3745=head2 FETCHING THE PARAMETER LIST AS A HASH:
3746
3747 $params = $q->Vars;
3748 print $params->{'address'};
3749 @foo = split("\0",$params->{'foo'});
3750 %params = $q->Vars;
3751
3752 use CGI ':cgi-lib';
3753 $params = Vars;
3754
3755Many people want to fetch the entire parameter list as a hash in which
3756the keys are the names of the CGI parameters, and the values are the
3757parameters' values. The Vars() method does this. Called in a scalar
3758context, it returns the parameter list as a tied hash reference.
3759Changing a key changes the value of the parameter in the underlying
a3b3a725 3760CGI parameter list. Called in a list context, it returns the
3538e1d5
GS
3761parameter list as an ordinary hash. This allows you to read the
3762contents of the parameter list, but not to change it.
3763
3764When using this, the thing you must watch out for are multivalued CGI
3765parameters. Because a hash cannot distinguish between scalar and
a3b3a725 3766list context, multivalued parameters will be returned as a packed
3538e1d5
GS
3767string, separated by the "\0" (null) character. You must split this
3768packed string in order to get at the individual values. This is the
3769convention introduced long ago by Steve Brenner in his cgi-lib.pl
3770module for Perl version 4.
3771
3772If you wish to use Vars() as a function, import the I<:cgi-lib> set of
3773function calls (also see the section on CGI-LIB compatibility).
3774
424ec8fa 3775=head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
54310121
PP
3776
3777 $query->save(FILEHANDLE)
3778
3779This will write the current state of the form to the provided
3780filehandle. You can read it back in by providing a filehandle
3781to the new() method. Note that the filehandle can be a file, a pipe,
3782or whatever!
3783
3784The format of the saved file is:
3785
3786 NAME1=VALUE1
3787 NAME1=VALUE1'
3788 NAME2=VALUE2
3789 NAME3=VALUE3
3790 =
3791
3792Both name and value are URL escaped. Multi-valued CGI parameters are
3793represented as repeated names. A session record is delimited by a
3794single = symbol. You can write out multiple records and read them
3795back in with several calls to B<new>. You can do this across several
3796sessions by opening the file in append mode, allowing you to create
3797primitive guest books, or to keep a history of users' queries. Here's
3798a short example of creating multiple session records:
3799
3800 use CGI;
3801
3802 open (OUT,">>test.out") || die;
3803 $records = 5;
3804 foreach (0..$records) {
3805 my $q = new CGI;
3806 $q->param(-name=>'counter',-value=>$_);
3807 $q->save(OUT);
3808 }
3809 close OUT;
3810
3811 # reopen for reading
3812 open (IN,"test.out") || die;
3813 while (!eof(IN)) {
3814 my $q = new CGI(IN);
3815 print $q->param('counter'),"\n";
3816 }
3817
3818The file format used for save/restore is identical to that used by the
3819Whitehead Genome Center's data exchange format "Boulderio", and can be
3820manipulated and even databased using Boulderio utilities. See
3cb6de81 3821
3538e1d5 3822 http://stein.cshl.org/boulder/
54310121
PP
3823
3824for further details.
3825
424ec8fa
GS
3826If you wish to use this method from the function-oriented (non-OO)
3827interface, the exported name for this method is B<save_parameters()>.
54310121 3828
3538e1d5
GS
3829=head2 RETRIEVING CGI ERRORS
3830
3831Errors can occur while processing user input, particularly when
3832processing uploaded files. When these errors occur, CGI will stop
3833processing and return an empty parameter list. You can test for
3834the existence and nature of errors using the I<cgi_error()> function.
3835The error messages are formatted as HTTP status codes. You can either
3836incorporate the error text into an HTML page, or use it as the value
3837of the HTTP status:
3838
3839 my $error = $q->cgi_error;
3840 if ($error) {
3841 print $q->header(-status=>$error),
3842 $q->start_html('Problems'),
3843 $q->h2('Request not processed'),
3844 $q->strong($error);
3845 exit 0;
3846 }
3847
3848When using the function-oriented interface (see the next section),
3849errors may only occur the first time you call I<param()>. Be ready
3850for this!
3851
424ec8fa 3852=head2 USING THE FUNCTION-ORIENTED INTERFACE
54310121 3853
424ec8fa
GS
3854To use the function-oriented interface, you must specify which CGI.pm
3855routines or sets of routines to import into your script's namespace.
3856There is a small overhead associated with this importation, but it
3857isn't much.
54310121 3858
424ec8fa 3859 use CGI <list of methods>;
54310121 3860
424ec8fa
GS
3861The listed methods will be imported into the current package; you can
3862call them directly without creating a CGI object first. This example
3863shows how to import the B<param()> and B<header()>
3864methods, and then use them directly:
54310121 3865
424ec8fa
GS
3866 use CGI 'param','header';
3867 print header('text/plain');
3868 $zipcode = param('zipcode');
54310121 3869
424ec8fa 3870More frequently, you'll import common sets of functions by referring
f610777f 3871to the groups by name. All function sets are preceded with a ":"
424ec8fa 3872character as in ":html3" (for tags defined in the HTML 3 standard).
54310121 3873
424ec8fa 3874Here is a list of the function sets you can import:
54310121 3875
424ec8fa 3876=over 4
54310121 3877
424ec8fa 3878=item B<:cgi>
54310121 3879
424ec8fa
GS
3880Import all CGI-handling methods, such as B<param()>, B<path_info()>
3881and the like.
54310121 3882