Commit | Line | Data |
---|---|---|
54310121 | 1 | package CGI; |
424ec8fa | 2 | require 5.004; |
ba056755 | 3 | use Carp 'croak'; |
54310121 | 4 | |
5 | # See the bottom of this file for the POD documentation. Search for the | |
6 | # string '=head'. | |
7 | ||
8 | # You can run this file through either pod2man or pod2html to produce pretty | |
9 | # documentation in manual or html file format (these utilities are part of the | |
10 | # Perl 5 distribution). | |
11 | ||
424ec8fa | 12 | # Copyright 1995-1998 Lincoln D. Stein. All rights reserved. |
54310121 | 13 | # It may be used and modified freely, but I do request that this copyright |
14 | # notice remain attached to the file. You may modify this module as you | |
15 | # wish, but if you redistribute a modified version, please attach a note | |
16 | # listing the modifications you have made. | |
17 | ||
18 | # The most recent version and complete docs are available at: | |
71f3e297 | 19 | # http://stein.cshl.org/WWW/software/CGI/ |
54310121 | 20 | |
bb8b3399 | 21 | $CGI::revision = '$Id: CGI.pm,v 1.240 2007/11/30 18:58:27 lstein Exp $'; |
af20bb80 | 22 | $CGI::VERSION='3.33_03'; |
f84167b3 YO |
23 | $CGI::VERSION=eval $CGI::VERSION; |
24 | ||
54310121 | 25 | |
26 | # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. | |
27 | # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. | |
ac734d8b | 28 | # $CGITempFile::TMPDIRECTORY = '/usr/tmp'; |
2ed511ec | 29 | use CGI::Util qw(rearrange make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic); |
54310121 | 30 | |
3acbd4f5 JH |
31 | #use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN', |
32 | # 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd']; | |
33 | ||
34 | use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN', | |
35 | 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd']; | |
6b4ac661 | 36 | |
8f3ccfa2 JH |
37 | { |
38 | local $^W = 0; | |
39 | $TAINTED = substr("$0$^X",0,0); | |
40 | } | |
188ba755 | 41 | |
8f3ccfa2 | 42 | $MOD_PERL = 0; # no mod_perl by default |
13548fdf | 43 | @SAVED_SYMBOLS = (); |
8f3ccfa2 | 44 | |
adb86593 | 45 | |
424ec8fa GS |
46 | # >>>>> Here are some globals that you might want to adjust <<<<<< |
47 | sub initialize_globals { | |
48 | # Set this to 1 to enable copious autoloader debugging messages | |
49 | $AUTOLOAD_DEBUG = 0; | |
2371fea9 | 50 | |
6b4ac661 JH |
51 | # Set this to 1 to generate XTML-compatible output |
52 | $XHTML = 1; | |
424ec8fa GS |
53 | |
54 | # Change this to the preferred DTD to print in start_html() | |
55 | # or use default_dtd('text of DTD to use'); | |
3d1a2ec4 GS |
56 | $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN', |
57 | 'http://www.w3.org/TR/html4/loose.dtd' ] ; | |
58 | ||
59 | # Set this to 1 to enable NOSTICKY scripts | |
60 | # or: | |
61 | # 1) use CGI qw(-nosticky) | |
62 | # 2) $CGI::nosticky(1) | |
63 | $NOSTICKY = 0; | |
424ec8fa GS |
64 | |
65 | # Set this to 1 to enable NPH scripts | |
66 | # or: | |
67 | # 1) use CGI qw(-nph) | |
3d1a2ec4 | 68 | # 2) CGI::nph(1) |
424ec8fa GS |
69 | # 3) print header(-nph=>1) |
70 | $NPH = 0; | |
71 | ||
3d1a2ec4 GS |
72 | # Set this to 1 to enable debugging from @ARGV |
73 | # Set to 2 to enable debugging from STDIN | |
74 | $DEBUG = 1; | |
424ec8fa GS |
75 | |
76 | # Set this to 1 to make the temporary files created | |
77 | # during file uploads safe from prying eyes | |
78 | # or do... | |
79 | # 1) use CGI qw(:private_tempfiles) | |
3d1a2ec4 | 80 | # 2) CGI::private_tempfiles(1); |
424ec8fa GS |
81 | $PRIVATE_TEMPFILES = 0; |
82 | ||
0a9bdad4 SP |
83 | # Set this to 1 to generate automatic tab indexes |
84 | $TABINDEX = 0; | |
85 | ||
8f3ccfa2 JH |
86 | # Set this to 1 to cause files uploaded in multipart documents |
87 | # to be closed, instead of caching the file handle | |
88 | # or: | |
89 | # 1) use CGI qw(:close_upload_files) | |
90 | # 2) $CGI::close_upload_files(1); | |
91 | # Uploads with many files run out of file handles. | |
92 | # Also, for performance, since the file is already on disk, | |
93 | # it can just be renamed, instead of read and written. | |
94 | $CLOSE_UPLOAD_FILES = 0; | |
95 | ||
424ec8fa GS |
96 | # Set this to a positive value to limit the size of a POSTing |
97 | # to a certain number of bytes: | |
98 | $POST_MAX = -1; | |
99 | ||
100 | # Change this to 1 to disable uploads entirely: | |
101 | $DISABLE_UPLOADS = 0; | |
102 | ||
3538e1d5 GS |
103 | # Automatically determined -- don't change |
104 | $EBCDIC = 0; | |
105 | ||
71f3e297 JH |
106 | # Change this to 1 to suppress redundant HTTP headers |
107 | $HEADERS_ONCE = 0; | |
108 | ||
109 | # separate the name=value pairs by semicolons rather than ampersands | |
3d1a2ec4 | 110 | $USE_PARAM_SEMICOLONS = 1; |
71f3e297 | 111 | |
2371fea9 JH |
112 | # Do not include undefined params parsed from query string |
113 | # use CGI qw(-no_undef_params); | |
114 | $NO_UNDEF_PARAMS = 0; | |
199d4a26 | 115 | |
bb8b3399 SP |
116 | # return everything as utf-8 |
117 | $PARAM_UTF8 = 0; | |
118 | ||
424ec8fa GS |
119 | # Other globals that you shouldn't worry about. |
120 | undef $Q; | |
121 | $BEEN_THERE = 0; | |
13548fdf | 122 | $DTD_PUBLIC_IDENTIFIER = ""; |
424ec8fa GS |
123 | undef @QUERY_PARAM; |
124 | undef %EXPORT; | |
d45d855d JH |
125 | undef $QUERY_CHARSET; |
126 | undef %QUERY_FIELDNAMES; | |
681699b9 | 127 | undef %QUERY_TMPFILES; |
424ec8fa GS |
128 | |
129 | # prevent complaints by mod_perl | |
130 | 1; | |
131 | } | |
132 | ||
54310121 | 133 | # ------------------ START OF THE LIBRARY ------------ |
134 | ||
13548fdf RGS |
135 | *end_form = \&endform; |
136 | ||
424ec8fa GS |
137 | # make mod_perlhappy |
138 | initialize_globals(); | |
139 | ||
54310121 | 140 | # FIGURE OUT THE OS WE'RE RUNNING UNDER |
141 | # Some systems support the $^O variable. If not | |
142 | # available then require() the Config library | |
143 | unless ($OS) { | |
144 | unless ($OS = $^O) { | |
145 | require Config; | |
146 | $OS = $Config::Config{'osname'}; | |
147 | } | |
148 | } | |
ac1855b3 | 149 | if ($OS =~ /^MSWin/i) { |
3538e1d5 | 150 | $OS = 'WINDOWS'; |
ac1855b3 | 151 | } elsif ($OS =~ /^VMS/i) { |
3538e1d5 | 152 | $OS = 'VMS'; |
ac1855b3 | 153 | } elsif ($OS =~ /^dos/i) { |
3538e1d5 | 154 | $OS = 'DOS'; |
ac1855b3 | 155 | } elsif ($OS =~ /^MacOS/i) { |
54310121 | 156 | $OS = 'MACINTOSH'; |
ac1855b3 | 157 | } elsif ($OS =~ /^os2/i) { |
54310121 | 158 | $OS = 'OS2'; |
ac1855b3 | 159 | } elsif ($OS =~ /^epoc/i) { |
fa6a1c44 | 160 | $OS = 'EPOC'; |
188ba755 JH |
161 | } elsif ($OS =~ /^cygwin/i) { |
162 | $OS = 'CYGWIN'; | |
54310121 | 163 | } else { |
164 | $OS = 'UNIX'; | |
165 | } | |
166 | ||
167 | # Some OS logic. Binary mode enabled on DOS, NT and VMS | |
188ba755 | 168 | $needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN)/; |
54310121 | 169 | |
170 | # This is the default class for the CGI object to use when all else fails. | |
171 | $DefaultClass = 'CGI' unless defined $CGI::DefaultClass; | |
424ec8fa | 172 | |
54310121 | 173 | # This is where to look for autoloaded routines. |
174 | $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass; | |
175 | ||
176 | # The path separator is a slash, backslash or semicolon, depending | |
177 | # on the paltform. | |
178 | $SL = { | |
8f3ccfa2 JH |
179 | UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/', |
180 | WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/' | |
54310121 | 181 | }->{$OS}; |
182 | ||
424ec8fa | 183 | # This no longer seems to be necessary |
54310121 | 184 | # Turn on NPH scripts by default when running under IIS server! |
424ec8fa GS |
185 | # $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; |
186 | $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; | |
54310121 | 187 | |
188 | # Turn on special checking for Doug MacEachern's modperl | |
8f3ccfa2 | 189 | if (exists $ENV{MOD_PERL}) { |
8f3ccfa2 JH |
190 | # mod_perl handlers may run system() on scripts using CGI.pm; |
191 | # Make sure so we don't get fooled by inherited $ENV{MOD_PERL} | |
70194bd6 | 192 | if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { |
741ff09d RGS |
193 | $MOD_PERL = 2; |
194 | require Apache2::Response; | |
195 | require Apache2::RequestRec; | |
196 | require Apache2::RequestUtil; | |
70194bd6 | 197 | require Apache2::RequestIO; |
741ff09d RGS |
198 | require APR::Pool; |
199 | } else { | |
200 | $MOD_PERL = 1; | |
201 | require Apache; | |
188ba755 | 202 | } |
8f3ccfa2 | 203 | } |
188ba755 | 204 | |
424ec8fa GS |
205 | # Turn on special checking for ActiveState's PerlEx |
206 | $PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; | |
207 | ||
208 | # Define the CRLF sequence. I can't use a simple "\r\n" because the meaning | |
209 | # of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF | |
210 | # and sometimes CR). The most popular VMS web server | |
211 | # doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't | |
212 | # use ASCII, so \015\012 means something different. I find this all | |
213 | # really annoying. | |
214 | $EBCDIC = "\t" ne "\011"; | |
215 | if ($OS eq 'VMS') { | |
3538e1d5 | 216 | $CRLF = "\n"; |
424ec8fa | 217 | } elsif ($EBCDIC) { |
3538e1d5 | 218 | $CRLF= "\r\n"; |
424ec8fa | 219 | } else { |
3538e1d5 GS |
220 | $CRLF = "\015\012"; |
221 | } | |
222 | ||
54310121 | 223 | if ($needs_binmode) { |
2ed511ec RGS |
224 | $CGI::DefaultClass->binmode(\*main::STDOUT); |
225 | $CGI::DefaultClass->binmode(\*main::STDIN); | |
226 | $CGI::DefaultClass->binmode(\*main::STDERR); | |
54310121 | 227 | } |
228 | ||
54310121 | 229 | %EXPORT_TAGS = ( |
424ec8fa GS |
230 | ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em |
231 | tt u i b blockquote pre img a address cite samp dfn html head | |
232 | base body Link nextid title meta kbd start_html end_html | |
3d1a2ec4 | 233 | input Select option comment charset escapeHTML/], |
71f3e297 | 234 | ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param |
1c87da1d | 235 | embed basefont style span layer ilayer font frameset frame script small big Area Map/], |
3acbd4f5 JH |
236 | ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe |
237 | ins label legend noframes noscript object optgroup Q | |
238 | thead tbody tfoot/], | |
424ec8fa GS |
239 | ':netscape'=>[qw/blink fontsize center/], |
240 | ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group | |
241 | submit reset defaults radio_group popup_menu button autoEscape | |
242 | scrolling_list image_button start_form end_form startform endform | |
71f3e297 | 243 | start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], |
7dc108d1 SP |
244 | ':cgi'=>[qw/param upload path_info path_translated request_uri url self_url script_name |
245 | cookie Dump | |
3538e1d5 | 246 | raw_cookie request_method query_string Accept user_agent remote_host content_type |
2ed511ec RGS |
247 | remote_addr referer server_name server_software server_port server_protocol virtual_port |
248 | virtual_host remote_ident auth_type http append | |
424ec8fa | 249 | save_parameters restore_parameters param_fetch |
3538e1d5 GS |
250 | remote_user user_name header redirect import_names put |
251 | Delete Delete_all url_param cgi_error/], | |
424ec8fa | 252 | ':ssl' => [qw/https/], |
3538e1d5 | 253 | ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/], |
3acbd4f5 JH |
254 | ':html' => [qw/:html2 :html3 :html4 :netscape/], |
255 | ':standard' => [qw/:html2 :html3 :html4 :form :cgi/], | |
ba056755 | 256 | ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/], |
3acbd4f5 | 257 | ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/] |
424ec8fa | 258 | ); |
54310121 | 259 | |
29ddc2a4 RGS |
260 | # Custom 'can' method for both autoloaded and non-autoloaded subroutines. |
261 | # Author: Cees Hek <cees@sitesuite.com.au> | |
262 | ||
263 | sub can { | |
264 | my($class, $method) = @_; | |
265 | ||
266 | # See if UNIVERSAL::can finds it. | |
267 | ||
268 | if (my $func = $class -> SUPER::can($method) ){ | |
269 | return $func; | |
270 | } | |
271 | ||
272 | # Try to compile the function. | |
273 | ||
274 | eval { | |
275 | # _compile looks at $AUTOLOAD for the function name. | |
276 | ||
277 | local $AUTOLOAD = join "::", $class, $method; | |
278 | &_compile; | |
279 | }; | |
280 | ||
281 | # Now that the function is loaded (if it exists) | |
282 | # just use UNIVERSAL::can again to do the work. | |
283 | ||
284 | return $class -> SUPER::can($method); | |
285 | } | |
286 | ||
54310121 | 287 | # to import symbols into caller |
288 | sub import { | |
289 | my $self = shift; | |
424ec8fa | 290 | |
188ba755 | 291 | # This causes modules to clash. |
b2d0d414 JH |
292 | undef %EXPORT_OK; |
293 | undef %EXPORT; | |
424ec8fa GS |
294 | |
295 | $self->_setup_symbols(@_); | |
54310121 | 296 | my ($callpack, $callfile, $callline) = caller; |
424ec8fa | 297 | |
54310121 | 298 | # To allow overriding, search through the packages |
299 | # Till we find one in which the correct subroutine is defined. | |
300 | my @packages = ($self,@{"$self\:\:ISA"}); | |
301 | foreach $sym (keys %EXPORT) { | |
302 | my $pck; | |
303 | my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass; | |
304 | foreach $pck (@packages) { | |
305 | if (defined(&{"$pck\:\:$sym"})) { | |
306 | $def = $pck; | |
307 | last; | |
308 | } | |
309 | } | |
310 | *{"${callpack}::$sym"} = \&{"$def\:\:$sym"}; | |
311 | } | |
312 | } | |
313 | ||
424ec8fa GS |
314 | sub compile { |
315 | my $pack = shift; | |
316 | $pack->_setup_symbols('-compile',@_); | |
317 | } | |
318 | ||
54310121 | 319 | sub expand_tags { |
320 | my($tag) = @_; | |
71f3e297 | 321 | return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/; |
54310121 | 322 | my(@r); |
323 | return ($tag) unless $EXPORT_TAGS{$tag}; | |
324 | foreach (@{$EXPORT_TAGS{$tag}}) { | |
325 | push(@r,&expand_tags($_)); | |
326 | } | |
327 | return @r; | |
328 | } | |
329 | ||
330 | #### Method: new | |
331 | # The new routine. This will check the current environment | |
332 | # for an existing query string, and initialize itself, if so. | |
333 | #### | |
334 | sub new { | |
8f3ccfa2 JH |
335 | my($class,@initializer) = @_; |
336 | my $self = {}; | |
2ed511ec | 337 | |
8f3ccfa2 | 338 | bless $self,ref $class || $class || $DefaultClass; |
cb3b230c SP |
339 | |
340 | # always use a tempfile | |
341 | $self->{'use_tempfile'} = 1; | |
342 | ||
8f3ccfa2 JH |
343 | if (ref($initializer[0]) |
344 | && (UNIVERSAL::isa($initializer[0],'Apache') | |
345 | || | |
741ff09d | 346 | UNIVERSAL::isa($initializer[0],'Apache2::RequestRec') |
8f3ccfa2 JH |
347 | )) { |
348 | $self->r(shift @initializer); | |
349 | } | |
efc8e943 NC |
350 | if (ref($initializer[0]) |
351 | && (UNIVERSAL::isa($initializer[0],'CODE'))) { | |
352 | $self->upload_hook(shift @initializer, shift @initializer); | |
cb3b230c | 353 | $self->{'use_tempfile'} = shift @initializer if (@initializer > 0); |
efc8e943 | 354 | } |
8f3ccfa2 | 355 | if ($MOD_PERL) { |
8f3ccfa2 | 356 | if ($MOD_PERL == 1) { |
741ff09d RGS |
357 | $self->r(Apache->request) unless $self->r; |
358 | my $r = $self->r; | |
8f3ccfa2 JH |
359 | $r->register_cleanup(\&CGI::_reset_globals); |
360 | } | |
361 | else { | |
362 | # XXX: once we have the new API | |
363 | # will do a real PerlOptions -SetupEnv check | |
741ff09d RGS |
364 | $self->r(Apache2::RequestUtil->request) unless $self->r; |
365 | my $r = $self->r; | |
8f3ccfa2 JH |
366 | $r->subprocess_env unless exists $ENV{REQUEST_METHOD}; |
367 | $r->pool->cleanup_register(\&CGI::_reset_globals); | |
424ec8fa | 368 | } |
8f3ccfa2 JH |
369 | undef $NPH; |
370 | } | |
371 | $self->_reset_globals if $PERLEX; | |
372 | $self->init(@initializer); | |
373 | return $self; | |
54310121 | 374 | } |
375 | ||
2ed511ec RGS |
376 | # We provide a DESTROY method so that we can ensure that |
377 | # temporary files are closed (via Fh->DESTROY) before they | |
378 | # are unlinked (via CGITempFile->DESTROY) because it is not | |
379 | # possible to unlink an open file on Win32. We explicitly | |
380 | # call DESTROY on each, rather than just undefing them and | |
381 | # letting Perl DESTROY them by garbage collection, in case the | |
382 | # user is still holding any reference to them as well. | |
383 | sub DESTROY { | |
384 | my $self = shift; | |
0a9bdad4 SP |
385 | if ($OS eq 'WINDOWS') { |
386 | foreach my $href (values %{$self->{'.tmpfiles'}}) { | |
387 | $href->{hndl}->DESTROY if defined $href->{hndl}; | |
388 | $href->{name}->DESTROY if defined $href->{name}; | |
389 | } | |
2ed511ec RGS |
390 | } |
391 | } | |
54310121 | 392 | |
8f3ccfa2 JH |
393 | sub r { |
394 | my $self = shift; | |
395 | my $r = $self->{'.r'}; | |
396 | $self->{'.r'} = shift if @_; | |
397 | $r; | |
398 | } | |
399 | ||
2ed511ec | 400 | sub upload_hook { |
0a9bdad4 SP |
401 | my $self; |
402 | if (ref $_[0] eq 'CODE') { | |
403 | $CGI::Q = $self = $CGI::DefaultClass->new(@_); | |
404 | } else { | |
405 | $self = shift; | |
406 | } | |
cb3b230c | 407 | my ($hook,$data,$use_tempfile) = @_; |
2ed511ec RGS |
408 | $self->{'.upload_hook'} = $hook; |
409 | $self->{'.upload_data'} = $data; | |
cb3b230c | 410 | $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile; |
2ed511ec RGS |
411 | } |
412 | ||
54310121 | 413 | #### Method: param |
414 | # Returns the value(s)of a named parameter. | |
415 | # If invoked in a list context, returns the | |
416 | # entire list. Otherwise returns the first | |
417 | # member of the list. | |
418 | # If name is not provided, return a list of all | |
419 | # the known parameters names available. | |
420 | # If more than one argument is provided, the | |
421 | # second and subsequent arguments are used to | |
422 | # set the value of the parameter. | |
423 | #### | |
424 | sub param { | |
425 | my($self,@p) = self_or_default(@_); | |
426 | return $self->all_parameters unless @p; | |
427 | my($name,$value,@other); | |
428 | ||
429 | # For compatibility between old calling style and use_named_parameters() style, | |
430 | # we have to special case for a single parameter present. | |
431 | if (@p > 1) { | |
3d1a2ec4 | 432 | ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p); |
54310121 | 433 | my(@values); |
434 | ||
3d1a2ec4 | 435 | if (substr($p[0],0,1) eq '-') { |
54310121 | 436 | @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : (); |
437 | } else { | |
438 | foreach ($value,@other) { | |
439 | push(@values,$_) if defined($_); | |
440 | } | |
441 | } | |
442 | # If values is provided, then we set it. | |
fc786e8b | 443 | if (@values or defined $value) { |
54310121 | 444 | $self->add_parameter($name); |
445 | $self->{$name}=[@values]; | |
446 | } | |
447 | } else { | |
448 | $name = $p[0]; | |
449 | } | |
450 | ||
71f3e297 | 451 | return unless defined($name) && $self->{$name}; |
fc786e8b | 452 | |
bb8b3399 SP |
453 | my @result = @{$self->{$name}}; |
454 | ||
455 | if ($PARAM_UTF8) { | |
456 | eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions | |
457 | @result = map {ref $_ ? $_ : Encode::decode(utf8=>$_) } @result; | |
fc786e8b | 458 | } |
bb8b3399 SP |
459 | |
460 | return wantarray ? @result : $result[0]; | |
54310121 | 461 | } |
462 | ||
54310121 | 463 | sub self_or_default { |
424ec8fa | 464 | return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI'); |
54310121 | 465 | unless (defined($_[0]) && |
424ec8fa GS |
466 | (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case |
467 | ) { | |
54310121 | 468 | $Q = $CGI::DefaultClass->new unless defined($Q); |
469 | unshift(@_,$Q); | |
470 | } | |
3d1a2ec4 | 471 | return wantarray ? @_ : $Q; |
54310121 | 472 | } |
473 | ||
54310121 | 474 | sub self_or_CGI { |
475 | local $^W=0; # prevent a warning | |
476 | if (defined($_[0]) && | |
477 | (substr(ref($_[0]),0,3) eq 'CGI' | |
424ec8fa | 478 | || UNIVERSAL::isa($_[0],'CGI'))) { |
54310121 | 479 | return @_; |
480 | } else { | |
481 | return ($DefaultClass,@_); | |
482 | } | |
483 | } | |
484 | ||
54310121 | 485 | ######################################## |
486 | # THESE METHODS ARE MORE OR LESS PRIVATE | |
487 | # GO TO THE __DATA__ SECTION TO SEE MORE | |
488 | # PUBLIC METHODS | |
489 | ######################################## | |
490 | ||
491 | # Initialize the query object from the environment. | |
492 | # If a parameter list is found, this object will be set | |
493 | # to an associative array in which parameter names are keys | |
494 | # and the values are stored as lists | |
495 | # If a keyword list is found, this method creates a bogus | |
496 | # parameter list with the single parameter 'keywords'. | |
497 | ||
498 | sub init { | |
8f3ccfa2 JH |
499 | my $self = shift; |
500 | my($query_string,$meth,$content_length,$fh,@lines) = ('','','',''); | |
501 | ||
8869a4b7 SP |
502 | my $is_xforms; |
503 | ||
8f3ccfa2 JH |
504 | my $initializer = shift; # for backward compatibility |
505 | local($/) = "\n"; | |
506 | ||
507 | # set autoescaping on by default | |
508 | $self->{'escape'} = 1; | |
54310121 | 509 | |
510 | # if we get called more than once, we want to initialize | |
511 | # ourselves from the original query (which may be gone | |
512 | # if it was read from STDIN originally.) | |
d45d855d | 513 | if (defined(@QUERY_PARAM) && !defined($initializer)) { |
681699b9 SP |
514 | for my $name (@QUERY_PARAM) { |
515 | my $val = $QUERY_PARAM{$name}; # always an arrayref; | |
516 | $self->param('-name'=>$name,'-value'=> $val); | |
517 | if (defined $val and ref $val eq 'ARRAY') { | |
518 | for my $fh (grep {defined(fileno($_))} @$val) { | |
519 | seek($fh,0,0); # reset the filehandle. | |
520 | } | |
521 | ||
522 | } | |
523 | } | |
524 | $self->charset($QUERY_CHARSET); | |
525 | $self->{'.fieldnames'} = {%QUERY_FIELDNAMES}; | |
526 | $self->{'.tmpfiles'} = {%QUERY_TMPFILES}; | |
527 | return; | |
54310121 | 528 | } |
529 | ||
530 | $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'}); | |
424ec8fa | 531 | $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0; |
3538e1d5 | 532 | |
424ec8fa | 533 | $fh = to_filehandle($initializer) if $initializer; |
54310121 | 534 | |
a3b3a725 JH |
535 | # set charset to the safe ISO-8859-1 |
536 | $self->charset('ISO-8859-1'); | |
537 | ||
54310121 | 538 | METHOD: { |
54310121 | 539 | |
3538e1d5 GS |
540 | # avoid unreasonably large postings |
541 | if (($POST_MAX > 0) && ($content_length > $POST_MAX)) { | |
fc786e8b SP |
542 | #discard the post, unread |
543 | $self->cgi_error("413 Request entity too large"); | |
544 | last METHOD; | |
545 | } | |
3538e1d5 | 546 | |
424ec8fa GS |
547 | # Process multipart postings, but only if the initializer is |
548 | # not defined. | |
549 | if ($meth eq 'POST' | |
550 | && defined($ENV{'CONTENT_TYPE'}) | |
551 | && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data| | |
552 | && !defined($initializer) | |
553 | ) { | |
71f3e297 | 554 | my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/; |
424ec8fa GS |
555 | $self->read_multipart($boundary,$content_length); |
556 | last METHOD; | |
557 | } | |
558 | ||
8869a4b7 SP |
559 | # Process XForms postings. We know that we have XForms in the |
560 | # following cases: | |
561 | # method eq 'POST' && content-type eq 'application/xml' | |
562 | # method eq 'POST' && content-type =~ /multipart\/related.+start=/ | |
563 | # There are more cases, actually, but for now, we don't support other | |
564 | # methods for XForm posts. | |
565 | # In a XForm POST, the QUERY_STRING is parsed normally. | |
566 | # If the content-type is 'application/xml', we just set the param | |
567 | # XForms:Model (referring to the xml syntax) param containing the | |
568 | # unparsed XML data. | |
569 | # In the case of multipart/related we set XForms:Model as above, but | |
570 | # the other parts are available as uploads with the Content-ID as the | |
571 | # the key. | |
572 | # See the URL below for XForms specs on this issue. | |
573 | # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options | |
574 | if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) { | |
575 | if ($ENV{'CONTENT_TYPE'} eq 'application/xml') { | |
576 | my($param) = 'XForms:Model'; | |
577 | my($value) = ''; | |
578 | $self->add_parameter($param); | |
579 | $self->read_from_client(\$value,$content_length,0) | |
580 | if $content_length > 0; | |
581 | push (@{$self->{$param}},$value); | |
582 | $is_xforms = 1; | |
583 | } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\<?([^\"\>]+)\>?\"?/) { | |
584 | my($boundary,$start) = ($1,$2); | |
585 | my($param) = 'XForms:Model'; | |
586 | $self->add_parameter($param); | |
587 | my($value) = $self->read_multipart_related($start,$boundary,$content_length,0); | |
588 | push (@{$self->{$param}},$value); | |
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 | $is_xforms = 1; | |
596 | } | |
597 | } | |
598 | ||
599 | ||
424ec8fa GS |
600 | # If initializer is defined, then read parameters |
601 | # from it. | |
8869a4b7 | 602 | if (!$is_xforms && defined($initializer)) { |
424ec8fa GS |
603 | if (UNIVERSAL::isa($initializer,'CGI')) { |
604 | $query_string = $initializer->query_string; | |
605 | last METHOD; | |
606 | } | |
54310121 | 607 | if (ref($initializer) && ref($initializer) eq 'HASH') { |
608 | foreach (keys %$initializer) { | |
609 | $self->param('-name'=>$_,'-value'=>$initializer->{$_}); | |
610 | } | |
611 | last METHOD; | |
612 | } | |
424ec8fa | 613 | |
2ed511ec RGS |
614 | if (defined($fh) && ($fh ne '')) { |
615 | while (<$fh>) { | |
616 | chomp; | |
617 | last if /^=/; | |
618 | push(@lines,$_); | |
619 | } | |
620 | # massage back into standard format | |
621 | if ("@lines" =~ /=/) { | |
622 | $query_string=join("&",@lines); | |
623 | } else { | |
624 | $query_string=join("+",@lines); | |
625 | } | |
626 | last METHOD; | |
627 | } | |
628 | ||
424ec8fa GS |
629 | # last chance -- treat it as a string |
630 | $initializer = $$initializer if ref($initializer) eq 'SCALAR'; | |
54310121 | 631 | $query_string = $initializer; |
424ec8fa | 632 | |
54310121 | 633 | last METHOD; |
634 | } | |
54310121 | 635 | |
424ec8fa GS |
636 | # If method is GET or HEAD, fetch the query from |
637 | # the environment. | |
8869a4b7 | 638 | if ($is_xforms || $meth=~/^(GET|HEAD)$/) { |
3538e1d5 | 639 | if ($MOD_PERL) { |
8f3ccfa2 | 640 | $query_string = $self->r->args; |
3538e1d5 GS |
641 | } else { |
642 | $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; | |
3d1a2ec4 | 643 | $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'}; |
3538e1d5 | 644 | } |
424ec8fa GS |
645 | last METHOD; |
646 | } | |
54310121 | 647 | |
bb8b3399 | 648 | if ($meth eq 'POST' || $meth eq 'PUT') { |
2ed511ec | 649 | $self->read_from_client(\$query_string,$content_length,0) |
424ec8fa | 650 | if $content_length > 0; |
54310121 | 651 | # Some people want to have their cake and eat it too! |
652 | # Uncomment this line to have the contents of the query string | |
653 | # APPENDED to the POST data. | |
424ec8fa | 654 | # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; |
54310121 | 655 | last METHOD; |
656 | } | |
424ec8fa GS |
657 | |
658 | # If $meth is not of GET, POST or HEAD, assume we're being debugged offline. | |
54310121 | 659 | # Check the command line and then the standard input for data. |
660 | # We use the shellwords package in order to behave the way that | |
661 | # UN*X programmers expect. | |
2ed511ec RGS |
662 | if ($DEBUG) |
663 | { | |
664 | my $cmdline_ret = read_from_cmdline(); | |
665 | $query_string = $cmdline_ret->{'query_string'}; | |
666 | if (defined($cmdline_ret->{'subpath'})) | |
667 | { | |
668 | $self->path_info($cmdline_ret->{'subpath'}); | |
669 | } | |
670 | } | |
54310121 | 671 | } |
424ec8fa | 672 | |
8f3ccfa2 | 673 | # YL: Begin Change for XML handler 10/19/2001 |
bb8b3399 | 674 | if (!$is_xforms && ($meth eq 'POST' || $meth eq 'PUT') |
8f3ccfa2 | 675 | && defined($ENV{'CONTENT_TYPE'}) |
1c87da1d JH |
676 | && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| |
677 | && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) { | |
bb8b3399 | 678 | my($param) = $meth . 'DATA' ; |
8f3ccfa2 JH |
679 | $self->add_parameter($param) ; |
680 | push (@{$self->{$param}},$query_string); | |
681 | undef $query_string ; | |
682 | } | |
683 | # YL: End Change for XML handler 10/19/2001 | |
684 | ||
54310121 | 685 | # We now have the query string in hand. We do slightly |
686 | # different things for keyword lists and parameter lists. | |
ba056755 | 687 | if (defined $query_string && length $query_string) { |
3d1a2ec4 | 688 | if ($query_string =~ /[&=;]/) { |
54310121 | 689 | $self->parse_params($query_string); |
690 | } else { | |
691 | $self->add_parameter('keywords'); | |
692 | $self->{'keywords'} = [$self->parse_keywordlist($query_string)]; | |
693 | } | |
694 | } | |
695 | ||
696 | # Special case. Erase everything if there is a field named | |
697 | # .defaults. | |
698 | if ($self->param('.defaults')) { | |
e70cb7eb | 699 | $self->delete_all(); |
54310121 | 700 | } |
701 | ||
702 | # Associative array containing our defined fieldnames | |
703 | $self->{'.fieldnames'} = {}; | |
704 | foreach ($self->param('.cgifields')) { | |
705 | $self->{'.fieldnames'}->{$_}++; | |
706 | } | |
707 | ||
708 | # Clear out our default submission button flag if present | |
709 | $self->delete('.submit'); | |
710 | $self->delete('.cgifields'); | |
3d1a2ec4 | 711 | |
8f3ccfa2 | 712 | $self->save_request unless defined $initializer; |
54310121 | 713 | } |
714 | ||
54310121 | 715 | # FUNCTIONS TO OVERRIDE: |
54310121 | 716 | # Turn a string into a filehandle |
717 | sub to_filehandle { | |
424ec8fa GS |
718 | my $thingy = shift; |
719 | return undef unless $thingy; | |
720 | return $thingy if UNIVERSAL::isa($thingy,'GLOB'); | |
721 | return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); | |
722 | if (!ref($thingy)) { | |
723 | my $caller = 1; | |
724 | while (my $package = caller($caller++)) { | |
725 | my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; | |
726 | return $tmp if defined(fileno($tmp)); | |
727 | } | |
54310121 | 728 | } |
424ec8fa | 729 | return undef; |
54310121 | 730 | } |
731 | ||
732 | # send output to the browser | |
733 | sub put { | |
734 | my($self,@p) = self_or_default(@_); | |
735 | $self->print(@p); | |
736 | } | |
737 | ||
738 | # print to standard output (for overriding in mod_perl) | |
739 | sub print { | |
740 | shift; | |
741 | CORE::print(@_); | |
742 | } | |
743 | ||
3538e1d5 GS |
744 | # get/set last cgi_error |
745 | sub cgi_error { | |
746 | my ($self,$err) = self_or_default(@_); | |
747 | $self->{'.cgi_error'} = $err if defined $err; | |
748 | return $self->{'.cgi_error'}; | |
749 | } | |
750 | ||
54310121 | 751 | sub save_request { |
752 | my($self) = @_; | |
753 | # We're going to play with the package globals now so that if we get called | |
754 | # again, we initialize ourselves in exactly the same way. This allows | |
755 | # us to have several of these objects. | |
756 | @QUERY_PARAM = $self->param; # save list of parameters | |
757 | foreach (@QUERY_PARAM) { | |
3d1a2ec4 GS |
758 | next unless defined $_; |
759 | $QUERY_PARAM{$_}=$self->{$_}; | |
54310121 | 760 | } |
d45d855d JH |
761 | $QUERY_CHARSET = $self->charset; |
762 | %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}}; | |
681699b9 | 763 | %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} }; |
54310121 | 764 | } |
765 | ||
54310121 | 766 | sub parse_params { |
767 | my($self,$tosplit) = @_; | |
71f3e297 | 768 | my(@pairs) = split(/[&;]/,$tosplit); |
54310121 | 769 | my($param,$value); |
770 | foreach (@pairs) { | |
424ec8fa | 771 | ($param,$value) = split('=',$_,2); |
b2d0d414 | 772 | next unless defined $param; |
69c89ae7 | 773 | next if $NO_UNDEF_PARAMS and not defined $value; |
3d1a2ec4 | 774 | $value = '' unless defined $value; |
424ec8fa GS |
775 | $param = unescape($param); |
776 | $value = unescape($value); | |
54310121 | 777 | $self->add_parameter($param); |
778 | push (@{$self->{$param}},$value); | |
779 | } | |
780 | } | |
781 | ||
782 | sub add_parameter { | |
783 | my($self,$param)=@_; | |
3d1a2ec4 | 784 | return unless defined $param; |
54310121 | 785 | push (@{$self->{'.parameters'}},$param) |
786 | unless defined($self->{$param}); | |
787 | } | |
788 | ||
789 | sub all_parameters { | |
790 | my $self = shift; | |
791 | return () unless defined($self) && $self->{'.parameters'}; | |
792 | return () unless @{$self->{'.parameters'}}; | |
793 | return @{$self->{'.parameters'}}; | |
794 | } | |
795 | ||
424ec8fa GS |
796 | # put a filehandle into binary mode (DOS) |
797 | sub binmode { | |
2ed511ec | 798 | return unless defined($_[1]) && defined fileno($_[1]); |
424ec8fa GS |
799 | CORE::binmode($_[1]); |
800 | } | |
801 | ||
802 | sub _make_tag_func { | |
71f3e297 | 803 | my ($self,$tagname) = @_; |
3538e1d5 | 804 | my $func = qq( |
3d1a2ec4 | 805 | sub $tagname { |
8f3ccfa2 JH |
806 | my (\$q,\$a,\@rest) = self_or_default(\@_); |
807 | my(\$attr) = ''; | |
808 | if (ref(\$a) && ref(\$a) eq 'HASH') { | |
809 | my(\@attr) = make_attributes(\$a,\$q->{'escape'}); | |
810 | \$attr = " \@attr" if \@attr; | |
811 | } else { | |
1c87da1d | 812 | unshift \@rest,\$a if defined \$a; |
8f3ccfa2 | 813 | } |
3538e1d5 | 814 | ); |
71f3e297 | 815 | if ($tagname=~/start_(\w+)/i) { |
6b4ac661 | 816 | $func .= qq! return "<\L$1\E\$attr>";} !; |
71f3e297 | 817 | } elsif ($tagname=~/end_(\w+)/i) { |
6b4ac661 | 818 | $func .= qq! return "<\L/$1\E>"; } !; |
71f3e297 JH |
819 | } else { |
820 | $func .= qq# | |
1c87da1d | 821 | return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest; |
6b4ac661 | 822 | my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E"); |
3d1a2ec4 | 823 | my \@result = map { "\$tag\$_\$untag" } |
8f3ccfa2 | 824 | (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest"; |
424ec8fa | 825 | return "\@result"; |
71f3e297 JH |
826 | }#; |
827 | } | |
828 | return $func; | |
54310121 | 829 | } |
830 | ||
831 | sub AUTOLOAD { | |
832 | print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG; | |
424ec8fa GS |
833 | my $func = &_compile; |
834 | goto &$func; | |
54310121 | 835 | } |
836 | ||
424ec8fa GS |
837 | sub _compile { |
838 | my($func) = $AUTOLOAD; | |
839 | my($pack,$func_name); | |
840 | { | |
841 | local($1,$2); # this fixes an obscure variable suicide problem. | |
842 | $func=~/(.+)::([^:]+)$/; | |
843 | ($pack,$func_name) = ($1,$2); | |
844 | $pack=~s/::SUPER$//; # fix another obscure problem | |
845 | $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass | |
846 | unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"}); | |
847 | ||
848 | my($sub) = \%{"$pack\:\:SUBS"}; | |
849 | unless (%$sub) { | |
850 | my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"}; | |
29ddc2a4 | 851 | local ($@,$!); |
424ec8fa | 852 | eval "package $pack; $$auto"; |
ba056755 | 853 | croak("$AUTOLOAD: $@") if $@; |
424ec8fa GS |
854 | $$auto = ''; # Free the unneeded storage (but don't undef it!!!) |
855 | } | |
856 | my($code) = $sub->{$func_name}; | |
857 | ||
858 | $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY'); | |
859 | if (!$code) { | |
71f3e297 | 860 | (my $base = $func_name) =~ s/^(start_|end_)//i; |
424ec8fa GS |
861 | if ($EXPORT{':any'} || |
862 | $EXPORT{'-any'} || | |
71f3e297 | 863 | $EXPORT{$base} || |
424ec8fa | 864 | (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html'))) |
71f3e297 JH |
865 | && $EXPORT_OK{$base}) { |
866 | $code = $CGI::DefaultClass->_make_tag_func($func_name); | |
424ec8fa GS |
867 | } |
868 | } | |
ba056755 | 869 | croak("Undefined subroutine $AUTOLOAD\n") unless $code; |
29ddc2a4 | 870 | local ($@,$!); |
424ec8fa GS |
871 | eval "package $pack; $code"; |
872 | if ($@) { | |
873 | $@ =~ s/ at .*\n//; | |
ba056755 | 874 | croak("$AUTOLOAD: $@"); |
424ec8fa GS |
875 | } |
876 | } | |
3538e1d5 | 877 | CORE::delete($sub->{$func_name}); #free storage |
424ec8fa GS |
878 | return "$pack\:\:$func_name"; |
879 | } | |
880 | ||
3acbd4f5 JH |
881 | sub _selected { |
882 | my $self = shift; | |
883 | my $value = shift; | |
884 | return '' unless $value; | |
0a9bdad4 | 885 | return $XHTML ? qq(selected="selected" ) : qq(selected ); |
3acbd4f5 JH |
886 | } |
887 | ||
888 | sub _checked { | |
889 | my $self = shift; | |
890 | my $value = shift; | |
891 | return '' unless $value; | |
0a9bdad4 | 892 | return $XHTML ? qq(checked="checked" ) : qq(checked ); |
3acbd4f5 JH |
893 | } |
894 | ||
424ec8fa GS |
895 | sub _reset_globals { initialize_globals(); } |
896 | ||
897 | sub _setup_symbols { | |
898 | my $self = shift; | |
899 | my $compile = 0; | |
b2d0d414 JH |
900 | |
901 | # to avoid reexporting unwanted variables | |
902 | undef %EXPORT; | |
903 | ||
424ec8fa | 904 | foreach (@_) { |
71f3e297 JH |
905 | $HEADERS_ONCE++, next if /^[:-]unique_headers$/; |
906 | $NPH++, next if /^[:-]nph$/; | |
3d1a2ec4 GS |
907 | $NOSTICKY++, next if /^[:-]nosticky$/; |
908 | $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/; | |
909 | $DEBUG=2, next if /^[:-][Dd]ebug$/; | |
71f3e297 | 910 | $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/; |
bb8b3399 | 911 | $PARAM_UTF8++, next if /^[:-]utf8$/; |
6b4ac661 JH |
912 | $XHTML++, next if /^[:-]xhtml$/; |
913 | $XHTML=0, next if /^[:-]no_?xhtml$/; | |
3d1a2ec4 | 914 | $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/; |
71f3e297 | 915 | $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/; |
0a9bdad4 | 916 | $TABINDEX++, next if /^[:-]tabindex$/; |
13548fdf | 917 | $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/; |
71f3e297 JH |
918 | $EXPORT{$_}++, next if /^[:-]any$/; |
919 | $compile++, next if /^[:-]compile$/; | |
199d4a26 | 920 | $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/; |
424ec8fa | 921 | |
71f3e297 | 922 | # This is probably extremely evil code -- to be deleted some day. |
424ec8fa GS |
923 | if (/^[-]autoload$/) { |
924 | my($pkg) = caller(1); | |
925 | *{"${pkg}::AUTOLOAD"} = sub { | |
926 | my($routine) = $AUTOLOAD; | |
927 | $routine =~ s/^.*::/CGI::/; | |
928 | &$routine; | |
929 | }; | |
930 | next; | |
931 | } | |
932 | ||
933 | foreach (&expand_tags($_)) { | |
934 | tr/a-zA-Z0-9_//cd; # don't allow weird function names | |
935 | $EXPORT{$_}++; | |
54310121 | 936 | } |
54310121 | 937 | } |
424ec8fa | 938 | _compile_all(keys %EXPORT) if $compile; |
188ba755 | 939 | @SAVED_SYMBOLS = @_; |
54310121 | 940 | } |
941 | ||
3d1a2ec4 GS |
942 | sub charset { |
943 | my ($self,$charset) = self_or_default(@_); | |
944 | $self->{'.charset'} = $charset if defined $charset; | |
945 | $self->{'.charset'}; | |
946 | } | |
947 | ||
29ddc2a4 RGS |
948 | sub element_id { |
949 | my ($self,$new_value) = self_or_default(@_); | |
950 | $self->{'.elid'} = $new_value if defined $new_value; | |
951 | sprintf('%010d',$self->{'.elid'}++); | |
952 | } | |
953 | ||
954 | sub element_tab { | |
955 | my ($self,$new_value) = self_or_default(@_); | |
70194bd6 | 956 | $self->{'.etab'} ||= 1; |
29ddc2a4 | 957 | $self->{'.etab'} = $new_value if defined $new_value; |
0a9bdad4 SP |
958 | my $tab = $self->{'.etab'}++; |
959 | return '' unless $TABINDEX or defined $new_value; | |
960 | return qq(tabindex="$tab" ); | |
29ddc2a4 RGS |
961 | } |
962 | ||
54310121 | 963 | ############################################################################### |
964 | ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### | |
965 | ############################################################################### | |
966 | $AUTOLOADED_ROUTINES = ''; # get rid of -w warning | |
967 | $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; | |
968 | ||
969 | %SUBS = ( | |
970 | ||
971 | 'URL_ENCODED'=> <<'END_OF_FUNC', | |
972 | sub URL_ENCODED { 'application/x-www-form-urlencoded'; } | |
973 | END_OF_FUNC | |
974 | ||
975 | 'MULTIPART' => <<'END_OF_FUNC', | |
976 | sub MULTIPART { 'multipart/form-data'; } | |
977 | END_OF_FUNC | |
978 | ||
424ec8fa | 979 | 'SERVER_PUSH' => <<'END_OF_FUNC', |
ba056755 | 980 | sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; } |
424ec8fa GS |
981 | END_OF_FUNC |
982 | ||
424ec8fa GS |
983 | 'new_MultipartBuffer' => <<'END_OF_FUNC', |
984 | # Create a new multipart buffer | |
985 | sub new_MultipartBuffer { | |
2ed511ec RGS |
986 | my($self,$boundary,$length) = @_; |
987 | return MultipartBuffer->new($self,$boundary,$length); | |
424ec8fa GS |
988 | } |
989 | END_OF_FUNC | |
990 | ||
991 | 'read_from_client' => <<'END_OF_FUNC', | |
992 | # Read data from a file handle | |
993 | sub read_from_client { | |
2ed511ec | 994 | my($self, $buff, $len, $offset) = @_; |
424ec8fa | 995 | local $^W=0; # prevent a warning |
2ed511ec RGS |
996 | return $MOD_PERL |
997 | ? $self->r->read($$buff, $len, $offset) | |
998 | : read(\*STDIN, $$buff, $len, $offset); | |
424ec8fa GS |
999 | } |
1000 | END_OF_FUNC | |
1001 | ||
1002 | 'delete' => <<'END_OF_FUNC', | |
1003 | #### Method: delete | |
1004 | # Deletes the named parameter entirely. | |
1005 | #### | |
1006 | sub delete { | |
6b4ac661 | 1007 | my($self,@p) = self_or_default(@_); |
1c87da1d JH |
1008 | my(@names) = rearrange([NAME],@p); |
1009 | my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names; | |
8f3ccfa2 JH |
1010 | my %to_delete; |
1011 | foreach my $name (@to_delete) | |
1012 | { | |
1013 | CORE::delete $self->{$name}; | |
1014 | CORE::delete $self->{'.fieldnames'}->{$name}; | |
1015 | $to_delete{$name}++; | |
188ba755 | 1016 | } |
8f3ccfa2 | 1017 | @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param(); |
13548fdf | 1018 | return; |
424ec8fa GS |
1019 | } |
1020 | END_OF_FUNC | |
1021 | ||
1022 | #### Method: import_names | |
1023 | # Import all parameters into the given namespace. | |
1024 | # Assumes namespace 'Q' if not specified | |
1025 | #### | |
1026 | 'import_names' => <<'END_OF_FUNC', | |
1027 | sub import_names { | |
1028 | my($self,$namespace,$delete) = self_or_default(@_); | |
1029 | $namespace = 'Q' unless defined($namespace); | |
1030 | die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::; | |
3538e1d5 | 1031 | if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) { |
424ec8fa GS |
1032 | # can anyone find an easier way to do this? |
1033 | foreach (keys %{"${namespace}::"}) { | |
1034 | local *symbol = "${namespace}::${_}"; | |
1035 | undef $symbol; | |
1036 | undef @symbol; | |
1037 | undef %symbol; | |
54310121 | 1038 | } |
424ec8fa GS |
1039 | } |
1040 | my($param,@value,$var); | |
1041 | foreach $param ($self->param) { | |
1042 | # protect against silly names | |
1043 | ($var = $param)=~tr/a-zA-Z0-9_/_/c; | |
1044 | $var =~ s/^(?=\d)/_/; | |
1045 | local *symbol = "${namespace}::$var"; | |
1046 | @value = $self->param($param); | |
1047 | @symbol = @value; | |
1048 | $symbol = $value[0]; | |
54310121 | 1049 | } |
1050 | } | |
1051 | END_OF_FUNC | |
1052 | ||
1053 | #### Method: keywords | |
1054 | # Keywords acts a bit differently. Calling it in a list context | |
1055 | # returns the list of keywords. | |
1056 | # Calling it in a scalar context gives you the size of the list. | |
1057 | #### | |
1058 | 'keywords' => <<'END_OF_FUNC', | |
1059 | sub keywords { | |
1060 | my($self,@values) = self_or_default(@_); | |
1061 | # If values is provided, then we set it. | |
475342a6 | 1062 | $self->{'keywords'}=[@values] if @values; |
424ec8fa | 1063 | my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : (); |
54310121 | 1064 | @result; |
1065 | } | |
1066 | END_OF_FUNC | |
1067 | ||
1068 | # These are some tie() interfaces for compatibility | |
1069 | # with Steve Brenner's cgi-lib.pl routines | |
3538e1d5 GS |
1070 | 'Vars' => <<'END_OF_FUNC', |
1071 | sub Vars { | |
ffd2dff2 | 1072 | my $q = shift; |
3538e1d5 | 1073 | my %in; |
ffd2dff2 | 1074 | tie(%in,CGI,$q); |
3538e1d5 GS |
1075 | return %in if wantarray; |
1076 | return \%in; | |
1077 | } | |
1078 | END_OF_FUNC | |
1079 | ||
1080 | # These are some tie() interfaces for compatibility | |
1081 | # with Steve Brenner's cgi-lib.pl routines | |
54310121 | 1082 | 'ReadParse' => <<'END_OF_FUNC', |
1083 | sub ReadParse { | |
1084 | local(*in); | |
1085 | if (@_) { | |
1086 | *in = $_[0]; | |
1087 | } else { | |
1088 | my $pkg = caller(); | |
1089 | *in=*{"${pkg}::in"}; | |
1090 | } | |
1091 | tie(%in,CGI); | |
424ec8fa | 1092 | return scalar(keys %in); |
54310121 | 1093 | } |
1094 | END_OF_FUNC | |
1095 | ||
1096 | 'PrintHeader' => <<'END_OF_FUNC', | |
1097 | sub PrintHeader { | |
1098 | my($self) = self_or_default(@_); | |
1099 | return $self->header(); | |
1100 | } | |
1101 | END_OF_FUNC | |
1102 | ||
1103 | 'HtmlTop' => <<'END_OF_FUNC', | |
1104 | sub HtmlTop { | |
1105 | my($self,@p) = self_or_default(@_); | |
1106 | return $self->start_html(@p); | |
1107 | } | |
1108 | END_OF_FUNC | |
1109 | ||
1110 | 'HtmlBot' => <<'END_OF_FUNC', | |
1111 | sub HtmlBot { | |
1112 | my($self,@p) = self_or_default(@_); | |
1113 | return $self->end_html(@p); | |
1114 | } | |
1115 | END_OF_FUNC | |
1116 | ||
1117 | 'SplitParam' => <<'END_OF_FUNC', | |
1118 | sub SplitParam { | |
1119 | my ($param) = @_; | |
1120 | my (@params) = split ("\0", $param); | |
1121 | return (wantarray ? @params : $params[0]); | |
1122 | } | |
1123 | END_OF_FUNC | |
1124 | ||
1125 | 'MethGet' => <<'END_OF_FUNC', | |
1126 | sub MethGet { | |
1127 | return request_method() eq 'GET'; | |
1128 | } | |
1129 | END_OF_FUNC | |
1130 | ||
1131 | 'MethPost' => <<'END_OF_FUNC', | |
1132 | sub MethPost { | |
1133 | return request_method() eq 'POST'; | |
1134 | } | |
1135 | END_OF_FUNC | |
1136 | ||
1137 | 'TIEHASH' => <<'END_OF_FUNC', | |
8f3ccfa2 JH |
1138 | sub TIEHASH { |
1139 | my $class = shift; | |
1140 | my $arg = $_[0]; | |
1141 | if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) { | |
1142 | return $arg; | |
1143 | } | |
1144 | return $Q ||= $class->new(@_); | |
54310121 | 1145 | } |
1146 | END_OF_FUNC | |
1147 | ||
1148 | 'STORE' => <<'END_OF_FUNC', | |
1149 | sub STORE { | |
3d1a2ec4 GS |
1150 | my $self = shift; |
1151 | my $tag = shift; | |
6b4ac661 JH |
1152 | my $vals = shift; |
1153 | my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals; | |
3d1a2ec4 | 1154 | $self->param(-name=>$tag,-value=>\@vals); |
54310121 | 1155 | } |
1156 | END_OF_FUNC | |
1157 | ||
1158 | 'FETCH' => <<'END_OF_FUNC', | |
1159 | sub FETCH { | |
1160 | return $_[0] if $_[1] eq 'CGI'; | |
1161 | return undef unless defined $_[0]->param($_[1]); | |
1162 | return join("\0",$_[0]->param($_[1])); | |
1163 | } | |
1164 | END_OF_FUNC | |
1165 | ||
1166 | 'FIRSTKEY' => <<'END_OF_FUNC', | |
1167 | sub FIRSTKEY { | |
1168 | $_[0]->{'.iterator'}=0; | |
1169 | $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; | |
1170 | } | |
1171 | END_OF_FUNC | |
1172 | ||
1173 | 'NEXTKEY' => <<'END_OF_FUNC', | |
1174 | sub NEXTKEY { | |
1175 | $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; | |
1176 | } | |
1177 | END_OF_FUNC | |
1178 | ||
1179 | 'EXISTS' => <<'END_OF_FUNC', | |
1180 | sub EXISTS { | |
1181 | exists $_[0]->{$_[1]}; | |
1182 | } | |
1183 | END_OF_FUNC | |
1184 | ||
1185 | 'DELETE' => <<'END_OF_FUNC', | |
1186 | sub DELETE { | |
1187 | $_[0]->delete($_[1]); | |
1188 | } | |
1189 | END_OF_FUNC | |
1190 | ||
1191 | 'CLEAR' => <<'END_OF_FUNC', | |
1192 | sub CLEAR { | |
1193 | %{$_[0]}=(); | |
1194 | } | |
1195 | #### | |
1196 | END_OF_FUNC | |
1197 | ||
1198 | #### | |
1199 | # Append a new value to an existing query | |
1200 | #### | |
1201 | 'append' => <<'EOF', | |
1202 | sub append { | |
7dc108d1 | 1203 | my($self,@p) = self_or_default(@_); |
3d1a2ec4 | 1204 | my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p); |
54310121 | 1205 | my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : (); |
1206 | if (@values) { | |
1207 | $self->add_parameter($name); | |
1208 | push(@{$self->{$name}},@values); | |
1209 | } | |
1210 | return $self->param($name); | |
1211 | } | |
1212 | EOF | |
1213 | ||
1214 | #### Method: delete_all | |
1215 | # Delete all parameters | |
1216 | #### | |
1217 | 'delete_all' => <<'EOF', | |
1218 | sub delete_all { | |
1219 | my($self) = self_or_default(@_); | |
1c87da1d | 1220 | my @param = $self->param(); |
8f3ccfa2 | 1221 | $self->delete(@param); |
54310121 | 1222 | } |
1223 | EOF | |
1224 | ||
424ec8fa GS |
1225 | 'Delete' => <<'EOF', |
1226 | sub Delete { | |
1227 | my($self,@p) = self_or_default(@_); | |
1228 | $self->delete(@p); | |
1229 | } | |
1230 | EOF | |
1231 | ||
1232 | 'Delete_all' => <<'EOF', | |
1233 | sub Delete_all { | |
1234 | my($self,@p) = self_or_default(@_); | |
1235 | $self->delete_all(@p); | |
1236 | } | |
1237 | EOF | |
1238 | ||
54310121 | 1239 | #### Method: autoescape |
1240 | # If you want to turn off the autoescaping features, | |
1241 | # call this method with undef as the argument | |
1242 | 'autoEscape' => <<'END_OF_FUNC', | |
1243 | sub autoEscape { | |
1244 | my($self,$escape) = self_or_default(@_); | |
188ba755 JH |
1245 | my $d = $self->{'escape'}; |
1246 | $self->{'escape'} = $escape; | |
1247 | $d; | |
54310121 | 1248 | } |
1249 | END_OF_FUNC | |
1250 | ||
1251 | ||
1252 | #### Method: version | |
1253 | # Return the current version | |
1254 | #### | |
1255 | 'version' => <<'END_OF_FUNC', | |
1256 | sub version { | |
1257 | return $VERSION; | |
1258 | } | |
1259 | END_OF_FUNC | |
1260 | ||
424ec8fa GS |
1261 | #### Method: url_param |
1262 | # Return a parameter in the QUERY_STRING, regardless of | |
1263 | # whether this was a POST or a GET | |
1264 | #### | |
1265 | 'url_param' => <<'END_OF_FUNC', | |
1266 | sub url_param { | |
1267 | my ($self,@p) = self_or_default(@_); | |
1268 | my $name = shift(@p); | |
1269 | return undef unless exists($ENV{QUERY_STRING}); | |
1270 | unless (exists($self->{'.url_param'})) { | |
1271 | $self->{'.url_param'}={}; # empty hash | |
1272 | if ($ENV{QUERY_STRING} =~ /=/) { | |
71f3e297 | 1273 | my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING}); |
424ec8fa GS |
1274 | my($param,$value); |
1275 | foreach (@pairs) { | |
1276 | ($param,$value) = split('=',$_,2); | |
1277 | $param = unescape($param); | |
1278 | $value = unescape($value); | |
1279 | push(@{$self->{'.url_param'}->{$param}},$value); | |
1280 | } | |
1281 | } else { | |
1282 | $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})]; | |
1283 | } | |
1284 | } | |
1285 | return keys %{$self->{'.url_param'}} unless defined($name); | |
1286 | return () unless $self->{'.url_param'}->{$name}; | |
1287 | return wantarray ? @{$self->{'.url_param'}->{$name}} | |
1288 | : $self->{'.url_param'}->{$name}->[0]; | |
1289 | } | |
1290 | END_OF_FUNC | |
1291 | ||
3d1a2ec4 | 1292 | #### Method: Dump |
54310121 | 1293 | # Returns a string in which all the known parameter/value |
1294 | # pairs are represented as nested lists, mainly for the purposes | |
1295 | # of debugging. | |
1296 | #### | |
3d1a2ec4 GS |
1297 | 'Dump' => <<'END_OF_FUNC', |
1298 | sub Dump { | |
54310121 | 1299 | my($self) = self_or_default(@_); |
1300 | my($param,$value,@result); | |
3acbd4f5 JH |
1301 | return '<ul></ul>' unless $self->param; |
1302 | push(@result,"<ul>"); | |
54310121 | 1303 | foreach $param ($self->param) { |
1304 | my($name)=$self->escapeHTML($param); | |
1c87da1d | 1305 | push(@result,"<li><strong>$param</strong></li>"); |
3acbd4f5 | 1306 | push(@result,"<ul>"); |
54310121 | 1307 | foreach $value ($self->param($param)) { |
1308 | $value = $self->escapeHTML($value); | |
58129083 | 1309 | $value =~ s/\n/<br \/>\n/g; |
1c87da1d | 1310 | push(@result,"<li>$value</li>"); |
54310121 | 1311 | } |
3acbd4f5 | 1312 | push(@result,"</ul>"); |
54310121 | 1313 | } |
3acbd4f5 | 1314 | push(@result,"</ul>"); |
54310121 | 1315 | return join("\n",@result); |
1316 | } | |
1317 | END_OF_FUNC | |
1318 | ||
424ec8fa GS |
1319 | #### Method as_string |
1320 | # | |
1321 | # synonym for "dump" | |
1322 | #### | |
1323 | 'as_string' => <<'END_OF_FUNC', | |
1324 | sub as_string { | |
3d1a2ec4 | 1325 | &Dump(@_); |
424ec8fa GS |
1326 | } |
1327 | END_OF_FUNC | |
1328 | ||
1329 | #### Method: save | |
1330 | # Write values out to a filehandle in such a way that they can | |
1331 | # be reinitialized by the filehandle form of the new() method | |
54310121 | 1332 | #### |
1333 | 'save' => <<'END_OF_FUNC', | |
1334 | sub save { | |
1335 | my($self,$filehandle) = self_or_default(@_); | |
54310121 | 1336 | $filehandle = to_filehandle($filehandle); |
424ec8fa GS |
1337 | my($param); |
1338 | local($,) = ''; # set print field separator back to a sane value | |
71f3e297 | 1339 | local($\) = ''; # set output line separator to a sane value |
54310121 | 1340 | foreach $param ($self->param) { |
424ec8fa | 1341 | my($escaped_param) = escape($param); |
54310121 | 1342 | my($value); |
1343 | foreach $value ($self->param($param)) { | |
3538e1d5 | 1344 | print $filehandle "$escaped_param=",escape("$value"),"\n"; |
54310121 | 1345 | } |
1346 | } | |
d45d855d JH |
1347 | foreach (keys %{$self->{'.fieldnames'}}) { |
1348 | print $filehandle ".cgifields=",escape("$_"),"\n"; | |
1349 | } | |
54310121 | 1350 | print $filehandle "=\n"; # end of record |
1351 | } | |
1352 | END_OF_FUNC | |
1353 | ||
1354 | ||
424ec8fa GS |
1355 | #### Method: save_parameters |
1356 | # An alias for save() that is a better name for exportation. | |
1357 | # Only intended to be used with the function (non-OO) interface. | |
1358 | #### | |
1359 | 'save_parameters' => <<'END_OF_FUNC', | |
1360 | sub save_parameters { | |
1361 | my $fh = shift; | |
1362 | return save(to_filehandle($fh)); | |
1363 | } | |
1364 | END_OF_FUNC | |
1365 | ||
1366 | #### Method: restore_parameters | |
1367 | # A way to restore CGI parameters from an initializer. | |
1368 | # Only intended to be used with the function (non-OO) interface. | |
1369 | #### | |
1370 | 'restore_parameters' => <<'END_OF_FUNC', | |
1371 | sub restore_parameters { | |
1372 | $Q = $CGI::DefaultClass->new(@_); | |
1373 | } | |
1374 | END_OF_FUNC | |
1375 | ||
1376 | #### Method: multipart_init | |
1377 | # Return a Content-Type: style header for server-push | |
ba056755 | 1378 | # This has to be NPH on most web servers, and it is advisable to set $| = 1 |
424ec8fa GS |
1379 | # |
1380 | # Many thanks to Ed Jordan <ed@fidalgo.net> for this | |
ba056755 | 1381 | # contribution, updated by Andrew Benham (adsb@bigfoot.com) |
424ec8fa GS |
1382 | #### |
1383 | 'multipart_init' => <<'END_OF_FUNC', | |
1384 | sub multipart_init { | |
1385 | my($self,@p) = self_or_default(@_); | |
3d1a2ec4 | 1386 | my($boundary,@other) = rearrange([BOUNDARY],@p); |
424ec8fa | 1387 | $boundary = $boundary || '------- =_aaaaaaaaaa0'; |
ba056755 JH |
1388 | $self->{'separator'} = "$CRLF--$boundary$CRLF"; |
1389 | $self->{'final_separator'} = "$CRLF--$boundary--$CRLF"; | |
424ec8fa GS |
1390 | $type = SERVER_PUSH($boundary); |
1391 | return $self->header( | |
13548fdf | 1392 | -nph => 0, |
424ec8fa GS |
1393 | -type => $type, |
1394 | (map { split "=", $_, 2 } @other), | |
ba056755 | 1395 | ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end; |
424ec8fa GS |
1396 | } |
1397 | END_OF_FUNC | |
1398 | ||
1399 | ||
1400 | #### Method: multipart_start | |
1401 | # Return a Content-Type: style header for server-push, start of section | |
1402 | # | |
1403 | # Many thanks to Ed Jordan <ed@fidalgo.net> for this | |
ba056755 | 1404 | # contribution, updated by Andrew Benham (adsb@bigfoot.com) |
424ec8fa GS |
1405 | #### |
1406 | 'multipart_start' => <<'END_OF_FUNC', | |
1407 | sub multipart_start { | |
ba056755 | 1408 | my(@header); |
424ec8fa | 1409 | my($self,@p) = self_or_default(@_); |
3d1a2ec4 | 1410 | my($type,@other) = rearrange([TYPE],@p); |
424ec8fa | 1411 | $type = $type || 'text/html'; |
ba056755 JH |
1412 | push(@header,"Content-Type: $type"); |
1413 | ||
1414 | # rearrange() was designed for the HTML portion, so we | |
1415 | # need to fix it up a little. | |
1416 | foreach (@other) { | |
8f3ccfa2 JH |
1417 | # Don't use \s because of perl bug 21951 |
1418 | next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/; | |
ba056755 JH |
1419 | ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e; |
1420 | } | |
1421 | push(@header,@other); | |
1422 | my $header = join($CRLF,@header)."${CRLF}${CRLF}"; | |
1423 | return $header; | |
424ec8fa GS |
1424 | } |
1425 | END_OF_FUNC | |
1426 | ||
1427 | ||
1428 | #### Method: multipart_end | |
ba056755 | 1429 | # Return a MIME boundary separator for server-push, end of section |
424ec8fa GS |
1430 | # |
1431 | # Many thanks to Ed Jordan <ed@fidalgo.net> for this | |
1432 | # contribution | |
1433 | #### | |
1434 | 'multipart_end' => <<'END_OF_FUNC', | |
1435 | sub multipart_end { | |
1436 | my($self,@p) = self_or_default(@_); | |
1437 | return $self->{'separator'}; | |
1438 | } | |
1439 | END_OF_FUNC | |
1440 | ||
1441 | ||
ba056755 JH |
1442 | #### Method: multipart_final |
1443 | # Return a MIME boundary separator for server-push, end of all sections | |
1444 | # | |
1445 | # Contributed by Andrew Benham (adsb@bigfoot.com) | |
1446 | #### | |
1447 | 'multipart_final' => <<'END_OF_FUNC', | |
1448 | sub multipart_final { | |
1449 | my($self,@p) = self_or_default(@_); | |
1450 | return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF; | |
1451 | } | |
1452 | END_OF_FUNC | |
1453 | ||
1454 | ||
54310121 | 1455 | #### Method: header |
1456 | # Return a Content-Type: style header | |
1457 | # | |
1458 | #### | |
1459 | 'header' => <<'END_OF_FUNC', | |
1460 | sub header { | |
1461 | my($self,@p) = self_or_default(@_); | |
1462 | my(@header); | |
1463 | ||
2ed511ec | 1464 | return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE; |
71f3e297 | 1465 | |
8f3ccfa2 | 1466 | my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) = |
3d1a2ec4 GS |
1467 | rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], |
1468 | 'STATUS',['COOKIE','COOKIES'],'TARGET', | |
6b4ac661 | 1469 | 'EXPIRES','NPH','CHARSET', |
8f3ccfa2 | 1470 | 'ATTACHMENT','P3P'],@p); |
3d1a2ec4 GS |
1471 | |
1472 | $nph ||= $NPH; | |
55b5d700 SP |
1473 | |
1474 | $type ||= 'text/html' unless defined($type); | |
1475 | ||
3d1a2ec4 GS |
1476 | if (defined $charset) { |
1477 | $self->charset($charset); | |
1478 | } else { | |
55b5d700 | 1479 | $charset = $self->charset if $type =~ /^text\//; |
3d1a2ec4 | 1480 | } |
cb3b230c | 1481 | $charset ||= ''; |
54310121 | 1482 | |
1483 | # rearrange() was designed for the HTML portion, so we | |
1484 | # need to fix it up a little. | |
1485 | foreach (@other) { | |
8f3ccfa2 JH |
1486 | # Don't use \s because of perl bug 21951 |
1487 | next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/; | |
1488 | ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e; | |
54310121 | 1489 | } |
1490 | ||
cd755de4 JJ |
1491 | $type .= "; charset=$charset" |
1492 | if $type ne '' | |
1493 | and $type !~ /\bcharset\b/ | |
1494 | and defined $charset | |
1495 | and $charset ne ''; | |
54310121 | 1496 | |
424ec8fa GS |
1497 | # Maybe future compatibility. Maybe not. |
1498 | my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; | |
1499 | push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph; | |
ba056755 | 1500 | push(@header,"Server: " . &server_software()) if $nph; |
424ec8fa | 1501 | |
54310121 | 1502 | push(@header,"Status: $status") if $status; |
424ec8fa | 1503 | push(@header,"Window-Target: $target") if $target; |
8f3ccfa2 JH |
1504 | if ($p3p) { |
1505 | $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY'; | |
1506 | push(@header,qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p")); | |
1507 | } | |
54310121 | 1508 | # push all the cookies -- there may be several |
1509 | if ($cookie) { | |
424ec8fa | 1510 | my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie; |
54310121 | 1511 | foreach (@cookie) { |
71f3e297 JH |
1512 | my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_; |
1513 | push(@header,"Set-Cookie: $cs") if $cs ne ''; | |
54310121 | 1514 | } |
1515 | } | |
1516 | # if the user indicates an expiration time, then we need | |
1517 | # both an Expires and a Date header (so that the browser is | |
1518 | # uses OUR clock) | |
424ec8fa | 1519 | push(@header,"Expires: " . expires($expires,'http')) |
7d37aa8e | 1520 | if $expires; |
ba056755 | 1521 | push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph; |
54310121 | 1522 | push(@header,"Pragma: no-cache") if $self->cache(); |
6b4ac661 | 1523 | push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment; |
69c89ae7 | 1524 | push(@header,map {ucfirst $_} @other); |
71f3e297 | 1525 | push(@header,"Content-Type: $type") if $type ne ''; |
424ec8fa | 1526 | my $header = join($CRLF,@header)."${CRLF}${CRLF}"; |
ead6d9e1 | 1527 | if (($MOD_PERL >= 1) && !$nph) { |
8f3ccfa2 JH |
1528 | $self->r->send_cgi_header($header); |
1529 | return ''; | |
424ec8fa GS |
1530 | } |
1531 | return $header; | |
54310121 | 1532 | } |
1533 | END_OF_FUNC | |
1534 | ||
1535 | ||
1536 | #### Method: cache | |
1537 | # Control whether header() will produce the no-cache | |
1538 | # Pragma directive. | |
1539 | #### | |
1540 | 'cache' => <<'END_OF_FUNC', | |
1541 | sub cache { | |
1542 | my($self,$new_value) = self_or_default(@_); | |
1543 | $new_value = '' unless $new_value; | |
1544 | if ($new_value ne '') { | |
1545 | $self->{'cache'} = $new_value; | |
1546 | } | |
1547 | return $self->{'cache'}; | |
1548 | } | |
1549 | END_OF_FUNC | |
1550 | ||
1551 | ||
1552 | #### Method: redirect | |
1553 | # Return a Location: style header | |
1554 | # | |
1555 | #### | |
1556 | 'redirect' => <<'END_OF_FUNC', | |
1557 | sub redirect { | |
1558 | my($self,@p) = self_or_default(@_); | |
13548fdf RGS |
1559 | my($url,$target,$status,$cookie,$nph,@other) = |
1560 | rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p); | |
55b5d700 | 1561 | $status = '302 Found' unless defined $status; |
6b4ac661 | 1562 | $url ||= $self->self_url; |
54310121 | 1563 | my(@o); |
424ec8fa GS |
1564 | foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); } |
1565 | unshift(@o, | |
13548fdf | 1566 | '-Status' => $status, |
8f3ccfa2 JH |
1567 | '-Location'=> $url, |
1568 | '-nph' => $nph); | |
424ec8fa | 1569 | unshift(@o,'-Target'=>$target) if $target; |
71f3e297 | 1570 | unshift(@o,'-Type'=>''); |
8f3ccfa2 JH |
1571 | my @unescaped; |
1572 | unshift(@unescaped,'-Cookie'=>$cookie) if $cookie; | |
1573 | return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped); | |
54310121 | 1574 | } |
1575 | END_OF_FUNC | |
1576 | ||
1577 | ||
1578 | #### Method: start_html | |
1579 | # Canned HTML header | |
1580 | # | |
1581 | # Parameters: | |
1582 | # $title -> (optional) The title for this HTML document (-title) | |
1583 | # $author -> (optional) e-mail address of the author (-author) | |
1584 | # $base -> (optional) if set to true, will enter the BASE address of this document | |
1585 | # for resolving relative references (-base) | |
1586 | # $xbase -> (optional) alternative base at some remote location (-xbase) | |
1587 | # $target -> (optional) target window to load all links into (-target) | |
1588 | # $script -> (option) Javascript code (-script) | |
47e3cabd | 1589 | # $no_script -> (option) Javascript <noscript> tag (-noscript) |
54310121 | 1590 | # $meta -> (optional) Meta information tags |
3acbd4f5 | 1591 | # $head -> (optional) any other elements you'd like to incorporate into the <head> tag |
7d37aa8e LS |
1592 | # (a scalar or array ref) |
1593 | # $style -> (optional) reference to an external style sheet | |
54310121 | 1594 | # @other -> (optional) any other named parameters you'd like to incorporate into |
3acbd4f5 | 1595 | # the <body> tag. |
54310121 | 1596 | #### |
1597 | 'start_html' => <<'END_OF_FUNC', | |
1598 | sub start_html { | |
1599 | my($self,@p) = &self_or_default(@_); | |
ac734d8b | 1600 | my($title,$author,$base,$xbase,$script,$noscript, |
29ddc2a4 RGS |
1601 | $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) = |
1602 | rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET, | |
1603 | META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p); | |
1604 | ||
1605 | $self->element_id(0); | |
1606 | $self->element_tab(0); | |
ac734d8b | 1607 | |
55b5d700 | 1608 | $encoding = lc($self->charset) unless defined $encoding; |
54310121 | 1609 | |
13548fdf | 1610 | # Need to sort out the DTD before it's okay to call escapeHTML(). |
ba056755 | 1611 | my(@result,$xml_dtd); |
3d1a2ec4 | 1612 | if ($dtd) { |
6b4ac661 | 1613 | if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) { |
3d1a2ec4 GS |
1614 | $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|; |
1615 | } else { | |
1616 | $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|; | |
1617 | } | |
1618 | } else { | |
6b4ac661 | 1619 | $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD; |
3d1a2ec4 | 1620 | } |
ba056755 JH |
1621 | |
1622 | $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i; | |
1623 | $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i; | |
29ddc2a4 | 1624 | push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml; |
ba056755 | 1625 | |
3d1a2ec4 | 1626 | if (ref($dtd) && ref($dtd) eq 'ARRAY') { |
b2d0d414 | 1627 | push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">)); |
13548fdf | 1628 | $DTD_PUBLIC_IDENTIFIER = $dtd->[0]; |
3d1a2ec4 | 1629 | } else { |
03b9648d | 1630 | push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">)); |
13548fdf RGS |
1631 | $DTD_PUBLIC_IDENTIFIER = $dtd; |
1632 | } | |
1633 | ||
1634 | # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to | |
1635 | # call escapeHTML(). Strangely enough, the title needs to be escaped as | |
1636 | # HTML while the author needs to be escaped as a URL. | |
1637 | $title = $self->escapeHTML($title || 'Untitled Document'); | |
1638 | $author = $self->escape($author); | |
1639 | ||
1640 | if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2)/i) { | |
1641 | $lang = "" unless defined $lang; | |
1642 | $XHTML = 0; | |
3d1a2ec4 | 1643 | } |
13548fdf RGS |
1644 | else { |
1645 | $lang = 'en-US' unless defined $lang; | |
1646 | } | |
1647 | ||
29ddc2a4 RGS |
1648 | my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : ''; |
1649 | my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />) | |
1650 | if $XHTML && $encoding && !$declare_xml; | |
1651 | ||
1652 | push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>) | |
1653 | : ($lang ? qq(<html lang="$lang">) : "<html>") | |
8f3ccfa2 | 1654 | . "<head><title>$title</title>"); |
6b4ac661 JH |
1655 | if (defined $author) { |
1656 | push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />" | |
29ddc2a4 | 1657 | : "<link rev=\"made\" href=\"mailto:$author\">"); |
6b4ac661 | 1658 | } |
54310121 | 1659 | |
1660 | if ($base || $xbase || $target) { | |
424ec8fa | 1661 | my $href = $xbase || $self->url('-path'=>1); |
6b4ac661 JH |
1662 | my $t = $target ? qq/ target="$target"/ : ''; |
1663 | push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>)); | |
54310121 | 1664 | } |
1665 | ||
1666 | if ($meta && ref($meta) && (ref($meta) eq 'HASH')) { | |
6b4ac661 JH |
1667 | foreach (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />) |
1668 | : qq(<meta name="$_" content="$meta->{$_}">)); } | |
54310121 | 1669 | } |
7d37aa8e LS |
1670 | |
1671 | push(@result,ref($head) ? @$head : $head) if $head; | |
1672 | ||
424ec8fa | 1673 | # handle the infrequently-used -style and -script parameters |
13548fdf | 1674 | push(@result,$self->_style($style)) if defined $style; |
424ec8fa | 1675 | push(@result,$self->_script($script)) if defined $script; |
29ddc2a4 | 1676 | push(@result,$meta_bits) if defined $meta_bits; |
424ec8fa GS |
1677 | |
1678 | # handle -noscript parameter | |
1679 | push(@result,<<END) if $noscript; | |
6b4ac661 | 1680 | <noscript> |
424ec8fa | 1681 | $noscript |
6b4ac661 | 1682 | </noscript> |
424ec8fa GS |
1683 | END |
1684 | ; | |
1685 | my($other) = @other ? " @other" : ''; | |
29ddc2a4 | 1686 | push(@result,"</head>\n<body$other>\n"); |
424ec8fa GS |
1687 | return join("\n",@result); |
1688 | } | |
1689 | END_OF_FUNC | |
1690 | ||
1691 | ### Method: _style | |
1692 | # internal method for generating a CSS style section | |
1693 | #### | |
1694 | '_style' => <<'END_OF_FUNC', | |
1695 | sub _style { | |
1696 | my ($self,$style) = @_; | |
1697 | my (@result); | |
8869a4b7 | 1698 | |
424ec8fa | 1699 | my $type = 'text/css'; |
0664a57d | 1700 | my $rel = 'stylesheet'; |
a3b3a725 | 1701 | |
8869a4b7 | 1702 | |
a3b3a725 JH |
1703 | my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- "; |
1704 | my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n"; | |
1705 | ||
13548fdf | 1706 | my @s = ref($style) eq 'ARRAY' ? @$style : $style; |
bb8b3399 | 1707 | my $other = ''; |
13548fdf RGS |
1708 | |
1709 | for my $s (@s) { | |
1710 | if (ref($s)) { | |
0664a57d SP |
1711 | my($src,$code,$verbatim,$stype,$alternate,$foo,@other) = |
1712 | rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)], | |
13548fdf RGS |
1713 | ('-foo'=>'bar', |
1714 | ref($s) eq 'ARRAY' ? @$s : %$s)); | |
8869a4b7 SP |
1715 | my $type = defined $stype ? $stype : 'text/css'; |
1716 | my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet'; | |
bb8b3399 | 1717 | $other = "@other" if @other; |
13548fdf RGS |
1718 | |
1719 | if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference | |
1720 | { # If it is, push a LINK tag for each one | |
1721 | foreach $src (@$src) | |
1722 | { | |
0664a57d SP |
1723 | push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>) |
1724 | : qq(<link rel="$rel" type="$type" href="$src"$other>)) if $src; | |
13548fdf | 1725 | } |
6b4ac661 | 1726 | } |
13548fdf RGS |
1727 | else |
1728 | { # Otherwise, push the single -src, if it exists. | |
0664a57d SP |
1729 | push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>) |
1730 | : qq(<link rel="$rel" type="$type" href="$src"$other>) | |
13548fdf RGS |
1731 | ) if $src; |
1732 | } | |
1733 | if ($verbatim) { | |
1734 | my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim; | |
1735 | push(@result, "<style type=\"text/css\">\n$_\n</style>") foreach @v; | |
1736 | } | |
1737 | my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code; | |
1738 | push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) foreach @c; | |
1739 | ||
1740 | } else { | |
1741 | my $src = $s; | |
0664a57d SP |
1742 | push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>) |
1743 | : qq(<link rel="$rel" type="$type" href="$src"$other>)); | |
13548fdf | 1744 | } |
7d37aa8e | 1745 | } |
424ec8fa GS |
1746 | @result; |
1747 | } | |
1748 | END_OF_FUNC | |
1749 | ||
424ec8fa GS |
1750 | '_script' => <<'END_OF_FUNC', |
1751 | sub _script { | |
1752 | my ($self,$script) = @_; | |
1753 | my (@result); | |
a3b3a725 | 1754 | |
424ec8fa GS |
1755 | my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script); |
1756 | foreach $script (@scripts) { | |
7d37aa8e LS |
1757 | my($src,$code,$language); |
1758 | if (ref($script)) { # script is a hash | |
8869a4b7 SP |
1759 | ($src,$code,$type) = |
1760 | rearrange(['SRC','CODE',['LANGUAGE','TYPE']], | |
7d37aa8e | 1761 | '-foo'=>'bar', # a trick to allow the '-' to be omitted |
3538e1d5 | 1762 | ref($script) eq 'ARRAY' ? @$script : %$script); |
8869a4b7 SP |
1763 | $type ||= 'text/javascript'; |
1764 | unless ($type =~ m!\w+/\w+!) { | |
1765 | $type =~ s/[\d.]+$//; | |
1766 | $type = "text/$type"; | |
3d1a2ec4 | 1767 | } |
7d37aa8e | 1768 | } else { |
8869a4b7 | 1769 | ($src,$code,$type) = ('',$script, 'text/javascript'); |
7d37aa8e | 1770 | } |
a3b3a725 JH |
1771 | |
1772 | my $comment = '//'; # javascript by default | |
1773 | $comment = '#' if $type=~/perl|tcl/i; | |
1774 | $comment = "'" if $type=~/vbscript/i; | |
1775 | ||
58129083 JH |
1776 | my ($cdata_start,$cdata_end); |
1777 | if ($XHTML) { | |
1778 | $cdata_start = "$comment<![CDATA[\n"; | |
1779 | $cdata_end .= "\n$comment]]>"; | |
1780 | } else { | |
1781 | $cdata_start = "\n<!-- Hide script\n"; | |
1782 | $cdata_end = $comment; | |
1783 | $cdata_end .= " End script hiding -->\n"; | |
1784 | } | |
1785 | my(@satts); | |
1786 | push(@satts,'src'=>$src) if $src; | |
58129083 | 1787 | push(@satts,'type'=>$type); |
29ddc2a4 RGS |
1788 | $code = $cdata_start . $code . $cdata_end if defined $code; |
1789 | push(@result,$self->script({@satts},$code || '')); | |
7d37aa8e | 1790 | } |
424ec8fa | 1791 | @result; |
54310121 | 1792 | } |
1793 | END_OF_FUNC | |
1794 | ||
54310121 | 1795 | #### Method: end_html |
1796 | # End an HTML document. | |
3acbd4f5 | 1797 | # Trivial method for completeness. Just returns "</body>" |
54310121 | 1798 | #### |
1799 | 'end_html' => <<'END_OF_FUNC', | |
1800 | sub end_html { | |
29ddc2a4 | 1801 | return "\n</body>\n</html>"; |
54310121 | 1802 | } |
1803 | END_OF_FUNC | |
1804 | ||
1805 | ||
1806 | ################################ | |
1807 | # METHODS USED IN BUILDING FORMS | |
1808 | ################################ | |
1809 | ||
1810 | #### Method: isindex | |
1811 | # Just prints out the isindex tag. | |
1812 | # Parameters: | |
1813 | # $action -> optional URL of script to run | |
1814 | # Returns: | |
188ba755 | 1815 | # A string containing a <isindex> tag |
54310121 | 1816 | 'isindex' => <<'END_OF_FUNC', |
1817 | sub isindex { | |
1818 | my($self,@p) = self_or_default(@_); | |
3d1a2ec4 | 1819 | my($action,@other) = rearrange([ACTION],@p); |
188ba755 | 1820 | $action = qq/ action="$action"/ if $action; |
54310121 | 1821 | my($other) = @other ? " @other" : ''; |
188ba755 | 1822 | return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>"; |
54310121 | 1823 | } |
1824 | END_OF_FUNC | |
1825 | ||
1826 | ||
1827 | #### Method: startform | |
1828 | # Start a form | |
1829 | # Parameters: | |
1830 | # $method -> optional submission method to use (GET or POST) | |
1831 | # $action -> optional URL of script to run | |
1832 | # $enctype ->encoding to use (URL_ENCODED or MULTIPART) | |
1833 | 'startform' => <<'END_OF_FUNC', | |
1834 | sub startform { | |
1835 | my($self,@p) = self_or_default(@_); | |
1836 | ||
1837 | my($method,$action,$enctype,@other) = | |
3d1a2ec4 | 1838 | rearrange([METHOD,ACTION,ENCTYPE],@p); |
54310121 | 1839 | |
89cc8928 | 1840 | $method = $self->escapeHTML(($method) ? lc($method) : 'post'); |
13548fdf RGS |
1841 | $enctype = $self->escapeHTML($enctype || &URL_ENCODED); |
1842 | if (defined $action) { | |
1843 | $action = $self->escapeHTML($action); | |
1844 | } | |
1845 | else { | |
0664a57d | 1846 | $action = $self->escapeHTML($self->request_uri || $self->self_url); |
03b9648d JH |
1847 | } |
1848 | $action = qq(action="$action"); | |
54310121 | 1849 | my($other) = @other ? " @other" : ''; |
1850 | $self->{'.parametersToAdd'}={}; | |
6b4ac661 | 1851 | return qq/<form method="$method" $action enctype="$enctype"$other>\n/; |
54310121 | 1852 | } |
1853 | END_OF_FUNC | |
1854 | ||
1855 | ||
1856 | #### Method: start_form | |
1857 | # synonym for startform | |
1858 | 'start_form' => <<'END_OF_FUNC', | |
1859 | sub start_form { | |
29ddc2a4 | 1860 | $XHTML ? &start_multipart_form : &startform; |
54310121 | 1861 | } |
1862 | END_OF_FUNC | |
1863 | ||
71f3e297 JH |
1864 | 'end_multipart_form' => <<'END_OF_FUNC', |
1865 | sub end_multipart_form { | |
1866 | &endform; | |
1867 | } | |
1868 | END_OF_FUNC | |
54310121 | 1869 | |
1870 | #### Method: start_multipart_form | |
1871 | # synonym for startform | |
1872 | 'start_multipart_form' => <<'END_OF_FUNC', | |
1873 | sub start_multipart_form { | |
1874 | my($self,@p) = self_or_default(@_); | |
0a9bdad4 | 1875 | if (defined($p[0]) && substr($p[0],0,1) eq '-') { |
adb86593 | 1876 | return $self->startform(-enctype=>&MULTIPART,@p); |
54310121 | 1877 | } else { |
1878 | my($method,$action,@other) = | |
3d1a2ec4 | 1879 | rearrange([METHOD,ACTION],@p); |
54310121 | 1880 | return $self->startform($method,$action,&MULTIPART,@other); |
1881 | } | |
1882 | } | |
1883 | END_OF_FUNC | |
1884 | ||
1885 | ||
1886 | #### Method: endform | |
1887 | # End a form | |
1888 | 'endform' => <<'END_OF_FUNC', | |
1889 | sub endform { | |
0a9bdad4 | 1890 | my($self,@p) = self_or_default(@_); |
3d1a2ec4 | 1891 | if ( $NOSTICKY ) { |
6b4ac661 | 1892 | return wantarray ? ("</form>") : "\n</form>"; |
3d1a2ec4 | 1893 | } else { |
0a9bdad4 SP |
1894 | if (my @fields = $self->get_fields) { |
1895 | return wantarray ? ("<div>",@fields,"</div>","</form>") | |
1896 | : "<div>".(join '',@fields)."</div>\n</form>"; | |
1897 | } else { | |
1898 | return "</form>"; | |
1899 | } | |
3d1a2ec4 | 1900 | } |
54310121 | 1901 | } |
1902 | END_OF_FUNC | |
1903 | ||
1904 | ||
424ec8fa GS |
1905 | '_textfield' => <<'END_OF_FUNC', |
1906 | sub _textfield { | |
1907 | my($self,$tag,@p) = self_or_default(@_); | |
29ddc2a4 RGS |
1908 | my($name,$default,$size,$maxlength,$override,$tabindex,@other) = |
1909 | rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p); | |
424ec8fa GS |
1910 | |
1911 | my $current = $override ? $default : | |
1912 | (defined($self->param($name)) ? $self->param($name) : $default); | |
1913 | ||
a3b3a725 | 1914 | $current = defined($current) ? $self->escapeHTML($current,1) : ''; |
424ec8fa | 1915 | $name = defined($name) ? $self->escapeHTML($name) : ''; |
ba056755 JH |
1916 | my($s) = defined($size) ? qq/ size="$size"/ : ''; |
1917 | my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : ''; | |
71f3e297 JH |
1918 | my($other) = @other ? " @other" : ''; |
1919 | # this entered at cristy's request to fix problems with file upload fields | |
1920 | # and WebTV -- not sure it won't break stuff | |
6b4ac661 | 1921 | my($value) = $current ne '' ? qq(value="$current") : ''; |
29ddc2a4 | 1922 | $tabindex = $self->element_tab($tabindex); |
0a9bdad4 | 1923 | return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />) |
b2d0d414 | 1924 | : qq(<input type="$tag" name="$name" $value$s$m$other>); |
424ec8fa GS |
1925 | } |
1926 | END_OF_FUNC | |
1927 | ||
54310121 | 1928 | #### Method: textfield |
1929 | # Parameters: | |
1930 | # $name -> Name of the text field | |
1931 | # $default -> Optional default value of the field if not | |
1932 | # already defined. | |
1933 | # $size -> Optional width of field in characaters. | |
1934 | # $maxlength -> Optional maximum number of characters. | |
1935 | # Returns: | |
188ba755 | 1936 | # A string containing a <input type="text"> field |
54310121 | 1937 | # |
1938 | 'textfield' => <<'END_OF_FUNC', | |
1939 | sub textfield { | |
1940 | my($self,@p) = self_or_default(@_); | |
424ec8fa | 1941 | $self->_textfield('text',@p); |
54310121 | 1942 | } |
1943 | END_OF_FUNC | |
1944 | ||
1945 | ||
1946 | #### Method: filefield | |
1947 | # Parameters: | |
1948 | # $name -> Name of the file upload field | |
1949 | # $size -> Optional width of field in characaters. | |
1950 | # $maxlength -> Optional maximum number of characters. | |
1951 | # Returns: | |
188ba755 | 1952 | # A string containing a <input type="file"> field |
54310121 | 1953 | # |
1954 | 'filefield' => <<'END_OF_FUNC', | |
1955 | sub filefield { | |
1956 | my($self,@p) = self_or_default(@_); | |
424ec8fa | 1957 | $self->_textfield('file',@p); |
54310121 | 1958 | } |
1959 | END_OF_FUNC | |
1960 | ||
1961 | ||
1962 | #### Method: password | |
1963 | # Create a "secret password" entry field | |
1964 | # Parameters: | |
1965 | # $name -> Name of the field | |
1966 | # $default -> Optional default value of the field if not | |
1967 | # already defined. | |
1968 | # $size -> Optional width of field in characters. | |
1969 | # $maxlength -> Optional maximum characters that can be entered. | |
1970 | # Returns: | |
188ba755 | 1971 | # A string containing a <input type="password"> field |
54310121 | 1972 | # |
1973 | 'password_field' => <<'END_OF_FUNC', | |
1974 | sub password_field { | |
1975 | my ($self,@p) = self_or_default(@_); | |
424ec8fa | 1976 | $self->_textfield('password',@p); |
54310121 | 1977 | } |
1978 | END_OF_FUNC | |
1979 | ||
54310121 | 1980 | #### Method: textarea |
1981 | # Parameters: | |
1982 | # $name -> Name of the text field | |
1983 | # $default -> Optional default value of the field if not | |
1984 | # already defined. | |
1985 | # $rows -> Optional number of rows in text area | |
1986 | # $columns -> Optional number of columns in text area | |
1987 | # Returns: | |
3acbd4f5 | 1988 | # A string containing a <textarea></textarea> tag |
54310121 | 1989 | # |
1990 | 'textarea' => <<'END_OF_FUNC', | |
1991 | sub textarea { | |
1992 | my($self,@p) = self_or_default(@_); | |
29ddc2a4 RGS |
1993 | my($name,$default,$rows,$cols,$override,$tabindex,@other) = |
1994 | rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p); | |
54310121 | 1995 | |
1996 | my($current)= $override ? $default : | |
1997 | (defined($self->param($name)) ? $self->param($name) : $default); | |
1998 | ||
1999 | $name = defined($name) ? $self->escapeHTML($name) : ''; | |
2000 | $current = defined($current) ? $self->escapeHTML($current) : ''; | |
3acbd4f5 JH |
2001 | my($r) = $rows ? qq/ rows="$rows"/ : ''; |
2002 | my($c) = $cols ? qq/ cols="$cols"/ : ''; | |
54310121 | 2003 | my($other) = @other ? " @other" : ''; |
29ddc2a4 | 2004 | $tabindex = $self->element_tab($tabindex); |
0a9bdad4 | 2005 | return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>}; |
54310121 | 2006 | } |
2007 | END_OF_FUNC | |
2008 | ||
2009 | ||
2010 | #### Method: button | |
2011 | # Create a javascript button. | |
2012 | # Parameters: | |
2013 | # $name -> (optional) Name for the button. (-name) | |
2014 | # $value -> (optional) Value of the button when selected (and visible name) (-value) | |
2015 | # $onclick -> (optional) Text of the JavaScript to run when the button is | |
2016 | # clicked. | |
2017 | # Returns: | |
188ba755 | 2018 | # A string containing a <input type="button"> tag |
54310121 | 2019 | #### |
2020 | 'button' => <<'END_OF_FUNC', | |
2021 | sub button { | |
2022 | my($self,@p) = self_or_default(@_); | |
2023 | ||
29ddc2a4 RGS |
2024 | my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL], |
2025 | [ONCLICK,SCRIPT],TABINDEX],@p); | |
54310121 | 2026 | |
2027 | $label=$self->escapeHTML($label); | |
a3b3a725 | 2028 | $value=$self->escapeHTML($value,1); |
54310121 | 2029 | $script=$self->escapeHTML($script); |
2030 | ||
2031 | my($name) = ''; | |
ba056755 | 2032 | $name = qq/ name="$label"/ if $label; |
54310121 | 2033 | $value = $value || $label; |
2034 | my($val) = ''; | |
6b4ac661 JH |
2035 | $val = qq/ value="$value"/ if $value; |
2036 | $script = qq/ onclick="$script"/ if $script; | |
54310121 | 2037 | my($other) = @other ? " @other" : ''; |
29ddc2a4 | 2038 | $tabindex = $self->element_tab($tabindex); |
0a9bdad4 | 2039 | return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />) |
b2d0d414 | 2040 | : qq(<input type="button"$name$val$script$other>); |
54310121 | 2041 | } |
2042 | END_OF_FUNC | |
2043 | ||
2044 | ||
2045 | #### Method: submit | |
2046 | # Create a "submit query" button. | |
2047 | # Parameters: | |
2048 | # $name -> (optional) Name for the button. | |
2049 | # $value -> (optional) Value of the button when selected (also doubles as label). | |
2050 | # $label -> (optional) Label printed on the button(also doubles as the value). | |
2051 | # Returns: | |
188ba755 | 2052 | # A string containing a <input type="submit"> tag |
54310121 | 2053 | #### |
2054 | 'submit' => <<'END_OF_FUNC', | |
2055 | sub submit { | |
2056 | my($self,@p) = self_or_default(@_); | |
2057 | ||
29ddc2a4 | 2058 | my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p); |
54310121 | 2059 | |
2060 | $label=$self->escapeHTML($label); | |
a3b3a725 | 2061 | $value=$self->escapeHTML($value,1); |
54310121 | 2062 | |
0a9bdad4 SP |
2063 | my $name = $NOSTICKY ? '' : 'name=".submit" '; |
2064 | $name = qq/name="$label" / if defined($label); | |
424ec8fa | 2065 | $value = defined($value) ? $value : $label; |
8f3ccfa2 | 2066 | my $val = ''; |
0a9bdad4 | 2067 | $val = qq/value="$value" / if defined($value); |
29ddc2a4 | 2068 | $tabindex = $self->element_tab($tabindex); |
0a9bdad4 SP |
2069 | my($other) = @other ? "@other " : ''; |
2070 | return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>) | |
2071 | : qq(<input type="submit" $name$val$other>); | |
54310121 | 2072 | } |
2073 | END_OF_FUNC | |
2074 | ||
2075 | ||
2076 | #### Method: reset | |
2077 | # Create a "reset" button. | |
2078 | # Parameters: | |
2079 | # $name -> (optional) Name for the button. | |
2080 | # Returns: | |
188ba755 | 2081 | # A string containing a <input type="reset"> tag |
54310121 | 2082 | #### |
2083 | 'reset' => <<'END_OF_FUNC', | |
2084 | sub reset { | |
2085 | my($self,@p) = self_or_default(@_); | |
29ddc2a4 | 2086 | my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p); |
54310121 | 2087 | $label=$self->escapeHTML($label); |
8f3ccfa2 JH |
2088 | $value=$self->escapeHTML($value,1); |
2089 | my ($name) = ' name=".reset"'; | |
2090 | $name = qq/ name="$label"/ if defined($label); | |
2091 | $value = defined($value) ? $value : $label; | |
2092 | my($val) = ''; | |
2093 | $val = qq/ value="$value"/ if defined($value); | |
54310121 | 2094 | my($other) = @other ? " @other" : ''; |
29ddc2a4 | 2095 | $tabindex = $self->element_tab($tabindex); |
0a9bdad4 | 2096 | return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />) |
8f3ccfa2 | 2097 | : qq(<input type="reset"$name$val$other>); |
54310121 | 2098 | } |
2099 | END_OF_FUNC | |
2100 | ||
2101 | ||
2102 | #### Method: defaults | |
2103 | # Create a "defaults" button. | |
2104 | # Parameters: | |
2105 | # $name -> (optional) Name for the button. | |
2106 | # Returns: | |
188ba755 | 2107 | # A string containing a <input type="submit" name=".defaults"> tag |
54310121 | 2108 | # |
2109 | # Note: this button has a special meaning to the initialization script, | |
2110 | # and tells it to ERASE the current query string so that your defaults | |
2111 | # are used again! | |
2112 | #### | |
2113 | 'defaults' => <<'END_OF_FUNC', | |
2114 | sub defaults { | |
2115 | my($self,@p) = self_or_default(@_); | |
2116 | ||
29ddc2a4 | 2117 | my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p); |
54310121 | 2118 | |
a3b3a725 | 2119 | $label=$self->escapeHTML($label,1); |
54310121 | 2120 | $label = $label || "Defaults"; |
6b4ac661 | 2121 | my($value) = qq/ value="$label"/; |
54310121 | 2122 | my($other) = @other ? " @other" : ''; |
29ddc2a4 | 2123 | $tabindex = $self->element_tab($tabindex); |
0a9bdad4 | 2124 | return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />) |
6b4ac661 | 2125 | : qq/<input type="submit" NAME=".defaults"$value$other>/; |
54310121 | 2126 | } |
2127 | END_OF_FUNC | |
2128 | ||
2129 | ||
424ec8fa GS |
2130 | #### Method: comment |
2131 | # Create an HTML <!-- comment --> | |
2132 | # Parameters: a string | |
2133 | 'comment' => <<'END_OF_FUNC', | |
2134 | sub comment { | |
2135 | my($self,@p) = self_or_CGI(@_); | |
2136 | return "<!-- @p -->"; | |
2137 | } | |
2138 | END_OF_FUNC | |
2139 | ||
54310121 | 2140 | #### Method: checkbox |
2141 | # Create a checkbox that is not logically linked to any others. | |
2142 | # The field value is "on" when the button is checked. | |
2143 | # Parameters: | |
2144 | # $name -> Name of the checkbox | |
2145 | # $checked -> (optional) turned on by default if true | |
2146 | # $value -> (optional) value of the checkbox, 'on' by default | |
2147 | # $label -> (optional) a user-readable label printed next to the box. | |
2148 | # Otherwise the checkbox name is used. | |
2149 | # Returns: | |
188ba755 | 2150 | # A string containing a <input type="checkbox"> field |
54310121 | 2151 | #### |
2152 | 'checkbox' => <<'END_OF_FUNC', | |
2153 | sub checkbox { | |
2154 | my($self,@p) = self_or_default(@_); | |
2155 | ||
bb8b3399 SP |
2156 | my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) = |
2157 | rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES, | |
2158 | [OVERRIDE,FORCE],TABINDEX],@p); | |
29ddc2a4 | 2159 | |
424ec8fa GS |
2160 | $value = defined $value ? $value : 'on'; |
2161 | ||
2162 | if (!$override && ($self->{'.fieldnames'}->{$name} || | |
2163 | defined $self->param($name))) { | |
3acbd4f5 | 2164 | $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : ''; |
54310121 | 2165 | } else { |
3acbd4f5 | 2166 | $checked = $self->_checked($checked); |
54310121 | 2167 | } |
2168 | my($the_label) = defined $label ? $label : $name; | |
2169 | $name = $self->escapeHTML($name); | |
a3b3a725 | 2170 | $value = $self->escapeHTML($value,1); |
54310121 | 2171 | $the_label = $self->escapeHTML($the_label); |
0a9bdad4 | 2172 | my($other) = @other ? "@other " : ''; |
29ddc2a4 | 2173 | $tabindex = $self->element_tab($tabindex); |
54310121 | 2174 | $self->register_parameter($name); |
bb8b3399 SP |
2175 | return $XHTML ? CGI::label($labelattributes, |
2176 | qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label}) | |
6b4ac661 | 2177 | : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label}; |
54310121 | 2178 | } |
2179 | END_OF_FUNC | |
2180 | ||
2181 | ||
54310121 | 2182 | |
54310121 | 2183 | # Escape HTML -- used internally |
2184 | 'escapeHTML' => <<'END_OF_FUNC', | |
2185 | sub escapeHTML { | |
ac734d8b JH |
2186 | # hack to work around earlier hacks |
2187 | push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; | |
a3b3a725 | 2188 | my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_); |
6b4ac661 | 2189 | return undef unless defined($toencode); |
188ba755 | 2190 | return $toencode if ref($self) && !$self->{'escape'}; |
6b4ac661 JH |
2191 | $toencode =~ s{&}{&}gso; |
2192 | $toencode =~ s{<}{<}gso; | |
2193 | $toencode =~ s{>}{>}gso; | |
13548fdf RGS |
2194 | if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) { |
2195 | # $quot; was accidentally omitted from the HTML 3.2 DTD -- see | |
2196 | # <http://validator.w3.org/docs/errors.html#bad-entity> / | |
2197 | # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>. | |
2198 | $toencode =~ s{"}{"}gso; | |
2199 | } | |
2200 | else { | |
2201 | $toencode =~ s{"}{"}gso; | |
2202 | } | |
89cc8928 JH |
2203 | # Handle bug in some browsers with Latin charsets |
2204 | if ($self->{'.charset'} && | |
2205 | (uc($self->{'.charset'}) eq 'ISO-8859-1' || | |
2206 | uc($self->{'.charset'}) eq 'WINDOWS-1252')) | |
2207 | { | |
ba056755 | 2208 | $toencode =~ s{'}{'}gso; |
188ba755 JH |
2209 | $toencode =~ s{\x8b}{‹}gso; |
2210 | $toencode =~ s{\x9b}{›}gso; | |
a3b3a725 JH |
2211 | if (defined $newlinestoo && $newlinestoo) { |
2212 | $toencode =~ s{\012}{ }gso; | |
2213 | $toencode =~ s{\015}{ }gso; | |
2214 | } | |
2215 | } | |
6b4ac661 | 2216 | return $toencode; |
54310121 | 2217 | } |
2218 | END_OF_FUNC | |
2219 | ||
424ec8fa GS |
2220 | # unescape HTML -- used internally |
2221 | 'unescapeHTML' => <<'END_OF_FUNC', | |
2222 | sub unescapeHTML { | |
efc8e943 NC |
2223 | # hack to work around earlier hacks |
2224 | push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; | |
6b4ac661 | 2225 | my ($self,$string) = CGI::self_or_default(@_); |
424ec8fa | 2226 | return undef unless defined($string); |
a3b3a725 JH |
2227 | my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i |
2228 | : 1; | |
71f3e297 JH |
2229 | # thanks to Randal Schwartz for the correct solution to this one |
2230 | $string=~ s[&(.*?);]{ | |
2231 | local $_ = $1; | |
2232 | /^amp$/i ? "&" : | |
2233 | /^quot$/i ? '"' : | |
2234 | /^gt$/i ? ">" : | |
2235 | /^lt$/i ? "<" : | |
6b4ac661 JH |
2236 | /^#(\d+)$/ && $latin ? chr($1) : |
2237 | /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) : | |
71f3e297 JH |
2238 | $_ |
2239 | }gex; | |
424ec8fa GS |
2240 | return $string; |
2241 | } | |
2242 | END_OF_FUNC | |
54310121 | 2243 | |
2244 | # Internal procedure - don't use | |
2245 | '_tableize' => <<'END_OF_FUNC', | |
2246 | sub _tableize { | |
2247 | my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; | |
29ddc2a4 RGS |
2248 | my @rowheaders = $rowheaders ? @$rowheaders : (); |
2249 | my @colheaders = $colheaders ? @$colheaders : (); | |
54310121 | 2250 | my($result); |
2251 | ||
424ec8fa GS |
2252 | if (defined($columns)) { |
2253 | $rows = int(0.99 + @elements/$columns) unless defined($rows); | |
2254 | } | |
2255 | if (defined($rows)) { | |
2256 | $columns = int(0.99 + @elements/$rows) unless defined($columns); | |
2257 | } | |
29ddc2a4 | 2258 | |
54310121 | 2259 | # rearrange into a pretty table |
6b4ac661 | 2260 | $result = "<table>"; |
54310121 | 2261 | my($row,$column); |
29ddc2a4 RGS |
2262 | unshift(@colheaders,'') if @colheaders && @rowheaders; |
2263 | $result .= "<tr>" if @colheaders; | |
2264 | foreach (@colheaders) { | |
6b4ac661 | 2265 | $result .= "<th>$_</th>"; |
54310121 | 2266 | } |
2267 | for ($row=0;$row<$rows;$row++) { | |
6b4ac661 | 2268 | $result .= "<tr>"; |
29ddc2a4 | 2269 | $result .= "<th>$rowheaders[$row]</th>" if @rowheaders; |
54310121 | 2270 | for ($column=0;$column<$columns;$column++) { |
6b4ac661 | 2271 | $result .= "<td>" . $elements[$column*$rows + $row] . "</td>" |
424ec8fa | 2272 | if defined($elements[$column*$rows + $row]); |
54310121 | 2273 | } |
6b4ac661 | 2274 | $result .= "</tr>"; |
54310121 | 2275 | } |
6b4ac661 | 2276 | $result .= "</table>"; |
54310121 | 2277 | return $result; |
2278 | } | |
2279 | END_OF_FUNC | |
2280 | ||
2281 | ||
2282 | #### Method: radio_group | |
2283 | # Create a list of logically-linked radio buttons. | |
2284 | # Parameters: | |
2285 | # $name -> Common name for all the buttons. | |
2286 | # $values -> A pointer to a regular array containing the | |
2287 | # values for each button in the group. | |
2288 | # $default -> (optional) Value of the button to turn on by default. Pass '-' | |
2289 | # to turn _nothing_ on. | |
2290 | # $linebreak -> (optional) Set to true to place linebreaks | |
2291 | # between the buttons. | |
2292 | # $labels -> (optional) | |
2293 | # A pointer to an associative array of labels to print next to each checkbox | |
2294 | # in the form $label{'value'}="Long explanatory label". | |
2295 | # Otherwise the provided values are used as the labels. | |
2296 | # Returns: | |
188ba755 | 2297 | # An ARRAY containing a series of <input type="radio"> fields |
54310121 | 2298 | #### |
2299 | 'radio_group' => <<'END_OF_FUNC', | |
2300 | sub radio_group { | |
2301 | my($self,@p) = self_or_default(@_); | |
29ddc2a4 RGS |
2302 | $self->_box_group('radio',@p); |
2303 | } | |
2304 | END_OF_FUNC | |
2305 | ||
2306 | #### Method: checkbox_group | |
2307 | # Create a list of logically-linked checkboxes. | |
2308 | # Parameters: | |
2309 | # $name -> Common name for all the check boxes | |
2310 | # $values -> A pointer to a regular array containing the | |
2311 | # values for each checkbox in the group. | |
2312 | # $defaults -> (optional) | |
2313 | # 1. If a pointer to a regular array of checkbox values, | |
2314 | # then this will be used to decide which | |
2315 | # checkboxes to turn on by default. | |
2316 | # 2. If a scalar, will be assumed to hold the | |
2317 | # value of a single checkbox in the group to turn on. | |
2318 | # $linebreak -> (optional) Set to true to place linebreaks | |
2319 | # between the buttons. | |
2320 | # $labels -> (optional) | |
2321 | # A pointer to an associative array of labels to print next to each checkbox | |
2322 | # in the form $label{'value'}="Long explanatory label". | |
2323 | # Otherwise the provided values are used as the labels. | |
2324 | # Returns: | |
2325 | # An ARRAY containing a series of <input type="checkbox"> fields | |
2326 | #### | |
2327 | ||
2328 | 'checkbox_group' => <<'END_OF_FUNC', | |
2329 | sub checkbox_group { | |
2330 | my($self,@p) = self_or_default(@_); | |
2331 | $self->_box_group('checkbox',@p); | |
2332 | } | |
2333 | END_OF_FUNC | |
54310121 | 2334 | |
29ddc2a4 RGS |
2335 | '_box_group' => <<'END_OF_FUNC', |
2336 | sub _box_group { | |
2337 | my $self = shift; | |
2338 | my $box_type = shift; | |
2339 | ||
bb8b3399 SP |
2340 | my($name,$values,$defaults,$linebreak,$labels,$labelattributes, |
2341 | $attributes,$rows,$columns,$rowheaders,$colheaders, | |
8869a4b7 | 2342 | $override,$nolabels,$tabindex,$disabled,@other) = |
bb8b3399 SP |
2343 | rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES, |
2344 | ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER], | |
2345 | [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED | |
2346 | ],@_); | |
2347 | ||
54310121 | 2348 | |
8869a4b7 | 2349 | my($result,$checked,@elements,@values); |
29ddc2a4 | 2350 | |
424ec8fa | 2351 | @values = $self->_set_values_and_labels($values,\$labels,$name); |
29ddc2a4 | 2352 | my %checked = $self->previous_or_default($name,$defaults,$override); |
424ec8fa | 2353 | |
71f3e297 | 2354 | # If no check array is specified, check the first by default |
29ddc2a4 RGS |
2355 | $checked{$values[0]}++ if $box_type eq 'radio' && !%checked; |
2356 | ||
71f3e297 JH |
2357 | $name=$self->escapeHTML($name); |
2358 | ||
29ddc2a4 | 2359 | my %tabs = (); |
0a9bdad4 | 2360 | if ($TABINDEX && $tabindex) { |
29ddc2a4 RGS |
2361 | if (!ref $tabindex) { |
2362 | $self->element_tab($tabindex); | |
2363 | } elsif (ref $tabindex eq 'ARRAY') { | |
2364 | %tabs = map {$_=>$self->element_tab} @$tabindex; | |
2365 | } elsif (ref $tabindex eq 'HASH') { | |
2366 | %tabs = %$tabindex; | |
2367 | } | |
2368 | } | |
2369 | %tabs = map {$_=>$self->element_tab} @values unless %tabs; | |
0a9bdad4 | 2370 | my $other = @other ? "@other " : ''; |
29ddc2a4 | 2371 | my $radio_checked; |
8869a4b7 SP |
2372 | |
2373 | # for disabling groups of radio/checkbox buttons | |
2374 | my %disabled; | |
2375 | foreach (@{$disabled}) { | |
2376 | $disabled{$_}=1; | |
2377 | } | |
2378 | ||
54310121 | 2379 | foreach (@values) { |
8869a4b7 SP |
2380 | my $disable=""; |
2381 | if ($disabled{$_}) { | |
2382 | $disable="disabled='1'"; | |
2383 | } | |
2384 | ||
29ddc2a4 RGS |
2385 | my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++) |
2386 | : $checked{$_}); | |
6b4ac661 JH |
2387 | my($break); |
2388 | if ($linebreak) { | |
ba056755 | 2389 | $break = $XHTML ? "<br />" : "<br>"; |
6b4ac661 JH |
2390 | } |
2391 | else { | |
ba056755 | 2392 | $break = ''; |
6b4ac661 | 2393 | } |
54310121 | 2394 | my($label)=''; |
2395 | unless (defined($nolabels) && $nolabels) { | |
2396 | $label = $_; | |
424ec8fa | 2397 | $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); |
a3b3a725 | 2398 | $label = $self->escapeHTML($label,1); |
8869a4b7 | 2399 | $label = "<span style=\"color:gray\">$label</span>" if $disabled{$_}; |
54310121 | 2400 | } |
29ddc2a4 | 2401 | my $attribs = $self->_set_attributes($_, $attributes); |
0a9bdad4 | 2402 | my $tab = $tabs{$_}; |
54310121 | 2403 | $_=$self->escapeHTML($_); |
8869a4b7 | 2404 | |
29ddc2a4 RGS |
2405 | if ($XHTML) { |
2406 | push @elements, | |
bb8b3399 | 2407 | CGI::label($labelattributes, |
8869a4b7 | 2408 | qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break}; |
29ddc2a4 | 2409 | } else { |
8869a4b7 | 2410 | push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs$disable>${label}${break}/); |
29ddc2a4 | 2411 | } |
54310121 | 2412 | } |
2413 | $self->register_parameter($name); | |
29ddc2a4 | 2414 | return wantarray ? @elements : "@elements" |
424ec8fa | 2415 | unless defined($columns) || defined($rows); |
54310121 | 2416 | return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); |
2417 | } | |
2418 | END_OF_FUNC | |
2419 | ||
2420 | ||
2421 | #### Method: popup_menu | |
2422 | # Create a popup menu. | |
2423 | # Parameters: | |
2424 | # $name -> Name for all the menu | |
2425 | # $values -> A pointer to a regular array containing the | |
2426 | # text of each menu item. | |
2427 | # $default -> (optional) Default item to display | |
2428 | # $labels -> (optional) | |
2429 | # A pointer to an associative array of labels to print next to each checkbox | |
2430 | # in the form $label{'value'}="Long explanatory label". | |
2431 | # Otherwise the provided values are used as the labels. | |
2432 | # Returns: | |
2433 | # A string containing the definition of a popup menu. | |
2434 | #### | |
2435 | 'popup_menu' => <<'END_OF_FUNC', | |
2436 | sub popup_menu { | |
2437 | my($self,@p) = self_or_default(@_); | |
2438 | ||
29ddc2a4 | 2439 | my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) = |
188ba755 | 2440 | rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS, |
29ddc2a4 | 2441 | ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); |
54310121 | 2442 | my($result,$selected); |
2443 | ||
2444 | if (!$override && defined($self->param($name))) { | |
2445 | $selected = $self->param($name); | |
2446 | } else { | |
2447 | $selected = $default; | |
2448 | } | |
2449 | $name=$self->escapeHTML($name); | |
2450 | my($other) = @other ? " @other" : ''; | |
2451 | ||
424ec8fa GS |
2452 | my(@values); |
2453 | @values = $self->_set_values_and_labels($values,\$labels,$name); | |
29ddc2a4 | 2454 | $tabindex = $self->element_tab($tabindex); |
0a9bdad4 | 2455 | $result = qq/<select name="$name" $tabindex$other>\n/; |
54310121 | 2456 | foreach (@values) { |
188ba755 JH |
2457 | if (/<optgroup/) { |
2458 | foreach (split(/\n/)) { | |
2459 | my $selectit = $XHTML ? 'selected="selected"' : 'selected'; | |
2460 | s/(value="$selected")/$selectit $1/ if defined $selected; | |
2461 | $result .= "$_\n"; | |
2462 | } | |
2463 | } | |
2464 | else { | |
cb3b230c SP |
2465 | my $attribs = $self->_set_attributes($_, $attributes); |
2466 | my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : ''; | |
2467 | my($label) = $_; | |
2468 | $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); | |
2469 | my($value) = $self->escapeHTML($_); | |
2470 | $label=$self->escapeHTML($label,1); | |
2471 | $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n"; | |
188ba755 | 2472 | } |
54310121 | 2473 | } |
2474 | ||
69c89ae7 | 2475 | $result .= "</select>"; |
54310121 | 2476 | return $result; |
2477 | } | |
2478 | END_OF_FUNC | |
2479 | ||
2480 | ||
188ba755 JH |
2481 | #### Method: optgroup |
2482 | # Create a optgroup. | |
2483 | # Parameters: | |
2484 | # $name -> Label for the group | |
2485 | # $values -> A pointer to a regular array containing the | |
2486 | # values for each option line in the group. | |
2487 | # $labels -> (optional) | |
2488 | # A pointer to an associative array of labels to print next to each item | |
2489 | # in the form $label{'value'}="Long explanatory label". | |
2490 | # Otherwise the provided values are used as the labels. | |
2491 | # $labeled -> (optional) | |
2492 | # A true value indicates the value should be used as the label attribute | |
2493 | # in the option elements. | |
2494 | # The label attribute specifies the option label presented to the user. | |
2495 | # This defaults to the content of the <option> element, but the label | |
2496 | # attribute allows authors to more easily use optgroup without sacrificing | |
2497 | # compatibility with browsers that do not support option groups. | |
2498 | # $novals -> (optional) | |
2499 | # A true value indicates to suppress the val attribute in the option elements | |
2500 | # Returns: | |
2501 | # A string containing the definition of an option group. | |
2502 | #### | |
2503 | 'optgroup' => <<'END_OF_FUNC', | |
2504 | sub optgroup { | |
2505 | my($self,@p) = self_or_default(@_); | |
2506 | my($name,$values,$attributes,$labeled,$noval,$labels,@other) | |
2507 | = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p); | |
2508 | ||
2509 | my($result,@values); | |
2510 | @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals); | |
2511 | my($other) = @other ? " @other" : ''; | |
2512 | ||
2513 | $name=$self->escapeHTML($name); | |
2514 | $result = qq/<optgroup label="$name"$other>\n/; | |
2515 | foreach (@values) { | |
2516 | if (/<optgroup/) { | |
2517 | foreach (split(/\n/)) { | |
2518 | my $selectit = $XHTML ? 'selected="selected"' : 'selected'; | |
2519 | s/(value="$selected")/$selectit $1/ if defined $selected; | |
2520 | $result .= "$_\n"; | |
2521 | } | |
2522 | } | |
2523 | else { | |
2524 | my $attribs = $self->_set_attributes($_, $attributes); | |
2525 | my($label) = $_; | |
2526 | $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); | |
2527 | $label=$self->escapeHTML($label); | |
2528 | my($value)=$self->escapeHTML($_,1); | |
2529 | $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n" | |
2530 | : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n" | |
2531 | : $novals ? "<option$attribs>$label</option>\n" | |
2532 | : "<option$attribs value=\"$value\">$label</option>\n"; | |
2533 | } | |
2534 | } | |
2535 | $result .= "</optgroup>"; | |
2536 | return $result; | |
2537 | } | |
2538 | END_OF_FUNC | |
2539 | ||
2540 | ||
54310121 | 2541 | #### Method: scrolling_list |
2542 | # Create a scrolling list. | |
2543 | # Parameters: | |
2544 | # $name -> name for the list | |
2545 | # $values -> A pointer to a regular array containing the | |
2546 | # values for each option line in the list. | |
2547 | # $defaults -> (optional) | |
2548 | # 1. If a pointer to a regular array of options, | |
2549 | # then this will be used to decide which | |
2550 | # lines to turn on by default. | |
2551 | # 2. Otherwise holds the value of the single line to turn on. | |
2552 | # $size -> (optional) Size of the list. | |
2553 | # $multiple -> (optional) If set, allow multiple selections. | |
2554 | # $labels -> (optional) | |
2555 | # A pointer to an associative array of labels to print next to each checkbox | |
2556 | # in the form $label{'value'}="Long explanatory label". | |
2557 | # Otherwise the provided values are used as the labels. | |
2558 | # Returns: | |
2559 | # A string containing the definition of a scrolling list. | |
2560 | #### | |
2561 | 'scrolling_list' => <<'END_OF_FUNC', | |
2562 | sub scrolling_list { | |
2563 | my($self,@p) = self_or_default(@_); | |
29ddc2a4 | 2564 | my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other) |
3d1a2ec4 | 2565 | = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], |
29ddc2a4 | 2566 | SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); |
54310121 | 2567 | |
424ec8fa GS |
2568 | my($result,@values); |
2569 | @values = $self->_set_values_and_labels($values,\$labels,$name); | |
2570 | ||
54310121 | 2571 | $size = $size || scalar(@values); |
2572 | ||
2573 | my(%selected) = $self->previous_or_default($name,$defaults,$override); | |
ac734d8b | 2574 | my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : ''; |
6b4ac661 | 2575 | my($has_size) = $size ? qq/ size="$size"/: ''; |
54310121 | 2576 | my($other) = @other ? " @other" : ''; |
2577 | ||
2578 | $name=$self->escapeHTML($name); | |
29ddc2a4 | 2579 | $tabindex = $self->element_tab($tabindex); |
0a9bdad4 | 2580 | $result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/; |
54310121 | 2581 | foreach (@values) { |
3acbd4f5 | 2582 | my($selectit) = $self->_selected($selected{$_}); |
54310121 | 2583 | my($label) = $_; |
424ec8fa | 2584 | $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); |
54310121 | 2585 | $label=$self->escapeHTML($label); |
a3b3a725 | 2586 | my($value)=$self->escapeHTML($_,1); |
188ba755 | 2587 | my $attribs = $self->_set_attributes($_, $attributes); |
1f426928 | 2588 | $result .= "<option ${selectit}${attribs}value=\"$value\">$label</option>\n"; |
54310121 | 2589 | } |
69c89ae7 | 2590 | $result .= "</select>"; |
54310121 | 2591 | $self->register_parameter($name); |
2592 | return $result; | |
2593 | } | |
2594 | END_OF_FUNC | |
2595 | ||
2596 | ||
2597 | #### Method: hidden | |
2598 | # Parameters: | |
2599 | # $name -> Name of the hidden field | |
2600 | # @default -> (optional) Initial values of field (may be an array) | |
2601 | # or | |
2602 | # $default->[initial values of field] | |
2603 | # Returns: | |
188ba755 | 2604 | # A string containing a <input type="hidden" name="name" value="value"> |
54310121 | 2605 | #### |
2606 | 'hidden' => <<'END_OF_FUNC', | |
2607 | sub hidden { | |
2608 | my($self,@p) = self_or_default(@_); | |
2609 | ||
2610 | # this is the one place where we departed from our standard | |
2611 | # calling scheme, so we have to special-case (darn) | |
2612 | my(@result,@value); | |
2613 | my($name,$default,$override,@other) = | |
3d1a2ec4 | 2614 | rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); |
54310121 | 2615 | |
2616 | my $do_override = 0; | |
3d1a2ec4 | 2617 | if ( ref($p[0]) || substr($p[0],0,1) eq '-') { |
54310121 | 2618 | @value = ref($default) ? @{$default} : $default; |
2619 | $do_override = $override; | |
2620 | } else { | |
2621 | foreach ($default,$override,@other) { | |
2622 | push(@value,$_) if defined($_); | |
2623 | } | |
2624 | } | |
2625 | ||
2626 | # use previous values if override is not set | |
2627 | my @prev = $self->param($name); | |
2628 | @value = @prev if !$do_override && @prev; | |
2629 | ||
2630 | $name=$self->escapeHTML($name); | |
2631 | foreach (@value) { | |
a3b3a725 | 2632 | $_ = defined($_) ? $self->escapeHTML($_,1) : ''; |
13548fdf RGS |
2633 | push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />) |
2634 | : qq(<input type="hidden" name="$name" value="$_" @other>); | |
54310121 | 2635 | } |
2636 | return wantarray ? @result : join('',@result); | |
2637 | } | |
2638 | END_OF_FUNC | |
2639 | ||
2640 | ||
2641 | #### Method: image_button | |
2642 | # Parameters: | |
2643 | # $name -> Name of the button | |
2644 | # $src -> URL of the image source | |
2645 | # $align -> Alignment style (TOP, BOTTOM or MIDDLE) | |
2646 | # Returns: | |
188ba755 | 2647 | # A string containing a <input type="image" name="name" src="url" align="alignment"> |
54310121 | 2648 | #### |
2649 | 'image_button' => <<'END_OF_FUNC', | |
2650 | sub image_button { | |
2651 | my($self,@p) = self_or_default(@_); | |
2652 | ||
2653 | my($name,$src,$alignment,@other) = | |
3d1a2ec4 | 2654 | rearrange([NAME,SRC,ALIGN],@p); |
54310121 | 2655 | |
0664a57d | 2656 | my($align) = $alignment ? " align=\L\"$alignment\"" : ''; |
54310121 | 2657 | my($other) = @other ? " @other" : ''; |
2658 | $name=$self->escapeHTML($name); | |
6b4ac661 JH |
2659 | return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />) |
2660 | : qq/<input type="image" name="$name" src="$src"$align$other>/; | |
54310121 | 2661 | } |
2662 | END_OF_FUNC | |
2663 | ||
2664 | ||
2665 | #### Method: self_url | |
2666 | # Returns a URL containing the current script and all its | |
2667 | # param/value pairs arranged as a query. You can use this | |
2668 | # to create a link that, when selected, will reinvoke the | |
2669 | # script with all its state information preserved. | |
2670 | #### | |
2671 | 'self_url' => <<'END_OF_FUNC', | |
2672 | sub self_url { | |
424ec8fa GS |
2673 | my($self,@p) = self_or_default(@_); |
2674 | return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p); | |
54310121 | 2675 | } |
2676 | END_OF_FUNC | |
2677 | ||
2678 | ||
2679 | # This is provided as a synonym to self_url() for people unfortunate | |
2680 | # enough to have incorporated it into their programs already! | |
2681 | 'state' => <<'END_OF_FUNC', | |
2682 | sub state { | |
2683 | &self_url; | |
2684 | } | |
2685 | END_OF_FUNC | |
2686 | ||
2687 | ||
2688 | #### Method: url | |
2689 | # Like self_url, but doesn't return the query string part of | |
2690 | # the URL. | |
2691 | #### | |
2692 | 'url' => <<'END_OF_FUNC', | |
2693 | sub url { | |
424ec8fa | 2694 | my($self,@p) = self_or_default(@_); |
0a9bdad4 SP |
2695 | my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) = |
2696 | rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p); | |
2697 | my $url = ''; | |
2371fea9 | 2698 | $full++ if $base || !($relative || $absolute); |
0a9bdad4 | 2699 | $rewrite++ unless defined $rewrite; |
424ec8fa | 2700 | |
0a9bdad4 SP |
2701 | my $path = $self->path_info; |
2702 | my $script_name = $self->script_name; | |
cb3b230c | 2703 | my $request_uri = unescape($self->request_uri) || ''; |
0a9bdad4 SP |
2704 | my $query_str = $self->query_string; |
2705 | ||
2706 | my $rewrite_in_use = $request_uri && $request_uri !~ /^$script_name/; | |
2707 | undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active | |
2708 | ||
2709 | my $uri = $rewrite && $request_uri ? $request_uri : $script_name; | |
edc47407 | 2710 | $uri =~ s/\?.*$//; # remove query string |
adb86593 | 2711 | $uri =~ s/\Q$path\E$// if defined $path; # remove path |
d45d855d | 2712 | |
424ec8fa GS |
2713 | if ($full) { |
2714 | my $protocol = $self->protocol(); | |
2715 | $url = "$protocol://"; | |
2c454cbd SP |
2716 | my $vh = http('x_forwarded_host') || http('host') || ''; |
2717 | $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it. | |
424ec8fa GS |
2718 | if ($vh) { |
2719 | $url .= $vh; | |
2720 | } else { | |
2721 | $url .= server_name(); | |
424ec8fa | 2722 | } |
8869a4b7 SP |
2723 | my $port = $self->server_port; |
2724 | $url .= ":" . $port | |
2725 | unless (lc($protocol) eq 'http' && $port == 80) | |
2726 | || (lc($protocol) eq 'https' && $port == 443); | |
03b9648d | 2727 | return $url if $base; |
0a9bdad4 | 2728 | $url .= $uri; |
424ec8fa | 2729 | } elsif ($relative) { |
cb3b230c | 2730 | ($url) = $uri =~ m!([^/]+)$!; |
424ec8fa | 2731 | } elsif ($absolute) { |
0a9bdad4 | 2732 | $url = $uri; |
424ec8fa | 2733 | } |
03b9648d | 2734 | |
0a9bdad4 SP |
2735 | $url .= $path if $path_info and defined $path; |
2736 | $url .= "?$query_str" if $query and $query_str ne ''; | |
c8d66bb3 | 2737 | $url ||= ''; |
2371fea9 | 2738 | $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg; |
424ec8fa | 2739 | return $url; |
54310121 | 2740 | } |
2741 | ||
2742 | END_OF_FUNC | |
2743 | ||
2744 | #### Method: cookie | |
2745 | # Set or read a cookie from the specified name. | |
2746 | # Cookie can then be passed to header(). | |
2747 | # Usual rules apply to the stickiness of -value. | |
2748 | # Parameters: | |
2749 | # -name -> name for this cookie (optional) | |
2750 | # -value -> value of this cookie (scalar, array or hash) | |
2751 | # -path -> paths for which this cookie is valid (optional) | |
2752 | # -domain -> internet domain in which this cookie is valid (optional) | |
2753 | # -secure -> if true, cookie only passed through secure channel (optional) | |
7d37aa8e | 2754 | # -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional) |
54310121 | 2755 | #### |
2756 | 'cookie' => <<'END_OF_FUNC', | |
54310121 | 2757 | sub cookie { |
2758 | my($self,@p) = self_or_default(@_); | |
fc786e8b SP |
2759 | my($name,$value,$path,$domain,$secure,$expires,$httponly) = |
2760 | rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p); | |
54310121 | 2761 | |
424ec8fa | 2762 | require CGI::Cookie; |
54310121 | 2763 | |
2764 | # if no value is supplied, then we retrieve the | |
2765 | # value of the cookie, if any. For efficiency, we cache the parsed | |
424ec8fa GS |
2766 | # cookies in our state variables. |
2767 | unless ( defined($value) ) { | |
2768 | $self->{'.cookies'} = CGI::Cookie->fetch | |
2769 | unless $self->{'.cookies'}; | |
54310121 | 2770 | |
2771 | # If no name is supplied, then retrieve the names of all our cookies. | |
2772 | return () unless $self->{'.cookies'}; | |
424ec8fa GS |
2773 | return keys %{$self->{'.cookies'}} unless $name; |
2774 | return () unless $self->{'.cookies'}->{$name}; | |
2775 | return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne ''; | |
54310121 | 2776 | } |
54310121 | 2777 | |
424ec8fa | 2778 | # If we get here, we're creating a new cookie |
ba056755 | 2779 | return undef unless defined($name) && $name ne ''; # this is an error |
54310121 | 2780 | |
424ec8fa GS |
2781 | my @param; |
2782 | push(@param,'-name'=>$name); | |
2783 | push(@param,'-value'=>$value); | |
2784 | push(@param,'-domain'=>$domain) if $domain; | |
2785 | push(@param,'-path'=>$path) if $path; | |
2786 | push(@param,'-expires'=>$expires) if $expires; | |
2787 | push(@param,'-secure'=>$secure) if $secure; | |
fc786e8b | 2788 | push(@param,'-httponly'=>$httponly) if $httponly; |
54310121 | 2789 | |
6b4ac661 | 2790 | return new CGI::Cookie(@param); |
54310121 | 2791 | } |
2792 | END_OF_FUNC | |
2793 | ||
424ec8fa GS |
2794 | 'parse_keywordlist' => <<'END_OF_FUNC', |
2795 | sub parse_keywordlist { | |
2796 | my($self,$tosplit) = @_; | |
2797 | $tosplit = unescape($tosplit); # unescape the keywords | |
2798 | $tosplit=~tr/+/ /; # pluses to spaces | |
2799 | my(@keywords) = split(/\s+/,$tosplit); | |
2800 | return @keywords; | |
2801 | } | |
2802 | END_OF_FUNC | |
2803 | ||
2804 | 'param_fetch' => <<'END_OF_FUNC', | |
2805 | sub param_fetch { | |
2806 | my($self,@p) = self_or_default(@_); | |
3d1a2ec4 | 2807 | my($name) = rearrange([NAME],@p); |
424ec8fa GS |
2808 | unless (exists($self->{$name})) { |
2809 | $self->add_parameter($name); | |
2810 | $self->{$name} = []; | |
2811 | } | |
2812 | ||
2813 | return $self->{$name}; | |
2814 | } | |
2815 | END_OF_FUNC | |
2816 | ||
54310121 | 2817 | ############################################### |
2818 | # OTHER INFORMATION PROVIDED BY THE ENVIRONMENT | |
2819 | ############################################### | |
2820 | ||
2821 | #### Method: path_info | |
2822 | # Return the extra virtual path information provided | |
2823 | # after the URL (if any) | |
2824 | #### | |
2825 | 'path_info' => <<'END_OF_FUNC', | |
2826 | sub path_info { | |
424ec8fa GS |
2827 | my ($self,$info) = self_or_default(@_); |
2828 | if (defined($info)) { | |
2829 | $info = "/$info" if $info ne '' && substr($info,0,1) ne '/'; | |
2830 | $self->{'.path_info'} = $info; | |
2831 | } elsif (! defined($self->{'.path_info'}) ) { | |
7dc108d1 SP |
2832 | my (undef,$path_info) = $self->_name_and_path_from_env; |
2833 | $self->{'.path_info'} = $path_info || ''; | |
424ec8fa GS |
2834 | } |
2835 | return $self->{'.path_info'}; | |
54310121 | 2836 | } |
2837 | END_OF_FUNC | |
2838 | ||
7dc108d1 SP |
2839 | # WE USE THIS TO COMPENSATE FOR A BUG IN APACHE 2 PRESENT AT LEAST UP THROUGH 2.0.54 |
2840 | '_name_and_path_from_env' => <<'END_OF_FUNC', | |
2841 | sub _name_and_path_from_env { | |
2842 | my $self = shift; | |
2843 | my $raw_script_name = $ENV{SCRIPT_NAME} || ''; | |
2844 | my $raw_path_info = $ENV{PATH_INFO} || ''; | |
cb3b230c | 2845 | my $uri = unescape($self->request_uri) || ''; |
7dc108d1 | 2846 | |
adb86593 SP |
2847 | my $protected = quotemeta($raw_path_info); |
2848 | $raw_script_name =~ s/$protected$//; | |
0a9bdad4 | 2849 | |
7dc108d1 SP |
2850 | my @uri_double_slashes = $uri =~ m^(/{2,}?)^g; |
2851 | my @path_double_slashes = "$raw_script_name $raw_path_info" =~ m^(/{2,}?)^g; | |
2852 | ||
2853 | my $apache_bug = @uri_double_slashes != @path_double_slashes; | |
2854 | return ($raw_script_name,$raw_path_info) unless $apache_bug; | |
2855 | ||
cb3b230c | 2856 | my $path_info_search = quotemeta($raw_path_info); |
7dc108d1 SP |
2857 | $path_info_search =~ s!/!/+!g; |
2858 | if ($uri =~ m/^(.+)($path_info_search)/) { | |
2859 | return ($1,$2); | |
2860 | } else { | |
2861 | return ($raw_script_name,$raw_path_info); | |
2862 | } | |
2863 | } | |
2864 | END_OF_FUNC | |
2865 | ||
54310121 | 2866 | |
2867 | #### Method: request_method | |
2868 | # Returns 'POST', 'GET', 'PUT' or 'HEAD' | |
2869 | #### | |
2870 | 'request_method' => <<'END_OF_FUNC', | |
2871 | sub request_method { | |
2872 | return $ENV{'REQUEST_METHOD'}; | |
2873 | } | |
2874 | END_OF_FUNC | |
2875 | ||
3538e1d5 GS |
2876 | #### Method: content_type |
2877 | # Returns the content_type string | |
2878 | #### | |
2879 | 'content_type' => <<'END_OF_FUNC', | |
2880 | sub content_type { | |
2881 | return $ENV{'CONTENT_TYPE'}; | |
2882 | } | |
2883 | END_OF_FUNC | |
2884 | ||
54310121 | 2885 | #### Method: path_translated |
2886 | # Return the physical path information provided | |
2887 | # by the URL (if any) | |
2888 | #### | |
2889 | 'path_translated' => <<'END_OF_FUNC', | |
2890 | sub path_translated { | |
2891 | return $ENV{'PATH_TRANSLATED'}; | |
2892 | } | |
2893 | END_OF_FUNC | |
2894 | ||
2895 | ||
7dc108d1 SP |
2896 | #### Method: request_uri |
2897 | # Return the literal request URI | |
2898 | #### | |
2899 | 'request_uri' => <<'END_OF_FUNC', | |
2900 | sub request_uri { | |
2901 | return $ENV{'REQUEST_URI'}; | |
2902 | } | |
2903 | END_OF_FUNC | |
2904 | ||
2905 | ||
54310121 | 2906 | #### Method: query_string |
2907 | # Synthesize a query string from our current | |
2908 | # parameters | |
2909 | #### | |
2910 | 'query_string' => <<'END_OF_FUNC', | |
2911 | sub query_string { | |
2912 | my($self) = self_or_default(@_); | |
2913 | my($param,$value,@pairs); | |
2914 | foreach $param ($self->param) { | |
424ec8fa | 2915 | my($eparam) = escape($param); |
54310121 | 2916 | foreach $value ($self->param($param)) { |
424ec8fa | 2917 | $value = escape($value); |
3538e1d5 | 2918 | next unless defined $value; |
54310121 | 2919 | push(@pairs,"$eparam=$value"); |
2920 | } | |
2921 | } | |
d45d855d JH |
2922 | foreach (keys %{$self->{'.fieldnames'}}) { |
2923 | push(@pairs,".cgifields=".escape("$_")); | |
2924 | } | |
71f3e297 | 2925 | return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs); |
54310121 | 2926 | } |
2927 | END_OF_FUNC | |
2928 | ||
2929 | ||
2930 | #### Method: accept | |
2931 | # Without parameters, returns an array of the | |
2932 | # MIME types the browser accepts. | |
2933 | # With a single parameter equal to a MIME | |
2934 | # type, will return undef if the browser won't | |
2935 | # accept it, 1 if the browser accepts it but | |
2936 | # doesn't give a preference, or a floating point | |
2937 | # value between 0.0 and 1.0 if the browser | |
2938 | # declares a quantitative score for it. | |
2939 | # This handles MIME type globs correctly. | |
2940 | #### | |
71f3e297 JH |
2941 | 'Accept' => <<'END_OF_FUNC', |
2942 | sub Accept { | |
54310121 | 2943 | my($self,$search) = self_or_CGI(@_); |
2944 | my(%prefs,$type,$pref,$pat); | |
2945 | ||
2946 | my(@accept) = split(',',$self->http('accept')); | |
2947 | ||
2948 | foreach (@accept) { | |
2949 | ($pref) = /q=(\d\.\d+|\d+)/; | |
2950 | ($type) = m#(\S+/[^;]+)#; | |
2951 | next unless $type; | |
2952 | $prefs{$type}=$pref || 1; | |
2953 | } | |
2954 | ||
2955 | return keys %prefs unless $search; | |
2956 | ||
2957 | # if a search type is provided, we may need to | |
2958 | # perform a pattern matching operation. | |
2959 | # The MIME types use a glob mechanism, which | |
2960 | # is easily translated into a perl pattern match | |
2961 | ||
2962 | # First return the preference for directly supported | |
2963 | # types: | |
2964 | return $prefs{$search} if $prefs{$search}; | |
2965 | ||
2966 | # Didn't get it, so try pattern matching. | |
2967 | foreach (keys %prefs) { | |
2968 | next unless /\*/; # not a pattern match | |
2969 | ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters | |
2970 | $pat =~ s/\*/.*/g; # turn it into a pattern | |
2971 | return $prefs{$_} if $search=~/$pat/; | |
2972 | } | |
2973 | } | |
2974 | END_OF_FUNC | |
2975 | ||
2976 | ||
2977 | #### Method: user_agent | |
2978 | # If called with no parameters, returns the user agent. | |
2979 | # If called with one parameter, does a pattern match (case | |
2980 | # insensitive) on the user agent. | |
2981 | #### | |
2982 | 'user_agent' => <<'END_OF_FUNC', | |
2983 | sub user_agent { | |
2984 | my($self,$match)=self_or_CGI(@_); | |
2985 | return $self->http('user_agent') unless $match; | |
2986 | return $self->http('user_agent') =~ /$match/i; | |
2987 | } | |
2988 | END_OF_FUNC | |
2989 | ||
2990 | ||
424ec8fa GS |
2991 | #### Method: raw_cookie |
2992 | # Returns the magic cookies for the session. | |
2993 | # The cookies are not parsed or altered in any way, i.e. | |
2994 | # cookies are returned exactly as given in the HTTP | |
2995 | # headers. If a cookie name is given, only that cookie's | |
2996 | # value is returned, otherwise the entire raw cookie | |
2997 | # is returned. | |
54310121 | 2998 | #### |
2999 | 'raw_cookie' => <<'END_OF_FUNC', | |
3000 | sub raw_cookie { | |
424ec8fa GS |
3001 | my($self,$key) = self_or_CGI(@_); |
3002 | ||
3003 | require CGI::Cookie; | |
3004 | ||
3005 | if (defined($key)) { | |
3006 | $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch | |
3007 | unless $self->{'.raw_cookies'}; | |
3008 | ||
3009 | return () unless $self->{'.raw_cookies'}; | |
3010 | return () unless $self->{'.raw_cookies'}->{$key}; | |
3011 | return $self->{'.raw_cookies'}->{$key}; | |
3012 | } | |
54310121 | 3013 | return $self->http('cookie') || $ENV{'COOKIE'} || ''; |
3014 | } | |
3015 | END_OF_FUNC | |
3016 | ||
3017 | #### Method: virtual_host | |
3018 | # Return the name of the virtual_host, which | |
3019 | # is not always the same as the server | |
3020 | ###### | |
3021 | 'virtual_host' => <<'END_OF_FUNC', | |
3022 | sub virtual_host { | |
13548fdf | 3023 | my $vh = http('x_forwarded_host') || http('host') || server_name(); |
424ec8fa GS |
3024 | $vh =~ s/:\d+$//; # get rid of port number |
3025 | return $vh; | |
54310121 | 3026 | } |
3027 | END_OF_FUNC | |
3028 | ||
3029 | #### Method: remote_host | |
3030 | # Return the name of the remote host, or its IP | |
3031 | # address if unavailable. If this variable isn't | |
3032 | # defined, it returns "localhost" for debugging | |
3033 | # purposes. | |
3034 | #### | |
3035 | 'remote_host' => <<'END_OF_FUNC', | |
3036 | sub remote_host { | |
3037 | return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} | |
3038 | || 'localhost'; | |
3039 | } | |
3040 | END_OF_FUNC | |
3041 | ||
3042 | ||
3043 | #### Method: remote_addr | |
3044 | # Return the IP addr of the remote host. | |
3045 | #### | |
3046 | 'remote_addr' => <<'END_OF_FUNC', | |
3047 | sub remote_addr { | |
3048 | return $ENV{'REMOTE_ADDR'} || '127.0.0.1'; | |
3049 | } | |
3050 | END_OF_FUNC | |
3051 | ||
3052 | ||
3053 | #### Method: script_name | |
3054 | # Return the partial URL to this script for | |
3055 | # self-referencing scripts. Also see | |
3056 | # self_url(), which returns a URL with all state information | |
3057 | # preserved. | |
3058 | #### | |
3059 | 'script_name' => <<'END_OF_FUNC', | |
3060 | sub script_name { | |
7dc108d1 SP |
3061 | my ($self,@p) = self_or_default(@_); |
3062 | if (@p) { | |
2c454cbd | 3063 | $self->{'.script_name'} = shift @p; |
7dc108d1 SP |
3064 | } elsif (!exists $self->{'.script_name'}) { |
3065 | my ($script_name,$path_info) = $self->_name_and_path_from_env(); | |
3066 | $self->{'.script_name'} = $script_name; | |
3067 | } | |
3068 | return $self->{'.script_name'}; | |
54310121 | 3069 | } |
3070 | END_OF_FUNC | |
3071 | ||
3072 | ||
3073 | #### Method: referer | |
3074 | # Return the HTTP_REFERER: useful for generating | |
3075 | # a GO BACK button. | |
3076 | #### | |
3077 | 'referer' => <<'END_OF_FUNC', | |
3078 | sub referer { | |
3079 | my($self) = self_or_CGI(@_); | |
3080 | return $self->http('referer'); | |
3081 | } | |
3082 | END_OF_FUNC | |
3083 | ||
3084 | ||
3085 | #### Method: server_name | |
3086 | # Return the name of the server | |
3087 | #### | |
3088 | 'server_name' => <<'END_OF_FUNC', | |
3089 | sub server_name { | |
3090 | return $ENV{'SERVER_NAME'} || 'localhost'; | |
3091 | } | |
3092 | END_OF_FUNC | |
3093 | ||
3094 | #### Method: server_software | |
3095 | # Return the name of the server software | |
3096 | #### | |
3097 | 'server_software' => <<'END_OF_FUNC', | |
3098 | sub server_software { | |
3099 | return $ENV{'SERVER_SOFTWARE'} || 'cmdline'; | |
3100 | } | |
3101 | END_OF_FUNC | |
3102 | ||
2ed511ec RGS |
3103 | #### Method: virtual_port |
3104 | # Return the server port, taking virtual hosts into account | |
3105 | #### | |
3106 | 'virtual_port' => <<'END_OF_FUNC', | |
3107 | sub virtual_port { | |
3108 | my($self) = self_or_default(@_); | |
13548fdf | 3109 | my $vh = $self->http('x_forwarded_host') || $self->http('host'); |
0a9bdad4 | 3110 | my $protocol = $self->protocol; |
2ed511ec | 3111 | if ($vh) { |
0a9bdad4 | 3112 | return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80); |
2ed511ec RGS |
3113 | } else { |
3114 | return $self->server_port(); | |
3115 | } | |
3116 | } | |
3117 | END_OF_FUNC | |
3118 | ||
54310121 | 3119 | #### Method: server_port |
3120 | # Return the tcp/ip port the server is running on | |
3121 | #### | |
3122 | 'server_port' => <<'END_OF_FUNC', | |
3123 | sub server_port { | |
3124 | return $ENV{'SERVER_PORT'} || 80; # for debugging | |
3125 | } | |
3126 | END_OF_FUNC | |
3127 | ||
3128 | #### Method: server_protocol | |
3129 | # Return the protocol (usually HTTP/1.0) | |
3130 | #### | |
3131 | 'server_protocol' => <<'END_OF_FUNC', | |
3132 | sub server_protocol { | |
3133 | return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging | |
3134 | } | |
3135 | END_OF_FUNC | |
3136 | ||
3137 | #### Method: http | |
3138 | # Return the value of an HTTP variable, or | |
3139 | # the list of variables if none provided | |
3140 | #### | |
3141 | 'http' => <<'END_OF_FUNC', | |
3142 | sub http { | |
3143 | my ($self,$parameter) = self_or_CGI(@_); | |
3144 | return $ENV{$parameter} if $parameter=~/^HTTP/; | |
3538e1d5 | 3145 | $parameter =~ tr/-/_/; |
54310121 | 3146 | return $ENV{"HTTP_\U$parameter\E"} if $parameter; |
3147 | my(@p); | |
3148 | foreach (keys %ENV) { | |
3149 | push(@p,$_) if /^HTTP/; | |
3150 | } | |
3151 | return @p; | |
3152 | } | |
3153 | END_OF_FUNC | |
3154 | ||
3155 | #### Method: https | |
3156 | # Return the value of HTTPS | |
3157 | #### | |
3158 | 'https' => <<'END_OF_FUNC', | |
3159 | sub https { | |
3160 | local($^W)=0; | |
3161 | my ($self,$parameter) = self_or_CGI(@_); | |
3162 | return $ENV{HTTPS} unless $parameter; | |
3163 | return $ENV{$parameter} if $parameter=~/^HTTPS/; | |
3538e1d5 | 3164 | $parameter =~ tr/-/_/; |
54310121 | 3165 | return $ENV{"HTTPS_\U$parameter\E"} if $parameter; |
3166 | my(@p); | |
3167 | foreach (keys %ENV) { | |
3168 | push(@p,$_) if /^HTTPS/; | |
3169 | } | |
3170 | return @p; | |
3171 | } | |
3172 | END_OF_FUNC | |
3173 | ||
3174 | #### Method: protocol | |
3175 | # Return the protocol (http or https currently) | |
3176 | #### | |
3177 | 'protocol' => <<'END_OF_FUNC', | |
3178 | sub protocol { | |
3179 | local($^W)=0; | |
3180 | my $self = shift; | |
424ec8fa | 3181 | return 'https' if uc($self->https()) eq 'ON'; |
54310121 | 3182 | return 'https' if $self->server_port == 443; |
3183 | my $prot = $self->server_protocol; | |
3184 | my($protocol,$version) = split('/',$prot); | |
3185 | return "\L$protocol\E"; | |
3186 | } | |
3187 | END_OF_FUNC | |
3188 | ||
3189 | #### Method: remote_ident | |
3190 | # Return the identity of the remote user | |
3191 | # (but only if his host is running identd) | |
3192 | #### | |
3193 | 'remote_ident' => <<'END_OF_FUNC', | |
3194 | sub remote_ident { | |
3195 | return $ENV{'REMOTE_IDENT'}; | |
3196 | } | |
3197 | END_OF_FUNC | |
3198 | ||
3199 | ||
3200 | #### Method: auth_type | |
3201 | # Return the type of use verification/authorization in use, if any. | |
3202 | #### | |
3203 | 'auth_type' => <<'END_OF_FUNC', | |
3204 | sub auth_type { | |
3205 | return $ENV{'AUTH_TYPE'}; | |
3206 | } | |
3207 | END_OF_FUNC | |
3208 | ||
3209 | ||
3210 | #### Method: remote_user | |
3211 | # Return the authorization name used for user | |
3212 | # verification. | |
3213 | #### | |
3214 | 'remote_user' => <<'END_OF_FUNC', | |
3215 | sub remote_user { | |
3216 | return $ENV{'REMOTE_USER'}; | |
3217 | } | |
3218 | END_OF_FUNC | |
3219 | ||
3220 | ||
3221 | #### Method: user_name | |
3222 | # Try to return the remote user's name by hook or by | |
3223 | # crook | |
3224 | #### | |
3225 | 'user_name' => <<'END_OF_FUNC', | |
3226 | sub user_name { | |
3227 | my ($self) = self_or_CGI(@_); | |
3228 | return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'}; | |
3229 | } | |
3230 | END_OF_FUNC | |
3231 | ||
3d1a2ec4 GS |
3232 | #### Method: nosticky |
3233 | # Set or return the NOSTICKY global flag | |
3234 | #### | |
3235 | 'nosticky' => <<'END_OF_FUNC', | |
3236 | sub nosticky { | |
3237 | my ($self,$param) = self_or_CGI(@_); | |
3238 | $CGI::NOSTICKY = $param if defined($param); | |
3239 | return $CGI::NOSTICKY; | |
3240 | } | |
3241 | END_OF_FUNC | |
3242 | ||
54310121 | 3243 | #### Method: nph |
3244 | # Set or return the NPH global flag | |
3245 | #### | |
3246 | 'nph' => <<'END_OF_FUNC', | |
3247 | sub nph { | |
3248 | my ($self,$param) = self_or_CGI(@_); | |
7d37aa8e LS |
3249 | $CGI::NPH = $param if defined($param); |
3250 | return $CGI::NPH; | |
3251 | } | |
3252 | END_OF_FUNC | |
3253 | ||
3254 | #### Method: private_tempfiles | |
3255 | # Set or return the private_tempfiles global flag | |
3256 | #### | |
3257 | 'private_tempfiles' => <<'END_OF_FUNC', | |
3258 | sub private_tempfiles { | |
3259 | my ($self,$param) = self_or_CGI(@_); | |
424ec8fa | 3260 | $CGI::PRIVATE_TEMPFILES = $param if defined($param); |
7d37aa8e | 3261 | return $CGI::PRIVATE_TEMPFILES; |
54310121 | 3262 | } |
3263 | END_OF_FUNC | |
8f3ccfa2 JH |
3264 | #### Method: close_upload_files |
3265 | # Set or return the close_upload_files global flag | |
3266 | #### | |
3267 | 'close_upload_files' => <<'END_OF_FUNC', | |
3268 | sub close_upload_files { | |
3269 | my ($self,$param) = self_or_CGI(@_); | |
3270 | $CGI::CLOSE_UPLOAD_FILES = $param if defined($param); | |
3271 | return $CGI::CLOSE_UPLOAD_FILES; | |
3272 | } | |
3273 | END_OF_FUNC | |
3274 | ||
54310121 | 3275 | |
424ec8fa GS |
3276 | #### Method: default_dtd |
3277 | # Set or return the default_dtd global | |
3278 | #### | |
3279 | 'default_dtd' => <<'END_OF_FUNC', | |
3280 | sub default_dtd { | |
3d1a2ec4 GS |
3281 | my ($self,$param,$param2) = self_or_CGI(@_); |
3282 | if (defined $param2 && defined $param) { | |
3283 | $CGI::DEFAULT_DTD = [ $param, $param2 ]; | |
3284 | } elsif (defined $param) { | |
3285 | $CGI::DEFAULT_DTD = $param; | |
3286 | } | |
424ec8fa GS |
3287 | return $CGI::DEFAULT_DTD; |
3288 | } | |
3289 | END_OF_FUNC | |
3290 | ||
54310121 | 3291 | # -------------- really private subroutines ----------------- |
3292 | 'previous_or_default' => <<'END_OF_FUNC', | |
3293 | sub previous_or_default { | |
3294 | my($self,$name,$defaults,$override) = @_; | |
3295 | my(%selected); | |
3296 | ||
3297 | if (!$override && ($self->{'.fieldnames'}->{$name} || | |
3298 | defined($self->param($name)) ) ) { | |
f84167b3 | 3299 | $selected{$_}++ for $self->param($name); |
54310121 | 3300 | } elsif (defined($defaults) && ref($defaults) && |
3301 | (ref($defaults) eq 'ARRAY')) { | |
f84167b3 | 3302 | $selected{$_}++ for @{$defaults}; |
54310121 | 3303 | } else { |
3304 | $selected{$defaults}++ if defined($defaults); | |
3305 | } | |
3306 | ||
3307 | return %selected; | |
3308 | } | |
3309 | END_OF_FUNC | |
3310 | ||
3311 | 'register_parameter' => <<'END_OF_FUNC', | |
3312 | sub register_parameter { | |
3313 | my($self,$param) = @_; | |
3314 | $self->{'.parametersToAdd'}->{$param}++; | |
3315 | } | |
3316 | END_OF_FUNC | |
3317 | ||
3318 | 'get_fields' => <<'END_OF_FUNC', | |
3319 | sub get_fields { | |
3320 | my($self) = @_; | |
424ec8fa GS |
3321 | return $self->CGI::hidden('-name'=>'.cgifields', |
3322 | '-values'=>[keys %{$self->{'.parametersToAdd'}}], | |
3323 | '-override'=>1); | |
54310121 | 3324 | } |
3325 | END_OF_FUNC | |
3326 | ||
3327 | 'read_from_cmdline' => <<'END_OF_FUNC', | |
3328 | sub read_from_cmdline { | |
54310121 | 3329 | my($input,@words); |
3330 | my($query_string); | |
2ed511ec | 3331 | my($subpath); |
3d1a2ec4 | 3332 | if ($DEBUG && @ARGV) { |
424ec8fa | 3333 | @words = @ARGV; |
3d1a2ec4 | 3334 | } elsif ($DEBUG > 1) { |
424ec8fa | 3335 | require "shellwords.pl"; |
2ed511ec | 3336 | print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n"; |
424ec8fa | 3337 | chomp(@lines = <STDIN>); # remove newlines |
54310121 | 3338 | $input = join(" ",@lines); |
424ec8fa GS |
3339 | @words = &shellwords($input); |
3340 | } | |
3341 | foreach (@words) { | |
3342 | s/\\=/%3D/g; | |
3343 | s/\\&/%26/g; | |
54310121 | 3344 | } |
3345 | ||
54310121 | 3346 | if ("@words"=~/=/) { |
3347 | $query_string = join('&',@words); | |
3348 | } else { | |
3349 | $query_string = join('+',@words); | |
3350 | } | |
2ed511ec RGS |
3351 | if ($query_string =~ /^(.*?)\?(.*)$/) |
3352 | { | |
3353 | $query_string = $2; | |
3354 | $subpath = $1; | |
3355 | } | |
3356 | return { 'query_string' => $query_string, 'subpath' => $subpath }; | |
54310121 | 3357 | } |
3358 | END_OF_FUNC | |
3359 | ||
3360 | ##### | |
3361 | # subroutine: read_multipart | |
3362 | # | |
3363 | # Read multipart data and store it into our parameters. | |
3364 | # An interesting feature is that if any of the parts is a file, we | |
3365 | # create a temporary file and open up a filehandle on it so that the | |
3366 | # caller can read from it if necessary. | |
3367 | ##### | |
3368 | 'read_multipart' => <<'END_OF_FUNC', | |
3369 | sub read_multipart { | |
2ed511ec RGS |
3370 | my($self,$boundary,$length) = @_; |
3371 | my($buffer) = $self->new_MultipartBuffer($boundary,$length); | |
54310121 | 3372 | return unless $buffer; |
3373 | my(%header,$body); | |
424ec8fa | 3374 | my $filenumber = 0; |
54310121 | 3375 | while (!$buffer->eof) { |
3376 | %header = $buffer->readHeader; | |
3538e1d5 GS |
3377 | |
3378 | unless (%header) { | |
3379 | $self->cgi_error("400 Bad request (malformed multipart POST)"); | |
3380 | return; | |
3381 | } | |
54310121 | 3382 | |
c29edf6c | 3383 | my($param)= $header{'Content-Disposition'}=~/ name="([^"]*)"/; |
188ba755 | 3384 | $param .= $TAINTED; |
54310121 | 3385 | |
424ec8fa | 3386 | # Bug: Netscape doesn't escape quotation marks in file names!!! |
959037a0 MA |
3387 | # See RFC 1867, 2183, 2045 |
3388 | # NB: File content will be loaded into memory should | |
3389 | # content-disposition parsing fail. | |
3390 | my ($filename) = $header{'Content-Disposition'}=~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i; | |
3391 | $filename =~ s/^"([^"]*)"$/$1/; | |
8f3ccfa2 JH |
3392 | # Test for Opera's multiple upload feature |
3393 | my($multipart) = ( defined( $header{'Content-Type'} ) && | |
3394 | $header{'Content-Type'} =~ /multipart\/mixed/ ) ? | |
3395 | 1 : 0; | |
54310121 | 3396 | |
3397 | # add this parameter to our list | |
3398 | $self->add_parameter($param); | |
3399 | ||
3400 | # If no filename specified, then just read the data and assign it | |
3401 | # to our parameter list. | |
8f3ccfa2 | 3402 | if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) { |
54310121 | 3403 | my($value) = $buffer->readBody; |
188ba755 | 3404 | $value .= $TAINTED; |
54310121 | 3405 | push(@{$self->{$param}},$value); |
3406 | next; | |
3407 | } | |
3408 | ||
424ec8fa GS |
3409 | my ($tmpfile,$tmp,$filehandle); |
3410 | UPLOADS: { | |
3411 | # If we get here, then we are dealing with a potentially large | |
3412 | # uploaded form. Save the data to a temporary file, then open | |
3413 | # the file for reading. | |
54310121 | 3414 | |
424ec8fa GS |
3415 | # skip the file if uploads disabled |
3416 | if ($DISABLE_UPLOADS) { | |
3417 | while (defined($data = $buffer->read)) { } | |
3418 | last UPLOADS; | |
3419 | } | |
7d37aa8e | 3420 | |
8f3ccfa2 JH |
3421 | # set the filename to some recognizable value |
3422 | if ( ( !defined($filename) || $filename eq '' ) && $multipart ) { | |
3423 | $filename = "multipart/mixed"; | |
3424 | } | |
3425 | ||
3538e1d5 | 3426 | # choose a relatively unpredictable tmpfile sequence number |
29ddc2a4 | 3427 | my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV)); |
3538e1d5 | 3428 | for (my $cnt=10;$cnt>0;$cnt--) { |
ac734d8b | 3429 | next unless $tmpfile = new CGITempFile($seqno); |
3538e1d5 | 3430 | $tmp = $tmpfile->as_string; |
ffd2dff2 | 3431 | last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES)); |
3538e1d5 GS |
3432 | $seqno += int rand(100); |
3433 | } | |
69c89ae7 | 3434 | die "CGI open of tmpfile: $!\n" unless defined $filehandle; |
2ed511ec RGS |
3435 | $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode |
3436 | && defined fileno($filehandle); | |
424ec8fa | 3437 | |
8f3ccfa2 | 3438 | # if this is an multipart/mixed attachment, save the header |
2ed511ec | 3439 | # together with the body for later parsing with an external |
8f3ccfa2 JH |
3440 | # MIME parser module |
3441 | if ( $multipart ) { | |
3442 | foreach ( keys %header ) { | |
3443 | print $filehandle "$_: $header{$_}${CRLF}"; | |
3444 | } | |
3445 | print $filehandle "${CRLF}"; | |
3446 | } | |
3447 | ||
424ec8fa | 3448 | my ($data); |
71f3e297 | 3449 | local($\) = ''; |
bb8b3399 | 3450 | my $totalbytes = 0; |
2ed511ec RGS |
3451 | while (defined($data = $buffer->read)) { |
3452 | if (defined $self->{'.upload_hook'}) | |
3453 | { | |
3454 | $totalbytes += length($data); | |
3455 | &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'}); | |
3456 | } | |
cb3b230c | 3457 | print $filehandle $data if ($self->{'use_tempfile'}); |
2ed511ec | 3458 | } |
424ec8fa GS |
3459 | |
3460 | # back up to beginning of file | |
3461 | seek($filehandle,0,0); | |
8f3ccfa2 JH |
3462 | |
3463 | ## Close the filehandle if requested this allows a multipart MIME | |
3464 | ## upload to contain many files, and we won't die due to too many | |
3465 | ## open file handles. The user can access the files using the hash | |
3466 | ## below. | |
3467 | close $filehandle if $CLOSE_UPLOAD_FILES; | |
424ec8fa GS |
3468 | $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; |
3469 | ||
3470 | # Save some information about the uploaded file where we can get | |
3471 | # at it later. | |
0a9bdad4 SP |
3472 | # Use the typeglob as the key, as this is guaranteed to be |
3473 | # unique for each filehandle. Don't use the file descriptor as | |
3474 | # this will be re-used for each filehandle if the | |
3475 | # close_upload_files feature is used. | |
3476 | $self->{'.tmpfiles'}->{$$filehandle}= { | |
2ed511ec | 3477 | hndl => $filehandle, |
424ec8fa GS |
3478 | name => $tmpfile, |
3479 | info => {%header}, | |
3480 | }; | |
3481 | push(@{$self->{$param}},$filehandle); | |
3482 | } | |
54310121 | 3483 | } |
3484 | } | |
3485 | END_OF_FUNC | |
3486 | ||
8869a4b7 SP |
3487 | ##### |
3488 | # subroutine: read_multipart_related | |
3489 | # | |
3490 | # Read multipart/related data and store it into our parameters. The | |
3491 | # first parameter sets the start of the data. The part identified by | |
3492 | # this Content-ID will not be stored as a file upload, but will be | |
3493 | # returned by this method. All other parts will be available as file | |
3494 | # uploads accessible by their Content-ID | |
3495 | ##### | |
3496 | 'read_multipart_related' => <<'END_OF_FUNC', | |
3497 | sub read_multipart_related { | |
3498 | my($self,$start,$boundary,$length) = @_; | |
3499 | my($buffer) = $self->new_MultipartBuffer($boundary,$length); | |
3500 | return unless $buffer; | |
3501 | my(%header,$body); | |
3502 | my $filenumber = 0; | |
3503 | my $returnvalue; | |
3504 | while (!$buffer->eof) { | |
3505 | %header = $buffer->readHeader; | |
3506 | ||
3507 | unless (%header) { | |
3508 | $self->cgi_error("400 Bad request (malformed multipart POST)"); | |
3509 | return; | |
3510 | } | |
3511 | ||
3512 | my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/; | |
3513 | $param .= $TAINTED; | |
3514 | ||
3515 | # If this is the start part, then just read the data and assign it | |
3516 | # to our return variable. | |
3517 | if ( $param eq $start ) { | |
3518 | $returnvalue = $buffer->readBody; | |
3519 | $returnvalue .= $TAINTED; | |
3520 | next; | |
3521 | } | |
3522 | ||
3523 | # add this parameter to our list | |
3524 | $self->add_parameter($param); | |
3525 | ||
3526 | my ($tmpfile,$tmp,$filehandle); | |
3527 | UPLOADS: { | |
3528 | # If we get here, then we are dealing with a potentially large | |
3529 | # uploaded form. Save the data to a temporary file, then open | |
3530 | # the file for reading. | |
3531 | ||
3532 | # skip the file if uploads disabled | |
3533 | if ($DISABLE_UPLOADS) { | |
3534 | while (defined($data = $buffer->read)) { } | |
3535 | last UPLOADS; | |
3536 | } | |
3537 | ||
3538 | # choose a relatively unpredictable tmpfile sequence number | |
3539 | my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV)); | |
3540 | for (my $cnt=10;$cnt>0;$cnt--) { | |
3541 | next unless $tmpfile = new CGITempFile($seqno); | |
3542 | $tmp = $tmpfile->as_string; | |
3543 | last if defined($filehandle = Fh->new($param,$tmp,$PRIVATE_TEMPFILES)); | |
3544 | $seqno += int rand(100); | |
3545 | } | |
3546 | die "CGI open of tmpfile: $!\n" unless defined $filehandle; | |
3547 | $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode | |
3548 | && defined fileno($filehandle); | |
3549 | ||
3550 | my ($data); | |
3551 | local($\) = ''; | |
3552 | my $totalbytes; | |
3553 | while (defined($data = $buffer->read)) { | |
3554 | if (defined $self->{'.upload_hook'}) | |
3555 | { | |
3556 | $totalbytes += length($data); | |
3557 | &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'}); | |
3558 | } | |
3559 | print $filehandle $data if ($self->{'use_tempfile'}); | |
3560 | } | |
3561 | ||
3562 | # back up to beginning of file | |
3563 | seek($filehandle,0,0); | |
3564 | ||
3565 | ## Close the filehandle if requested this allows a multipart MIME | |
3566 | ## upload to contain many files, and we won't die due to too many | |
3567 | ## open file handles. The user can access the files using the hash | |
3568 | ## below. | |
3569 | close $filehandle if $CLOSE_UPLOAD_FILES; | |
3570 | $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; | |
3571 | ||
3572 | # Save some information about the uploaded file where we can get | |
3573 | # at it later. | |
3574 | # Use the typeglob as the key, as this is guaranteed to be | |
3575 | # unique for each filehandle. Don't use the file descriptor as | |
3576 | # this will be re-used for each filehandle if the | |
3577 | # close_upload_files feature is used. | |
3578 | $self->{'.tmpfiles'}->{$$filehandle}= { | |
3579 | hndl => $filehandle, | |
3580 | name => $tmpfile, | |
3581 | info => {%header}, | |
3582 | }; | |
3583 | push(@{$self->{$param}},$filehandle); | |
3584 | } | |
3585 | } | |
3586 | return $returnvalue; | |
3587 | } | |
3588 | END_OF_FUNC | |
3589 | ||
3590 | ||
3538e1d5 GS |
3591 | 'upload' =><<'END_OF_FUNC', |
3592 | sub upload { | |
3593 | my($self,$param_name) = self_or_default(@_); | |
0664a57d | 3594 | my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name); |
199d4a26 JH |
3595 | return unless @param; |
3596 | return wantarray ? @param : $param[0]; | |
3538e1d5 GS |
3597 | } |
3598 | END_OF_FUNC | |
3599 | ||
54310121 | 3600 | 'tmpFileName' => <<'END_OF_FUNC', |
3601 | sub tmpFileName { | |
3602 | my($self,$filename) = self_or_default(@_); | |
0a9bdad4 SP |
3603 | return $self->{'.tmpfiles'}->{$$filename}->{name} ? |
3604 | $self->{'.tmpfiles'}->{$$filename}->{name}->as_string | |
7d37aa8e | 3605 | : ''; |
54310121 | 3606 | } |
3607 | END_OF_FUNC | |
3608 | ||
424ec8fa | 3609 | 'uploadInfo' => <<'END_OF_FUNC', |
54310121 | 3610 | sub uploadInfo { |
3611 | my($self,$filename) = self_or_default(@_); | |
0a9bdad4 | 3612 | return $self->{'.tmpfiles'}->{$$filename}->{info}; |
54310121 | 3613 | } |
3614 | END_OF_FUNC | |
3615 | ||
424ec8fa GS |
3616 | # internal routine, don't use |
3617 | '_set_values_and_labels' => <<'END_OF_FUNC', | |
3618 | sub _set_values_and_labels { | |
3619 | my $self = shift; | |
3620 | my ($v,$l,$n) = @_; | |
3621 | $$l = $v if ref($v) eq 'HASH' && !ref($$l); | |
3622 | return $self->param($n) if !defined($v); | |
3623 | return $v if !ref($v); | |
3624 | return ref($v) eq 'HASH' ? keys %$v : @$v; | |
3625 | } | |
3626 | END_OF_FUNC | |
3627 | ||
188ba755 JH |
3628 | # internal routine, don't use |
3629 | '_set_attributes' => <<'END_OF_FUNC', | |
3630 | sub _set_attributes { | |
3631 | my $self = shift; | |
3632 | my($element, $attributes) = @_; | |
3633 | return '' unless defined($attributes->{$element}); | |
3634 | $attribs = ' '; | |
3635 | foreach my $attrib (keys %{$attributes->{$element}}) { | |
13548fdf RGS |
3636 | (my $clean_attrib = $attrib) =~ s/^-//; |
3637 | $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" "; | |
188ba755 JH |
3638 | } |
3639 | $attribs =~ s/ $//; | |
3640 | return $attribs; | |
3641 | } | |
3642 | END_OF_FUNC | |
3643 | ||
424ec8fa GS |
3644 | '_compile_all' => <<'END_OF_FUNC', |
3645 | sub _compile_all { | |
3646 | foreach (@_) { | |
3647 | next if defined(&$_); | |
3648 | $AUTOLOAD = "CGI::$_"; | |
3649 | _compile(); | |
3650 | } | |
3651 | } | |
3652 | END_OF_FUNC | |
3653 | ||
54310121 | 3654 | ); |
3655 | END_OF_AUTOLOAD | |
3656 | ; | |
3657 | ||
424ec8fa GS |
3658 | ######################################################### |
3659 | # Globals and stubs for other packages that we use. | |
3660 | ######################################################### | |
3661 | ||
3662 | ################### Fh -- lightweight filehandle ############### | |
3663 | package Fh; | |
3664 | use overload | |
3665 | '""' => \&asString, | |
3666 | 'cmp' => \&compare, | |
3667 | 'fallback'=>1; | |
3668 | ||
3669 | $FH='fh00000'; | |
3670 | ||
3671 | *Fh::AUTOLOAD = \&CGI::AUTOLOAD; | |
3672 | ||
29ddc2a4 RGS |
3673 | sub DESTROY { |
3674 | my $self = shift; | |
3675 | close $self; | |
3676 | } | |
3677 | ||
424ec8fa GS |
3678 | $AUTOLOADED_ROUTINES = ''; # prevent -w error |
3679 | $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; | |
3680 | %SUBS = ( | |
3681 | 'asString' => <<'END_OF_FUNC', | |
3682 | sub asString { | |
3683 | my $self = shift; | |
71f3e297 | 3684 | # get rid of package name |
ffd2dff2 | 3685 | (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//; |
ba056755 | 3686 | $i =~ s/%(..)/ chr(hex($1)) /eg; |
188ba755 | 3687 | return $i.$CGI::TAINTED; |
71f3e297 JH |
3688 | # BEGIN DEAD CODE |
3689 | # This was an extremely clever patch that allowed "use strict refs". | |
3690 | # Unfortunately it relied on another bug that caused leaky file descriptors. | |
3691 | # The underlying bug has been fixed, so this no longer works. However | |
3692 | # "strict refs" still works for some reason. | |
3693 | # my $self = shift; | |
3694 | # return ${*{$self}{SCALAR}}; | |
3695 | # END DEAD CODE | |
424ec8fa GS |
3696 | } |
3697 | END_OF_FUNC | |
3698 | ||
3699 | 'compare' => <<'END_OF_FUNC', | |
3700 | sub compare { | |
3701 | my $self = shift; | |
3702 | my $value = shift; | |
3703 | return "$self" cmp $value; | |
3704 | } | |
3705 | END_OF_FUNC | |
3706 | ||
3707 | 'new' => <<'END_OF_FUNC', | |
3708 | sub new { | |
3709 | my($pack,$name,$file,$delete) = @_; | |
188ba755 | 3710 | _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS; |
424ec8fa | 3711 | require Fcntl unless defined &Fcntl::O_RDWR; |
ba056755 JH |
3712 | (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg; |
3713 | my $fv = ++$FH . $safename; | |
6b4ac661 | 3714 | my $ref = \*{"Fh::$fv"}; |
bb8b3399 | 3715 | $file =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\-]+)$! || return; |
188ba755 JH |
3716 | my $safe = $1; |
3717 | sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return; | |
3718 | unlink($safe) if $delete; | |
6b4ac661 | 3719 | CORE::delete $Fh::{$fv}; |
71f3e297 | 3720 | return bless $ref,$pack; |
424ec8fa GS |
3721 | } |
3722 | END_OF_FUNC | |
3723 | ||
424ec8fa GS |
3724 | ); |
3725 | END_OF_AUTOLOAD | |
3726 | ||
3727 | ######################## MultipartBuffer #################### | |
54310121 | 3728 | package MultipartBuffer; |
3729 | ||
2ed511ec RGS |
3730 | use constant DEBUG => 0; |
3731 | ||
54310121 | 3732 | # how many bytes to read at a time. We use |
71f3e297 JH |
3733 | # a 4K buffer by default. |
3734 | $INITIAL_FILLUNIT = 1024 * 4; | |
3735 | $TIMEOUT = 240*60; # 4 hour timeout for big files | |
3736 | $SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers | |
54310121 | 3737 | $CRLF=$CGI::CRLF; |
3738 | ||
3739 | #reuse the autoload function | |
3740 | *MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD; | |
3741 | ||
424ec8fa GS |
3742 | # avoid autoloader warnings |
3743 | sub DESTROY {} | |
3744 | ||
54310121 | 3745 | ############################################################################### |
3746 | ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### | |
3747 | ############################################################################### | |
3748 | $AUTOLOADED_ROUTINES = ''; # prevent -w error | |
3749 | $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; | |
3750 | %SUBS = ( | |
3751 | ||
3752 | 'new' => <<'END_OF_FUNC', | |
3753 | sub new { | |
2ed511ec | 3754 | my($package,$interface,$boundary,$length) = @_; |
424ec8fa | 3755 | $FILLUNIT = $INITIAL_FILLUNIT; |
2ed511ec | 3756 | $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always |
29ddc2a4 | 3757 | |
54310121 | 3758 | # If the user types garbage into the file upload field, |
3759 | # then Netscape passes NOTHING to the server (not good). | |
3760 | # We may hang on this read in that case. So we implement | |
3761 | # a read timeout. If nothing is ready to read | |
3762 | # by then, we return. | |
3763 | ||
3764 | # Netscape seems to be a little bit unreliable | |
3765 | # about providing boundary strings. | |
3d1a2ec4 | 3766 | my $boundary_read = 0; |
54310121 | 3767 | if ($boundary) { |
3768 | ||
3769 | # Under the MIME spec, the boundary consists of the | |
3770 | # characters "--" PLUS the Boundary string | |
424ec8fa GS |
3771 | |
3772 | # BUG: IE 3.01 on the Macintosh uses just the boundary -- not | |
71f3e297 | 3773 | # the two extra hyphens. We do a special case here on the user-agent!!!! |
69c89ae7 | 3774 | $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport'); |
424ec8fa | 3775 | |
54310121 | 3776 | } else { # otherwise we find it ourselves |
3777 | my($old); | |
3778 | ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line | |
2ed511ec | 3779 | $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl |
54310121 | 3780 | $length -= length($boundary); |
3781 | chomp($boundary); # remove the CRLF | |
3782 | $/ = $old; # restore old line separator | |
3d1a2ec4 | 3783 | $boundary_read++; |
54310121 | 3784 | } |
3785 | ||
3786 | my $self = {LENGTH=>$length, | |
29ddc2a4 | 3787 | CHUNKED=>!defined $length, |
54310121 | 3788 | BOUNDARY=>$boundary, |
54310121 | 3789 | INTERFACE=>$interface, |
3790 | BUFFER=>'', | |
3791 | }; | |
3792 | ||
3793 | $FILLUNIT = length($boundary) | |
3794 | if length($boundary) > $FILLUNIT; | |
3795 | ||
424ec8fa GS |
3796 | my $retval = bless $self,ref $package || $package; |
3797 | ||
3798 | # Read the preamble and the topmost (boundary) line plus the CRLF. | |
3d1a2ec4 GS |
3799 | unless ($boundary_read) { |
3800 | while ($self->read(0)) { } | |
3801 | } | |
2ed511ec | 3802 | die "Malformed multipart POST: data truncated\n" if $self->eof; |
424ec8fa GS |
3803 | |
3804 | return $retval; | |
54310121 | 3805 | } |
3806 | END_OF_FUNC | |
3807 | ||
3808 | 'readHeader' => <<'END_OF_FUNC', | |
3809 | sub readHeader { | |
3810 | my($self) = @_; | |
3811 | my($end); | |
3812 | my($ok) = 0; | |
47e3cabd | 3813 | my($bad) = 0; |
424ec8fa | 3814 | |
2ed511ec | 3815 | local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC; |
424ec8fa | 3816 | |
54310121 | 3817 | do { |
3818 | $self->fillBuffer($FILLUNIT); | |
3819 | $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0; | |
3820 | $ok++ if $self->{BUFFER} eq ''; | |
47e3cabd | 3821 | $bad++ if !$ok && $self->{LENGTH} <= 0; |
424ec8fa GS |
3822 | # this was a bad idea |
3823 | # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; | |
47e3cabd LS |
3824 | } until $ok || $bad; |
3825 | return () if $bad; | |
54310121 | 3826 | |
2ed511ec RGS |
3827 | #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines! |
3828 | ||
54310121 | 3829 | my($header) = substr($self->{BUFFER},0,$end+2); |
3830 | substr($self->{BUFFER},0,$end+4) = ''; | |
3831 | my %return; | |
424ec8fa | 3832 | |
2ed511ec RGS |
3833 | if ($CGI::EBCDIC) { |
3834 | warn "untranslated header=$header\n" if DEBUG; | |
3835 | $header = CGI::Util::ascii2ebcdic($header); | |
3836 | warn "translated header=$header\n" if DEBUG; | |
3837 | } | |
3838 | ||
424ec8fa GS |
3839 | # See RFC 2045 Appendix A and RFC 822 sections 3.4.8 |
3840 | # (Folding Long Header Fields), 3.4.3 (Comments) | |
3841 | # and 3.4.5 (Quoted-Strings). | |
3842 | ||
3843 | my $token = '[-\w!\#$%&\'*+.^_\`|{}~]'; | |
3844 | $header=~s/$CRLF\s+/ /og; # merge continuation lines | |
188ba755 | 3845 | |
424ec8fa | 3846 | while ($header=~/($token+):\s+([^$CRLF]*)/mgox) { |
188ba755 | 3847 | my ($field_name,$field_value) = ($1,$2); |
424ec8fa GS |
3848 | $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize |
3849 | $return{$field_name}=$field_value; | |
54310121 | 3850 | } |
3851 | return %return; | |
3852 | } | |
3853 | END_OF_FUNC | |
3854 | ||
3855 | # This reads and returns the body as a single scalar value. | |
3856 | 'readBody' => <<'END_OF_FUNC', | |
3857 | sub readBody { | |
3858 | my($self) = @_; | |
3859 | my($data); | |
3860 | my($returnval)=''; | |
2ed511ec RGS |
3861 | |
3862 | #EBCDIC NOTE: want to translate returnval into EBCDIC HERE | |
3863 | ||
54310121 | 3864 | while (defined($data = $self->read)) { |
3865 | $returnval .= $data; | |
3866 | } | |
2ed511ec RGS |
3867 | |
3868 | if ($CGI::EBCDIC) { | |
3869 | warn "untranslated body=$returnval\n" if DEBUG; | |
3870 | $returnval = CGI::Util::ascii2ebcdic($returnval); | |
3871 | warn "translated body=$returnval\n" if DEBUG; | |
3872 | } | |
54310121 | 3873 | return $returnval; |
3874 | } | |
3875 | END_OF_FUNC | |
3876 | ||
3877 | # This will read $bytes or until the boundary is hit, whichever happens | |
3878 | # first. After the boundary is hit, we return undef. The next read will | |
3879 | # skip over the boundary and begin reading again; | |
3880 | 'read' => <<'END_OF_FUNC', | |
3881 | sub read { | |
3882 | my($self,$bytes) = @_; | |
3883 | ||
3884 | # default number of bytes to read | |
2ed511ec | 3885 | $bytes = $bytes || $FILLUNIT; |
54310121 | 3886 | |
3887 | # Fill up our internal buffer in such a way that the boundary | |
3888 | # is never split between reads. | |
3889 | $self->fillBuffer($bytes); | |
3890 | ||
2ed511ec RGS |
3891 | my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY}; |
3892 | my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--'; | |
3893 | ||
54310121 | 3894 | # Find the boundary in the buffer (it may not be there). |
2ed511ec RGS |
3895 | my $start = index($self->{BUFFER},$boundary_start); |
3896 | ||
3897 | warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG; | |
54310121 | 3898 | |
29ddc2a4 RGS |
3899 | # protect against malformed multipart POST operations |
3900 | die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0); | |
2ed511ec RGS |
3901 | |
3902 | #EBCDIC NOTE: want to translate boundary search into ASCII here. | |
3903 | ||
54310121 | 3904 | # If the boundary begins the data, then skip past it |
03b9648d | 3905 | # and return undef. |
54310121 | 3906 | if ($start == 0) { |
3907 | ||
3908 | # clear us out completely if we've hit the last boundary. | |
2ed511ec | 3909 | if (index($self->{BUFFER},$boundary_end)==0) { |
54310121 | 3910 | $self->{BUFFER}=''; |
3911 | $self->{LENGTH}=0; | |
3912 | return undef; | |
3913 | } | |
3914 | ||
3915 | # just remove the boundary. | |
2ed511ec | 3916 | substr($self->{BUFFER},0,length($boundary_start))=''; |
03b9648d | 3917 | $self->{BUFFER} =~ s/^\012\015?//; |
54310121 | 3918 | return undef; |
3919 | } | |
3920 | ||
8f3ccfa2 | 3921 | my $bytesToReturn; |
54310121 | 3922 | if ($start > 0) { # read up to the boundary |
8f3ccfa2 | 3923 | $bytesToReturn = $start-2 > $bytes ? $bytes : $start; |
54310121 | 3924 | } else { # read the requested number of bytes |
3925 | # leave enough bytes in the buffer to allow us to read | |
3926 | # the boundary. Thanks to Kevin Hendrick for finding | |
3927 | # this one. | |
2ed511ec | 3928 | $bytesToReturn = $bytes - (length($boundary_start)+1); |
54310121 | 3929 | } |
3930 | ||
3931 | my $returnval=substr($self->{BUFFER},0,$bytesToReturn); | |
3932 | substr($self->{BUFFER},0,$bytesToReturn)=''; | |
3933 | ||
3934 | # If we hit the boundary, remove the CRLF from the end. | |
8f3ccfa2 | 3935 | return ($bytesToReturn==$start) |
ac734d8b | 3936 | ? substr($returnval,0,-2) : $returnval; |
54310121 | 3937 | } |
3938 | END_OF_FUNC | |
3939 | ||
3940 | ||
3941 | # This fills up our internal buffer in such a way that the | |
3942 | # boundary is never split between reads | |
3943 | 'fillBuffer' => <<'END_OF_FUNC', | |
3944 | sub fillBuffer { | |
3945 | my($self,$bytes) = @_; | |
29ddc2a4 | 3946 | return unless $self->{CHUNKED} || $self->{LENGTH}; |
54310121 | 3947 | |
3948 | my($boundaryLength) = length($self->{BOUNDARY}); | |
3949 | my($bufferLength) = length($self->{BUFFER}); | |
3950 | my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2; | |
29ddc2a4 | 3951 | $bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $self->{LENGTH} < $bytesToRead; |
54310121 | 3952 | |
2ed511ec RGS |
3953 | # Try to read some data. We may hang here if the browser is screwed up. |
3954 | my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER}, | |
54310121 | 3955 | $bytesToRead, |
3956 | $bufferLength); | |
2ed511ec | 3957 | warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG; |
71f3e297 | 3958 | $self->{BUFFER} = '' unless defined $self->{BUFFER}; |
54310121 | 3959 | |
47e3cabd | 3960 | # An apparent bug in the Apache server causes the read() |
54310121 | 3961 | # to return zero bytes repeatedly without blocking if the |
3962 | # remote user aborts during a file transfer. I don't know how | |
3963 | # they manage this, but the workaround is to abort if we get | |
3964 | # more than SPIN_LOOP_MAX consecutive zero reads. | |
29ddc2a4 | 3965 | if ($bytesRead <= 0) { |
54310121 | 3966 | die "CGI.pm: Server closed socket during multipart read (client aborted?).\n" |
3967 | if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX); | |
3968 | } else { | |
3969 | $self->{ZERO_LOOP_COUNTER}=0; | |
3970 | } | |
3971 | ||
29ddc2a4 | 3972 | $self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead; |
54310121 | 3973 | } |
3974 | END_OF_FUNC | |
3975 | ||
3976 | ||
3977 | # Return true when we've finished reading | |
3978 | 'eof' => <<'END_OF_FUNC' | |
3979 | sub eof { | |
3980 | my($self) = @_; | |
3981 | return 1 if (length($self->{BUFFER}) == 0) | |
3982 | && ($self->{LENGTH} <= 0); | |
3983 | undef; | |
3984 | } | |
3985 | END_OF_FUNC | |
3986 | ||
3987 | ); | |
3988 | END_OF_AUTOLOAD | |
3989 | ||
3990 | #################################################################################### | |
3991 | ################################## TEMPORARY FILES ################################# | |
3992 | #################################################################################### | |
ac734d8b | 3993 | package CGITempFile; |
54310121 | 3994 | |
cff99809 | 3995 | sub find_tempdir { |
cff99809 JH |
3996 | $SL = $CGI::SL; |
3997 | $MAC = $CGI::OS eq 'MACINTOSH'; | |
3998 | my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : ""; | |
0a9bdad4 | 3999 | unless (defined $TMPDIRECTORY) { |
424ec8fa | 4000 | @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp", |
3538e1d5 | 4001 | "C:${SL}temp","${SL}tmp","${SL}temp", |
3d1a2ec4 | 4002 | "${vol}${SL}Temporary Items", |
ba056755 JH |
4003 | "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH", |
4004 | "C:${SL}system${SL}temp"); | |
188ba755 | 4005 | unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'}; |
3538e1d5 | 4006 | |
3d1a2ec4 GS |
4007 | # this feature was supposed to provide per-user tmpfiles, but |
4008 | # it is problematic. | |
3538e1d5 GS |
4009 | # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX'; |
4010 | # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this | |
4011 | # : can generate a 'getpwuid() not implemented' exception, even though | |
4012 | # : it's never called. Found under DOS/Win with the DJGPP perl port. | |
4013 | # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX. | |
3d1a2ec4 | 4014 | # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0; |
3538e1d5 | 4015 | |
54310121 | 4016 | foreach (@TEMP) { |
cff99809 | 4017 | do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; |
54310121 | 4018 | } |
cff99809 JH |
4019 | } |
4020 | $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY; | |
54310121 | 4021 | } |
4022 | ||
cff99809 JH |
4023 | find_tempdir(); |
4024 | ||
424ec8fa | 4025 | $MAXTRIES = 5000; |
54310121 | 4026 | |
4027 | # cute feature, but overload implementation broke it | |
4028 | # %OVERLOAD = ('""'=>'as_string'); | |
ac734d8b | 4029 | *CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD; |
54310121 | 4030 | |
2371fea9 JH |
4031 | sub DESTROY { |
4032 | my($self) = @_; | |
188ba755 JH |
4033 | $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return; |
4034 | my $safe = $1; # untaint operation | |
4035 | unlink $safe; # get rid of the file | |
2371fea9 JH |
4036 | } |
4037 | ||
54310121 | 4038 | ############################################################################### |
4039 | ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### | |
4040 | ############################################################################### | |
4041 | $AUTOLOADED_ROUTINES = ''; # prevent -w error | |
4042 | $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; | |
4043 | %SUBS = ( | |
4044 | ||
4045 | 'new' => <<'END_OF_FUNC', | |
4046 | sub new { | |
3538e1d5 GS |
4047 | my($package,$sequence) = @_; |
4048 | my $filename; | |
cff99809 | 4049 | find_tempdir() unless -w $TMPDIRECTORY; |
3538e1d5 | 4050 | for (my $i = 0; $i < $MAXTRIES; $i++) { |
af20bb80 | 4051 | last if ! -f ($filename = sprintf("\%s${SL}CGItemp%d",$TMPDIRECTORY,$sequence++)); |
424ec8fa | 4052 | } |
188ba755 | 4053 | # check that it is a more-or-less valid filename |
bb8b3399 | 4054 | return unless $filename =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\-]+)$!; |
188ba755 JH |
4055 | # this used to untaint, now it doesn't |
4056 | # $filename = $1; | |
3538e1d5 | 4057 | return bless \$filename; |
54310121 | 4058 | } |
4059 | END_OF_FUNC | |
4060 | ||
54310121 | 4061 | 'as_string' => <<'END_OF_FUNC' |
4062 | sub as_string { | |
4063 | my($self) = @_; | |
4064 | return $$self; | |
4065 | } | |
4066 | END_OF_FUNC | |
4067 | ||
4068 | ); | |
4069 | END_OF_AUTOLOAD | |
4070 | ||
4071 | package CGI; | |
4072 | ||
4073 | # We get a whole bunch of warnings about "possibly uninitialized variables" | |
4074 | # when running with the -w switch. Touch them all once to get rid of the | |
4075 | # warnings. This is ugly and I hate it. | |
4076 | if ($^W) { | |
4077 | $CGI::CGI = ''; | |
4078 | $CGI::CGI=<<EOF; | |
4079 | $CGI::VERSION; | |
4080 | $MultipartBuffer::SPIN_LOOP_MAX; | |
4081 | $MultipartBuffer::CRLF; | |
4082 | $MultipartBuffer::TIMEOUT; | |
424ec8fa | 4083 | $MultipartBuffer::INITIAL_FILLUNIT; |
54310121 | 4084 | EOF |
4085 | ; | |
4086 | } | |
4087 | ||
424ec8fa | 4088 | 1; |
54310121 | 4089 | |
4090 | __END__ | |
4091 | ||
4092 | =head1 NAME | |
4093 | ||
4094 | CGI - Simple Common Gateway Interface Class | |
4095 | ||
dc848c6f | 4096 | =head1 SYNOPSIS |
4097 | ||
424ec8fa GS |
4098 | # CGI script that creates a fill-out form |
4099 | # and echoes back its values. | |
4100 | ||
4101 | use CGI qw/:standard/; | |
4102 | print header, | |
4103 | start_html('A Simple Example'), | |
4104 | h1('A Simple Example'), | |
4105 | start_form, | |
4106 | "What's your name? ",textfield('name'),p, | |
4107 | "What's the combination?", p, | |
4108 | checkbox_group(-name=>'words', | |
4109 | -values=>['eenie','meenie','minie','moe'], | |
4110 | -defaults=>['eenie','minie']), p, | |
4111 | "What's your favorite color? ", | |
4112 | popup_menu(-name=>'color', | |
4113 | -values=>['red','green','blue','chartreuse']),p, | |
4114 | submit, | |
4115 | end_form, | |
4116 | hr; | |
4117 | ||
4118 | if (param()) { | |
7dc108d1 SP |
4119 | my $name = param('name'); |
4120 | my $keywords = join ', ',param('words'); | |
4121 | my $color = param('color'); | |
4122 | print "Your name is",em(escapeHTML($name)),p, | |
4123 | "The keywords are: ",em(escapeHTML($keywords)),p, | |
4124 | "Your favorite color is ",em(escapeHTML($color)), | |
424ec8fa GS |
4125 | hr; |
4126 | } | |
dc848c6f | 4127 | |
384f06ae SP |
4128 | print end_html; |
4129 | ||
54310121 | 4130 | =head1 ABSTRACT |
4131 | ||
424ec8fa GS |
4132 | This perl library uses perl5 objects to make it easy to create Web |
4133 | fill-out forms and parse their contents. This package defines CGI | |
4134 | objects, entities that contain the values of the current query string | |
4135 | and other state variables. Using a CGI object's methods, you can | |
4136 | examine keywords and parameters passed to your script, and create | |
4137 | forms whose initial values are taken from the current query (thereby | |
4138 | preserving state information). The module provides shortcut functions | |
4139 | that produce boilerplate HTML, reducing typing and coding errors. It | |
4140 | also provides functionality for some of the more advanced features of | |
4141 | CGI scripting, including support for file uploads, cookies, cascading | |
4142 | style sheets, server push, and frames. | |
4143 | ||
4144 | CGI.pm also provides a simple function-oriented programming style for | |
4145 | those who don't need its object-oriented features. | |
54310121 | 4146 | |
4147 | The current version of CGI.pm is available at | |
4148 | ||
4149 | http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html | |
4150 | ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ | |
4151 | ||
424ec8fa | 4152 | =head1 DESCRIPTION |
47e3cabd | 4153 | |
424ec8fa GS |
4154 | =head2 PROGRAMMING STYLE |
4155 | ||
4156 | There are two styles of programming with CGI.pm, an object-oriented | |
4157 | style and a function-oriented style. In the object-oriented style you | |
4158 | create one or more CGI objects and then use object methods to create | |
4159 | the various elements of the page. Each CGI object starts out with the | |
4160 | list of named parameters that were passed to your CGI script by the | |
4161 | server. You can modify the objects, save them to a file or database | |
4162 | and recreate them. Because each object corresponds to the "state" of | |
4163 | the CGI script, and because each object's parameter list is | |
4164 | independent of the others, this allows you to save the state of the | |
4165 | script and restore it later. | |
4166 | ||
f610777f | 4167 | For example, using the object oriented style, here is how you create |
424ec8fa GS |
4168 | a simple "Hello World" HTML page: |
4169 | ||
3538e1d5 | 4170 | #!/usr/local/bin/perl -w |
424ec8fa GS |
4171 | use CGI; # load CGI routines |
4172 | $q = new CGI; # create new CGI object | |
4173 | print $q->header, # create the HTTP header | |
4174 | $q->start_html('hello world'), # start the HTML | |
4175 | $q->h1('hello world'), # level 1 header | |
4176 | $q->end_html; # end the HTML | |
4177 | ||
4178 | In the function-oriented style, there is one default CGI object that | |
4179 | you rarely deal with directly. Instead you just call functions to | |
4180 | retrieve CGI parameters, create HTML tags, manage cookies, and so | |
4181 | on. This provides you with a cleaner programming interface, but | |
4182 | limits you to using one CGI object at a time. The following example | |
4183 | prints the same page, but uses the function-oriented interface. | |
4184 | The main differences are that we now need to import a set of functions | |
4185 | into our name space (usually the "standard" functions), and we don't | |
4186 | need to create the CGI object. | |
4187 | ||
71f3e297 | 4188 | #!/usr/local/bin/perl |
424ec8fa GS |
4189 | use CGI qw/:standard/; # load standard CGI routines |
4190 | print header, # create the HTTP header | |
4191 | start_html('hello world'), # start the HTML | |
4192 | h1('hello world'), # level 1 header | |
4193 | end_html; # end the HTML | |
4194 | ||
4195 | The examples in this document mainly use the object-oriented style. | |
4196 | See HOW TO IMPORT FUNCTIONS for important information on | |
4197 | function-oriented programming in CGI.pm | |
4198 | ||
4199 | =head2 CALLING CGI.PM ROUTINES | |
4200 | ||
4201 | Most CGI.pm routines accept several arguments, sometimes as many as 20 | |
4202 | optional ones! To simplify this interface, all routines use a named | |
4203 | argument calling style that looks like this: | |
4204 | ||
4205 | print $q->header(-type=>'image/gif',-expires=>'+3d'); | |
4206 | ||
4207 | Each argument name is preceded by a dash. Neither case nor order | |
4208 | matters in the argument list. -type, -Type, and -TYPE are all | |
4209 | acceptable. In fact, only the first argument needs to begin with a | |
4210 | dash. If a dash is present in the first argument, CGI.pm assumes | |
4211 | dashes for the subsequent ones. | |
4212 | ||
424ec8fa GS |
4213 | Several routines are commonly called with just one argument. In the |
4214 | case of these routines you can provide the single argument without an | |
4215 | argument name. header() happens to be one of these routines. In this | |
4216 | case, the single argument is the document type. | |
4217 | ||
4218 | print $q->header('text/html'); | |
4219 | ||
4220 | Other such routines are documented below. | |
4221 | ||
4222 | Sometimes named arguments expect a scalar, sometimes a reference to an | |
4223 | array, and sometimes a reference to a hash. Often, you can pass any | |
4224 | type of argument and the routine will do whatever is most appropriate. | |
4225 | For example, the param() routine is used to set a CGI parameter to a | |
4226 | single or a multi-valued value. The two cases are shown below: | |
4227 | ||
4228 | $q->param(-name=>'veggie',-value=>'tomato'); | |
3d1a2ec4 | 4229 | $q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']); |
424ec8fa GS |
4230 | |
4231 | A large number of routines in CGI.pm actually aren't specifically | |
4232 | defined in the module, but are generated automatically as needed. | |
4233 | These are the "HTML shortcuts," routines that generate HTML tags for | |
4234 | use in dynamically-generated pages. HTML tags have both attributes | |
4235 | (the attribute="value" pairs within the tag itself) and contents (the | |
4236 | part between the opening and closing pairs.) To distinguish between | |
4237 | attributes and contents, CGI.pm uses the convention of passing HTML | |
4238 | attributes as a hash reference as the first argument, and the | |
4239 | contents, if any, as any subsequent arguments. It works out like | |
4240 | this: | |
4241 | ||
4242 | Code Generated HTML | |
4243 | ---- -------------- | |
3acbd4f5 JH |
4244 | h1() <h1> |
4245 | h1('some','contents'); <h1>some contents</h1> | |
188ba755 JH |
4246 | h1({-align=>left}); <h1 align="LEFT"> |
4247 | h1({-align=>left},'contents'); <h1 align="LEFT">contents</h1> | |
424ec8fa | 4248 | |
188ba755 | 4249 | HTML tags are described in more detail later. |
424ec8fa GS |
4250 | |
4251 | Many newcomers to CGI.pm are puzzled by the difference between the | |
4252 | calling conventions for the HTML shortcuts, which require curly braces | |
4253 | around the HTML tag attributes, and the calling conventions for other | |
4254 | routines, which manage to generate attributes without the curly | |
4255 | brackets. Don't be confused. As a convenience the curly braces are | |
4256 | optional in all but the HTML shortcuts. If you like, you can use | |
4257 | curly braces when calling any routine that takes named arguments. For | |
4258 | example: | |
4259 | ||
4260 | print $q->header( {-type=>'image/gif',-expires=>'+3d'} ); | |
4261 | ||
4262 | If you use the B<-w> switch, you will be warned that some CGI.pm argument | |
4263 | names conflict with built-in Perl functions. The most frequent of | |
4264 | these is the -values argument, used to create multi-valued menus, | |
4265 | radio button clusters and the like. To get around this warning, you | |
4266 | have several choices: | |
54310121 | 4267 | |
424ec8fa | 4268 | =over 4 |
54310121 | 4269 | |
551e1d92 RB |
4270 | =item 1. |
4271 | ||
4272 | Use another name for the argument, if one is available. | |
4273 | For example, -value is an alias for -values. | |
54310121 | 4274 | |
551e1d92 | 4275 | =item 2. |
54310121 | 4276 | |
551e1d92 RB |
4277 | Change the capitalization, e.g. -Values |
4278 | ||
4279 | =item 3. | |
4280 | ||
4281 | Put quotes around the argument name, e.g. '-values' | |
54310121 | 4282 | |
424ec8fa | 4283 | =back |
54310121 | 4284 | |
424ec8fa GS |
4285 | Many routines will do something useful with a named argument that it |
4286 | doesn't recognize. For example, you can produce non-standard HTTP | |
4287 | header fields by providing them as named arguments: | |
54310121 | 4288 | |
424ec8fa GS |
4289 | print $q->header(-type => 'text/html', |
4290 | -cost => 'Three smackers', | |
4291 | -annoyance_level => 'high', | |
4292 | -complaints_to => 'bit bucket'); | |
54310121 | 4293 | |
424ec8fa GS |
4294 | This will produce the following nonstandard HTTP header: |
4295 | ||
4296 | HTTP/1.0 200 OK | |
4297 | Cost: Three smackers | |
4298 | Annoyance-level: high | |
4299 | Complaints-to: bit bucket | |
4300 | Content-type: text/html | |
4301 | ||
4302 | Notice the way that underscores are translated automatically into | |
4303 | hyphens. HTML-generating routines perform a different type of | |
4304 | translation. | |
4305 | ||
4306 | This feature allows you to keep up with the rapidly changing HTTP and | |
4307 | HTML "standards". | |
54310121 | 4308 | |
424ec8fa | 4309 | =head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE): |
54310121 | 4310 | |
4311 | $query = new CGI; | |
4312 | ||
4313 | This will parse the input (from both POST and GET methods) and store | |
681699b9 SP |
4314 | it into a perl5 object called $query. |
4315 | ||
4316 | Any filehandles from file uploads will have their position reset to | |
4317 | the beginning of the file. | |
54310121 | 4318 | |
4319 | =head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE | |
4320 | ||
4321 | $query = new CGI(INPUTFILE); | |
4322 | ||
424ec8fa GS |
4323 | If you provide a file handle to the new() method, it will read |
4324 | parameters from the file (or STDIN, or whatever). The file can be in | |
4325 | any of the forms describing below under debugging (i.e. a series of | |
4326 | newline delimited TAG=VALUE pairs will work). Conveniently, this type | |
4327 | of file is created by the save() method (see below). Multiple records | |
4328 | can be saved and restored. | |
54310121 | 4329 | |
4330 | Perl purists will be pleased to know that this syntax accepts | |
4331 | references to file handles, or even references to filehandle globs, | |
4332 | which is the "official" way to pass a filehandle: | |
4333 | ||
4334 | $query = new CGI(\*STDIN); | |
4335 | ||
424ec8fa GS |
4336 | You can also initialize the CGI object with a FileHandle or IO::File |
4337 | object. | |
4338 | ||
4339 | If you are using the function-oriented interface and want to | |
4340 | initialize CGI state from a file handle, the way to do this is with | |
4341 | B<restore_parameters()>. This will (re)initialize the | |
4342 | default CGI object from the indicated file handle. | |
4343 | ||
4344 | open (IN,"test.in") || die; | |
4345 | restore_parameters(IN); | |
4346 | close IN; | |
4347 | ||
54310121 | 4348 | You can also initialize the query object from an associative array |
4349 | reference: | |
4350 | ||
4351 | $query = new CGI( {'dinosaur'=>'barney', | |
4352 | 'song'=>'I love you', | |
4353 | 'friends'=>[qw/Jessica George Nancy/]} | |
4354 | ); | |
4355 | ||
4356 | or from a properly formatted, URL-escaped query string: | |
4357 | ||
4358 | $query = new CGI('dinosaur=barney&color=purple'); | |
4359 | ||
424ec8fa GS |
4360 | or from a previously existing CGI object (currently this clones the |
4361 | parameter list, but none of the other object-specific fields, such as | |
4362 | autoescaping): | |
4363 | ||
4364 | $old_query = new CGI; | |
4365 | $new_query = new CGI($old_query); | |
4366 | ||
54310121 | 4367 | To create an empty query, initialize it from an empty string or hash: |
4368 | ||
424ec8fa GS |
4369 | $empty_query = new CGI(""); |
4370 | ||
4371 | -or- | |
4372 | ||
4373 | $empty_query = new CGI({}); | |
54310121 | 4374 | |
4375 | =head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY: | |
4376 | ||
4377 | @keywords = $query->keywords | |
4378 | ||
4379 | If the script was invoked as the result of an <ISINDEX> search, the | |
4380 | parsed keywords can be obtained as an array using the keywords() method. | |
4381 | ||
4382 | =head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT: | |
4383 | ||
4384 | @names = $query->param | |
4385 | ||
4386 | If the script was invoked with a parameter list | |
3d1a2ec4 GS |
4387 | (e.g. "name1=value1&name2=value2&name3=value3"), the param() method |
4388 | will return the parameter names as a list. If the script was invoked | |
4389 | as an <ISINDEX> script and contains a string without ampersands | |
4390 | (e.g. "value1+value2+value3") , there will be a single parameter named | |
4391 | "keywords" containing the "+"-delimited keywords. | |
54310121 | 4392 | |
4393 | NOTE: As of version 1.5, the array of parameter names returned will | |
4394 | be in the same order as they were submitted by the browser. | |
4395 | Usually this order is the same as the order in which the | |
4396 | parameters are defined in the form (however, this isn't part | |
4397 | of the spec, and so isn't guaranteed). | |
4398 | ||
4399 | =head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER: | |
4400 | ||
4401 | @values = $query->param('foo'); | |
4402 | ||
4403 | -or- | |
4404 | ||
4405 | $value = $query->param('foo'); | |
4406 | ||
4407 | Pass the param() method a single argument to fetch the value of the | |
4408 | named parameter. If the parameter is multivalued (e.g. from multiple | |
4409 | selections in a scrolling list), you can ask to receive an array. Otherwise | |
4410 | the method will return a single value. | |
4411 | ||
3d1a2ec4 GS |
4412 | If a value is not given in the query string, as in the queries |
4413 | "name1=&name2=" or "name1&name2", it will be returned as an empty | |
4414 | string. This feature is new in 2.63. | |
4415 | ||
8f3ccfa2 JH |
4416 | |
4417 | If the parameter does not exist at all, then param() will return undef | |
4418 | in a scalar context, and the empty list in a list context. | |
4419 | ||
4420 | ||
54310121 | 4421 | =head2 SETTING THE VALUE(S) OF A NAMED PARAMETER: |
4422 | ||
4423 | $query->param('foo','an','array','of','values'); | |
4424 | ||
4425 | This sets the value for the named parameter 'foo' to an array of | |
4426 | values. This is one way to change the value of a field AFTER | |
4427 | the script has been invoked once before. (Another way is with | |
4428 | the -override parameter accepted by all methods that generate | |
4429 | form elements.) | |
4430 | ||
4431 | param() also recognizes a named parameter style of calling described | |
4432 | in more detail later: | |
4433 | ||
4434 | $query->param(-name=>'foo',-values=>['an','array','of','values']); | |
4435 | ||
4436 | -or- | |
4437 | ||
4438 | $query->param(-name=>'foo',-value=>'the value'); | |
4439 | ||
4440 | =head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER: | |
4441 | ||
424ec8fa | 4442 | $query->append(-name=>'foo',-values=>['yet','more','values']); |
54310121 | 4443 | |
4444 | This adds a value or list of values to the named parameter. The | |
4445 | values are appended to the end of the parameter if it already exists. | |
4446 | Otherwise the parameter is created. Note that this method only | |
4447 | recognizes the named argument calling syntax. | |
4448 | ||
4449 | =head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE: | |
4450 | ||
4451 | $query->import_names('R'); | |
4452 | ||
4453 | This creates a series of variables in the 'R' namespace. For example, | |
4454 | $R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear. | |
4455 | If no namespace is given, this method will assume 'Q'. | |
4456 | WARNING: don't import anything into 'main'; this is a major security | |
4457 | risk!!!! | |
4458 | ||
8f3ccfa2 JH |
4459 | NOTE 1: Variable names are transformed as necessary into legal Perl |
4460 | variable names. All non-legal characters are transformed into | |
4461 | underscores. If you need to keep the original names, you should use | |
4462 | the param() method instead to access CGI variables by name. | |
4463 | ||
4464 | NOTE 2: In older versions, this method was called B<import()>. As of version 2.20, | |
54310121 | 4465 | this name has been removed completely to avoid conflict with the built-in |
4466 | Perl module B<import> operator. | |
4467 | ||
4468 | =head2 DELETING A PARAMETER COMPLETELY: | |
4469 | ||
188ba755 | 4470 | $query->delete('foo','bar','baz'); |
54310121 | 4471 | |
188ba755 JH |
4472 | This completely clears a list of parameters. It sometimes useful for |
4473 | resetting parameters that you don't want passed down between script | |
4474 | invocations. | |
54310121 | 4475 | |
424ec8fa GS |
4476 | If you are using the function call interface, use "Delete()" instead |
4477 | to avoid conflicts with Perl's built-in delete operator. | |
4478 | ||
54310121 | 4479 | =head2 DELETING ALL PARAMETERS: |
4480 | ||
424ec8fa | 4481 | $query->delete_all(); |
54310121 | 4482 | |
4483 | This clears the CGI object completely. It might be useful to ensure | |
4484 | that all the defaults are taken when you create a fill-out form. | |
4485 | ||
424ec8fa GS |
4486 | Use Delete_all() instead if you are using the function call interface. |
4487 | ||
0a9bdad4 SP |
4488 | =head2 HANDLING NON-URLENCODED ARGUMENTS |
4489 | ||
4490 | ||
4491 | If POSTed data is not of type application/x-www-form-urlencoded or | |
4492 | multipart/form-data, then the POSTed data will not be processed, but | |
4493 | instead be returned as-is in a parameter named POSTDATA. To retrieve | |
4494 | it, use code like this: | |
4495 | ||
4496 | my $data = $query->param('POSTDATA'); | |
4497 | ||
bb8b3399 SP |
4498 | Likewise if PUTed data can be retrieved with code like this: |
4499 | ||
4500 | my $data = $query->param('PUTDATA'); | |
4501 | ||
0a9bdad4 SP |
4502 | (If you don't know what the preceding means, don't worry about it. It |
4503 | only affects people trying to use CGI for XML processing and other | |
4504 | specialized tasks.) | |
4505 | ||
4506 | ||
424ec8fa GS |
4507 | =head2 DIRECT ACCESS TO THE PARAMETER LIST: |
4508 | ||
4509 | $q->param_fetch('address')->[1] = '1313 Mockingbird Lane'; | |
4510 | unshift @{$q->param_fetch(-name=>'address')},'George Munster'; | |
4511 | ||
4512 | If you need access to the parameter list in a way that isn't covered | |
4513 | by the methods above, you can obtain a direct reference to it by | |
4514 | calling the B<param_fetch()> method with the name of the . This | |
4515 | will return an array reference to the named parameters, which you then | |
4516 | can manipulate in any way you like. | |
4517 | ||
4518 | You can also use a named argument style using the B<-name> argument. | |
4519 | ||
3538e1d5 GS |
4520 | =head2 FETCHING THE PARAMETER LIST AS A HASH: |
4521 | ||
4522 | $params = $q->Vars; | |
4523 | print $params->{'address'}; | |
4524 | @foo = split("\0",$params->{'foo'}); | |
4525 | %params = $q->Vars; | |
4526 | ||
4527 | use CGI ':cgi-lib'; | |
4528 | $params = Vars; | |
4529 | ||
4530 | Many people want to fetch the entire parameter list as a hash in which | |
4531 | the keys are the names of the CGI parameters, and the values are the | |
4532 | parameters' values. The Vars() method does this. Called in a scalar | |
4533 | context, it returns the parameter list as a tied hash reference. | |
4534 | Changing a key changes the value of the parameter in the underlying | |
a3b3a725 | 4535 | CGI parameter list. Called in a list context, it returns the |
3538e1d5 GS |
4536 | parameter list as an ordinary hash. This allows you to read the |
4537 | contents of the parameter list, but not to change it. | |
4538 | ||
4539 | When using this, the thing you must watch out for are multivalued CGI | |
4540 | parameters. Because a hash cannot distinguish between scalar and | |
a3b3a725 | 4541 | list context, multivalued parameters will be returned as a packed |
3538e1d5 GS |
4542 | string, separated by the "\0" (null) character. You must split this |
4543 | packed string in order to get at the individual values. This is the | |
4544 | convention introduced long ago by Steve Brenner in his cgi-lib.pl | |
4545 | module for Perl version 4. | |
4546 | ||
4547 | If you wish to use Vars() as a function, import the I<:cgi-lib> set of | |
4548 | function calls (also see the section on CGI-LIB compatibility). | |
4549 | ||
424ec8fa | 4550 | =head2 SAVING THE STATE OF THE SCRIPT TO A FILE: |
54310121 | 4551 | |
29ddc2a4 | 4552 | $query->save(\*FILEHANDLE) |
54310121 | 4553 | |
4554 | This will write the current state of the form to the provided | |
4555 | filehandle. You can read it back in by providing a filehandle | |
4556 | to the new() method. Note that the filehandle can be a file, a pipe, | |
4557 | or whatever! | |
4558 | ||
4559 | The format of the saved file is: | |
4560 | ||
4561 | NAME1=VALUE1 | |
4562 | NAME1=VALUE1' | |
4563 | NAME2=VALUE2 | |
4564 | NAME3=VALUE3 | |
4565 | = | |
4566 | ||
4567 | Both name and value are URL escaped. Multi-valued CGI parameters are | |
4568 | represented as repeated names. A session record is delimited by a | |
4569 | single = symbol. You can write out multiple records and read them | |
4570 | back in with several calls to B<new>. You can do this across several | |
4571 | sessions by opening the file in append mode, allowing you to create | |
4572 | primitive guest books, or to keep a history of users' queries. Here's | |
4573 | a short example of creating multiple session records: | |
4574 | ||
4575 | use CGI; | |
4576 | ||
4577 | open (OUT,">>test.out") || die; | |
4578 | $records = 5; | |
4579 | foreach (0..$records) { | |
4580 | my $q = new CGI; | |
4581 | $q->param(-name=>'counter',-value=>$_); | |
29ddc2a4 | 4582 | $q->save(\*OUT); |
54310121 | 4583 | } |
4584 | close OUT; | |
4585 | ||
4586 | # reopen for reading | |
4587 | open (IN,"test.out") || die; | |
4588 | while (!eof(IN)) { | |
29ddc2a4 | 4589 | my $q = new CGI(\*IN); |
54310121 | 4590 | print $q->param('counter'),"\n"; |
4591 | } | |
4592 | ||
4593 | The file format used for save/restore is identical to that used by the | |
4594 | Whitehead Genome Center's data exchange format "Boulderio", and can be | |
4595 | manipulated and even databased using Boulderio utilities. See | |
3cb6de81 | 4596 | |
3538e1d5 | 4597 | http://stein.cshl.org/boulder/ |
54310121 | 4598 | |
4599 | for further details. | |
4600 | ||
424ec8fa GS |
4601 | If you wish to use this method from the function-oriented (non-OO) |
4602 | interface, the exported name for this method is B<save_parameters()>. | |
54310121 | 4603 | |
3538e1d5 GS |
4604 | =head2 RETRIEVING CGI ERRORS |
4605 | ||
4606 | Errors can occur while processing user input, particularly when | |
4607 | processing uploaded files. When these errors occur, CGI will stop | |
4608 | processing and return an empty parameter list. You can test for | |
4609 | the existence and nature of errors using the I<cgi_error()> function. | |
4610 | The error messages are formatted as HTTP status codes. You can either | |
4611 | incorporate the error text into an HTML page, or use it as the value | |
4612 | of the HTTP status: | |
4613 | ||
4614 | my $error = $q->cgi_error; | |
4615 | if ($error) { | |
4616 | print $q->header(-status=>$error), | |
4617 | $q->start_html('Problems'), | |
4618 | $q->h2('Request not processed'), | |
4619 | $q->strong($error); | |
4620 | exit 0; | |
4621 | } | |
4622 | ||
4623 | When using the function-oriented interface (see the next section), | |
4624 | errors may only occur the first time you call I<param()>. Be ready | |
4625 | for this! | |
4626 | ||
424ec8fa | 4627 | =head2 USING THE FUNCTION-ORIENTED INTERFACE |
54310121 | 4628 | |
424ec8fa GS |
4629 | To use the function-oriented interface, you must specify which CGI.pm |
4630 | routines or sets of routines to import into your script's namespace. | |
4631 | There is a small overhead associated with this importation, but it | |
4632 | isn't much. | |
54310121 | 4633 | |
424ec8fa | 4634 | use CGI <list of methods>; |
54310121 | 4635 | |
424ec8fa GS |
4636 | The listed methods will be imported into the current package; you can |
4637 | call them directly without creating a CGI object first. This example | |
4638 | shows how to import the B<param()> and B<header()> | |
4639 | methods, and then use them directly: | |
54310121 | 4640 | |
424ec8fa GS |
4641 | use CGI 'param','header'; |
4642 | print header('text/plain'); | |
4643 | $zipcode = param('zipcode'); | |
54310121 | 4644 | |
424ec8fa | 4645 | More frequently, you'll import common sets of functions by referring |
f610777f | 4646 | to the groups by name. All function sets are preceded with a ":" |
424ec8fa | 4647 | character as in ":html3" (for tags defined in the HTML 3 standard). |
54310121 | 4648 | |
424ec8fa | 4649 | Here is a list of the function sets you can import: |
54310121 | 4650 | |
424ec8fa | 4651 | =over 4 |
54310121 | 4652 | |
424ec8fa | 4653 | =item B<:cgi> |
54310121 | 4654 | |
424ec8fa GS |
4655 | Import all CGI-handling methods, such as B<param()>, B<path_info()> |
4656 | and the like. | |
54310121 | 4657 | |
424ec8fa | 4658 | =item B<:form> |
54310121 | 4659 | |
424ec8fa | 4660 | Import all fill-out form generating methods, such as B<textfield()>. |
54310121 | 4661 | |
424ec8fa | 4662 | =item B<:html2> |
54310121 | 4663 | |
424ec8fa | 4664 | Import all methods that generate HTML 2.0 standard elements. |
54310121 | 4665 | |
424ec8fa | 4666 | =item B<:html3> |
54310121 | 4667 | |
3acbd4f5 | 4668 | Import all methods that generate HTML 3.0 elements (such as |
424ec8fa | 4669 | <table>, <super> and <sub>). |
54310121 | 4670 | |
3acbd4f5 JH |
4671 | =item B<:html4> |
4672 | ||
4673 | Import all methods that generate HTML 4 elements (such as | |
4674 | <abbrev>, <acronym> and <thead>). | |
4675 | ||
424ec8fa | 4676 | =item B<:netscape> |
54310121 | 4677 | |
424ec8fa | 4678 | Import all methods that generate Netscape-specific HTML extensions. |
54310121 | 4679 | |
424ec8fa | 4680 | =item B<:html> |
54310121 | 4681 | |
424ec8fa GS |
4682 | Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' + |
4683 | 'netscape')... | |
54310121 | 4684 | |
424ec8fa | 4685 | =item B<:standard> |
54310121 | 4686 | |
3acbd4f5 | 4687 | Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'. |
54310121 | 4688 | |
424ec8fa | 4689 | =item B<:all> |
54310121 | 4690 | |
424ec8fa | 4691 | Import all the available methods. For the full list, see the CGI.pm |
3538e1d5 | 4692 | code, where the variable %EXPORT_TAGS is defined. |
424ec8fa GS |
4693 | |
4694 | =back | |
4695 | ||
4696 | If you import a function name that is not part of CGI.pm, the module | |
4697 | will treat it as a new HTML tag and generate the appropriate | |
4698 | subroutine. You can then use it like any other HTML tag. This is to | |
4699 | provide for the rapidly-evolving HTML "standard." For example, say | |
3acbd4f5 | 4700 | Microsoft comes out with a new tag called <gradient> (which causes the |
424ec8fa GS |
4701 | user's desktop to be flooded with a rotating gradient fill until his |
4702 | machine reboots). You don't need to wait for a new version of CGI.pm | |
d23a249d | 4703 | to start using it immediately: |
424ec8fa GS |
4704 | |
4705 | use CGI qw/:standard :html3 gradient/; | |
4706 | print gradient({-start=>'red',-end=>'blue'}); | |
4707 | ||
4708 | Note that in the interests of execution speed CGI.pm does B<not> use | |
4709 | the standard L<Exporter> syntax for specifying load symbols. This may | |
4710 | change in the future. | |
4711 | ||
4712 | If you import any of the state-maintaining CGI or form-generating | |
4713 | methods, a default CGI object will be created and initialized | |
4714 | automatically the first time you use any of the methods that require | |
4715 | one to be present. This includes B<param()>, B<textfield()>, | |
4716 | B<submit()> and the like. (If you need direct access to the CGI | |
4717 | object, you can find it in the global variable B<$CGI::Q>). By | |
4718 | importing CGI.pm methods, you can create visually elegant scripts: | |
4719 | ||
4720 | use CGI qw/:standard/; | |
4721 | ||
4722 | header, | |
4723 | start_html('Simple Script'), | |
4724 | h1('Simple Script'), | |
4725 | start_form, | |
4726 | "What's your name? ",textfield('name'),p, | |
4727 | "What's the combination?", | |
4728 | checkbox_group(-name=>'words', | |
4729 | -values=>['eenie','meenie','minie','moe'], | |
4730 | -defaults=>['eenie','moe']),p, | |
4731 | "What's your favorite color?", | |
4732 | popup_menu(-name=>'color', | |
4733 | -values=>['red','green','blue','chartreuse']),p, | |
4734 | submit, | |
4735 | end_form, | |
4736 | hr,"\n"; | |
4737 | ||
4738 | if (param) { | |
4739 | ||
4740 | "Your name is ",em(param('name')),p, | |
4741 | "The keywords are: ",em(join(", ",param('words'))),p, | |
4742 | "Your favorite color is ",em(param('color')),".\n"; | |
4743 | } | |
4744 | print end_html; | |
4745 | ||
4746 | =head2 PRAGMAS | |
4747 | ||
4748 | In addition to the function sets, there are a number of pragmas that | |
4749 | you can import. Pragmas, which are always preceded by a hyphen, | |
4750 | change the way that CGI.pm functions in various ways. Pragmas, | |
4751 | function sets, and individual functions can all be imported in the | |
4752 | same use() line. For example, the following use statement imports the | |
3d1a2ec4 GS |
4753 | standard set of functions and enables debugging mode (pragma |
4754 | -debug): | |
424ec8fa | 4755 | |
3d1a2ec4 | 4756 | use CGI qw/:standard -debug/; |
424ec8fa GS |
4757 | |
4758 | The current list of pragmas is as follows: | |
4759 | ||
4760 | =over 4 | |
4761 | ||
4762 | =item -any | |
4763 | ||
4764 | When you I<use CGI -any>, then any method that the query object | |
4765 | doesn't recognize will be interpreted as a new HTML tag. This allows | |
4766 | you to support the next I<ad hoc> Netscape or Microsoft HTML | |
4767 | extension. This lets you go wild with new and unsupported tags: | |
4768 | ||
4769 | use CGI qw(-any); | |
4770 | $q=new CGI; | |
4771 | print $q->gradient({speed=>'fast',start=>'red',end=>'blue'}); | |
4772 | ||
4773 | Since using <cite>any</cite> causes any mistyped method name | |
4774 | to be interpreted as an HTML tag, use it with care or not at | |
4775 | all. | |
54310121 | 4776 | |
424ec8fa | 4777 | =item -compile |
54310121 | 4778 | |
424ec8fa GS |
4779 | This causes the indicated autoloaded methods to be compiled up front, |
4780 | rather than deferred to later. This is useful for scripts that run | |
4781 | for an extended period of time under FastCGI or mod_perl, and for | |
8869a4b7 | 4782 | those destined to be crunched by Malcolm Beattie's Perl compiler. Use |
f610777f | 4783 | it in conjunction with the methods or method families you plan to use. |
424ec8fa GS |
4784 | |
4785 | use CGI qw(-compile :standard :html3); | |
4786 | ||
4787 | or even | |
4788 | ||
4789 | use CGI qw(-compile :all); | |
4790 | ||
4791 | Note that using the -compile pragma in this way will always have | |
4792 | the effect of importing the compiled functions into the current | |
4793 | namespace. If you want to compile without importing use the | |
188ba755 JH |
4794 | compile() method instead: |
4795 | ||
4796 | use CGI(); | |
4797 | CGI->compile(); | |
4798 | ||
4799 | This is particularly useful in a mod_perl environment, in which you | |
4800 | might want to precompile all CGI routines in a startup script, and | |
4801 | then import the functions individually in each mod_perl script. | |
424ec8fa | 4802 | |
3d1a2ec4 GS |
4803 | =item -nosticky |
4804 | ||
29ddc2a4 RGS |
4805 | By default the CGI module implements a state-preserving behavior |
4806 | called "sticky" fields. The way this works is that if you are | |
4807 | regenerating a form, the methods that generate the form field values | |
4808 | will interrogate param() to see if similarly-named parameters are | |
4809 | present in the query string. If they find a like-named parameter, they | |
4810 | will use it to set their default values. | |
4811 | ||
4812 | Sometimes this isn't what you want. The B<-nosticky> pragma prevents | |
4813 | this behavior. You can also selectively change the sticky behavior in | |
4814 | each element that you generate. | |
3d1a2ec4 | 4815 | |
0a9bdad4 SP |
4816 | =item -tabindex |
4817 | ||
4818 | Automatically add tab index attributes to each form field. With this | |
4819 | option turned off, you can still add tab indexes manually by passing a | |
4820 | -tabindex option to each field-generating method. | |
4821 | ||
199d4a26 JH |
4822 | =item -no_undef_params |
4823 | ||
4824 | This keeps CGI.pm from including undef params in the parameter list. | |
4825 | ||
6b4ac661 JH |
4826 | =item -no_xhtml |
4827 | ||
4828 | By default, CGI.pm versions 2.69 and higher emit XHTML | |
4829 | (http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this | |
4830 | feature. Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this | |
4831 | feature. | |
4832 | ||
13548fdf RGS |
4833 | If start_html()'s -dtd parameter specifies an HTML 2.0 or 3.2 DTD, |
4834 | XHTML will automatically be disabled without needing to use this | |
4835 | pragma. | |
4836 | ||
bb8b3399 SP |
4837 | =item -utf8 |
4838 | ||
4839 | This makes CGI.pm treat all parameters as UTF-8 strings. Use this with | |
4840 | care, as it will interfere with the processing of binary uploads. It | |
4841 | is better to manually select which fields are expected to return utf-8 | |
4842 | strings and convert them using code like this: | |
4843 | ||
4844 | use Encode; | |
4845 | my $arg = decode utf8=>param('foo'); | |
4846 | ||
424ec8fa GS |
4847 | =item -nph |
4848 | ||
4849 | This makes CGI.pm produce a header appropriate for an NPH (no | |
4850 | parsed header) script. You may need to do other things as well | |
4851 | to tell the server that the script is NPH. See the discussion | |
4852 | of NPH scripts below. | |
4853 | ||
71f3e297 JH |
4854 | =item -newstyle_urls |
4855 | ||
4856 | Separate the name=value pairs in CGI parameter query strings with | |
4857 | semicolons rather than ampersands. For example: | |
4858 | ||
4859 | ?name=fred;age=24;favorite_color=3 | |
4860 | ||
4861 | Semicolon-delimited query strings are always accepted, but will not be | |
4862 | emitted by self_url() and query_string() unless the -newstyle_urls | |
4863 | pragma is specified. | |
4864 | ||
3d1a2ec4 GS |
4865 | This became the default in version 2.64. |
4866 | ||
4867 | =item -oldstyle_urls | |
4868 | ||
4869 | Separate the name=value pairs in CGI parameter query strings with | |
4870 | ampersands rather than semicolons. This is no longer the default. | |
4871 | ||
424ec8fa GS |
4872 | =item -autoload |
4873 | ||
4874 | This overrides the autoloader so that any function in your program | |
4875 | that is not recognized is referred to CGI.pm for possible evaluation. | |
4876 | This allows you to use all the CGI.pm functions without adding them to | |
4877 | your symbol table, which is of concern for mod_perl users who are | |
4878 | worried about memory consumption. I<Warning:> when | |
4879 | I<-autoload> is in effect, you cannot use "poetry mode" | |
4880 | (functions without the parenthesis). Use I<hr()> rather | |
4881 | than I<hr>, or add something like I<use subs qw/hr p header/> | |
4882 | to the top of your script. | |
4883 | ||
4884 | =item -no_debug | |
4885 | ||
4886 | This turns off the command-line processing features. If you want to | |
4887 | run a CGI.pm script from the command line to produce HTML, and you | |
3d1a2ec4 GS |
4888 | don't want it to read CGI parameters from the command line or STDIN, |
4889 | then use this pragma: | |
424ec8fa GS |
4890 | |
4891 | use CGI qw(-no_debug :standard); | |
4892 | ||
3d1a2ec4 | 4893 | =item -debug |
424ec8fa | 4894 | |
3d1a2ec4 GS |
4895 | This turns on full debugging. In addition to reading CGI arguments |
4896 | from the command-line processing, CGI.pm will pause and try to read | |
4897 | arguments from STDIN, producing the message "(offline mode: enter | |
4898 | name=value pairs on standard input)" features. | |
3cb6de81 | 4899 | |
424ec8fa GS |
4900 | See the section on debugging for more details. |
4901 | ||
4902 | =item -private_tempfiles | |
4903 | ||
3538e1d5 GS |
4904 | CGI.pm can process uploaded file. Ordinarily it spools the uploaded |
4905 | file to a temporary directory, then deletes the file when done. | |
4906 | However, this opens the risk of eavesdropping as described in the file | |
4907 | upload section. Another CGI script author could peek at this data | |
4908 | during the upload, even if it is confidential information. On Unix | |
4909 | systems, the -private_tempfiles pragma will cause the temporary file | |
4910 | to be unlinked as soon as it is opened and before any data is written | |
4911 | into it, reducing, but not eliminating the risk of eavesdropping | |
4912 | (there is still a potential race condition). To make life harder for | |
4913 | the attacker, the program chooses tempfile names by calculating a 32 | |
4914 | bit checksum of the incoming HTTP headers. | |
4915 | ||
4916 | To ensure that the temporary file cannot be read by other CGI scripts, | |
4917 | use suEXEC or a CGI wrapper program to run your script. The temporary | |
4918 | file is created with mode 0600 (neither world nor group readable). | |
4919 | ||
4920 | The temporary directory is selected using the following algorithm: | |
4921 | ||
4922 | 1. if the current user (e.g. "nobody") has a directory named | |
4923 | "tmp" in its home directory, use that (Unix systems only). | |
4924 | ||
4925 | 2. if the environment variable TMPDIR exists, use the location | |
4926 | indicated. | |
4927 | ||
4928 | 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp, | |
4929 | /tmp, /temp, ::Temporary Items, and \WWW_ROOT. | |
4930 | ||
4931 | Each of these locations is checked that it is a directory and is | |
4932 | writable. If not, the algorithm tries the next choice. | |
71f3e297 JH |
4933 | |
4934 | =back | |
4935 | ||
4936 | =head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS | |
4937 | ||
4938 | Many of the methods generate HTML tags. As described below, tag | |
4939 | functions automatically generate both the opening and closing tags. | |
4940 | For example: | |
4941 | ||
4942 | print h1('Level 1 Header'); | |
4943 | ||
4944 | produces | |
4945 | ||
3acbd4f5 | 4946 | <h1>Level 1 Header</h1> |
71f3e297 JH |
4947 | |
4948 | There will be some times when you want to produce the start and end | |
4949 | tags yourself. In this case, you can use the form start_I<tag_name> | |
4950 | and end_I<tag_name>, as in: | |
4951 | ||
4952 | print start_h1,'Level 1 Header',end_h1; | |
4953 | ||
4954 | With a few exceptions (described below), start_I<tag_name> and | |
4955 | end_I<tag_name> functions are not generated automatically when you | |
4956 | I<use CGI>. However, you can specify the tags you want to generate | |
4957 | I<start/end> functions for by putting an asterisk in front of their | |
4958 | name, or, alternatively, requesting either "start_I<tag_name>" or | |
4959 | "end_I<tag_name>" in the import list. | |
4960 | ||
4961 | Example: | |
4962 | ||
4963 | use CGI qw/:standard *table start_ul/; | |
4964 | ||
4965 | In this example, the following functions are generated in addition to | |
4966 | the standard ones: | |
4967 | ||
4968 | =over 4 | |
4969 | ||
3acbd4f5 | 4970 | =item 1. start_table() (generates a <table> tag) |
71f3e297 | 4971 | |
3acbd4f5 | 4972 | =item 2. end_table() (generates a </table> tag) |
71f3e297 | 4973 | |
3acbd4f5 | 4974 | =item 3. start_ul() (generates a <ul> tag) |
71f3e297 | 4975 | |
3acbd4f5 | 4976 | =item 4. end_ul() (generates a </ul> tag) |
71f3e297 | 4977 | |
424ec8fa GS |
4978 | =back |
4979 | ||
4980 | =head1 GENERATING DYNAMIC DOCUMENTS | |
4981 | ||
4982 | Most of CGI.pm's functions deal with creating documents on the fly. | |
4983 | Generally you will produce the HTTP header first, followed by the | |
4984 | document itself. CGI.pm provides functions for generating HTTP | |
4985 | headers of various types as well as for generating HTML. For creating | |
4986 | GIF images, see the GD.pm module. | |
4987 | ||
4988 | Each of these functions produces a fragment of HTML or HTTP which you | |
4989 | can print out directly so that it displays in the browser window, | |
4990 | append to a string, or save to a file for later use. | |
4991 | ||
4992 | =head2 CREATING A STANDARD HTTP HEADER: | |
4993 | ||
4994 | Normally the first thing you will do in any CGI script is print out an | |
4995 | HTTP header. This tells the browser what type of document to expect, | |
4996 | and gives other optional information, such as the language, expiration | |
4997 | date, and whether to cache the document. The header can also be | |
4998 | manipulated for special purposes, such as server push and pay per view | |
4999 | pages. | |
54310121 | 5000 | |
29ddc2a4 | 5001 | print header; |
54310121 | 5002 | |
5003 | -or- | |
5004 | ||
29ddc2a4 | 5005 | print header('image/gif'); |
54310121 | 5006 | |
5007 | -or- | |
5008 | ||
29ddc2a4 | 5009 | print header('text/html','204 No response'); |
54310121 | 5010 | |
5011 | -or- | |
5012 | ||
29ddc2a4 | 5013 | print header(-type=>'image/gif', |
54310121 | 5014 | -nph=>1, |
5015 | -status=>'402 Payment required', | |
5016 | -expires=>'+3d', | |
5017 | -cookie=>$cookie, | |
3d1a2ec4 | 5018 | -charset=>'utf-7', |
6b4ac661 | 5019 | -attachment=>'foo.gif', |
54310121 | 5020 | -Cost=>'$2.00'); |
5021 | ||
5022 | header() returns the Content-type: header. You can provide your own | |
5023 | MIME type if you choose, otherwise it defaults to text/html. An | |
5024 | optional second parameter specifies the status code and a human-readable | |
5025 | message. For example, you can specify 204, "No response" to create a | |
424ec8fa | 5026 | script that tells the browser to do nothing at all. |
54310121 | 5027 | |
5028 | The last example shows the named argument style for passing arguments | |
5029 | to the CGI methods using named parameters. Recognized parameters are | |
424ec8fa | 5030 | B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named |
54310121 | 5031 | parameters will be stripped of their initial hyphens and turned into |
5032 | header fields, allowing you to specify any HTTP header you desire. | |
424ec8fa GS |
5033 | Internal underscores will be turned into hyphens: |
5034 | ||
29ddc2a4 | 5035 | print header(-Content_length=>3002); |
54310121 | 5036 | |
5037 | Most browsers will not cache the output from CGI scripts. Every time | |
5038 | the browser reloads the page, the script is invoked anew. You can | |
5039 | change this behavior with the B<-expires> parameter. When you specify | |
5040 | an absolute or relative expiration interval with this parameter, some | |
5041 | browsers and proxy servers will cache the script's output until the | |
5042 | indicated expiration date. The following forms are all valid for the | |
5043 | -expires field: | |
5044 | ||
5045 | +30s 30 seconds from now | |
5046 | +10m ten minutes from now | |
5047 | +1h one hour from now | |
5048 | -1d yesterday (i.e. "ASAP!") | |
5049 | now immediately | |
5050 | +3M in three months | |
5051 | +10y in ten years time | |
424ec8fa | 5052 | Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date |
54310121 | 5053 | |
5054 | The B<-cookie> parameter generates a header that tells the browser to provide | |
5055 | a "magic cookie" during all subsequent transactions with your script. | |
5056 | Netscape cookies have a special format that includes interesting attributes | |
5057 | such as expiration time. Use the cookie() method to create and retrieve | |
5058 | session cookies. | |
5059 | ||
5060 | The B<-nph> parameter, if set to a true value, will issue the correct | |
8f3ccfa2 | 5061 | headers to work with a NPH (no-parse-header) script. This is important |
3d1a2ec4 GS |
5062 | to use with certain servers that expect all their scripts to be NPH. |
5063 | ||
5064 | The B<-charset> parameter can be used to control the character set | |
5065 | sent to the browser. If not provided, defaults to ISO-8859-1. As a | |
5066 | side effect, this sets the charset() method as well. | |
54310121 | 5067 | |
6b4ac661 JH |
5068 | The B<-attachment> parameter can be used to turn the page into an |
5069 | attachment. Instead of displaying the page, some browsers will prompt | |
5070 | the user to save it to disk. The value of the argument is the | |
5071 | suggested name for the saved file. In order for this to work, you may | |
5072 | have to set the B<-type> to "application/octet-stream". | |
5073 | ||
8f3ccfa2 JH |
5074 | The B<-p3p> parameter will add a P3P tag to the outgoing header. The |
5075 | parameter can be an arrayref or a space-delimited string of P3P tags. | |
5076 | For example: | |
5077 | ||
5078 | print header(-p3p=>[qw(CAO DSP LAW CURa)]); | |
5079 | print header(-p3p=>'CAO DSP LAW CURa'); | |
5080 | ||
5081 | In either case, the outgoing header will be formatted as: | |
5082 | ||
5083 | P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa" | |
5084 | ||
424ec8fa | 5085 | =head2 GENERATING A REDIRECTION HEADER |
54310121 | 5086 | |
29ddc2a4 | 5087 | print redirect('http://somewhere.else/in/movie/land'); |
54310121 | 5088 | |
424ec8fa GS |
5089 | Sometimes you don't want to produce a document yourself, but simply |
5090 | redirect the browser elsewhere, perhaps choosing a URL based on the | |
5091 | time of day or the identity of the user. | |
5092 | ||
5093 | The redirect() function redirects the browser to a different URL. If | |
5094 | you use redirection like this, you should B<not> print out a header as | |
6b4ac661 | 5095 | well. |
54310121 | 5096 | |
2ed511ec RGS |
5097 | You should always use full URLs (including the http: or ftp: part) in |
5098 | redirection requests. Relative URLs will not work correctly. | |
54310121 | 5099 | |
424ec8fa | 5100 | You can also use named arguments: |
54310121 | 5101 | |
29ddc2a4 | 5102 | print redirect(-uri=>'http://somewhere.else/in/movie/land', |
13548fdf RGS |
5103 | -nph=>1, |
5104 | -status=>301); | |
54310121 | 5105 | |
5106 | The B<-nph> parameter, if set to a true value, will issue the correct | |
8f3ccfa2 | 5107 | headers to work with a NPH (no-parse-header) script. This is important |
58129083 | 5108 | to use with certain servers, such as Microsoft IIS, which |
54310121 | 5109 | expect all their scripts to be NPH. |
5110 | ||
13548fdf RGS |
5111 | The B<-status> parameter will set the status of the redirect. HTTP |
5112 | defines three different possible redirection status codes: | |
5113 | ||
5114 | 301 Moved Permanently | |
5115 | 302 Found | |
5116 | 303 See Other | |
5117 | ||
5118 | The default if not specified is 302, which means "moved temporarily." | |
5119 | You may change the status to another status code if you wish. Be | |
5120 | advised that changing the status to anything other than 301, 302 or | |
5121 | 303 will probably break redirection. | |
5122 | ||
424ec8fa | 5123 | =head2 CREATING THE HTML DOCUMENT HEADER |
54310121 | 5124 | |
29ddc2a4 | 5125 | print start_html(-title=>'Secrets of the Pyramids', |
54310121 | 5126 | -author=>'fred@capricorn.org', |
5127 | -base=>'true', | |
5128 | -target=>'_blank', | |
5129 | -meta=>{'keywords'=>'pharaoh secret mummy', | |
5130 | 'copyright'=>'copyright 1996 King Tut'}, | |
7d37aa8e | 5131 | -style=>{'src'=>'/styles/style1.css'}, |
54310121 | 5132 | -BGCOLOR=>'blue'); |
5133 | ||
424ec8fa GS |
5134 | After creating the HTTP header, most CGI scripts will start writing |
5135 | out an HTML document. The start_html() routine creates the top of the | |
5136 | page, along with a lot of optional information that controls the | |
5137 | page's appearance and behavior. | |
54310121 | 5138 | |
3acbd4f5 | 5139 | This method returns a canned HTML header and the opening <body> tag. |
424ec8fa | 5140 | All parameters are optional. In the named parameter form, recognized |
6b4ac661 JH |
5141 | parameters are -title, -author, -base, -xbase, -dtd, -lang and -target |
5142 | (see below for the explanation). Any additional parameters you | |
5143 | provide, such as the Netscape unofficial BGCOLOR attribute, are added | |
3acbd4f5 | 5144 | to the <body> tag. Additional parameters must be proceeded by a |
6b4ac661 | 5145 | hyphen. |
54310121 | 5146 | |
3acbd4f5 | 5147 | The argument B<-xbase> allows you to provide an HREF for the <base> tag |
54310121 | 5148 | different from the current location, as in |
5149 | ||
5150 | -xbase=>"http://home.mcom.com/" | |
5151 | ||
5152 | All relative links will be interpreted relative to this tag. | |
5153 | ||
5154 | The argument B<-target> allows you to provide a default target frame | |
3d1a2ec4 GS |
5155 | for all the links and fill-out forms on the page. B<This is a |
5156 | non-standard HTTP feature which only works with Netscape browsers!> | |
5157 | See the Netscape documentation on frames for details of how to | |
5158 | manipulate this. | |
54310121 | 5159 | |
5160 | -target=>"answer_window" | |
5161 | ||
5162 | All relative links will be interpreted relative to this tag. | |
5163 | You add arbitrary meta information to the header with the B<-meta> | |
5164 | argument. This argument expects a reference to an associative array | |
5165 | containing name/value pairs of meta information. These will be turned | |
3acbd4f5 | 5166 | into a series of header <meta> tags that look something like this: |
54310121 | 5167 | |
3acbd4f5 JH |
5168 | <meta name="keywords" content="pharaoh secret mummy"> |
5169 | <meta name="description" content="copyright 1996 King Tut"> | |
424ec8fa | 5170 | |
3acbd4f5 | 5171 | To create an HTTP-EQUIV type of <meta> tag, use B<-head>, described |
6b4ac661 | 5172 | below. |
424ec8fa | 5173 | |
6b4ac661 JH |
5174 | The B<-style> argument is used to incorporate cascading stylesheets |
5175 | into your code. See the section on CASCADING STYLESHEETS for more | |
5176 | information. | |
424ec8fa | 5177 | |
6b4ac661 | 5178 | The B<-lang> argument is used to incorporate a language attribute into |
13548fdf | 5179 | the <html> tag. For example: |
6b4ac661 | 5180 | |
ba056755 | 5181 | print $q->start_html(-lang=>'fr-CA'); |
424ec8fa | 5182 | |
13548fdf RGS |
5183 | The default if not specified is "en-US" for US English, unless the |
5184 | -dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the | |
5185 | lang attribute is left off. You can force the lang attribute to left | |
5186 | off in other cases by passing an empty string (-lang=>''). | |
8f3ccfa2 | 5187 | |
ac734d8b | 5188 | The B<-encoding> argument can be used to specify the character set for |
b2d0d414 | 5189 | XHTML. It defaults to iso-8859-1 if not specified. |
ac734d8b | 5190 | |
29ddc2a4 RGS |
5191 | The B<-declare_xml> argument, when used in conjunction with XHTML, |
5192 | will put a <?xml> declaration at the top of the HTML header. The sole | |
5193 | purpose of this declaration is to declare the character set | |
5194 | encoding. In the absence of -declare_xml, the output HTML will contain | |
5195 | a <meta> tag that specifies the encoding, allowing the HTML to pass | |
5196 | most validators. The default for -declare_xml is false. | |
5197 | ||
3acbd4f5 JH |
5198 | You can place other arbitrary HTML elements to the <head> section with the |
5199 | B<-head> tag. For example, to place the rarely-used <link> element in the | |
424ec8fa GS |
5200 | head section, use this: |
5201 | ||
3538e1d5 | 5202 | print start_html(-head=>Link({-rel=>'next', |
6b4ac661 | 5203 | -href=>'http://www.capricorn.com/s2.html'})); |
424ec8fa | 5204 | |
3acbd4f5 | 5205 | To incorporate multiple HTML elements into the <head> section, just pass an |
424ec8fa GS |
5206 | array reference: |
5207 | ||
3538e1d5 GS |
5208 | print start_html(-head=>[ |
5209 | Link({-rel=>'next', | |
5210 | -href=>'http://www.capricorn.com/s2.html'}), | |
5211 | Link({-rel=>'previous', | |
5212 | -href=>'http://www.capricorn.com/s1.html'}) | |
424ec8fa GS |
5213 | ] |
5214 | ); | |
5215 | ||
3acbd4f5 | 5216 | And here's how to create an HTTP-EQUIV <meta> tag: |
6b4ac661 | 5217 | |
ba056755 JH |
5218 | print start_html(-head=>meta({-http_equiv => 'Content-Type', |
5219 | -content => 'text/html'})) | |
6b4ac661 JH |
5220 | |
5221 | ||
424ec8fa GS |
5222 | JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>, |
5223 | B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used | |
5224 | to add Netscape JavaScript calls to your pages. B<-script> should | |
5225 | point to a block of text containing JavaScript function definitions. | |
3acbd4f5 | 5226 | This block will be placed within a <script> block inside the HTML (not |
424ec8fa GS |
5227 | HTTP) header. The block is placed in the header in order to give your |
5228 | page a fighting chance of having all its JavaScript functions in place | |
5229 | even if the user presses the stop button before the page has loaded | |
5230 | completely. CGI.pm attempts to format the script in such a way that | |
5231 | JavaScript-naive browsers will not choke on the code: unfortunately | |
5232 | there are some browsers, such as Chimera for Unix, that get confused | |
5233 | by it nevertheless. | |
5234 | ||
5235 | The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript | |
5236 | code to execute when the page is respectively opened and closed by the | |
5237 | browser. Usually these parameters are calls to functions defined in the | |
5238 | B<-script> field: | |
5239 | ||
5240 | $query = new CGI; | |
29ddc2a4 | 5241 | print header; |
424ec8fa GS |
5242 | $JSCRIPT=<<END; |
5243 | // Ask a silly question | |
5244 | function riddle_me_this() { | |
5245 | var r = prompt("What walks on four legs in the morning, " + | |
5246 | "two legs in the afternoon, " + | |
5247 | "and three legs in the evening?"); | |
5248 | response(r); | |
5249 | } | |
5250 | // Get a silly answer | |
5251 | function response(answer) { | |
5252 | if (answer == "man") | |
5253 | alert("Right you are!"); | |
5254 | else | |
5255 | alert("Wrong! Guess again."); | |
5256 | } | |
5257 | END | |
29ddc2a4 | 5258 | print start_html(-title=>'The Riddle of the Sphinx', |
424ec8fa GS |
5259 | -script=>$JSCRIPT); |
5260 | ||
5261 | Use the B<-noScript> parameter to pass some HTML text that will be displayed on | |
5262 | browsers that do not have JavaScript (or browsers where JavaScript is turned | |
5263 | off). | |
5264 | ||
8869a4b7 SP |
5265 | The <script> tag, has several attributes including "type" and src. |
5266 | The latter is particularly interesting, as it allows you to keep the | |
5267 | JavaScript code in a file or CGI script rather than cluttering up each | |
5268 | page with the source. To use these attributes pass a HASH reference | |
5269 | in the B<-script> parameter containing one or more of -type, -src, or | |
5270 | -code: | |
424ec8fa GS |
5271 | |
5272 | print $q->start_html(-title=>'The Riddle of the Sphinx', | |
8869a4b7 | 5273 | -script=>{-type=>'JAVASCRIPT', |
424ec8fa GS |
5274 | -src=>'/javascript/sphinx.js'} |
5275 | ); | |
5276 | ||
5277 | print $q->(-title=>'The Riddle of the Sphinx', | |
8869a4b7 | 5278 | -script=>{-type=>'PERLSCRIPT', |
3538e1d5 | 5279 | -code=>'print "hello world!\n;"'} |
424ec8fa GS |
5280 | ); |
5281 | ||
5282 | ||
3acbd4f5 | 5283 | A final feature allows you to incorporate multiple <script> sections into the |
424ec8fa GS |
5284 | header. Just pass the list of script sections as an array reference. |
5285 | this allows you to specify different source files for different dialects | |
8869a4b7 | 5286 | of JavaScript. Example: |
424ec8fa | 5287 | |
3538e1d5 GS |
5288 | print $q->start_html(-title=>'The Riddle of the Sphinx', |
5289 | -script=>[ | |
8869a4b7 | 5290 | { -type => 'text/javascript', |
3538e1d5 | 5291 | -src => '/javascript/utilities10.js' |
424ec8fa | 5292 | }, |
8869a4b7 | 5293 | { -type => 'text/javascript', |
3538e1d5 | 5294 | -src => '/javascript/utilities11.js' |
424ec8fa | 5295 | }, |
8869a4b7 | 5296 | { -type => 'text/jscript', |
3538e1d5 | 5297 | -src => '/javascript/utilities12.js' |
424ec8fa | 5298 | }, |
8869a4b7 | 5299 | { -type => 'text/ecmascript', |
3538e1d5 | 5300 | -src => '/javascript/utilities219.js' |
424ec8fa GS |
5301 | } |
5302 | ] | |
5303 | ); | |
424ec8fa | 5304 | |
8869a4b7 SP |
5305 | The option "-language" is a synonym for -type, and is supported for |
5306 | backwad compatibility. | |
424ec8fa GS |
5307 | |
5308 | The old-style positional parameters are as follows: | |
5309 | ||
5310 | =over 4 | |
5311 | ||
5312 | =item B<Parameters:> | |
5313 | ||
5314 | =item 1. | |
5315 | ||
5316 | The title | |
5317 | ||
5318 | =item 2. | |
5319 | ||
3acbd4f5 | 5320 | The author's e-mail address (will create a <link rev="MADE"> tag if present |
424ec8fa GS |
5321 | |
5322 | =item 3. | |
5323 | ||
3acbd4f5 | 5324 | A 'true' flag if you want to include a <base> tag in the header. This |
424ec8fa GS |
5325 | helps resolve relative addresses to absolute ones when the document is moved, |
5326 | but makes the document hierarchy non-portable. Use with care! | |
5327 | ||
5328 | =item 4, 5, 6... | |
5329 | ||
3acbd4f5 | 5330 | Any other parameters you want to include in the <body> tag. This is a good |
424ec8fa GS |
5331 | place to put Netscape extensions, such as colors and wallpaper patterns. |
5332 | ||
5333 | =back | |
5334 | ||
5335 | =head2 ENDING THE HTML DOCUMENT: | |
5336 | ||
29ddc2a4 | 5337 | print end_html |
424ec8fa | 5338 | |
3acbd4f5 | 5339 | This ends an HTML document by printing the </body></html> tags. |
424ec8fa GS |
5340 | |
5341 | =head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION: | |
5342 | ||
29ddc2a4 | 5343 | $myself = self_url; |
3acbd4f5 | 5344 | print q(<a href="$myself">I'm talking to myself.</a>); |
424ec8fa GS |
5345 | |
5346 | self_url() will return a URL, that, when selected, will reinvoke | |
5347 | this script with all its state information intact. This is most | |
5348 | useful when you want to jump around within the document using | |
5349 | internal anchors but you don't want to disrupt the current contents | |
5350 | of the form(s). Something like this will do the trick. | |
5351 | ||
29ddc2a4 | 5352 | $myself = self_url; |
188ba755 JH |
5353 | print "<a href=\"$myself#table1\">See table 1</a>"; |
5354 | print "<a href=\"$myself#table2\">See table 2</a>"; | |
5355 | print "<a href=\"$myself#yourself\">See for yourself</a>"; | |
424ec8fa GS |
5356 | |
5357 | If you want more control over what's returned, using the B<url()> | |
5358 | method instead. | |
5359 | ||
5360 | You can also retrieve the unprocessed query string with query_string(): | |
5361 | ||
29ddc2a4 | 5362 | $the_string = query_string; |
424ec8fa GS |
5363 | |
5364 | =head2 OBTAINING THE SCRIPT'S URL | |
5365 | ||
29ddc2a4 RGS |
5366 | $full_url = url(); |
5367 | $full_url = url(-full=>1); #alternative syntax | |
5368 | $relative_url = url(-relative=>1); | |
5369 | $absolute_url = url(-absolute=>1); | |
5370 | $url_with_path = url(-path_info=>1); | |
5371 | $url_with_path_and_query = url(-path_info=>1,-query=>1); | |
5372 | $netloc = url(-base => 1); | |
424ec8fa GS |
5373 | |
5374 | B<url()> returns the script's URL in a variety of formats. Called | |
5375 | without any arguments, it returns the full form of the URL, including | |
5376 | host name and port number | |
5377 | ||
5378 | http://your.host.com/path/to/script.cgi | |
5379 | ||
5380 | You can modify this format with the following named arguments: | |
5381 | ||
5382 | =over 4 | |
5383 | ||
5384 | =item B<-absolute> | |
5385 | ||
5386 | If true, produce an absolute URL, e.g. | |
5387 | ||
5388 | /path/to/script.cgi | |
5389 | ||
5390 | =item B<-relative> | |
5391 | ||
5392 | Produce a relative URL. This is useful if you want to reinvoke your | |
5393 | script with different parameters. For example: | |
5394 | ||
5395 | script.cgi | |
5396 | ||
5397 | =item B<-full> | |
5398 | ||
5399 | Produce the full URL, exactly as if called without any arguments. | |
5400 | This overrides the -relative and -absolute arguments. | |
5401 | ||
5402 | =item B<-path> (B<-path_info>) | |
5403 | ||
5404 | Append the additional path information to the URL. This can be | |
5405 | combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info> | |
5406 | is provided as a synonym. | |
5407 | ||
5408 | =item B<-query> (B<-query_string>) | |
5409 | ||
5410 | Append the query string to the URL. This can be combined with | |
5411 | B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided | |
5412 | as a synonym. | |
5413 | ||
03b9648d JH |
5414 | =item B<-base> |
5415 | ||
5416 | Generate just the protocol and net location, as in http://www.foo.com:8000 | |
5417 | ||
0a9bdad4 SP |
5418 | =item B<-rewrite> |
5419 | ||
5420 | If Apache's mod_rewrite is turned on, then the script name and path | |
5421 | info probably won't match the request that the user sent. Set | |
5422 | -rewrite=>1 (default) to return URLs that match what the user sent | |
384f06ae | 5423 | (the original request URI). Set -rewrite=>0 to return URLs that match |
0a9bdad4 SP |
5424 | the URL after mod_rewrite's rules have run. Because the additional |
5425 | path information only makes sense in the context of the rewritten URL, | |
5426 | -rewrite is set to false when you request path info in the URL. | |
5427 | ||
424ec8fa GS |
5428 | =back |
5429 | ||
71f3e297 JH |
5430 | =head2 MIXING POST AND URL PARAMETERS |
5431 | ||
29ddc2a4 | 5432 | $color = url_param('color'); |
71f3e297 JH |
5433 | |
5434 | It is possible for a script to receive CGI parameters in the URL as | |
5435 | well as in the fill-out form by creating a form that POSTs to a URL | |
5436 | containing a query string (a "?" mark followed by arguments). The | |
5437 | B<param()> method will always return the contents of the POSTed | |
5438 | fill-out form, ignoring the URL's query string. To retrieve URL | |
5439 | parameters, call the B<url_param()> method. Use it in the same way as | |
5440 | B<param()>. The main difference is that it allows you to read the | |
5441 | parameters, but not set them. | |
5442 | ||
5443 | ||
5444 | Under no circumstances will the contents of the URL query string | |
5445 | interfere with similarly-named CGI parameters in POSTed forms. If you | |
5446 | try to mix a URL query string with a form submitted with the GET | |
5447 | method, the results will not be what you expect. | |
5448 | ||
424ec8fa GS |
5449 | =head1 CREATING STANDARD HTML ELEMENTS: |
5450 | ||
5451 | CGI.pm defines general HTML shortcut methods for most, if not all of | |
5452 | the HTML 3 and HTML 4 tags. HTML shortcuts are named after a single | |
5453 | HTML element and return a fragment of HTML text that you can then | |
5454 | print or manipulate as you like. Each shortcut returns a fragment of | |
5455 | HTML code that you can append to a string, save to a file, or, most | |
5456 | commonly, print out so that it displays in the browser window. | |
5457 | ||
5458 | This example shows how to use the HTML methods: | |
5459 | ||
424ec8fa GS |
5460 | print $q->blockquote( |
5461 | "Many years ago on the island of", | |
5462 | $q->a({href=>"http://crete.org/"},"Crete"), | |
3538e1d5 | 5463 | "there lived a Minotaur named", |
424ec8fa GS |
5464 | $q->strong("Fred."), |
5465 | ), | |
5466 | $q->hr; | |
5467 | ||
5468 | This results in the following HTML code (extra newlines have been | |
5469 | added for readability): | |
5470 | ||
5471 | <blockquote> | |
5472 | Many years ago on the island of | |
3acbd4f5 | 5473 | <a href="http://crete.org/">Crete</a> there lived |
424ec8fa GS |
5474 | a minotaur named <strong>Fred.</strong> |
5475 | </blockquote> | |
5476 | <hr> | |
5477 | ||
5478 | If you find the syntax for calling the HTML shortcuts awkward, you can | |
5479 | import them into your namespace and dispense with the object syntax | |
5480 | completely (see the next section for more details): | |
5481 | ||
5482 | use CGI ':standard'; | |
5483 | print blockquote( | |
5484 | "Many years ago on the island of", | |
5485 | a({href=>"http://crete.org/"},"Crete"), | |
5486 | "there lived a minotaur named", | |
5487 | strong("Fred."), | |
5488 | ), | |
5489 | hr; | |
54310121 | 5490 | |
424ec8fa | 5491 | =head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS |
7d37aa8e | 5492 | |
424ec8fa GS |
5493 | The HTML methods will accept zero, one or multiple arguments. If you |
5494 | provide no arguments, you get a single tag: | |
7d37aa8e | 5495 | |
3acbd4f5 | 5496 | print hr; # <hr> |
7d37aa8e | 5497 | |
424ec8fa GS |
5498 | If you provide one or more string arguments, they are concatenated |
5499 | together with spaces and placed between opening and closing tags: | |
7d37aa8e | 5500 | |
3acbd4f5 | 5501 | print h1("Chapter","1"); # <h1>Chapter 1</h1>" |
7d37aa8e | 5502 | |
424ec8fa GS |
5503 | If the first argument is an associative array reference, then the keys |
5504 | and values of the associative array become the HTML tag's attributes: | |
7d37aa8e | 5505 | |
424ec8fa GS |
5506 | print a({-href=>'fred.html',-target=>'_new'}, |
5507 | "Open a new frame"); | |
7d37aa8e | 5508 | |
3acbd4f5 | 5509 | <a href="fred.html",target="_new">Open a new frame</a> |
3cb6de81 | 5510 | |
424ec8fa GS |
5511 | You may dispense with the dashes in front of the attribute names if |
5512 | you prefer: | |
54310121 | 5513 | |
424ec8fa | 5514 | print img {src=>'fred.gif',align=>'LEFT'}; |
54310121 | 5515 | |
3acbd4f5 | 5516 | <img align="LEFT" src="fred.gif"> |
54310121 | 5517 | |
424ec8fa | 5518 | Sometimes an HTML tag attribute has no argument. For example, ordered |
8f3ccfa2 | 5519 | lists can be marked as COMPACT. The syntax for this is an argument that |
424ec8fa | 5520 | that points to an undef string: |
54310121 | 5521 | |
424ec8fa | 5522 | print ol({compact=>undef},li('one'),li('two'),li('three')); |
47e3cabd | 5523 | |
424ec8fa GS |
5524 | Prior to CGI.pm version 2.41, providing an empty ('') string as an |
5525 | attribute argument was the same as providing undef. However, this has | |
8f3ccfa2 | 5526 | changed in order to accommodate those who want to create tags of the form |
3acbd4f5 | 5527 | <img alt="">. The difference is shown in these two pieces of code: |
3cb6de81 | 5528 | |
8f3ccfa2 JH |
5529 | CODE RESULT |
5530 | img({alt=>undef}) <img alt> | |
5531 | img({alt=>''}) <img alt=""> | |
7d37aa8e | 5532 | |
424ec8fa | 5533 | =head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS |
7d37aa8e | 5534 | |
424ec8fa GS |
5535 | One of the cool features of the HTML shortcuts is that they are |
5536 | distributive. If you give them an argument consisting of a | |
5537 | B<reference> to a list, the tag will be distributed across each | |
5538 | element of the list. For example, here's one way to make an ordered | |
5539 | list: | |
7d37aa8e | 5540 | |
424ec8fa | 5541 | print ul( |
6b4ac661 | 5542 | li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']) |
424ec8fa | 5543 | ); |
7d37aa8e | 5544 | |
424ec8fa | 5545 | This example will result in HTML output that looks like this: |
54310121 | 5546 | |
3acbd4f5 JH |
5547 | <ul> |
5548 | <li type="disc">Sneezy</li> | |
5549 | <li type="disc">Doc</li> | |
5550 | <li type="disc">Sleepy</li> | |
5551 | <li type="disc">Happy</li> | |
5552 | </ul> | |
54310121 | 5553 | |
424ec8fa | 5554 | This is extremely useful for creating tables. For example: |
54310121 | 5555 | |
424ec8fa GS |
5556 | print table({-border=>undef}, |
5557 | caption('When Should You Eat Your Vegetables?'), | |
5558 | Tr({-align=>CENTER,-valign=>TOP}, | |
5559 | [ | |
5560 | th(['Vegetable', 'Breakfast','Lunch','Dinner']), | |
5561 | td(['Tomatoes' , 'no', 'yes', 'yes']), | |
5562 | td(['Broccoli' , 'no', 'no', 'yes']), | |
5563 | td(['Onions' , 'yes','yes', 'yes']) | |
5564 | ] | |
5565 | ) | |
5566 | ); | |
54310121 | 5567 | |
424ec8fa | 5568 | =head2 HTML SHORTCUTS AND LIST INTERPOLATION |
54310121 | 5569 | |
424ec8fa | 5570 | Consider this bit of code: |
54310121 | 5571 | |
424ec8fa | 5572 | print blockquote(em('Hi'),'mom!')); |
54310121 | 5573 | |
424ec8fa | 5574 | It will ordinarily return the string that you probably expect, namely: |
54310121 | 5575 | |
3acbd4f5 | 5576 | <blockquote><em>Hi</em> mom!</blockquote> |
54310121 | 5577 | |
424ec8fa GS |
5578 | Note the space between the element "Hi" and the element "mom!". |
5579 | CGI.pm puts the extra space there using array interpolation, which is | |
5580 | controlled by the magic $" variable. Sometimes this extra space is | |
5581 | not what you want, for example, when you are trying to align a series | |
5582 | of images. In this case, you can simply change the value of $" to an | |
5583 | empty string. | |
54310121 | 5584 | |
424ec8fa GS |
5585 | { |
5586 | local($") = ''; | |
5587 | print blockquote(em('Hi'),'mom!')); | |
5588 | } | |
54310121 | 5589 | |
424ec8fa GS |
5590 | I suggest you put the code in a block as shown here. Otherwise the |
5591 | change to $" will affect all subsequent code until you explicitly | |
5592 | reset it. | |
54310121 | 5593 | |
424ec8fa | 5594 | =head2 NON-STANDARD HTML SHORTCUTS |
54310121 | 5595 | |
424ec8fa GS |
5596 | A few HTML tags don't follow the standard pattern for various |
5597 | reasons. | |
54310121 | 5598 | |
424ec8fa GS |
5599 | B<comment()> generates an HTML comment (<!-- comment -->). Call it |
5600 | like | |
54310121 | 5601 | |
424ec8fa | 5602 | print comment('here is my comment'); |
54310121 | 5603 | |
424ec8fa GS |
5604 | Because of conflicts with built-in Perl functions, the following functions |
5605 | begin with initial caps: | |
54310121 | 5606 | |
424ec8fa GS |
5607 | Select |
5608 | Tr | |
5609 | Link | |
5610 | Delete | |
71f3e297 JH |
5611 | Accept |
5612 | Sub | |
54310121 | 5613 | |
424ec8fa GS |
5614 | In addition, start_html(), end_html(), start_form(), end_form(), |
5615 | start_multipart_form() and all the fill-out form tags are special. | |
5616 | See their respective sections. | |
5617 | ||
3d1a2ec4 GS |
5618 | =head2 AUTOESCAPING HTML |
5619 | ||
5620 | By default, all HTML that is emitted by the form-generating functions | |
5621 | is passed through a function called escapeHTML(): | |
5622 | ||
5623 | =over 4 | |
5624 | ||
5625 | =item $escaped_string = escapeHTML("unescaped string"); | |
5626 | ||
5627 | Escape HTML formatting characters in a string. | |
5628 | ||
5629 | =back | |
5630 | ||
5631 | Provided that you have specified a character set of ISO-8859-1 (the | |
5632 | default), the standard HTML escaping rules will be used. The "<" | |
5633 | character becomes "<", ">" becomes ">", "&" becomes "&", and | |
5634 | the quote character becomes """. In addition, the hexadecimal | |
188ba755 | 5635 | 0x8b and 0x9b characters, which some browsers incorrectly interpret |
3d1a2ec4 | 5636 | as the left and right angle-bracket characters, are replaced by their |
188ba755 | 5637 | numeric character entities ("‹" and "›"). If you manually change |
3d1a2ec4 GS |
5638 | the charset, either by calling the charset() method explicitly or by |
5639 | passing a -charset argument to header(), then B<all> characters will | |
5640 | be replaced by their numeric entities, since CGI.pm has no lookup | |
5641 | table for all the possible encodings. | |
5642 | ||
5643 | The automatic escaping does not apply to other shortcuts, such as | |
5644 | h1(). You should call escapeHTML() yourself on untrusted data in | |
5645 | order to protect your pages against nasty tricks that people may enter | |
5646 | into guestbooks, etc.. To change the character set, use charset(). | |
188ba755 | 5647 | To turn autoescaping off completely, use autoEscape(0): |
3d1a2ec4 GS |
5648 | |
5649 | =over 4 | |
5650 | ||
5651 | =item $charset = charset([$charset]); | |
5652 | ||
5653 | Get or set the current character set. | |
5654 | ||
5655 | =item $flag = autoEscape([$flag]); | |
5656 | ||
5657 | Get or set the value of the autoescape flag. | |
5658 | ||
5659 | =back | |
5660 | ||
71f3e297 JH |
5661 | =head2 PRETTY-PRINTING HTML |
5662 | ||
5663 | By default, all the HTML produced by these functions comes out as one | |
5664 | long line without carriage returns or indentation. This is yuck, but | |
5665 | it does reduce the size of the documents by 10-20%. To get | |
5666 | pretty-printed output, please use L<CGI::Pretty>, a subclass | |
5667 | contributed by Brian Paulsen. | |
5668 | ||
424ec8fa | 5669 | =head1 CREATING FILL-OUT FORMS: |
54310121 | 5670 | |
5671 | I<General note> The various form-creating methods all return strings | |
5672 | to the caller, containing the tag or tags that will create the requested | |
5673 | form element. You are responsible for actually printing out these strings. | |
5674 | It's set up this way so that you can place formatting tags | |
5675 | around the form elements. | |
5676 | ||
5677 | I<Another note> The default values that you specify for the forms are only | |
5678 | used the B<first> time the script is invoked (when there is no query | |
5679 | string). On subsequent invocations of the script (when there is a query | |
5680 | string), the former values are used even if they are blank. | |
5681 | ||
5682 | If you want to change the value of a field from its previous value, you have two | |
5683 | choices: | |
5684 | ||
5685 | (1) call the param() method to set it. | |
5686 | ||
5687 | (2) use the -override (alias -force) parameter (a new feature in version 2.15). | |
5688 | This forces the default value to be used, regardless of the previous value: | |
5689 | ||
29ddc2a4 | 5690 | print textfield(-name=>'field_name', |
54310121 | 5691 | -default=>'starting value', |
5692 | -override=>1, | |
5693 | -size=>50, | |
5694 | -maxlength=>80); | |
5695 | ||
5696 | I<Yet another note> By default, the text and labels of form elements are | |
5697 | escaped according to HTML rules. This means that you can safely use | |
5698 | "<CLICK ME>" as the label for a button. However, it also interferes with | |
5699 | your ability to incorporate special HTML character sequences, such as Á, | |
5700 | into your fields. If you wish to turn off automatic escaping, call the | |
5701 | autoEscape() method with a false value immediately after creating the CGI object: | |
5702 | ||
5703 | $query = new CGI; | |
29ddc2a4 | 5704 | autoEscape(undef); |
3cb6de81 | 5705 | |
13548fdf RGS |
5706 | I<A Lurking Trap!> Some of the form-element generating methods return |
5707 | multiple tags. In a scalar context, the tags will be concatenated | |
5708 | together with spaces, or whatever is the current value of the $" | |
5709 | global. In a list context, the methods will return a list of | |
5710 | elements, allowing you to modify them if you wish. Usually you will | |
5711 | not notice this behavior, but beware of this: | |
5712 | ||
29ddc2a4 | 5713 | printf("%s\n",end_form()) |
13548fdf RGS |
5714 | |
5715 | end_form() produces several tags, and only the first of them will be | |
5716 | printed because the format only expects one value. | |
5717 | ||
5718 | <p> | |
5719 | ||
5720 | ||
54310121 | 5721 | =head2 CREATING AN ISINDEX TAG |
5722 | ||
29ddc2a4 | 5723 | print isindex(-action=>$action); |
54310121 | 5724 | |
5725 | -or- | |
5726 | ||
29ddc2a4 | 5727 | print isindex($action); |
54310121 | 5728 | |
3acbd4f5 | 5729 | Prints out an <isindex> tag. Not very exciting. The parameter |
54310121 | 5730 | -action specifies the URL of the script to process the query. The |
5731 | default is to process the query with the current script. | |
5732 | ||
5733 | =head2 STARTING AND ENDING A FORM | |
5734 | ||
29ddc2a4 RGS |
5735 | print start_form(-method=>$method, |
5736 | -action=>$action, | |
5737 | -enctype=>$encoding); | |
54310121 | 5738 | <... various form stuff ...> |
29ddc2a4 | 5739 | print endform; |
54310121 | 5740 | |
5741 | -or- | |
5742 | ||
29ddc2a4 | 5743 | print start_form($method,$action,$encoding); |
54310121 | 5744 | <... various form stuff ...> |
29ddc2a4 | 5745 | print endform; |
54310121 | 5746 | |
3acbd4f5 | 5747 | start_form() will return a <form> tag with the optional method, |
54310121 | 5748 | action and form encoding that you specify. The defaults are: |
3cb6de81 | 5749 | |
54310121 | 5750 | method: POST |
5751 | action: this script | |
71f3e297 | 5752 | enctype: application/x-www-form-urlencoded |
54310121 | 5753 | |
3acbd4f5 | 5754 | endform() returns the closing </form> tag. |
54310121 | 5755 | |
3d1a2ec4 | 5756 | Start_form()'s enctype argument tells the browser how to package the various |
54310121 | 5757 | fields of the form before sending the form to the server. Two |
5758 | values are possible: | |
5759 | ||
3d1a2ec4 GS |
5760 | B<Note:> This method was previously named startform(), and startform() |
5761 | is still recognized as an alias. | |
5762 | ||
54310121 | 5763 | =over 4 |
5764 | ||
5765 | =item B<application/x-www-form-urlencoded> | |
5766 | ||
5767 | This is the older type of encoding used by all browsers prior to | |
5768 | Netscape 2.0. It is compatible with many CGI scripts and is | |
5769 | suitable for short fields containing text data. For your | |
5770 | convenience, CGI.pm stores the name of this encoding | |
6b4ac661 | 5771 | type in B<&CGI::URL_ENCODED>. |
54310121 | 5772 | |
5773 | =item B<multipart/form-data> | |
5774 | ||
5775 | This is the newer type of encoding introduced by Netscape 2.0. | |
5776 | It is suitable for forms that contain very large fields or that | |
5777 | are intended for transferring binary data. Most importantly, | |
5778 | it enables the "file upload" feature of Netscape 2.0 forms. For | |
5779 | your convenience, CGI.pm stores the name of this encoding type | |
424ec8fa | 5780 | in B<&CGI::MULTIPART> |
54310121 | 5781 | |
5782 | Forms that use this type of encoding are not easily interpreted | |
5783 | by CGI scripts unless they use CGI.pm or another library designed | |
5784 | to handle them. | |
5785 | ||
29ddc2a4 RGS |
5786 | If XHTML is activated (the default), then forms will be automatically |
5787 | created using this type of encoding. | |
5788 | ||
54310121 | 5789 | =back |
5790 | ||
3d1a2ec4 | 5791 | For compatibility, the start_form() method uses the older form of |
54310121 | 5792 | encoding by default. If you want to use the newer form of encoding |
5793 | by default, you can call B<start_multipart_form()> instead of | |
3d1a2ec4 | 5794 | B<start_form()>. |
54310121 | 5795 | |
5796 | JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided | |
5797 | for use with JavaScript. The -name parameter gives the | |
5798 | form a name so that it can be identified and manipulated by | |
5799 | JavaScript functions. -onSubmit should point to a JavaScript | |
5800 | function that will be executed just before the form is submitted to your | |
5801 | server. You can use this opportunity to check the contents of the form | |
5802 | for consistency and completeness. If you find something wrong, you | |
5803 | can put up an alert box or maybe fix things up yourself. You can | |
5804 | abort the submission by returning false from this function. | |
5805 | ||
3acbd4f5 | 5806 | Usually the bulk of JavaScript functions are defined in a <script> |
54310121 | 5807 | block in the HTML header and -onSubmit points to one of these function |
5808 | call. See start_html() for details. | |
5809 | ||
29ddc2a4 RGS |
5810 | =head2 FORM ELEMENTS |
5811 | ||
5812 | After starting a form, you will typically create one or more | |
5813 | textfields, popup menus, radio groups and other form elements. Each | |
5814 | of these elements takes a standard set of named arguments. Some | |
5815 | elements also have optional arguments. The standard arguments are as | |
5816 | follows: | |
5817 | ||
5818 | =over 4 | |
5819 | ||
5820 | =item B<-name> | |
5821 | ||
5822 | The name of the field. After submission this name can be used to | |
5823 | retrieve the field's value using the param() method. | |
5824 | ||
5825 | =item B<-value>, B<-values> | |
5826 | ||
5827 | The initial value of the field which will be returned to the script | |
5828 | after form submission. Some form elements, such as text fields, take | |
5829 | a single scalar -value argument. Others, such as popup menus, take a | |
5830 | reference to an array of values. The two arguments are synonyms. | |
5831 | ||
5832 | =item B<-tabindex> | |
5833 | ||
5834 | A numeric value that sets the order in which the form element receives | |
5835 | focus when the user presses the tab key. Elements with lower values | |
5836 | receive focus first. | |
5837 | ||
5838 | =item B<-id> | |
5839 | ||
5840 | A string identifier that can be used to identify this element to | |
5841 | JavaScript and DHTML. | |
5842 | ||
5843 | =item B<-override> | |
5844 | ||
5845 | A boolean, which, if true, forces the element to take on the value | |
5846 | specified by B<-value>, overriding the sticky behavior described | |
5847 | earlier for the B<-no_sticky> pragma. | |
5848 | ||
5849 | =item B<-onChange>, B<-onFocus>, B<-onBlur>, B<-onMouseOver>, B<-onMouseOut>, B<-onSelect> | |
5850 | ||
5851 | These are used to assign JavaScript event handlers. See the | |
5852 | JavaScripting section for more details. | |
5853 | ||
5854 | =back | |
5855 | ||
5856 | Other common arguments are described in the next section. In addition | |
5857 | to these, all attributes described in the HTML specifications are | |
5858 | supported. | |
5859 | ||
54310121 | 5860 | =head2 CREATING A TEXT FIELD |
5861 | ||
29ddc2a4 RGS |
5862 | print textfield(-name=>'field_name', |
5863 | -value=>'starting value', | |
5864 | -size=>50, | |
5865 | -maxlength=>80); | |
54310121 | 5866 | -or- |
5867 | ||
29ddc2a4 | 5868 | print textfield('field_name','starting value',50,80); |
54310121 | 5869 | |
29ddc2a4 | 5870 | textfield() will return a text input field. |
54310121 | 5871 | |
5872 | =over 4 | |
5873 | ||
5874 | =item B<Parameters> | |
5875 | ||
5876 | =item 1. | |
5877 | ||
29ddc2a4 | 5878 | The first parameter is the required name for the field (-name). |
54310121 | 5879 | |
5880 | =item 2. | |
5881 | ||
5882 | The optional second parameter is the default starting value for the field | |
29ddc2a4 | 5883 | contents (-value, formerly known as -default). |
54310121 | 5884 | |
5885 | =item 3. | |
5886 | ||
5887 | The optional third parameter is the size of the field in | |
5888 | characters (-size). | |
5889 | ||
5890 | =item 4. | |
5891 | ||
5892 | The optional fourth parameter is the maximum number of characters the | |
5893 | field will accept (-maxlength). | |
5894 | ||
5895 | =back | |
5896 | ||
5897 | As with all these methods, the field will be initialized with its | |
5898 | previous contents from earlier invocations of the script. | |
5899 | When the form is processed, the value of the text field can be | |
5900 | retrieved with: | |
5901 | ||
29ddc2a4 | 5902 | $value = param('foo'); |
54310121 | 5903 | |
5904 | If you want to reset it from its initial value after the script has been | |
5905 | called once, you can do so like this: | |
5906 | ||
29ddc2a4 | 5907 | param('foo',"I'm taking over this value!"); |
54310121 | 5908 | |
5909 | =head2 CREATING A BIG TEXT FIELD | |
5910 | ||
29ddc2a4 | 5911 | print textarea(-name=>'foo', |
54310121 | 5912 | -default=>'starting value', |
5913 | -rows=>10, | |
5914 | -columns=>50); | |
5915 | ||
5916 | -or | |
5917 | ||
29ddc2a4 | 5918 | print textarea('foo','starting value',10,50); |
54310121 | 5919 | |
5920 | textarea() is just like textfield, but it allows you to specify | |
5921 | rows and columns for a multiline text entry box. You can provide | |
5922 | a starting value for the field, which can be long and contain | |
5923 | multiple lines. | |
5924 | ||
54310121 | 5925 | =head2 CREATING A PASSWORD FIELD |
5926 | ||
29ddc2a4 | 5927 | print password_field(-name=>'secret', |
54310121 | 5928 | -value=>'starting value', |
5929 | -size=>50, | |
5930 | -maxlength=>80); | |
5931 | -or- | |
5932 | ||
29ddc2a4 | 5933 | print password_field('secret','starting value',50,80); |
54310121 | 5934 | |
5935 | password_field() is identical to textfield(), except that its contents | |
5936 | will be starred out on the web page. | |
5937 | ||
54310121 | 5938 | =head2 CREATING A FILE UPLOAD FIELD |
5939 | ||
29ddc2a4 | 5940 | print filefield(-name=>'uploaded_file', |
54310121 | 5941 | -default=>'starting value', |
5942 | -size=>50, | |
5943 | -maxlength=>80); | |
5944 | -or- | |
5945 | ||
29ddc2a4 | 5946 | print filefield('uploaded_file','starting value',50,80); |
54310121 | 5947 | |
5948 | filefield() will return a file upload field for Netscape 2.0 browsers. | |
5949 | In order to take full advantage of this I<you must use the new | |
5950 | multipart encoding scheme> for the form. You can do this either | |
6b4ac661 | 5951 | by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>, |
54310121 | 5952 | or by calling the new method B<start_multipart_form()> instead of |
3d1a2ec4 | 5953 | vanilla B<start_form()>. |
54310121 | 5954 | |
5955 | =over 4 | |
5956 | ||
5957 | =item B<Parameters> | |
5958 | ||
5959 | =item 1. | |
5960 | ||
5961 | The first parameter is the required name for the field (-name). | |
5962 | ||
5963 | =item 2. | |
5964 | ||
5965 | The optional second parameter is the starting value for the field contents | |
5966 | to be used as the default file name (-default). | |
5967 | ||
71f3e297 JH |
5968 | For security reasons, browsers don't pay any attention to this field, |
5969 | and so the starting value will always be blank. Worse, the field | |
5970 | loses its "sticky" behavior and forgets its previous contents. The | |
5971 | starting value field is called for in the HTML specification, however, | |
5972 | and possibly some browser will eventually provide support for it. | |
54310121 | 5973 | |
5974 | =item 3. | |
5975 | ||
5976 | The optional third parameter is the size of the field in | |
5977 | characters (-size). | |
5978 | ||
5979 | =item 4. | |
5980 | ||
5981 | The optional fourth parameter is the maximum number of characters the | |
5982 | field will accept (-maxlength). | |
5983 | ||
5984 | =back | |
5985 | ||
5986 | When the form is processed, you can retrieve the entered filename | |
3538e1d5 | 5987 | by calling param(): |
54310121 | 5988 | |
29ddc2a4 | 5989 | $filename = param('uploaded_file'); |
54310121 | 5990 | |
3538e1d5 GS |
5991 | Different browsers will return slightly different things for the |
5992 | name. Some browsers return the filename only. Others return the full | |
5993 | path to the file, using the path conventions of the user's machine. | |
5994 | Regardless, the name returned is always the name of the file on the | |
5995 | I<user's> machine, and is unrelated to the name of the temporary file | |
5996 | that CGI.pm creates during upload spooling (see below). | |
54310121 | 5997 | |
5998 | The filename returned is also a file handle. You can read the contents | |
5999 | of the file using standard Perl file reading calls: | |
6000 | ||
6001 | # Read a text file and print it out | |
6002 | while (<$filename>) { | |
6003 | print; | |
6004 | } | |
6005 | ||
6006 | # Copy a binary file to somewhere safe | |
6007 | open (OUTFILE,">>/usr/local/web/users/feedback"); | |
6008 | while ($bytesread=read($filename,$buffer,1024)) { | |
6009 | print OUTFILE $buffer; | |
6010 | } | |
6011 | ||
3538e1d5 GS |
6012 | However, there are problems with the dual nature of the upload fields. |
6013 | If you C<use strict>, then Perl will complain when you try to use a | |
6014 | string as a filehandle. You can get around this by placing the file | |
6015 | reading code in a block containing the C<no strict> pragma. More | |
6016 | seriously, it is possible for the remote user to type garbage into the | |
6017 | upload field, in which case what you get from param() is not a | |
6018 | filehandle at all, but a string. | |
6019 | ||
6020 | To be safe, use the I<upload()> function (new in version 2.47). When | |
6021 | called with the name of an upload field, I<upload()> returns a | |
6022 | filehandle, or undef if the parameter is not a valid filehandle. | |
6023 | ||
29ddc2a4 | 6024 | $fh = upload('uploaded_file'); |
3538e1d5 GS |
6025 | while (<$fh>) { |
6026 | print; | |
6027 | } | |
6028 | ||
13548fdf | 6029 | In an list context, upload() will return an array of filehandles. |
199d4a26 JH |
6030 | This makes it possible to create forms that use the same name for |
6031 | multiple upload fields. | |
6032 | ||
3538e1d5 GS |
6033 | This is the recommended idiom. |
6034 | ||
681699b9 SP |
6035 | For robust code, consider reseting the file handle position to beginning of the |
6036 | file. Inside of larger frameworks, other code may have already used the query | |
6037 | object and changed the filehandle postion: | |
6038 | ||
6039 | seek($fh,0,0); # reset postion to beginning of file. | |
6040 | ||
54310121 | 6041 | When a file is uploaded the browser usually sends along some |
6042 | information along with it in the format of headers. The information | |
6043 | usually includes the MIME content type. Future browsers may send | |
6044 | other information as well (such as modification date and size). To | |
6045 | retrieve this information, call uploadInfo(). It returns a reference to | |
6046 | an associative array containing all the document headers. | |
6047 | ||
29ddc2a4 RGS |
6048 | $filename = param('uploaded_file'); |
6049 | $type = uploadInfo($filename)->{'Content-Type'}; | |
54310121 | 6050 | unless ($type eq 'text/html') { |
6051 | die "HTML FILES ONLY!"; | |
6052 | } | |
6053 | ||
6054 | If you are using a machine that recognizes "text" and "binary" data | |
6055 | modes, be sure to understand when and how to use them (see the Camel book). | |
3538e1d5 GS |
6056 | Otherwise you may find that binary files are corrupted during file |
6057 | uploads. | |
6058 | ||
6059 | There are occasionally problems involving parsing the uploaded file. | |
6060 | This usually happens when the user presses "Stop" before the upload is | |
6061 | finished. In this case, CGI.pm will return undef for the name of the | |
6062 | uploaded file and set I<cgi_error()> to the string "400 Bad request | |
6063 | (malformed multipart POST)". This error message is designed so that | |
6064 | you can incorporate it into a status code to be sent to the browser. | |
6065 | Example: | |
6066 | ||
29ddc2a4 RGS |
6067 | $file = upload('uploaded_file'); |
6068 | if (!$file && cgi_error) { | |
6069 | print header(-status=>cgi_error); | |
3538e1d5 GS |
6070 | exit 0; |
6071 | } | |
6072 | ||
6073 | You are free to create a custom HTML page to complain about the error, | |
6074 | if you wish. | |
54310121 | 6075 | |
2ed511ec RGS |
6076 | You can set up a callback that will be called whenever a file upload |
6077 | is being read during the form processing. This is much like the | |
6078 | UPLOAD_HOOK facility available in Apache::Request, with the exception | |
6079 | that the first argument to the callback is an Apache::Upload object, | |
6080 | here it's the remote filename. | |
6081 | ||
cb3b230c | 6082 | $q = CGI->new(\&hook [,$data [,$use_tempfile]]); |
2ed511ec RGS |
6083 | |
6084 | sub hook | |
6085 | { | |
6086 | my ($filename, $buffer, $bytes_read, $data) = @_; | |
6087 | print "Read $bytes_read bytes of $filename\n"; | |
6088 | } | |
6089 | ||
cb3b230c SP |
6090 | The $data field is optional; it lets you pass configuration |
6091 | information (e.g. a database handle) to your hook callback. | |
6092 | ||
6093 | The $use_tempfile field is a flag that lets you turn on and off | |
6094 | CGI.pm's use of a temporary disk-based file during file upload. If you | |
6095 | set this to a FALSE value (default true) then param('uploaded_file') | |
6096 | will no longer work, and the only way to get at the uploaded data is | |
6097 | via the hook you provide. | |
6098 | ||
2ed511ec RGS |
6099 | If using the function-oriented interface, call the CGI::upload_hook() |
6100 | method before calling param() or any other CGI functions: | |
6101 | ||
cb3b230c | 6102 | CGI::upload_hook(\&hook [,$data [,$use_tempfile]]); |
2ed511ec RGS |
6103 | |
6104 | This method is not exported by default. You will have to import it | |
6105 | explicitly if you wish to use it without the CGI:: prefix. | |
6106 | ||
199d4a26 JH |
6107 | If you are using CGI.pm on a Windows platform and find that binary |
6108 | files get slightly larger when uploaded but that text files remain the | |
6109 | same, then you have forgotten to activate binary mode on the output | |
6110 | filehandle. Be sure to call binmode() on any handle that you create | |
6111 | to write the uploaded file to disk. | |
6112 | ||
424ec8fa GS |
6113 | JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>, |
6114 | B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are | |
6115 | recognized. See textfield() for details. | |
54310121 | 6116 | |
6117 | =head2 CREATING A POPUP MENU | |
6118 | ||
29ddc2a4 | 6119 | print popup_menu('menu_name', |
54310121 | 6120 | ['eenie','meenie','minie'], |
6121 | 'meenie'); | |
6122 | ||
6123 | -or- | |
6124 | ||
6125 | %labels = ('eenie'=>'your first choice', | |
6126 | 'meenie'=>'your second choice', | |
6127 | 'minie'=>'your third choice'); | |
188ba755 | 6128 | %attributes = ('eenie'=>{'class'=>'class of first choice'}); |
29ddc2a4 | 6129 | print popup_menu('menu_name', |
54310121 | 6130 | ['eenie','meenie','minie'], |
188ba755 | 6131 | 'meenie',\%labels,\%attributes); |
54310121 | 6132 | |
6133 | -or (named parameter style)- | |
6134 | ||
29ddc2a4 | 6135 | print popup_menu(-name=>'menu_name', |
54310121 | 6136 | -values=>['eenie','meenie','minie'], |
6137 | -default=>'meenie', | |
188ba755 JH |
6138 | -labels=>\%labels, |
6139 | -attributes=>\%attributes); | |
54310121 | 6140 | |
6141 | popup_menu() creates a menu. | |
6142 | ||
6143 | =over 4 | |
6144 | ||
6145 | =item 1. | |
6146 | ||
6147 | The required first argument is the menu's name (-name). | |
6148 | ||
6149 | =item 2. | |
6150 | ||
6151 | The required second argument (-values) is an array B<reference> | |
6152 | containing the list of menu items in the menu. You can pass the | |
6153 | method an anonymous array, as shown in the example, or a reference to | |
6154 | a named array, such as "\@foo". | |
6155 | ||
6156 | =item 3. | |
6157 | ||
6158 | The optional third parameter (-default) is the name of the default | |
6159 | menu choice. If not specified, the first item will be the default. | |
6160 | The values of the previous choice will be maintained across queries. | |
6161 | ||
6162 | =item 4. | |
6163 | ||
6164 | The optional fourth parameter (-labels) is provided for people who | |
6165 | want to use different values for the user-visible label inside the | |
188ba755 | 6166 | popup menu and the value returned to your script. It's a pointer to an |
54310121 | 6167 | associative array relating menu values to user-visible labels. If you |
6168 | leave this parameter blank, the menu values will be displayed by | |
6169 | default. (You can also leave a label undefined if you want to). | |
6170 | ||
188ba755 JH |
6171 | =item 5. |
6172 | ||
6173 | The optional fifth parameter (-attributes) is provided to assign | |
6174 | any of the common HTML attributes to an individual menu item. It's | |
6175 | a pointer to an associative array relating menu values to another | |
6176 | associative array with the attribute's name as the key and the | |
6177 | attribute's value as the value. | |
6178 | ||
54310121 | 6179 | =back |
6180 | ||
6181 | When the form is processed, the selected value of the popup menu can | |
6182 | be retrieved using: | |
6183 | ||
29ddc2a4 | 6184 | $popup_menu_value = param('menu_name'); |
54310121 | 6185 | |
188ba755 JH |
6186 | =head2 CREATING AN OPTION GROUP |
6187 | ||
6188 | Named parameter style | |
6189 | ||
29ddc2a4 | 6190 | print popup_menu(-name=>'menu_name', |
188ba755 | 6191 | -values=>[qw/eenie meenie minie/, |
29ddc2a4 RGS |
6192 | optgroup(-name=>'optgroup_name', |
6193 | -values => ['moe','catch'], | |
6194 | -attributes=>{'catch'=>{'class'=>'red'}})], | |
188ba755 JH |
6195 | -labels=>{'eenie'=>'one', |
6196 | 'meenie'=>'two', | |
6197 | 'minie'=>'three'}, | |
6198 | -default=>'meenie'); | |
6199 | ||
6200 | Old style | |
29ddc2a4 | 6201 | print popup_menu('menu_name', |
188ba755 | 6202 | ['eenie','meenie','minie', |
29ddc2a4 RGS |
6203 | optgroup('optgroup_name', ['moe', 'catch'], |
6204 | {'catch'=>{'class'=>'red'}})],'meenie', | |
188ba755 JH |
6205 | {'eenie'=>'one','meenie'=>'two','minie'=>'three'}); |
6206 | ||
29ddc2a4 | 6207 | optgroup() creates an option group within a popup menu. |
188ba755 JH |
6208 | |
6209 | =over 4 | |
6210 | ||
6211 | =item 1. | |
6212 | ||
6213 | The required first argument (B<-name>) is the label attribute of the | |
6214 | optgroup and is B<not> inserted in the parameter list of the query. | |
6215 | ||
6216 | =item 2. | |
6217 | ||
6218 | The required second argument (B<-values>) is an array reference | |
6219 | containing the list of menu items in the menu. You can pass the | |
6220 | method an anonymous array, as shown in the example, or a reference | |
6221 | to a named array, such as \@foo. If you pass a HASH reference, | |
6222 | the keys will be used for the menu values, and the values will be | |
6223 | used for the menu labels (see -labels below). | |
6224 | ||
6225 | =item 3. | |
6226 | ||
6227 | The optional third parameter (B<-labels>) allows you to pass a reference | |
6228 | to an associative array containing user-visible labels for one or more | |
6229 | of the menu items. You can use this when you want the user to see one | |
6230 | menu string, but have the browser return your program a different one. | |
6231 | If you don't specify this, the value string will be used instead | |
6232 | ("eenie", "meenie" and "minie" in this example). This is equivalent | |
6233 | to using a hash reference for the -values parameter. | |
6234 | ||
6235 | =item 4. | |
6236 | ||
6237 | An optional fourth parameter (B<-labeled>) can be set to a true value | |
6238 | and indicates that the values should be used as the label attribute | |
6239 | for each option element within the optgroup. | |
6240 | ||
6241 | =item 5. | |
6242 | ||
6243 | An optional fifth parameter (-novals) can be set to a true value and | |
3c4b39be | 6244 | indicates to suppress the val attribute in each option element within |
188ba755 JH |
6245 | the optgroup. |
6246 | ||
6247 | See the discussion on optgroup at W3C | |
6248 | (http://www.w3.org/TR/REC-html40/interact/forms.html#edef-OPTGROUP) | |
6249 | for details. | |
6250 | ||
6251 | =item 6. | |
6252 | ||
6253 | An optional sixth parameter (-attributes) is provided to assign | |
6254 | any of the common HTML attributes to an individual menu item. It's | |
6255 | a pointer to an associative array relating menu values to another | |
6256 | associative array with the attribute's name as the key and the | |
6257 | attribute's value as the value. | |
6258 | ||
cff99809 JH |
6259 | =back |
6260 | ||
54310121 | 6261 | =head2 CREATING A SCROLLING LIST |
6262 | ||
29ddc2a4 | 6263 | print scrolling_list('list_name', |
54310121 | 6264 | ['eenie','meenie','minie','moe'], |
188ba755 | 6265 | ['eenie','moe'],5,'true',{'moe'=>{'class'=>'red'}}); |
54310121 | 6266 | -or- |
6267 | ||
29ddc2a4 | 6268 | print scrolling_list('list_name', |
54310121 | 6269 | ['eenie','meenie','minie','moe'], |
6270 | ['eenie','moe'],5,'true', | |
188ba755 | 6271 | \%labels,%attributes); |
54310121 | 6272 | |
6273 | -or- | |
6274 | ||
29ddc2a4 | 6275 | print scrolling_list(-name=>'list_name', |
54310121 | 6276 | -values=>['eenie','meenie','minie','moe'], |
6277 | -default=>['eenie','moe'], | |
6278 | -size=>5, | |
6279 | -multiple=>'true', | |
188ba755 JH |
6280 | -labels=>\%labels, |
6281 | -attributes=>\%attributes); | |
54310121 | 6282 | |
6283 | scrolling_list() creates a scrolling list. | |
6284 | ||
6285 | =over 4 | |
6286 | ||
6287 | =item B<Parameters:> | |
6288 | ||
6289 | =item 1. | |
6290 | ||
6291 | The first and second arguments are the list name (-name) and values | |
6292 | (-values). As in the popup menu, the second argument should be an | |
6293 | array reference. | |
6294 | ||
6295 | =item 2. | |
6296 | ||
6297 | The optional third argument (-default) can be either a reference to a | |
6298 | list containing the values to be selected by default, or can be a | |
6299 | single value to select. If this argument is missing or undefined, | |
6300 | then nothing is selected when the list first appears. In the named | |
6301 | parameter version, you can use the synonym "-defaults" for this | |
6302 | parameter. | |
6303 | ||
6304 | =item 3. | |
6305 | ||
6306 | The optional fourth argument is the size of the list (-size). | |
6307 | ||
6308 | =item 4. | |
6309 | ||
6310 | The optional fifth argument can be set to true to allow multiple | |
6311 | simultaneous selections (-multiple). Otherwise only one selection | |
6312 | will be allowed at a time. | |
6313 | ||
6314 | =item 5. | |
6315 | ||
6316 | The optional sixth argument is a pointer to an associative array | |
6317 | containing long user-visible labels for the list items (-labels). | |
6318 | If not provided, the values will be displayed. | |
6319 | ||
188ba755 JH |
6320 | =item 6. |
6321 | ||
6322 | The optional sixth parameter (-attributes) is provided to assign | |
6323 | any of the common HTML attributes to an individual menu item. It's | |
6324 | a pointer to an associative array relating menu values to another | |
6325 | associative array with the attribute's name as the key and the | |
6326 | attribute's value as the value. | |
6327 | ||
54310121 | 6328 | When this form is processed, all selected list items will be returned as |
6329 | a list under the parameter name 'list_name'. The values of the | |
6330 | selected items can be retrieved with: | |
6331 | ||
29ddc2a4 | 6332 | @selected = param('list_name'); |
54310121 | 6333 | |
6334 | =back | |
6335 | ||
54310121 | 6336 | =head2 CREATING A GROUP OF RELATED CHECKBOXES |
6337 | ||
29ddc2a4 | 6338 | print checkbox_group(-name=>'group_name', |
54310121 | 6339 | -values=>['eenie','meenie','minie','moe'], |
6340 | -default=>['eenie','moe'], | |
6341 | -linebreak=>'true', | |
8869a4b7 | 6342 | -disabled => ['moe'], |
188ba755 JH |
6343 | -labels=>\%labels, |
6344 | -attributes=>\%attributes); | |
54310121 | 6345 | |
29ddc2a4 | 6346 | print checkbox_group('group_name', |
54310121 | 6347 | ['eenie','meenie','minie','moe'], |
188ba755 JH |
6348 | ['eenie','moe'],'true',\%labels, |
6349 | {'moe'=>{'class'=>'red'}}); | |
54310121 | 6350 | |
6351 | HTML3-COMPATIBLE BROWSERS ONLY: | |
6352 | ||
29ddc2a4 | 6353 | print checkbox_group(-name=>'group_name', |
54310121 | 6354 | -values=>['eenie','meenie','minie','moe'], |
6355 | -rows=2,-columns=>2); | |
3cb6de81 | 6356 | |
54310121 | 6357 | |
6358 | checkbox_group() creates a list of checkboxes that are related | |
6359 | by the same name. | |
6360 | ||
6361 | =over 4 | |
6362 | ||
6363 | =item B<Parameters:> | |
6364 | ||
6365 | =item 1. | |
6366 | ||
6367 | The first and second arguments are the checkbox name and values, | |
6368 | respectively (-name and -values). As in the popup menu, the second | |
6369 | argument should be an array reference. These values are used for the | |
6370 | user-readable labels printed next to the checkboxes as well as for the | |
6371 | values passed to your script in the query string. | |
6372 | ||
6373 | =item 2. | |
6374 | ||
6375 | The optional third argument (-default) can be either a reference to a | |
6376 | list containing the values to be checked by default, or can be a | |
6377 | single value to checked. If this argument is missing or undefined, | |
6378 | then nothing is selected when the list first appears. | |
6379 | ||
6380 | =item 3. | |
6381 | ||
6382 | The optional fourth argument (-linebreak) can be set to true to place | |
6383 | line breaks between the checkboxes so that they appear as a vertical | |
6384 | list. Otherwise, they will be strung together on a horizontal line. | |
6385 | ||
29ddc2a4 | 6386 | =back |
54310121 | 6387 | |
54310121 | 6388 | |
29ddc2a4 RGS |
6389 | The optional b<-labels> argument is a pointer to an associative array |
6390 | relating the checkbox values to the user-visible labels that will be | |
6391 | printed next to them. If not provided, the values will be used as the | |
6392 | default. | |
54310121 | 6393 | |
54310121 | 6394 | |
8869a4b7 SP |
6395 | The optional parameters B<-rows>, and B<-columns> cause |
6396 | checkbox_group() to return an HTML3 compatible table containing the | |
6397 | checkbox group formatted with the specified number of rows and | |
6398 | columns. You can provide just the -columns parameter if you wish; | |
6399 | checkbox_group will calculate the correct number of rows for you. | |
188ba755 | 6400 | |
8869a4b7 SP |
6401 | The option b<-disabled> takes an array of checkbox values and disables |
6402 | them by greying them out (this may not be supported by all browsers). | |
188ba755 | 6403 | |
29ddc2a4 RGS |
6404 | The optional B<-attributes> argument is provided to assign any of the |
6405 | common HTML attributes to an individual menu item. It's a pointer to | |
6406 | an associative array relating menu values to another associative array | |
6407 | with the attribute's name as the key and the attribute's value as the | |
6408 | value. | |
54310121 | 6409 | |
29ddc2a4 RGS |
6410 | The optional B<-tabindex> argument can be used to control the order in which |
6411 | radio buttons receive focus when the user presses the tab button. If | |
6412 | passed a scalar numeric value, the first element in the group will | |
6413 | receive this tab index and subsequent elements will be incremented by | |
6414 | one. If given a reference to an array of radio button values, then | |
6415 | the indexes will be jiggered so that the order specified in the array | |
6416 | will correspond to the tab order. You can also pass a reference to a | |
6417 | hash in which the hash keys are the radio button values and the values | |
6418 | are the tab indexes of each button. Examples: | |
6419 | ||
6420 | -tabindex => 100 # this group starts at index 100 and counts up | |
6421 | -tabindex => ['moe','minie','eenie','meenie'] # tab in this order | |
6422 | -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order | |
54310121 | 6423 | |
bb8b3399 SP |
6424 | The optional B<-labelattributes> argument will contain attributes |
6425 | attached to the <label> element that surrounds each button. | |
6426 | ||
54310121 | 6427 | When the form is processed, all checked boxes will be returned as |
6428 | a list under the parameter name 'group_name'. The values of the | |
6429 | "on" checkboxes can be retrieved with: | |
6430 | ||
29ddc2a4 | 6431 | @turned_on = param('group_name'); |
54310121 | 6432 | |
6433 | The value returned by checkbox_group() is actually an array of button | |
6434 | elements. You can capture them and use them within tables, lists, | |
6435 | or in other creative ways: | |
6436 | ||
29ddc2a4 | 6437 | @h = checkbox_group(-name=>'group_name',-values=>\@values); |
54310121 | 6438 | &use_in_creative_way(@h); |
6439 | ||
54310121 | 6440 | =head2 CREATING A STANDALONE CHECKBOX |
6441 | ||
29ddc2a4 | 6442 | print checkbox(-name=>'checkbox_name', |
ac734d8b | 6443 | -checked=>1, |
54310121 | 6444 | -value=>'ON', |
6445 | -label=>'CLICK ME'); | |
6446 | ||
6447 | -or- | |
6448 | ||
29ddc2a4 | 6449 | print checkbox('checkbox_name','checked','ON','CLICK ME'); |
54310121 | 6450 | |
6451 | checkbox() is used to create an isolated checkbox that isn't logically | |
6452 | related to any others. | |
6453 | ||
6454 | =over 4 | |
6455 | ||
6456 | =item B<Parameters:> | |
6457 | ||
6458 | =item 1. | |
6459 | ||
6460 | The first parameter is the required name for the checkbox (-name). It | |
6461 | will also be used for the user-readable label printed next to the | |
6462 | checkbox. | |
6463 | ||
6464 | =item 2. | |
6465 | ||
6466 | The optional second parameter (-checked) specifies that the checkbox | |
6467 | is turned on by default. Synonyms are -selected and -on. | |
6468 | ||
6469 | =item 3. | |
6470 | ||
6471 | The optional third parameter (-value) specifies the value of the | |
6472 | checkbox when it is checked. If not provided, the word "on" is | |
6473 | assumed. | |
6474 | ||
6475 | =item 4. | |
6476 | ||
6477 | The optional fourth parameter (-label) is the user-readable label to | |
6478 | be attached to the checkbox. If not provided, the checkbox name is | |
6479 | used. | |
6480 | ||
6481 | =back | |
6482 | ||
6483 | The value of the checkbox can be retrieved using: | |
6484 | ||
29ddc2a4 | 6485 | $turned_on = param('checkbox_name'); |
54310121 | 6486 | |
6487 | =head2 CREATING A RADIO BUTTON GROUP | |
6488 | ||
29ddc2a4 | 6489 | print radio_group(-name=>'group_name', |
54310121 | 6490 | -values=>['eenie','meenie','minie'], |
6491 | -default=>'meenie', | |
6492 | -linebreak=>'true', | |
188ba755 JH |
6493 | -labels=>\%labels, |
6494 | -attributes=>\%attributes); | |
54310121 | 6495 | |
6496 | -or- | |
6497 | ||
29ddc2a4 | 6498 | print radio_group('group_name',['eenie','meenie','minie'], |
188ba755 | 6499 | 'meenie','true',\%labels,\%attributes); |
54310121 | 6500 | |
6501 | ||
6502 | HTML3-COMPATIBLE BROWSERS ONLY: | |
6503 | ||
29ddc2a4 | 6504 | print radio_group(-name=>'group_name', |
54310121 | 6505 | -values=>['eenie','meenie','minie','moe'], |
6506 | -rows=2,-columns=>2); | |
6507 | ||
6508 | radio_group() creates a set of logically-related radio buttons | |
6509 | (turning one member of the group on turns the others off) | |
6510 | ||
6511 | =over 4 | |
6512 | ||
6513 | =item B<Parameters:> | |
6514 | ||
6515 | =item 1. | |
6516 | ||
6517 | The first argument is the name of the group and is required (-name). | |
6518 | ||
6519 | =item 2. | |
6520 | ||
6521 | The second argument (-values) is the list of values for the radio | |
6522 | buttons. The values and the labels that appear on the page are | |
6523 | identical. Pass an array I<reference> in the second argument, either | |
6524 | using an anonymous array, as shown, or by referencing a named array as | |
6525 | in "\@foo". | |
6526 | ||
6527 | =item 3. | |
6528 | ||
6529 | The optional third parameter (-default) is the name of the default | |
6530 | button to turn on. If not specified, the first item will be the | |
6531 | default. You can provide a nonexistent button name, such as "-" to | |
6532 | start up with no buttons selected. | |
6533 | ||
6534 | =item 4. | |
6535 | ||
6536 | The optional fourth parameter (-linebreak) can be set to 'true' to put | |
6537 | line breaks between the buttons, creating a vertical list. | |
6538 | ||
6539 | =item 5. | |
6540 | ||
6541 | The optional fifth parameter (-labels) is a pointer to an associative | |
6542 | array relating the radio button values to user-visible labels to be | |
6543 | used in the display. If not provided, the values themselves are | |
6544 | displayed. | |
6545 | ||
29ddc2a4 | 6546 | =back |
54310121 | 6547 | |
188ba755 | 6548 | |
29ddc2a4 RGS |
6549 | All modern browsers can take advantage of the optional parameters |
6550 | B<-rows>, and B<-columns>. These parameters cause radio_group() to | |
6551 | return an HTML3 compatible table containing the radio group formatted | |
6552 | with the specified number of rows and columns. You can provide just | |
6553 | the -columns parameter if you wish; radio_group will calculate the | |
6554 | correct number of rows for you. | |
188ba755 | 6555 | |
54310121 | 6556 | To include row and column headings in the returned table, you |
8869a4b7 | 6557 | can use the B<-rowheaders> and B<-colheaders> parameters. Both |
54310121 | 6558 | of these accept a pointer to an array of headings to use. |
6559 | The headings are just decorative. They don't reorganize the | |
f610777f | 6560 | interpretation of the radio buttons -- they're still a single named |
54310121 | 6561 | unit. |
6562 | ||
29ddc2a4 RGS |
6563 | The optional B<-tabindex> argument can be used to control the order in which |
6564 | radio buttons receive focus when the user presses the tab button. If | |
6565 | passed a scalar numeric value, the first element in the group will | |
6566 | receive this tab index and subsequent elements will be incremented by | |
6567 | one. If given a reference to an array of radio button values, then | |
6568 | the indexes will be jiggered so that the order specified in the array | |
6569 | will correspond to the tab order. You can also pass a reference to a | |
6570 | hash in which the hash keys are the radio button values and the values | |
6571 | are the tab indexes of each button. Examples: | |
6572 | ||
6573 | -tabindex => 100 # this group starts at index 100 and counts up | |
6574 | -tabindex => ['moe','minie','eenie','meenie'] # tab in this order | |
6575 | -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order | |
6576 | ||
6577 | ||
6578 | The optional B<-attributes> argument is provided to assign any of the | |
6579 | common HTML attributes to an individual menu item. It's a pointer to | |
6580 | an associative array relating menu values to another associative array | |
6581 | with the attribute's name as the key and the attribute's value as the | |
6582 | value. | |
54310121 | 6583 | |
bb8b3399 SP |
6584 | The optional B<-labelattributes> argument will contain attributes |
6585 | attached to the <label> element that surrounds each button. | |
6586 | ||
54310121 | 6587 | When the form is processed, the selected radio button can |
6588 | be retrieved using: | |
6589 | ||
29ddc2a4 | 6590 | $which_radio_button = param('group_name'); |
54310121 | 6591 | |
6592 | The value returned by radio_group() is actually an array of button | |
6593 | elements. You can capture them and use them within tables, lists, | |
6594 | or in other creative ways: | |
6595 | ||
29ddc2a4 | 6596 | @h = radio_group(-name=>'group_name',-values=>\@values); |
54310121 | 6597 | &use_in_creative_way(@h); |
6598 | ||
6599 | =head2 CREATING A SUBMIT BUTTON | |
6600 | ||
29ddc2a4 | 6601 | print submit(-name=>'button_name', |
54310121 | 6602 | -value=>'value'); |
6603 | ||
6604 | -or- | |
6605 | ||
29ddc2a4 | 6606 | print submit('button_name','value'); |
54310121 | 6607 | |
6608 | submit() will create the query submission button. Every form | |
6609 | should have one of these. | |
6610 | ||
6611 | =over 4 | |
6612 | ||
6613 | =item B<Parameters:> | |
6614 | ||
6615 | =item 1. | |
6616 | ||
6617 | The first argument (-name) is optional. You can give the button a | |
6618 | name if you have several submission buttons in your form and you want | |
13548fdf | 6619 | to distinguish between them. |
54310121 | 6620 | |
6621 | =item 2. | |
6622 | ||
6623 | The second argument (-value) is also optional. This gives the button | |
13548fdf RGS |
6624 | a value that will be passed to your script in the query string. The |
6625 | name will also be used as the user-visible label. | |
6626 | ||
6627 | =item 3. | |
6628 | ||
6629 | You can use -label as an alias for -value. I always get confused | |
6630 | about which of -name and -value changes the user-visible label on the | |
6631 | button. | |
54310121 | 6632 | |
6633 | =back | |
6634 | ||
6635 | You can figure out which button was pressed by using different | |
6636 | values for each one: | |
6637 | ||
29ddc2a4 | 6638 | $which_one = param('button_name'); |
54310121 | 6639 | |
6640 | =head2 CREATING A RESET BUTTON | |
6641 | ||
29ddc2a4 | 6642 | print reset |
54310121 | 6643 | |
6644 | reset() creates the "reset" button. Note that it restores the | |
6645 | form to its value from the last time the script was called, | |
6646 | NOT necessarily to the defaults. | |
6647 | ||
71f3e297 JH |
6648 | Note that this conflicts with the Perl reset() built-in. Use |
6649 | CORE::reset() to get the original reset function. | |
6650 | ||
54310121 | 6651 | =head2 CREATING A DEFAULT BUTTON |
6652 | ||
29ddc2a4 | 6653 | print defaults('button_label') |
54310121 | 6654 | |
6655 | defaults() creates a button that, when invoked, will cause the | |
6656 | form to be completely reset to its defaults, wiping out all the | |
6657 | changes the user ever made. | |
6658 | ||
6659 | =head2 CREATING A HIDDEN FIELD | |
6660 | ||
29ddc2a4 | 6661 | print hidden(-name=>'hidden_name', |
54310121 | 6662 | -default=>['value1','value2'...]); |
6663 | ||
6664 | -or- | |
6665 | ||
29ddc2a4 | 6666 | print hidden('hidden_name','value1','value2'...); |
54310121 | 6667 | |
6668 | hidden() produces a text field that can't be seen by the user. It | |
6669 | is useful for passing state variable information from one invocation | |
6670 | of the script to the next. | |
6671 | ||
6672 | =over 4 | |
6673 | ||
6674 | =item B<Parameters:> | |
6675 | ||
6676 | =item 1. | |
6677 | ||
6678 | The first argument is required and specifies the name of this | |
6679 | field (-name). | |
6680 | ||
6681 | =item 2. | |
6682 | ||
6683 | The second argument is also required and specifies its value | |
6684 | (-default). In the named parameter style of calling, you can provide | |
6685 | a single value here or a reference to a whole list | |
6686 | ||
6687 | =back | |
6688 | ||
6689 | Fetch the value of a hidden field this way: | |
6690 | ||
29ddc2a4 | 6691 | $hidden_value = param('hidden_name'); |
54310121 | 6692 | |
6693 | Note, that just like all the other form elements, the value of a | |
6694 | hidden field is "sticky". If you want to replace a hidden field with | |
6695 | some other values after the script has been called once you'll have to | |
6696 | do it manually: | |
6697 | ||
29ddc2a4 | 6698 | param('hidden_name','new','values','here'); |
54310121 | 6699 | |
6700 | =head2 CREATING A CLICKABLE IMAGE BUTTON | |
6701 | ||
29ddc2a4 | 6702 | print image_button(-name=>'button_name', |
54310121 | 6703 | -src=>'/source/URL', |
6704 | -align=>'MIDDLE'); | |
6705 | ||
6706 | -or- | |
6707 | ||
29ddc2a4 | 6708 | print image_button('button_name','/source/URL','MIDDLE'); |
54310121 | 6709 | |
6710 | image_button() produces a clickable image. When it's clicked on the | |
6711 | position of the click is returned to your script as "button_name.x" | |
6712 | and "button_name.y", where "button_name" is the name you've assigned | |
6713 | to it. | |
6714 | ||
54310121 | 6715 | =over 4 |
6716 | ||
6717 | =item B<Parameters:> | |
6718 | ||
6719 | =item 1. | |
6720 | ||
6721 | The first argument (-name) is required and specifies the name of this | |
6722 | field. | |
6723 | ||
6724 | =item 2. | |
6725 | ||
6726 | The second argument (-src) is also required and specifies the URL | |
6727 | ||
6728 | =item 3. | |
6729 | The third option (-align, optional) is an alignment type, and may be | |
6730 | TOP, BOTTOM or MIDDLE | |
6731 | ||
6732 | =back | |
6733 | ||
6734 | Fetch the value of the button this way: | |
29ddc2a4 RGS |
6735 | $x = param('button_name.x'); |
6736 | $y = param('button_name.y'); | |
54310121 | 6737 | |
6738 | =head2 CREATING A JAVASCRIPT ACTION BUTTON | |
6739 | ||
29ddc2a4 | 6740 | print button(-name=>'button_name', |
54310121 | 6741 | -value=>'user visible label', |
6742 | -onClick=>"do_something()"); | |
6743 | ||
6744 | -or- | |
6745 | ||
29ddc2a4 | 6746 | print button('button_name',"do_something()"); |
54310121 | 6747 | |
6748 | button() produces a button that is compatible with Netscape 2.0's | |
6749 | JavaScript. When it's pressed the fragment of JavaScript code | |
6750 | pointed to by the B<-onClick> parameter will be executed. On | |
6751 | non-Netscape browsers this form element will probably not even | |
6752 | display. | |
6753 | ||
71f3e297 | 6754 | =head1 HTTP COOKIES |
54310121 | 6755 | |
71f3e297 JH |
6756 | Netscape browsers versions 1.1 and higher, and all versions of |
6757 | Internet Explorer, support a so-called "cookie" designed to help | |
6758 | maintain state within a browser session. CGI.pm has several methods | |
6759 | that support cookies. | |
54310121 | 6760 | |
6761 | A cookie is a name=value pair much like the named parameters in a CGI | |
6762 | query string. CGI scripts create one or more cookies and send | |
6763 | them to the browser in the HTTP header. The browser maintains a list | |
6764 | of cookies that belong to a particular Web server, and returns them | |
6765 | to the CGI script during subsequent interactions. | |
6766 | ||
6767 | In addition to the required name=value pair, each cookie has several | |
6768 | optional attributes: | |
6769 | ||
6770 | =over 4 | |
6771 | ||
6772 | =item 1. an expiration time | |
6773 | ||
6774 | This is a time/date string (in a special GMT format) that indicates | |
6775 | when a cookie expires. The cookie will be saved and returned to your | |
6776 | script until this expiration date is reached if the user exits | |
71f3e297 JH |
6777 | the browser and restarts it. If an expiration date isn't specified, the cookie |
6778 | will remain active until the user quits the browser. | |
54310121 | 6779 | |
6780 | =item 2. a domain | |
6781 | ||
6782 | This is a partial or complete domain name for which the cookie is | |
6783 | valid. The browser will return the cookie to any host that matches | |
6784 | the partial domain name. For example, if you specify a domain name | |
71f3e297 | 6785 | of ".capricorn.com", then the browser will return the cookie to |
54310121 | 6786 | Web servers running on any of the machines "www.capricorn.com", |
6787 | "www2.capricorn.com", "feckless.capricorn.com", etc. Domain names | |
6788 | must contain at least two periods to prevent attempts to match | |
6789 | on top level domains like ".edu". If no domain is specified, then | |
6790 | the browser will only return the cookie to servers on the host the | |
6791 | cookie originated from. | |
6792 | ||
6793 | =item 3. a path | |
6794 | ||
6795 | If you provide a cookie path attribute, the browser will check it | |
6796 | against your script's URL before returning the cookie. For example, | |
6797 | if you specify the path "/cgi-bin", then the cookie will be returned | |
6798 | to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", | |
6799 | and "/cgi-bin/customer_service/complain.pl", but not to the script | |
6800 | "/cgi-private/site_admin.pl". By default, path is set to "/", which | |
6801 | causes the cookie to be sent to any CGI script on your site. | |
6802 | ||
6803 | =item 4. a "secure" flag | |
6804 | ||
6805 | If the "secure" attribute is set, the cookie will only be sent to your | |
6806 | script if the CGI request is occurring on a secure channel, such as SSL. | |
6807 | ||
6808 | =back | |
6809 | ||
71f3e297 | 6810 | The interface to HTTP cookies is the B<cookie()> method: |
54310121 | 6811 | |
29ddc2a4 | 6812 | $cookie = cookie(-name=>'sessionID', |
54310121 | 6813 | -value=>'xyzzy', |
6814 | -expires=>'+1h', | |
6815 | -path=>'/cgi-bin/database', | |
6816 | -domain=>'.capricorn.org', | |
6817 | -secure=>1); | |
29ddc2a4 | 6818 | print header(-cookie=>$cookie); |
54310121 | 6819 | |
6820 | B<cookie()> creates a new cookie. Its parameters include: | |
6821 | ||
6822 | =over 4 | |
6823 | ||
6824 | =item B<-name> | |
6825 | ||
6826 | The name of the cookie (required). This can be any string at all. | |
71f3e297 | 6827 | Although browsers limit their cookie names to non-whitespace |
54310121 | 6828 | alphanumeric characters, CGI.pm removes this restriction by escaping |
6829 | and unescaping cookies behind the scenes. | |
6830 | ||
6831 | =item B<-value> | |
6832 | ||
6833 | The value of the cookie. This can be any scalar value, | |
6834 | array reference, or even associative array reference. For example, | |
6835 | you can store an entire associative array into a cookie this way: | |
6836 | ||
29ddc2a4 | 6837 | $cookie=cookie(-name=>'family information', |
54310121 | 6838 | -value=>\%childrens_ages); |
6839 | ||
6840 | =item B<-path> | |
6841 | ||
6842 | The optional partial path for which this cookie will be valid, as described | |
6843 | above. | |
6844 | ||
6845 | =item B<-domain> | |
6846 | ||
6847 | The optional partial domain for which this cookie will be valid, as described | |
6848 | above. | |
6849 | ||
6850 | =item B<-expires> | |
6851 | ||
6852 | The optional expiration date for this cookie. The format is as described | |
6853 | in the section on the B<header()> method: | |
6854 | ||
6855 | "+1h" one hour from now | |
6856 | ||
6857 | =item B<-secure> | |
6858 | ||
6859 | If set to true, this cookie will only be used within a secure | |
6860 | SSL session. | |
6861 | ||
6862 | =back | |
6863 | ||
6864 | The cookie created by cookie() must be incorporated into the HTTP | |
6865 | header within the string returned by the header() method: | |
6866 | ||
0664a57d | 6867 | use CGI ':standard'; |
29ddc2a4 | 6868 | print header(-cookie=>$my_cookie); |
54310121 | 6869 | |
6870 | To create multiple cookies, give header() an array reference: | |
6871 | ||
29ddc2a4 | 6872 | $cookie1 = cookie(-name=>'riddle_name', |
54310121 | 6873 | -value=>"The Sphynx's Question"); |
29ddc2a4 | 6874 | $cookie2 = cookie(-name=>'answers', |
54310121 | 6875 | -value=>\%answers); |
29ddc2a4 | 6876 | print header(-cookie=>[$cookie1,$cookie2]); |
54310121 | 6877 | |
03b9648d | 6878 | To retrieve a cookie, request it by name by calling cookie() method |
0664a57d SP |
6879 | without the B<-value> parameter. This example uses the object-oriented |
6880 | form: | |
54310121 | 6881 | |
6882 | use CGI; | |
6883 | $query = new CGI; | |
0664a57d SP |
6884 | $riddle = $query->cookie('riddle_name'); |
6885 | %answers = $query->cookie('answers'); | |
03b9648d JH |
6886 | |
6887 | Cookies created with a single scalar value, such as the "riddle_name" | |
6888 | cookie, will be returned in that form. Cookies with array and hash | |
6889 | values can also be retrieved. | |
54310121 | 6890 | |
6891 | The cookie and CGI namespaces are separate. If you have a parameter | |
6892 | named 'answers' and a cookie named 'answers', the values retrieved by | |
6893 | param() and cookie() are independent of each other. However, it's | |
6894 | simple to turn a CGI parameter into a cookie, and vice-versa: | |
6895 | ||
6896 | # turn a CGI parameter into a cookie | |
29ddc2a4 | 6897 | $c=cookie(-name=>'answers',-value=>[param('answers')]); |
54310121 | 6898 | # vice-versa |
29ddc2a4 | 6899 | param(-name=>'answers',-value=>[cookie('answers')]); |
54310121 | 6900 | |
55b5d700 SP |
6901 | If you call cookie() without any parameters, it will return a list of |
6902 | the names of all cookies passed to your script: | |
6903 | ||
6904 | @cookies = cookie(); | |
6905 | ||
54310121 | 6906 | See the B<cookie.cgi> example script for some ideas on how to use |
6907 | cookies effectively. | |
6908 | ||
71f3e297 | 6909 | =head1 WORKING WITH FRAMES |
54310121 | 6910 | |
71f3e297 JH |
6911 | It's possible for CGI.pm scripts to write into several browser panels |
6912 | and windows using the HTML 4 frame mechanism. There are three | |
6913 | techniques for defining new frames programmatically: | |
54310121 | 6914 | |
6915 | =over 4 | |
6916 | ||
6917 | =item 1. Create a <Frameset> document | |
6918 | ||
6919 | After writing out the HTTP header, instead of creating a standard | |
3acbd4f5 | 6920 | HTML document using the start_html() call, create a <frameset> |
54310121 | 6921 | document that defines the frames on the page. Specify your script(s) |
6922 | (with appropriate parameters) as the SRC for each of the frames. | |
6923 | ||
3acbd4f5 | 6924 | There is no specific support for creating <frameset> sections |
54310121 | 6925 | in CGI.pm, but the HTML is very simple to write. See the frame |
6926 | documentation in Netscape's home pages for details | |
6927 | ||
0664a57d | 6928 | http://wp.netscape.com/assist/net_sites/frames.html |
54310121 | 6929 | |
6930 | =item 2. Specify the destination for the document in the HTTP header | |
6931 | ||
6932 | You may provide a B<-target> parameter to the header() method: | |
3cb6de81 | 6933 | |
29ddc2a4 | 6934 | print header(-target=>'ResultsWindow'); |
54310121 | 6935 | |
71f3e297 JH |
6936 | This will tell the browser to load the output of your script into the |
6937 | frame named "ResultsWindow". If a frame of that name doesn't already | |
6938 | exist, the browser will pop up a new window and load your script's | |
6939 | document into that. There are a number of magic names that you can | |
6940 | use for targets. See the frame documents on Netscape's home pages for | |
6941 | details. | |
54310121 | 6942 | |
3acbd4f5 | 6943 | =item 3. Specify the destination for the document in the <form> tag |
54310121 | 6944 | |
6945 | You can specify the frame to load in the FORM tag itself. With | |
6946 | CGI.pm it looks like this: | |
6947 | ||
29ddc2a4 | 6948 | print start_form(-target=>'ResultsWindow'); |
54310121 | 6949 | |
6950 | When your script is reinvoked by the form, its output will be loaded | |
6951 | into the frame named "ResultsWindow". If one doesn't already exist | |
6952 | a new window will be created. | |
6953 | ||
6954 | =back | |
6955 | ||
6956 | The script "frameset.cgi" in the examples directory shows one way to | |
6957 | create pages in which the fill-out form and the response live in | |
6958 | side-by-side frames. | |
6959 | ||
29ddc2a4 RGS |
6960 | =head1 SUPPORT FOR JAVASCRIPT |
6961 | ||
6962 | Netscape versions 2.0 and higher incorporate an interpreted language | |
6963 | called JavaScript. Internet Explorer, 3.0 and higher, supports a | |
6964 | closely-related dialect called JScript. JavaScript isn't the same as | |
6965 | Java, and certainly isn't at all the same as Perl, which is a great | |
3c4b39be | 6966 | pity. JavaScript allows you to programmatically change the contents of |
29ddc2a4 RGS |
6967 | fill-out forms, create new windows, and pop up dialog box from within |
6968 | Netscape itself. From the point of view of CGI scripting, JavaScript | |
6969 | is quite useful for validating fill-out forms prior to submitting | |
6970 | them. | |
6971 | ||
6972 | You'll need to know JavaScript in order to use it. There are many good | |
6973 | sources in bookstores and on the web. | |
6974 | ||
6975 | The usual way to use JavaScript is to define a set of functions in a | |
6976 | <SCRIPT> block inside the HTML header and then to register event | |
6977 | handlers in the various elements of the page. Events include such | |
6978 | things as the mouse passing over a form element, a button being | |
6979 | clicked, the contents of a text field changing, or a form being | |
6980 | submitted. When an event occurs that involves an element that has | |
6981 | registered an event handler, its associated JavaScript code gets | |
6982 | called. | |
6983 | ||
6984 | The elements that can register event handlers include the <BODY> of an | |
6985 | HTML document, hypertext links, all the various elements of a fill-out | |
6986 | form, and the form itself. There are a large number of events, and | |
6987 | each applies only to the elements for which it is relevant. Here is a | |
6988 | partial list: | |
6989 | ||
6990 | =over 4 | |
6991 | ||
6992 | =item B<onLoad> | |
6993 | ||
6994 | The browser is loading the current document. Valid in: | |
6995 | ||
6996 | + The HTML <BODY> section only. | |
6997 | ||
6998 | =item B<onUnload> | |
6999 | ||
7000 | The browser is closing the current page or frame. Valid for: | |
7001 | ||
7002 | + The HTML <BODY> section only. | |
7003 | ||
7004 | =item B<onSubmit> | |
7005 | ||
7006 | The user has pressed the submit button of a form. This event happens | |
7007 | just before the form is submitted, and your function can return a | |
7008 | value of false in order to abort the submission. Valid for: | |
7009 | ||
7010 | + Forms only. | |
7011 | ||
7012 | =item B<onClick> | |
7013 | ||
7014 | The mouse has clicked on an item in a fill-out form. Valid for: | |
7015 | ||
7016 | + Buttons (including submit, reset, and image buttons) | |
7017 | + Checkboxes | |
7018 | + Radio buttons | |
7019 | ||
7020 | =item B<onChange> | |
7021 | ||
7022 | The user has changed the contents of a field. Valid for: | |
7023 | ||
7024 | + Text fields | |
7025 | + Text areas | |
7026 | + Password fields | |
7027 | + File fields | |
7028 | + Popup Menus | |
7029 | + Scrolling lists | |
7030 | ||
7031 | =item B<onFocus> | |
7032 | ||
7033 | The user has selected a field to work with. Valid for: | |
7034 | ||
7035 | + Text fields | |
7036 | + Text areas | |
7037 | + Password fields | |
7038 | + File fields | |
7039 | + Popup Menus | |
7040 | + Scrolling lists | |
7041 | ||
7042 | =item B<onBlur> | |
7043 | ||
7044 | The user has deselected a field (gone to work somewhere else). Valid | |
7045 | for: | |
7046 | ||
7047 | + Text fields | |
7048 | + Text areas | |
7049 | + Password fields | |
7050 | + File fields | |
7051 | + Popup Menus | |
7052 | + Scrolling lists | |
7053 | ||
7054 | =item B<onSelect> | |
7055 | ||
7056 | The user has changed the part of a text field that is selected. Valid | |
7057 | for: | |
7058 | ||
7059 | + Text fields | |
7060 | + Text areas | |
7061 | + Password fields | |
7062 | + File fields | |
7063 | ||
7064 | =item B<onMouseOver> | |
7065 | ||
7066 | The mouse has moved over an element. | |
7067 | ||
7068 | + Text fields | |
7069 | + Text areas | |
7070 | + Password fields | |
7071 | + File fields | |
7072 | + Popup Menus | |
7073 | + Scrolling lists | |
7074 | ||
7075 | =item B<onMouseOut> | |
7076 | ||
7077 | The mouse has moved off an element. | |
7078 | ||
7079 | + Text fields | |
7080 | + Text areas | |
7081 | + Password fields | |
7082 | + File fields | |
7083 | + Popup Menus | |
7084 | + Scrolling lists | |
7085 | ||
7086 | =back | |
7087 | ||
7088 | In order to register a JavaScript event handler with an HTML element, | |
7089 | just use the event name as a parameter when you call the corresponding | |
7090 | CGI method. For example, to have your validateAge() JavaScript code | |
7091 | executed every time the textfield named "age" changes, generate the | |
7092 | field like this: | |
7093 | ||
7094 | print textfield(-name=>'age',-onChange=>"validateAge(this)"); | |
7095 | ||
7096 | This example assumes that you've already declared the validateAge() | |
7097 | function by incorporating it into a <SCRIPT> block. The CGI.pm | |
7098 | start_html() method provides a convenient way to create this section. | |
7099 | ||
7100 | Similarly, you can create a form that checks itself over for | |
7101 | consistency and alerts the user if some essential value is missing by | |
7102 | creating it this way: | |
7103 | print startform(-onSubmit=>"validateMe(this)"); | |
7104 | ||
7105 | See the javascript.cgi script for a demonstration of how this all | |
7106 | works. | |
7107 | ||
7108 | ||
7d37aa8e LS |
7109 | =head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS |
7110 | ||
7111 | CGI.pm has limited support for HTML3's cascading style sheets (css). | |
7112 | To incorporate a stylesheet into your document, pass the | |
7113 | start_html() method a B<-style> parameter. The value of this | |
2ed511ec RGS |
7114 | parameter may be a scalar, in which case it is treated as the source |
7115 | URL for the stylesheet, or it may be a hash reference. In the latter | |
7d37aa8e LS |
7116 | case you should provide the hash with one or more of B<-src> or |
7117 | B<-code>. B<-src> points to a URL where an externally-defined | |
7118 | stylesheet can be found. B<-code> points to a scalar value to be | |
3acbd4f5 | 7119 | incorporated into a <style> section. Style definitions in B<-code> |
7d37aa8e LS |
7120 | override similarly-named ones in B<-src>, hence the name "cascading." |
7121 | ||
424ec8fa GS |
7122 | You may also specify the type of the stylesheet by adding the optional |
7123 | B<-type> parameter to the hash pointed to by B<-style>. If not | |
7124 | specified, the style defaults to 'text/css'. | |
7125 | ||
7d37aa8e LS |
7126 | To refer to a style within the body of your document, add the |
7127 | B<-class> parameter to any HTML element: | |
7128 | ||
7129 | print h1({-class=>'Fancy'},'Welcome to the Party'); | |
7130 | ||
7131 | Or define styles on the fly with the B<-style> parameter: | |
7132 | ||
7133 | print h1({-style=>'Color: red;'},'Welcome to Hell'); | |
7134 | ||
7135 | You may also use the new B<span()> element to apply a style to a | |
7136 | section of text: | |
7137 | ||
7138 | print span({-style=>'Color: red;'}, | |
7139 | h1('Welcome to Hell'), | |
7140 | "Where did that handbasket get to?" | |
7141 | ); | |
7142 | ||
7143 | Note that you must import the ":html3" definitions to have the | |
7144 | B<span()> method available. Here's a quick and dirty example of using | |
7145 | CSS's. See the CSS specification at | |
7146 | http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information. | |
7147 | ||
7148 | use CGI qw/:standard :html3/; | |
7149 | ||
7150 | #here's a stylesheet incorporated directly into the page | |
7151 | $newStyle=<<END; | |
7152 | <!-- | |
7153 | P.Tip { | |
7154 | margin-right: 50pt; | |
7155 | margin-left: 50pt; | |
7156 | color: red; | |
7157 | } | |
7158 | P.Alert { | |
7159 | font-size: 30pt; | |
7160 | font-family: sans-serif; | |
7161 | color: red; | |
7162 | } | |
7163 | --> | |
7164 | END | |
7165 | print header(); | |
7166 | print start_html( -title=>'CGI with Style', | |
7167 | -style=>{-src=>'http://www.capricorn.com/style/st1.css', | |
7168 | -code=>$newStyle} | |
7169 | ); | |
7170 | print h1('CGI with Style'), | |
7171 | p({-class=>'Tip'}, | |
7172 | "Better read the cascading style sheet spec before playing with this!"), | |
7173 | span({-style=>'color: magenta'}, | |
7174 | "Look Mom, no hands!", | |
7175 | p(), | |
7176 | "Whooo wee!" | |
7177 | ); | |
7178 | print end_html; | |
7179 | ||
13548fdf RGS |
7180 | Pass an array reference to B<-code> or B<-src> in order to incorporate |
7181 | multiple stylesheets into your document. | |
6b4ac661 | 7182 | |
8f3ccfa2 JH |
7183 | Should you wish to incorporate a verbatim stylesheet that includes |
7184 | arbitrary formatting in the header, you may pass a -verbatim tag to | |
7185 | the -style hash, as follows: | |
7186 | ||
8869a4b7 SP |
7187 | print start_html (-style => {-verbatim => '@import url("/server-common/css/'.$cssFile.'");', |
7188 | -src => '/server-common/css/core.css'}); | |
8f3ccfa2 JH |
7189 | |
7190 | ||
7191 | This will generate an HTML header that contains this: | |
7192 | ||
7193 | <link rel="stylesheet" type="text/css" href="/server-common/css/core.css"> | |
7194 | <style type="text/css"> | |
7195 | @import url("/server-common/css/main.css"); | |
7196 | </style> | |
7197 | ||
1c87da1d JH |
7198 | Any additional arguments passed in the -style value will be |
7199 | incorporated into the <link> tag. For example: | |
7200 | ||
7201 | start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'], | |
7202 | -media => 'all'}); | |
7203 | ||
7204 | This will give: | |
7205 | ||
7206 | <link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/> | |
7207 | <link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/> | |
7208 | ||
7209 | <p> | |
7210 | ||
7211 | To make more complicated <link> tags, use the Link() function | |
7212 | and pass it to start_html() in the -head argument, as in: | |
7213 | ||
7214 | @h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}), | |
7215 | Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'})); | |
7216 | print start_html({-head=>\@h}) | |
7217 | ||
0664a57d SP |
7218 | To create primary and "alternate" stylesheet, use the B<-alternate> option: |
7219 | ||
7220 | start_html(-style=>{-src=>[ | |
7221 | {-src=>'/styles/print.css'}, | |
7222 | {-src=>'/styles/alt.css',-alternate=>1} | |
7223 | ] | |
7224 | }); | |
7225 | ||
54310121 | 7226 | =head1 DEBUGGING |
7227 | ||
3d1a2ec4 GS |
7228 | If you are running the script from the command line or in the perl |
7229 | debugger, you can pass the script a list of keywords or | |
7230 | parameter=value pairs on the command line or from standard input (you | |
7231 | don't have to worry about tricking your script into reading from | |
7232 | environment variables). You can pass keywords like this: | |
54310121 | 7233 | |
7234 | your_script.pl keyword1 keyword2 keyword3 | |
7235 | ||
7236 | or this: | |
7237 | ||
7238 | your_script.pl keyword1+keyword2+keyword3 | |
7239 | ||
7240 | or this: | |
7241 | ||
7242 | your_script.pl name1=value1 name2=value2 | |
7243 | ||
7244 | or this: | |
7245 | ||
7246 | your_script.pl name1=value1&name2=value2 | |
7247 | ||
3d1a2ec4 GS |
7248 | To turn off this feature, use the -no_debug pragma. |
7249 | ||
7250 | To test the POST method, you may enable full debugging with the -debug | |
7251 | pragma. This will allow you to feed newline-delimited name=value | |
7252 | pairs to the script on standard input. | |
54310121 | 7253 | |
7254 | When debugging, you can use quotes and backslashes to escape | |
7255 | characters in the familiar shell manner, letting you place | |
7256 | spaces and other funny characters in your parameter=value | |
7257 | pairs: | |
7258 | ||
7259 | your_script.pl "name1='I am a long value'" "name2=two\ words" | |
7260 | ||
2ed511ec RGS |
7261 | Finally, you can set the path info for the script by prefixing the first |
7262 | name/value parameter with the path followed by a question mark (?): | |
7263 | ||
7264 | your_script.pl /your/path/here?name1=value1&name2=value2 | |
7265 | ||
54310121 | 7266 | =head2 DUMPING OUT ALL THE NAME/VALUE PAIRS |
7267 | ||
3d1a2ec4 | 7268 | The Dump() method produces a string consisting of all the query's |
54310121 | 7269 | name/value pairs formatted nicely as a nested list. This is useful |
7270 | for debugging purposes: | |
7271 | ||
29ddc2a4 | 7272 | print Dump |
3cb6de81 | 7273 | |
54310121 | 7274 | |
7275 | Produces something that looks like: | |
7276 | ||
3acbd4f5 JH |
7277 | <ul> |
7278 | <li>name1 | |
7279 | <ul> | |
7280 | <li>value1 | |
7281 | <li>value2 | |
7282 | </ul> | |
7283 | <li>name2 | |
7284 | <ul> | |
7285 | <li>value1 | |
7286 | </ul> | |
7287 | </ul> | |
54310121 | 7288 | |
71f3e297 JH |
7289 | As a shortcut, you can interpolate the entire CGI object into a string |
7290 | and it will be replaced with the a nice HTML dump shown above: | |
54310121 | 7291 | |
7292 | $query=new CGI; | |
3acbd4f5 | 7293 | print "<h2>Current Values</h2> $query\n"; |
54310121 | 7294 | |
7295 | =head1 FETCHING ENVIRONMENT VARIABLES | |
7296 | ||
7297 | Some of the more useful environment variables can be fetched | |
7298 | through this interface. The methods are as follows: | |
7299 | ||
7300 | =over 4 | |
7301 | ||
71f3e297 JH |
7302 | =item B<Accept()> |
7303 | ||
7304 | Return a list of MIME types that the remote browser accepts. If you | |
7305 | give this method a single argument corresponding to a MIME type, as in | |
29ddc2a4 | 7306 | Accept('text/html'), it will return a floating point value |
71f3e297 JH |
7307 | corresponding to the browser's preference for this type from 0.0 |
7308 | (don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept | |
7309 | list are handled correctly. | |
54310121 | 7310 | |
71f3e297 JH |
7311 | Note that the capitalization changed between version 2.43 and 2.44 in |
7312 | order to avoid conflict with Perl's accept() function. | |
54310121 | 7313 | |
7314 | =item B<raw_cookie()> | |
7315 | ||
424ec8fa | 7316 | Returns the HTTP_COOKIE variable, an HTTP extension implemented by |
71f3e297 JH |
7317 | Netscape browsers version 1.1 and higher, and all versions of Internet |
7318 | Explorer. Cookies have a special format, and this method call just | |
7319 | returns the raw form (?cookie dough). See cookie() for ways of | |
7320 | setting and retrieving cooked cookies. | |
424ec8fa GS |
7321 | |
7322 | Called with no parameters, raw_cookie() returns the packed cookie | |
7323 | structure. You can separate it into individual cookies by splitting | |
7324 | on the character sequence "; ". Called with the name of a cookie, | |
7325 | retrieves the B<unescaped> form of the cookie. You can use the | |
7326 | regular cookie() method to get the names, or use the raw_fetch() | |
7327 | method from the CGI::Cookie module. | |
54310121 | 7328 | |
7329 | =item B<user_agent()> | |
7330 | ||
7331 | Returns the HTTP_USER_AGENT variable. If you give | |
7332 | this method a single argument, it will attempt to | |
7333 | pattern match on it, allowing you to do something | |
29ddc2a4 | 7334 | like user_agent(netscape); |
54310121 | 7335 | |
7336 | =item B<path_info()> | |
7337 | ||
7338 | Returns additional path information from the script URL. | |
6b4ac661 | 7339 | E.G. fetching /cgi-bin/your_script/additional/stuff will result in |
29ddc2a4 | 7340 | path_info() returning "/additional/stuff". |
54310121 | 7341 | |
7342 | NOTE: The Microsoft Internet Information Server | |
7343 | is broken with respect to additional path information. If | |
7344 | you use the Perl DLL library, the IIS server will attempt to | |
7345 | execute the additional path information as a Perl script. | |
7346 | If you use the ordinary file associations mapping, the | |
7347 | path information will be present in the environment, | |
7348 | but incorrect. The best thing to do is to avoid using additional | |
7349 | path information in CGI scripts destined for use with IIS. | |
7350 | ||
7351 | =item B<path_translated()> | |
7352 | ||
7353 | As per path_info() but returns the additional | |
7354 | path information translated into a physical path, e.g. | |
7355 | "/usr/local/etc/httpd/htdocs/additional/stuff". | |
7356 | ||
7357 | The Microsoft IIS is broken with respect to the translated | |
7358 | path as well. | |
7359 | ||
7360 | =item B<remote_host()> | |
7361 | ||
7362 | Returns either the remote host name or IP address. | |
7363 | if the former is unavailable. | |
7364 | ||
7365 | =item B<script_name()> | |
7366 | Return the script name as a partial URL, for self-refering | |
7367 | scripts. | |
7368 | ||
7369 | =item B<referer()> | |
7370 | ||
7371 | Return the URL of the page the browser was viewing | |
7372 | prior to fetching your script. Not available for all | |
7373 | browsers. | |
7374 | ||
7375 | =item B<auth_type ()> | |
7376 | ||
7377 | Return the authorization/verification method in use for this | |
7378 | script, if any. | |
7379 | ||
7380 | =item B<server_name ()> | |
7381 | ||
7382 | Returns the name of the server, usually the machine's host | |
7383 | name. | |
7384 | ||
7385 | =item B<virtual_host ()> | |
7386 | ||
7387 | When using virtual hosts, returns the name of the host that | |
7388 | the browser attempted to contact | |
7389 | ||
03b9648d JH |
7390 | =item B<server_port ()> |
7391 | ||
7392 | Return the port that the server is listening on. | |
7393 | ||
2ed511ec RGS |
7394 | =item B<virtual_port ()> |
7395 | ||
7396 | Like server_port() except that it takes virtual hosts into account. | |
7397 | Use this when running with virtual hosts. | |
7398 | ||
54310121 | 7399 | =item B<server_software ()> |
7400 | ||
7401 | Returns the server software and version number. | |
7402 | ||
7403 | =item B<remote_user ()> | |
7404 | ||
7405 | Return the authorization/verification name used for user | |
7406 | verification, if this script is protected. | |
7407 | ||
7408 | =item B<user_name ()> | |
7409 | ||
71f3e297 JH |
7410 | Attempt to obtain the remote user's name, using a variety of different |
7411 | techniques. This only works with older browsers such as Mosaic. | |
7412 | Newer browsers do not report the user name for privacy reasons! | |
54310121 | 7413 | |
7414 | =item B<request_method()> | |
7415 | ||
7416 | Returns the method used to access your script, usually | |
7417 | one of 'POST', 'GET' or 'HEAD'. | |
7418 | ||
3538e1d5 GS |
7419 | =item B<content_type()> |
7420 | ||
7421 | Returns the content_type of data submitted in a POST, generally | |
7422 | multipart/form-data or application/x-www-form-urlencoded | |
7423 | ||
7424 | =item B<http()> | |
7425 | ||
7426 | Called with no arguments returns the list of HTTP environment | |
7427 | variables, including such things as HTTP_USER_AGENT, | |
7428 | HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the | |
7429 | like-named HTTP header fields in the request. Called with the name of | |
7430 | an HTTP header field, returns its value. Capitalization and the use | |
7431 | of hyphens versus underscores are not significant. | |
7432 | ||
7433 | For example, all three of these examples are equivalent: | |
7434 | ||
29ddc2a4 RGS |
7435 | $requested_language = http('Accept-language'); |
7436 | $requested_language = http('Accept_language'); | |
7437 | $requested_language = http('HTTP_ACCEPT_LANGUAGE'); | |
3538e1d5 GS |
7438 | |
7439 | =item B<https()> | |
7440 | ||
7441 | The same as I<http()>, but operates on the HTTPS environment variables | |
7442 | present when the SSL protocol is in effect. Can be used to determine | |
7443 | whether SSL is turned on. | |
7444 | ||
54310121 | 7445 | =back |
7446 | ||
424ec8fa | 7447 | =head1 USING NPH SCRIPTS |
54310121 | 7448 | |
424ec8fa GS |
7449 | NPH, or "no-parsed-header", scripts bypass the server completely by |
7450 | sending the complete HTTP header directly to the browser. This has | |
7451 | slight performance benefits, but is of most use for taking advantage | |
7452 | of HTTP extensions that are not directly supported by your server, | |
7453 | such as server push and PICS headers. | |
54310121 | 7454 | |
424ec8fa GS |
7455 | Servers use a variety of conventions for designating CGI scripts as |
7456 | NPH. Many Unix servers look at the beginning of the script's name for | |
7457 | the prefix "nph-". The Macintosh WebSTAR server and Microsoft's | |
7458 | Internet Information Server, in contrast, try to decide whether a | |
7459 | program is an NPH script by examining the first line of script output. | |
54310121 | 7460 | |
54310121 | 7461 | |
424ec8fa GS |
7462 | CGI.pm supports NPH scripts with a special NPH mode. When in this |
7463 | mode, CGI.pm will output the necessary extra header information when | |
7464 | the header() and redirect() methods are | |
7465 | called. | |
54310121 | 7466 | |
69c89ae7 JH |
7467 | The Microsoft Internet Information Server requires NPH mode. As of |
7468 | version 2.30, CGI.pm will automatically detect when the script is | |
7469 | running under IIS and put itself into this mode. You do not need to | |
7470 | do this manually, although it won't hurt anything if you do. However, | |
7471 | note that if you have applied Service Pack 6, much of the | |
7472 | functionality of NPH scripts, including the ability to redirect while | |
7473 | setting a cookie, b<do not work at all> on IIS without a special patch | |
7474 | from Microsoft. See | |
7475 | http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP: | |
7476 | Non-Parsed Headers Stripped From CGI Applications That Have nph- | |
7477 | Prefix in Name. | |
54310121 | 7478 | |
424ec8fa | 7479 | =over 4 |
54310121 | 7480 | |
424ec8fa | 7481 | =item In the B<use> statement |
54310121 | 7482 | |
424ec8fa GS |
7483 | Simply add the "-nph" pragmato the list of symbols to be imported into |
7484 | your script: | |
54310121 | 7485 | |
424ec8fa | 7486 | use CGI qw(:standard -nph) |
54310121 | 7487 | |
424ec8fa | 7488 | =item By calling the B<nph()> method: |
54310121 | 7489 | |
424ec8fa | 7490 | Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program. |
54310121 | 7491 | |
424ec8fa | 7492 | CGI->nph(1) |
54310121 | 7493 | |
551e1d92 RB |
7494 | =item By using B<-nph> parameters |
7495 | ||
7496 | in the B<header()> and B<redirect()> statements: | |
54310121 | 7497 | |
29ddc2a4 | 7498 | print header(-nph=>1); |
54310121 | 7499 | |
424ec8fa | 7500 | =back |
54310121 | 7501 | |
424ec8fa GS |
7502 | =head1 Server Push |
7503 | ||
ba056755 | 7504 | CGI.pm provides four simple functions for producing multipart |
424ec8fa GS |
7505 | documents of the type needed to implement server push. These |
7506 | functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To | |
7507 | import these into your namespace, you must import the ":push" set. | |
7508 | You are also advised to put the script into NPH mode and to set $| to | |
7509 | 1 to avoid buffering problems. | |
7510 | ||
7511 | Here is a simple script that demonstrates server push: | |
7512 | ||
7513 | #!/usr/local/bin/perl | |
7514 | use CGI qw/:push -nph/; | |
7515 | $| = 1; | |
ba056755 JH |
7516 | print multipart_init(-boundary=>'----here we go!'); |
7517 | foreach (0 .. 4) { | |
424ec8fa | 7518 | print multipart_start(-type=>'text/plain'), |
ba056755 JH |
7519 | "The current time is ",scalar(localtime),"\n"; |
7520 | if ($_ < 4) { | |
7521 | print multipart_end; | |
7522 | } else { | |
7523 | print multipart_final; | |
7524 | } | |
424ec8fa GS |
7525 | sleep 1; |
7526 | } | |
54310121 | 7527 | |
424ec8fa | 7528 | This script initializes server push by calling B<multipart_init()>. |
ba056755 JH |
7529 | It then enters a loop in which it begins a new multipart section by |
7530 | calling B<multipart_start()>, prints the current local time, | |
424ec8fa | 7531 | and ends a multipart section with B<multipart_end()>. It then sleeps |
ba056755 JH |
7532 | a second, and begins again. On the final iteration, it ends the |
7533 | multipart section with B<multipart_final()> rather than with | |
7534 | B<multipart_end()>. | |
54310121 | 7535 | |
424ec8fa | 7536 | =over 4 |
54310121 | 7537 | |
424ec8fa | 7538 | =item multipart_init() |
3cb6de81 | 7539 | |
424ec8fa | 7540 | multipart_init(-boundary=>$boundary); |
54310121 | 7541 | |
424ec8fa GS |
7542 | Initialize the multipart system. The -boundary argument specifies |
7543 | what MIME boundary string to use to separate parts of the document. | |
7544 | If not provided, CGI.pm chooses a reasonable boundary for you. | |
54310121 | 7545 | |
424ec8fa | 7546 | =item multipart_start() |
54310121 | 7547 | |
424ec8fa | 7548 | multipart_start(-type=>$type) |
54310121 | 7549 | |
424ec8fa GS |
7550 | Start a new part of the multipart document using the specified MIME |
7551 | type. If not specified, text/html is assumed. | |
54310121 | 7552 | |
424ec8fa | 7553 | =item multipart_end() |
54310121 | 7554 | |
424ec8fa | 7555 | multipart_end() |
54310121 | 7556 | |
424ec8fa | 7557 | End a part. You must remember to call multipart_end() once for each |
ba056755 JH |
7558 | multipart_start(), except at the end of the last part of the multipart |
7559 | document when multipart_final() should be called instead of multipart_end(). | |
7560 | ||
7561 | =item multipart_final() | |
7562 | ||
7563 | multipart_final() | |
7564 | ||
7565 | End all parts. You should call multipart_final() rather than | |
7566 | multipart_end() at the end of the last part of the multipart document. | |
54310121 | 7567 | |
424ec8fa | 7568 | =back |
54310121 | 7569 | |
424ec8fa GS |
7570 | Users interested in server push applications should also have a look |
7571 | at the CGI::Push module. | |
54310121 | 7572 | |
ba056755 JH |
7573 | Only Netscape Navigator supports server push. Internet Explorer |
7574 | browsers do not. | |
7575 | ||
424ec8fa | 7576 | =head1 Avoiding Denial of Service Attacks |
54310121 | 7577 | |
424ec8fa GS |
7578 | A potential problem with CGI.pm is that, by default, it attempts to |
7579 | process form POSTings no matter how large they are. A wily hacker | |
7580 | could attack your site by sending a CGI script a huge POST of many | |
7581 | megabytes. CGI.pm will attempt to read the entire POST into a | |
7582 | variable, growing hugely in size until it runs out of memory. While | |
7583 | the script attempts to allocate the memory the system may slow down | |
7584 | dramatically. This is a form of denial of service attack. | |
54310121 | 7585 | |
424ec8fa GS |
7586 | Another possible attack is for the remote user to force CGI.pm to |
7587 | accept a huge file upload. CGI.pm will accept the upload and store it | |
7588 | in a temporary directory even if your script doesn't expect to receive | |
7589 | an uploaded file. CGI.pm will delete the file automatically when it | |
7590 | terminates, but in the meantime the remote user may have filled up the | |
7591 | server's disk space, causing problems for other programs. | |
54310121 | 7592 | |
424ec8fa GS |
7593 | The best way to avoid denial of service attacks is to limit the amount |
7594 | of memory, CPU time and disk space that CGI scripts can use. Some Web | |
7595 | servers come with built-in facilities to accomplish this. In other | |
7596 | cases, you can use the shell I<limit> or I<ulimit> | |
7597 | commands to put ceilings on CGI resource usage. | |
54310121 | 7598 | |
54310121 | 7599 | |
424ec8fa GS |
7600 | CGI.pm also has some simple built-in protections against denial of |
7601 | service attacks, but you must activate them before you can use them. | |
7602 | These take the form of two global variables in the CGI name space: | |
54310121 | 7603 | |
424ec8fa | 7604 | =over 4 |
54310121 | 7605 | |
424ec8fa | 7606 | =item B<$CGI::POST_MAX> |
54310121 | 7607 | |
424ec8fa GS |
7608 | If set to a non-negative integer, this variable puts a ceiling |
7609 | on the size of POSTings, in bytes. If CGI.pm detects a POST | |
7610 | that is greater than the ceiling, it will immediately exit with an error | |
7611 | message. This value will affect both ordinary POSTs and | |
7612 | multipart POSTs, meaning that it limits the maximum size of file | |
7613 | uploads as well. You should set this to a reasonably high | |
7614 | value, such as 1 megabyte. | |
54310121 | 7615 | |
424ec8fa | 7616 | =item B<$CGI::DISABLE_UPLOADS> |
54310121 | 7617 | |
424ec8fa GS |
7618 | If set to a non-zero value, this will disable file uploads |
7619 | completely. Other fill-out form values will work as usual. | |
54310121 | 7620 | |
7621 | =back | |
7622 | ||
424ec8fa | 7623 | You can use these variables in either of two ways. |
54310121 | 7624 | |
424ec8fa | 7625 | =over 4 |
54310121 | 7626 | |
424ec8fa | 7627 | =item B<1. On a script-by-script basis> |
54310121 | 7628 | |
424ec8fa | 7629 | Set the variable at the top of the script, right after the "use" statement: |
54310121 | 7630 | |
424ec8fa GS |
7631 | use CGI qw/:standard/; |
7632 | use CGI::Carp 'fatalsToBrowser'; | |
7633 | $CGI::POST_MAX=1024 * 100; # max 100K posts | |
7634 | $CGI::DISABLE_UPLOADS = 1; # no uploads | |
54310121 | 7635 | |
424ec8fa | 7636 | =item B<2. Globally for all scripts> |
54310121 | 7637 | |
424ec8fa GS |
7638 | Open up CGI.pm, find the definitions for $POST_MAX and |
7639 | $DISABLE_UPLOADS, and set them to the desired values. You'll | |
7640 | find them towards the top of the file in a subroutine named | |
7641 | initialize_globals(). | |
54310121 | 7642 | |
424ec8fa | 7643 | =back |
54310121 | 7644 | |
3538e1d5 GS |
7645 | An attempt to send a POST larger than $POST_MAX bytes will cause |
7646 | I<param()> to return an empty CGI parameter list. You can test for | |
7647 | this event by checking I<cgi_error()>, either after you create the CGI | |
7648 | object or, if you are using the function-oriented interface, call | |
7649 | <param()> for the first time. If the POST was intercepted, then | |
7650 | cgi_error() will return the message "413 POST too large". | |
7651 | ||
7652 | This error message is actually defined by the HTTP protocol, and is | |
7653 | designed to be returned to the browser as the CGI script's status | |
7654 | code. For example: | |
7655 | ||
7656 | $uploaded_file = param('upload'); | |
7657 | if (!$uploaded_file && cgi_error()) { | |
7658 | print header(-status=>cgi_error()); | |
7659 | exit 0; | |
7660 | } | |
7661 | ||
7662 | However it isn't clear that any browser currently knows what to do | |
7663 | with this status code. It might be better just to create an | |
7664 | HTML page that warns the user of the problem. | |
54310121 | 7665 | |
424ec8fa | 7666 | =head1 COMPATIBILITY WITH CGI-LIB.PL |
54310121 | 7667 | |
3538e1d5 GS |
7668 | To make it easier to port existing programs that use cgi-lib.pl the |
7669 | compatibility routine "ReadParse" is provided. Porting is simple: | |
54310121 | 7670 | |
424ec8fa GS |
7671 | OLD VERSION |
7672 | require "cgi-lib.pl"; | |
7673 | &ReadParse; | |
7674 | print "The value of the antique is $in{antique}.\n"; | |
54310121 | 7675 | |
424ec8fa GS |
7676 | NEW VERSION |
7677 | use CGI; | |
5158e96b | 7678 | CGI::ReadParse(); |
424ec8fa | 7679 | print "The value of the antique is $in{antique}.\n"; |
54310121 | 7680 | |
424ec8fa GS |
7681 | CGI.pm's ReadParse() routine creates a tied variable named %in, |
7682 | which can be accessed to obtain the query variables. Like | |
7683 | ReadParse, you can also provide your own variable. Infrequently | |
7684 | used features of ReadParse, such as the creation of @in and $in | |
7685 | variables, are not supported. | |
54310121 | 7686 | |
424ec8fa GS |
7687 | Once you use ReadParse, you can retrieve the query object itself |
7688 | this way: | |
54310121 | 7689 | |
424ec8fa | 7690 | $q = $in{CGI}; |
29ddc2a4 | 7691 | print textfield(-name=>'wow', |
424ec8fa | 7692 | -value=>'does this really work?'); |
54310121 | 7693 | |
424ec8fa GS |
7694 | This allows you to start using the more interesting features |
7695 | of CGI.pm without rewriting your old scripts from scratch. | |
54310121 | 7696 | |
7697 | =head1 AUTHOR INFORMATION | |
7698 | ||
71f3e297 JH |
7699 | Copyright 1995-1998, Lincoln D. Stein. All rights reserved. |
7700 | ||
7701 | This library is free software; you can redistribute it and/or modify | |
7702 | it under the same terms as Perl itself. | |
54310121 | 7703 | |
71f3e297 JH |
7704 | Address bug reports and comments to: lstein@cshl.org. When sending |
7705 | bug reports, please provide the version of CGI.pm, the version of | |
7706 | Perl, the name and version of your Web server, and the name and | |
7707 | version of the operating system you are using. If the problem is even | |
7708 | remotely browser dependent, please provide information about the | |
7709 | affected browers as well. | |
54310121 | 7710 | |
7711 | =head1 CREDITS | |
7712 | ||
7713 | Thanks very much to: | |
7714 | ||
7715 | =over 4 | |
7716 | ||
7717 | =item Matt Heffron (heffron@falstaff.css.beckman.com) | |
7718 | ||
7719 | =item James Taylor (james.taylor@srs.gov) | |
7720 | ||
7721 | =item Scott Anguish <sanguish@digifix.com> | |
7722 | ||
7723 | =item Mike Jewell (mlj3u@virginia.edu) | |
7724 | ||
7725 | =item Timothy Shimmin (tes@kbs.citri.edu.au) | |
7726 | ||
7727 | =item Joergen Haegg (jh@axis.se) | |
7728 | ||
71f3e297 | 7729 | =item Laurent Delfosse (delfosse@delfosse.com) |
54310121 | 7730 | |
7731 | =item Richard Resnick (applepi1@aol.com) | |
7732 | ||
7733 | =item Craig Bishop (csb@barwonwater.vic.gov.au) | |
7734 | ||
7735 | =item Tony Curtis (tc@vcpc.univie.ac.at) | |
7736 | ||
7737 | =item Tim Bunce (Tim.Bunce@ig.co.uk) | |
7738 | ||
7739 | =item Tom Christiansen (tchrist@convex.com) | |
7740 | ||
7741 | =item Andreas Koenig (k@franz.ww.TU-Berlin.DE) | |
7742 | ||
7743 | =item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au) | |
7744 | ||
7745 | =item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu) | |
7746 | ||
7747 | =item Stephen Dahmen (joyfire@inxpress.net) | |
7748 | ||
7749 | =item Ed Jordan (ed@fidalgo.net) | |
7750 | ||
7751 | =item David Alan Pisoni (david@cnation.com) | |
7752 | ||
424ec8fa GS |
7753 | =item Doug MacEachern (dougm@opengroup.org) |
7754 | ||
7755 | =item Robin Houston (robin@oneworld.org) | |
7756 | ||
54310121 | 7757 | =item ...and many many more... |
7758 | ||
7759 | for suggestions and bug fixes. | |
7760 | ||
7761 | =back | |
7762 | ||
7763 | =head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT | |
7764 | ||
7765 | ||
7766 | #!/usr/local/bin/perl | |
3cb6de81 | 7767 | |
29ddc2a4 | 7768 | use CGI ':standard'; |
3cb6de81 | 7769 | |
29ddc2a4 RGS |
7770 | print header; |
7771 | print start_html("Example CGI.pm Form"); | |
3acbd4f5 | 7772 | print "<h1> Example CGI.pm Form</h1>\n"; |
29ddc2a4 RGS |
7773 | print_prompt(); |
7774 | do_work(); | |
7775 | print_tail(); | |
7776 | print end_html; | |
3cb6de81 | 7777 | |
54310121 | 7778 | sub print_prompt { |
29ddc2a4 | 7779 | print start_form; |
3acbd4f5 | 7780 | print "<em>What's your name?</em><br>"; |
29ddc2a4 RGS |
7781 | print textfield('name'); |
7782 | print checkbox('Not my real name'); | |
3cb6de81 | 7783 | |
3acbd4f5 | 7784 | print "<p><em>Where can you find English Sparrows?</em><br>"; |
29ddc2a4 | 7785 | print checkbox_group( |
54310121 | 7786 | -name=>'Sparrow locations', |
7787 | -values=>[England,France,Spain,Asia,Hoboken], | |
7788 | -linebreak=>'yes', | |
7789 | -defaults=>[England,Asia]); | |
3cb6de81 | 7790 | |
3acbd4f5 | 7791 | print "<p><em>How far can they fly?</em><br>", |
29ddc2a4 | 7792 | radio_group( |
54310121 | 7793 | -name=>'how far', |
7794 | -values=>['10 ft','1 mile','10 miles','real far'], | |
7795 | -default=>'1 mile'); | |
3cb6de81 | 7796 | |
3acbd4f5 | 7797 | print "<p><em>What's your favorite color?</em> "; |
29ddc2a4 | 7798 | print popup_menu(-name=>'Color', |
54310121 | 7799 | -values=>['black','brown','red','yellow'], |
7800 | -default=>'red'); | |
3cb6de81 | 7801 | |
29ddc2a4 | 7802 | print hidden('Reference','Monty Python and the Holy Grail'); |
3cb6de81 | 7803 | |
3acbd4f5 | 7804 | print "<p><em>What have you got there?</em><br>"; |
29ddc2a4 | 7805 | print scrolling_list( |
54310121 | 7806 | -name=>'possessions', |
7807 | -values=>['A Coconut','A Grail','An Icon', | |
7808 | 'A Sword','A Ticket'], | |
7809 | -size=>5, | |
7810 | -multiple=>'true'); | |
3cb6de81 | 7811 | |
3acbd4f5 | 7812 | print "<p><em>Any parting comments?</em><br>"; |
29ddc2a4 | 7813 | print textarea(-name=>'Comments', |
54310121 | 7814 | -rows=>10, |
7815 | -columns=>50); | |
3cb6de81 | 7816 | |
29ddc2a4 RGS |
7817 | print "<p>",reset; |
7818 | print submit('Action','Shout'); | |
7819 | print submit('Action','Scream'); | |
7820 | print endform; | |
3acbd4f5 | 7821 | print "<hr>\n"; |
54310121 | 7822 | } |
3cb6de81 | 7823 | |
54310121 | 7824 | sub do_work { |
54310121 | 7825 | my(@values,$key); |
7826 | ||
3acbd4f5 | 7827 | print "<h2>Here are the current settings in this form</h2>"; |
54310121 | 7828 | |
29ddc2a4 | 7829 | foreach $key (param) { |
3acbd4f5 | 7830 | print "<strong>$key</strong> -> "; |
29ddc2a4 | 7831 | @values = param($key); |
3acbd4f5 | 7832 | print join(", ",@values),"<br>\n"; |
54310121 | 7833 | } |
7834 | } | |
3cb6de81 | 7835 | |
54310121 | 7836 | sub print_tail { |
7837 | print <<END; | |
3acbd4f5 JH |
7838 | <hr> |
7839 | <address>Lincoln D. Stein</address><br> | |
7840 | <a href="/">Home Page</a> | |
54310121 | 7841 | END |
7842 | } | |
7843 | ||
7844 | =head1 BUGS | |
7845 | ||
188ba755 | 7846 | Please report them. |
54310121 | 7847 | |
7848 | =head1 SEE ALSO | |
7849 | ||
b2d0d414 | 7850 | L<CGI::Carp>, L<CGI::Fast>, L<CGI::Pretty> |
54310121 | 7851 | |
7852 | =cut | |
7853 |