source: for-distributions/trunk/bin/windows/perl/lib/CGI.pm@ 14489

Last change on this file since 14489 was 14489, checked in by oranfry, 17 years ago

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