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