Commit | Line | Data |
---|---|---|
54310121 | 1 | package CGI; |
2 | require 5.001; | |
3 | ||
4 | # See the bottom of this file for the POD documentation. Search for the | |
5 | # string '=head'. | |
6 | ||
7 | # You can run this file through either pod2man or pod2html to produce pretty | |
8 | # documentation in manual or html file format (these utilities are part of the | |
9 | # Perl 5 distribution). | |
10 | ||
11 | # Copyright 1995-1997 Lincoln D. Stein. All rights reserved. | |
12 | # It may be used and modified freely, but I do request that this copyright | |
13 | # notice remain attached to the file. You may modify this module as you | |
14 | # wish, but if you redistribute a modified version, please attach a note | |
15 | # listing the modifications you have made. | |
16 | ||
17 | # The most recent version and complete docs are available at: | |
18 | # http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html | |
19 | # ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ | |
20 | ||
21 | # Set this to 1 to enable copious autoloader debugging messages | |
22 | $AUTOLOAD_DEBUG=0; | |
23 | ||
24 | # Set this to 1 to enable NPH scripts | |
25 | # or: | |
26 | # 1) use CGI qw(:nph) | |
27 | # 2) $CGI::nph(1) | |
28 | # 3) print header(-nph=>1) | |
29 | $NPH=0; | |
30 | ||
12c5d27a | 31 | $CGI::revision = '$Id: CGI.pm,v 2.34 1997/4/7 7:23 lstein Exp $'; |
fabdde38 | 32 | $CGI::VERSION='2.3402'; |
54310121 | 33 | |
34 | # OVERRIDE THE OS HERE IF CGI.pm GUESSES WRONG | |
35 | # $OS = 'UNIX'; | |
36 | # $OS = 'MACINTOSH'; | |
37 | # $OS = 'WINDOWS'; | |
38 | # $OS = 'VMS'; | |
39 | # $OS = 'OS2'; | |
40 | ||
41 | # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. | |
42 | # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. | |
43 | # $TempFile::TMPDIRECTORY = '/usr/tmp'; | |
44 | ||
45 | # ------------------ START OF THE LIBRARY ------------ | |
46 | ||
47 | # FIGURE OUT THE OS WE'RE RUNNING UNDER | |
48 | # Some systems support the $^O variable. If not | |
49 | # available then require() the Config library | |
50 | unless ($OS) { | |
51 | unless ($OS = $^O) { | |
52 | require Config; | |
53 | $OS = $Config::Config{'osname'}; | |
54 | } | |
55 | } | |
56 | if ($OS=~/Win/i) { | |
57 | $OS = 'WINDOWS'; | |
58 | } elsif ($OS=~/vms/i) { | |
59 | $OS = 'VMS'; | |
60 | } elsif ($OS=~/Mac/i) { | |
61 | $OS = 'MACINTOSH'; | |
62 | } elsif ($OS=~/os2/i) { | |
63 | $OS = 'OS2'; | |
64 | } else { | |
65 | $OS = 'UNIX'; | |
66 | } | |
67 | ||
68 | # Some OS logic. Binary mode enabled on DOS, NT and VMS | |
69 | $needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/; | |
70 | ||
71 | # This is the default class for the CGI object to use when all else fails. | |
72 | $DefaultClass = 'CGI' unless defined $CGI::DefaultClass; | |
73 | # This is where to look for autoloaded routines. | |
74 | $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass; | |
75 | ||
76 | # The path separator is a slash, backslash or semicolon, depending | |
77 | # on the paltform. | |
78 | $SL = { | |
79 | UNIX=>'/', | |
80 | OS2=>'\\', | |
81 | WINDOWS=>'\\', | |
82 | MACINTOSH=>':', | |
83 | VMS=>'\\' | |
84 | }->{$OS}; | |
85 | ||
86 | # Turn on NPH scripts by default when running under IIS server! | |
87 | $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; | |
88 | ||
89 | # Turn on special checking for Doug MacEachern's modperl | |
12c5d27a | 90 | if (defined($ENV{'GATEWAY_INTERFACE'}) && ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)) { |
54310121 | 91 | $NPH++; |
92 | $| = 1; | |
93 | $SEQNO = 1; | |
94 | } | |
95 | ||
96 | # This is really "\r\n", but the meaning of \n is different | |
97 | # in MacPerl, so we resort to octal here. | |
98 | $CRLF = "\015\012"; | |
99 | ||
100 | if ($needs_binmode) { | |
101 | $CGI::DefaultClass->binmode(main::STDOUT); | |
102 | $CGI::DefaultClass->binmode(main::STDIN); | |
103 | $CGI::DefaultClass->binmode(main::STDERR); | |
104 | } | |
105 | ||
106 | # Cute feature, but it broke when the overload mechanism changed... | |
107 | # %OVERLOAD = ('""'=>'as_string'); | |
108 | ||
109 | %EXPORT_TAGS = ( | |
110 | ':html2'=>[h1..h6,qw/p br hr ol ul li dl dt dd menu code var strong em | |
111 | tt i b blockquote pre img a address cite samp dfn html head | |
112 | base body link nextid title meta kbd start_html end_html | |
113 | input Select option/], | |
114 | ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont/], | |
115 | ':netscape'=>[qw/blink frameset frame script font fontsize center/], | |
116 | ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group | |
117 | submit reset defaults radio_group popup_menu button autoEscape | |
118 | scrolling_list image_button start_form end_form startform endform | |
119 | start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], | |
120 | ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump | |
121 | raw_cookie request_method query_string accept user_agent remote_host | |
122 | remote_addr referer server_name server_software server_port server_protocol | |
123 | virtual_host remote_ident auth_type http | |
124 | remote_user user_name header redirect import_names put/], | |
125 | ':ssl' => [qw/https/], | |
126 | ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/], | |
127 | ':html' => [qw/:html2 :html3 :netscape/], | |
128 | ':standard' => [qw/:html2 :form :cgi/], | |
129 | ':all' => [qw/:html2 :html3 :netscape :form :cgi/] | |
130 | ); | |
131 | ||
132 | # to import symbols into caller | |
133 | sub import { | |
134 | my $self = shift; | |
135 | my ($callpack, $callfile, $callline) = caller; | |
136 | foreach (@_) { | |
137 | $NPH++, next if $_ eq ':nph'; | |
138 | foreach (&expand_tags($_)) { | |
139 | tr/a-zA-Z0-9_//cd; # don't allow weird function names | |
140 | $EXPORT{$_}++; | |
141 | } | |
142 | } | |
143 | # To allow overriding, search through the packages | |
144 | # Till we find one in which the correct subroutine is defined. | |
145 | my @packages = ($self,@{"$self\:\:ISA"}); | |
146 | foreach $sym (keys %EXPORT) { | |
147 | my $pck; | |
148 | my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass; | |
149 | foreach $pck (@packages) { | |
150 | if (defined(&{"$pck\:\:$sym"})) { | |
151 | $def = $pck; | |
152 | last; | |
153 | } | |
154 | } | |
155 | *{"${callpack}::$sym"} = \&{"$def\:\:$sym"}; | |
156 | } | |
157 | } | |
158 | ||
159 | sub expand_tags { | |
160 | my($tag) = @_; | |
161 | my(@r); | |
162 | return ($tag) unless $EXPORT_TAGS{$tag}; | |
163 | foreach (@{$EXPORT_TAGS{$tag}}) { | |
164 | push(@r,&expand_tags($_)); | |
165 | } | |
166 | return @r; | |
167 | } | |
168 | ||
169 | #### Method: new | |
170 | # The new routine. This will check the current environment | |
171 | # for an existing query string, and initialize itself, if so. | |
172 | #### | |
173 | sub new { | |
174 | my($class,$initializer) = @_; | |
175 | my $self = {}; | |
176 | bless $self,ref $class || $class || $DefaultClass; | |
fabdde38 | 177 | $CGI::DefaultClass->_reset_globals() if $MOD_PERL; |
54310121 | 178 | $initializer = to_filehandle($initializer) if $initializer; |
179 | $self->init($initializer); | |
180 | return $self; | |
181 | } | |
182 | ||
183 | # We provide a DESTROY method so that the autoloader | |
184 | # doesn't bother trying to find it. | |
185 | sub DESTROY { } | |
186 | ||
187 | #### Method: param | |
188 | # Returns the value(s)of a named parameter. | |
189 | # If invoked in a list context, returns the | |
190 | # entire list. Otherwise returns the first | |
191 | # member of the list. | |
192 | # If name is not provided, return a list of all | |
193 | # the known parameters names available. | |
194 | # If more than one argument is provided, the | |
195 | # second and subsequent arguments are used to | |
196 | # set the value of the parameter. | |
197 | #### | |
198 | sub param { | |
199 | my($self,@p) = self_or_default(@_); | |
200 | return $self->all_parameters unless @p; | |
201 | my($name,$value,@other); | |
202 | ||
203 | # For compatibility between old calling style and use_named_parameters() style, | |
204 | # we have to special case for a single parameter present. | |
205 | if (@p > 1) { | |
206 | ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p); | |
207 | my(@values); | |
208 | ||
209 | if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) { | |
210 | @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : (); | |
211 | } else { | |
212 | foreach ($value,@other) { | |
213 | push(@values,$_) if defined($_); | |
214 | } | |
215 | } | |
216 | # If values is provided, then we set it. | |
217 | if (@values) { | |
218 | $self->add_parameter($name); | |
219 | $self->{$name}=[@values]; | |
220 | } | |
221 | } else { | |
222 | $name = $p[0]; | |
223 | } | |
224 | ||
225 | return () unless defined($name) && $self->{$name}; | |
226 | return wantarray ? @{$self->{$name}} : $self->{$name}->[0]; | |
227 | } | |
228 | ||
229 | #### Method: delete | |
230 | # Deletes the named parameter entirely. | |
231 | #### | |
232 | sub delete { | |
233 | my($self,$name) = self_or_default(@_); | |
234 | delete $self->{$name}; | |
235 | delete $self->{'.fieldnames'}->{$name}; | |
236 | @{$self->{'.parameters'}}=grep($_ ne $name,$self->param()); | |
237 | return wantarray ? () : undef; | |
238 | } | |
239 | ||
240 | sub self_or_default { | |
241 | return @_ if defined($_[0]) && !ref($_[0]) && ($_[0] eq 'CGI'); | |
242 | unless (defined($_[0]) && | |
243 | ref($_[0]) && | |
244 | (ref($_[0]) eq 'CGI' || | |
245 | eval "\$_[0]->isaCGI()")) { # optimize for the common case | |
246 | $CGI::DefaultClass->_reset_globals() | |
247 | if defined($Q) && $MOD_PERL && $CGI::DefaultClass->_new_request(); | |
248 | $Q = $CGI::DefaultClass->new unless defined($Q); | |
249 | unshift(@_,$Q); | |
250 | } | |
251 | return @_; | |
252 | } | |
253 | ||
254 | sub _new_request { | |
255 | return undef unless (defined(Apache->seqno()) or eval { require Apache }); | |
256 | if (Apache->seqno() != $SEQNO) { | |
257 | $SEQNO = Apache->seqno(); | |
258 | return 1; | |
259 | } else { | |
260 | return undef; | |
261 | } | |
262 | } | |
263 | ||
264 | sub _reset_globals { | |
265 | undef $Q; | |
266 | undef @QUERY_PARAM; | |
267 | } | |
268 | ||
269 | sub self_or_CGI { | |
270 | local $^W=0; # prevent a warning | |
271 | if (defined($_[0]) && | |
272 | (substr(ref($_[0]),0,3) eq 'CGI' | |
273 | || eval "\$_[0]->isaCGI()")) { | |
274 | return @_; | |
275 | } else { | |
276 | return ($DefaultClass,@_); | |
277 | } | |
278 | } | |
279 | ||
280 | sub isaCGI { | |
281 | return 1; | |
282 | } | |
283 | ||
284 | #### Method: import_names | |
285 | # Import all parameters into the given namespace. | |
286 | # Assumes namespace 'Q' if not specified | |
287 | #### | |
288 | sub import_names { | |
289 | my($self,$namespace) = self_or_default(@_); | |
290 | $namespace = 'Q' unless defined($namespace); | |
291 | die "Can't import names into 'main'\n" | |
292 | if $namespace eq 'main'; | |
293 | my($param,@value,$var); | |
294 | foreach $param ($self->param) { | |
295 | # protect against silly names | |
296 | ($var = $param)=~tr/a-zA-Z0-9_/_/c; | |
297 | $var = "${namespace}::$var"; | |
298 | @value = $self->param($param); | |
299 | @{$var} = @value; | |
300 | ${$var} = $value[0]; | |
301 | } | |
302 | } | |
303 | ||
304 | #### Method: use_named_parameters | |
305 | # Force CGI.pm to use named parameter-style method calls | |
306 | # rather than positional parameters. The same effect | |
307 | # will happen automatically if the first parameter | |
308 | # begins with a -. | |
309 | sub use_named_parameters { | |
310 | my($self,$use_named) = self_or_default(@_); | |
311 | return $self->{'.named'} unless defined ($use_named); | |
312 | ||
313 | # stupidity to avoid annoying warnings | |
314 | return $self->{'.named'}=$use_named; | |
315 | } | |
316 | ||
317 | ######################################## | |
318 | # THESE METHODS ARE MORE OR LESS PRIVATE | |
319 | # GO TO THE __DATA__ SECTION TO SEE MORE | |
320 | # PUBLIC METHODS | |
321 | ######################################## | |
322 | ||
323 | # Initialize the query object from the environment. | |
324 | # If a parameter list is found, this object will be set | |
325 | # to an associative array in which parameter names are keys | |
326 | # and the values are stored as lists | |
327 | # If a keyword list is found, this method creates a bogus | |
328 | # parameter list with the single parameter 'keywords'. | |
329 | ||
330 | sub init { | |
331 | my($self,$initializer) = @_; | |
332 | my($query_string,@lines); | |
333 | my($meth) = ''; | |
334 | ||
335 | # if we get called more than once, we want to initialize | |
336 | # ourselves from the original query (which may be gone | |
337 | # if it was read from STDIN originally.) | |
338 | if (defined(@QUERY_PARAM) && !defined($initializer)) { | |
339 | ||
340 | foreach (@QUERY_PARAM) { | |
341 | $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_}); | |
342 | } | |
343 | return; | |
344 | } | |
345 | ||
346 | $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'}); | |
347 | ||
348 | # If initializer is defined, then read parameters | |
349 | # from it. | |
350 | METHOD: { | |
351 | if (defined($initializer)) { | |
352 | ||
353 | if (ref($initializer) && ref($initializer) eq 'HASH') { | |
354 | foreach (keys %$initializer) { | |
355 | $self->param('-name'=>$_,'-value'=>$initializer->{$_}); | |
356 | } | |
357 | last METHOD; | |
358 | } | |
359 | ||
360 | $initializer = $$initializer if ref($initializer); | |
361 | if (defined(fileno($initializer))) { | |
362 | while (<$initializer>) { | |
363 | chomp; | |
364 | last if /^=/; | |
365 | push(@lines,$_); | |
366 | } | |
367 | # massage back into standard format | |
368 | if ("@lines" =~ /=/) { | |
369 | $query_string=join("&",@lines); | |
370 | } else { | |
371 | $query_string=join("+",@lines); | |
372 | } | |
373 | last METHOD; | |
374 | } | |
375 | $query_string = $initializer; | |
376 | last METHOD; | |
377 | } | |
378 | # If method is GET or HEAD, fetch the query from | |
379 | # the environment. | |
380 | if ($meth=~/^(GET|HEAD)$/) { | |
381 | $query_string = $ENV{'QUERY_STRING'}; | |
382 | last METHOD; | |
383 | } | |
384 | ||
385 | # If the method is POST, fetch the query from standard | |
386 | # input. | |
387 | if ($meth eq 'POST') { | |
388 | ||
389 | if (defined($ENV{'CONTENT_TYPE'}) | |
390 | && | |
391 | $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|) { | |
392 | my($boundary) = $ENV{'CONTENT_TYPE'}=~/boundary=(\S+)/; | |
393 | $self->read_multipart($boundary,$ENV{'CONTENT_LENGTH'}); | |
394 | ||
395 | } else { | |
396 | ||
397 | $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0) | |
398 | if $ENV{'CONTENT_LENGTH'} > 0; | |
399 | ||
400 | } | |
401 | # Some people want to have their cake and eat it too! | |
402 | # Uncomment this line to have the contents of the query string | |
403 | # APPENDED to the POST data. | |
404 | # $query_string .= ($query_string ? '&' : '') . $ENV{'QUERY_STRING'} if $ENV{'QUERY_STRING'}; | |
405 | last METHOD; | |
406 | } | |
407 | ||
408 | # If neither is set, assume we're being debugged offline. | |
409 | # Check the command line and then the standard input for data. | |
410 | # We use the shellwords package in order to behave the way that | |
411 | # UN*X programmers expect. | |
412 | $query_string = &read_from_cmdline; | |
413 | } | |
414 | ||
415 | # We now have the query string in hand. We do slightly | |
416 | # different things for keyword lists and parameter lists. | |
417 | if ($query_string) { | |
418 | if ($query_string =~ /=/) { | |
419 | $self->parse_params($query_string); | |
420 | } else { | |
421 | $self->add_parameter('keywords'); | |
422 | $self->{'keywords'} = [$self->parse_keywordlist($query_string)]; | |
423 | } | |
424 | } | |
425 | ||
426 | # Special case. Erase everything if there is a field named | |
427 | # .defaults. | |
428 | if ($self->param('.defaults')) { | |
429 | undef %{$self}; | |
430 | } | |
431 | ||
432 | # Associative array containing our defined fieldnames | |
433 | $self->{'.fieldnames'} = {}; | |
434 | foreach ($self->param('.cgifields')) { | |
435 | $self->{'.fieldnames'}->{$_}++; | |
436 | } | |
437 | ||
438 | # Clear out our default submission button flag if present | |
439 | $self->delete('.submit'); | |
440 | $self->delete('.cgifields'); | |
441 | $self->save_request unless $initializer; | |
442 | ||
443 | } | |
444 | ||
445 | ||
446 | # FUNCTIONS TO OVERRIDE: | |
447 | ||
448 | # Turn a string into a filehandle | |
449 | sub to_filehandle { | |
450 | my $string = shift; | |
451 | if ($string && !ref($string)) { | |
452 | my($package) = caller(1); | |
453 | my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string"; | |
454 | return $tmp if defined(fileno($tmp)); | |
455 | } | |
456 | return $string; | |
457 | } | |
458 | ||
459 | # Create a new multipart buffer | |
460 | sub new_MultipartBuffer { | |
461 | my($self,$boundary,$length,$filehandle) = @_; | |
462 | return MultipartBuffer->new($self,$boundary,$length,$filehandle); | |
463 | } | |
464 | ||
465 | # Read data from a file handle | |
466 | sub read_from_client { | |
467 | my($self, $fh, $buff, $len, $offset) = @_; | |
468 | local $^W=0; # prevent a warning | |
469 | return read($fh, $$buff, $len, $offset); | |
470 | } | |
471 | ||
472 | # put a filehandle into binary mode (DOS) | |
473 | sub binmode { | |
474 | binmode($_[1]); | |
475 | } | |
476 | ||
477 | # send output to the browser | |
478 | sub put { | |
479 | my($self,@p) = self_or_default(@_); | |
480 | $self->print(@p); | |
481 | } | |
482 | ||
483 | # print to standard output (for overriding in mod_perl) | |
484 | sub print { | |
485 | shift; | |
486 | CORE::print(@_); | |
487 | } | |
488 | ||
489 | # unescape URL-encoded data | |
490 | sub unescape { | |
491 | my($todecode) = @_; | |
492 | $todecode =~ tr/+/ /; # pluses become spaces | |
493 | $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; | |
494 | return $todecode; | |
495 | } | |
496 | ||
497 | # URL-encode data | |
498 | sub escape { | |
499 | my($toencode) = @_; | |
500 | $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg; | |
501 | return $toencode; | |
502 | } | |
503 | ||
504 | sub save_request { | |
505 | my($self) = @_; | |
506 | # We're going to play with the package globals now so that if we get called | |
507 | # again, we initialize ourselves in exactly the same way. This allows | |
508 | # us to have several of these objects. | |
509 | @QUERY_PARAM = $self->param; # save list of parameters | |
510 | foreach (@QUERY_PARAM) { | |
511 | $QUERY_PARAM{$_}=$self->{$_}; | |
512 | } | |
513 | } | |
514 | ||
515 | sub parse_keywordlist { | |
516 | my($self,$tosplit) = @_; | |
517 | $tosplit = &unescape($tosplit); # unescape the keywords | |
518 | $tosplit=~tr/+/ /; # pluses to spaces | |
519 | my(@keywords) = split(/\s+/,$tosplit); | |
520 | return @keywords; | |
521 | } | |
522 | ||
523 | sub parse_params { | |
524 | my($self,$tosplit) = @_; | |
525 | my(@pairs) = split('&',$tosplit); | |
526 | my($param,$value); | |
527 | foreach (@pairs) { | |
528 | ($param,$value) = split('='); | |
529 | $param = &unescape($param); | |
530 | $value = &unescape($value); | |
531 | $self->add_parameter($param); | |
532 | push (@{$self->{$param}},$value); | |
533 | } | |
534 | } | |
535 | ||
536 | sub add_parameter { | |
537 | my($self,$param)=@_; | |
538 | push (@{$self->{'.parameters'}},$param) | |
539 | unless defined($self->{$param}); | |
540 | } | |
541 | ||
542 | sub all_parameters { | |
543 | my $self = shift; | |
544 | return () unless defined($self) && $self->{'.parameters'}; | |
545 | return () unless @{$self->{'.parameters'}}; | |
546 | return @{$self->{'.parameters'}}; | |
547 | } | |
548 | ||
549 | ||
550 | ||
551 | #### Method as_string | |
552 | # | |
553 | # synonym for "dump" | |
554 | #### | |
555 | sub as_string { | |
556 | &dump(@_); | |
557 | } | |
558 | ||
559 | sub AUTOLOAD { | |
560 | print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG; | |
561 | my($func) = $AUTOLOAD; | |
562 | my($pack,$func_name) = $func=~/(.+)::([^:]+)$/; | |
563 | $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass | |
564 | unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"}); | |
565 | ||
566 | my($sub) = \%{"$pack\:\:SUBS"}; | |
567 | unless (%$sub) { | |
568 | my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"}; | |
569 | eval "package $pack; $$auto"; | |
570 | die $@ if $@; | |
571 | } | |
572 | my($code) = $sub->{$func_name}; | |
573 | ||
574 | $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY'); | |
575 | if (!$code) { | |
576 | if ($EXPORT{':any'} || | |
577 | $EXPORT{$func_name} || | |
578 | (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html'))) | |
579 | && $EXPORT_OK{$func_name}) { | |
580 | $code = $sub->{'HTML_FUNC'}; | |
581 | $code=~s/func_name/$func_name/mg; | |
582 | } | |
583 | } | |
584 | die "Undefined subroutine $AUTOLOAD\n" unless $code; | |
585 | eval "package $pack; $code"; | |
586 | if ($@) { | |
587 | $@ =~ s/ at .*\n//; | |
588 | die $@; | |
589 | } | |
590 | goto &{"$pack\:\:$func_name"}; | |
591 | } | |
592 | ||
593 | # PRIVATE SUBROUTINE | |
594 | # Smart rearrangement of parameters to allow named parameter | |
595 | # calling. We do the rearangement if: | |
596 | # 1. The first parameter begins with a - | |
597 | # 2. The use_named_parameters() method returns true | |
598 | sub rearrange { | |
599 | my($self,$order,@param) = @_; | |
600 | return () unless @param; | |
601 | ||
602 | return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-') | |
603 | || $self->use_named_parameters; | |
604 | ||
605 | my $i; | |
606 | for ($i=0;$i<@param;$i+=2) { | |
607 | $param[$i]=~s/^\-//; # get rid of initial - if present | |
608 | $param[$i]=~tr/a-z/A-Z/; # parameters are upper case | |
609 | } | |
610 | ||
611 | my(%param) = @param; # convert into associative array | |
612 | my(@return_array); | |
613 | ||
614 | my($key)=''; | |
615 | foreach $key (@$order) { | |
616 | my($value); | |
617 | # this is an awful hack to fix spurious warnings when the | |
618 | # -w switch is set. | |
619 | if (ref($key) && ref($key) eq 'ARRAY') { | |
620 | foreach (@$key) { | |
621 | last if defined($value); | |
622 | $value = $param{$_}; | |
623 | delete $param{$_}; | |
624 | } | |
625 | } else { | |
626 | $value = $param{$key}; | |
627 | delete $param{$key}; | |
628 | } | |
629 | push(@return_array,$value); | |
630 | } | |
631 | push (@return_array,$self->make_attributes(\%param)) if %param; | |
632 | return (@return_array); | |
633 | } | |
634 | ||
635 | ############################################################################### | |
636 | ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### | |
637 | ############################################################################### | |
638 | $AUTOLOADED_ROUTINES = ''; # get rid of -w warning | |
639 | $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; | |
640 | ||
641 | %SUBS = ( | |
642 | ||
643 | 'URL_ENCODED'=> <<'END_OF_FUNC', | |
644 | sub URL_ENCODED { 'application/x-www-form-urlencoded'; } | |
645 | END_OF_FUNC | |
646 | ||
647 | 'MULTIPART' => <<'END_OF_FUNC', | |
648 | sub MULTIPART { 'multipart/form-data'; } | |
649 | END_OF_FUNC | |
650 | ||
651 | 'HTML_FUNC' => <<'END_OF_FUNC', | |
652 | sub func_name { | |
653 | ||
654 | # handle various cases in which we're called | |
655 | # most of this bizarre stuff is to avoid -w errors | |
656 | shift if $_[0] && | |
657 | (!ref($_[0]) && $_[0] eq $CGI::DefaultClass) || | |
658 | (ref($_[0]) && | |
659 | (substr(ref($_[0]),0,3) eq 'CGI' || | |
660 | eval "\$_[0]->isaCGI()")); | |
661 | ||
662 | my($attr) = ''; | |
663 | if (ref($_[0]) && ref($_[0]) eq 'HASH') { | |
664 | my(@attr) = CGI::make_attributes('',shift); | |
665 | $attr = " @attr" if @attr; | |
666 | } | |
667 | my($tag,$untag) = ("\U<func_name\E$attr>","\U</func_name>\E"); | |
668 | return $tag unless @_; | |
669 | if (ref($_[0]) eq 'ARRAY') { | |
670 | my(@r); | |
671 | foreach (@{$_[0]}) { | |
672 | push(@r,"$tag$_$untag"); | |
673 | } | |
674 | return "@r"; | |
675 | } else { | |
676 | return "$tag@_$untag"; | |
677 | } | |
678 | } | |
679 | END_OF_FUNC | |
680 | ||
681 | #### Method: keywords | |
682 | # Keywords acts a bit differently. Calling it in a list context | |
683 | # returns the list of keywords. | |
684 | # Calling it in a scalar context gives you the size of the list. | |
685 | #### | |
686 | 'keywords' => <<'END_OF_FUNC', | |
687 | sub keywords { | |
688 | my($self,@values) = self_or_default(@_); | |
689 | # If values is provided, then we set it. | |
690 | $self->{'keywords'}=[@values] if @values; | |
691 | my(@result) = @{$self->{'keywords'}}; | |
692 | @result; | |
693 | } | |
694 | END_OF_FUNC | |
695 | ||
696 | # These are some tie() interfaces for compatibility | |
697 | # with Steve Brenner's cgi-lib.pl routines | |
698 | 'ReadParse' => <<'END_OF_FUNC', | |
699 | sub ReadParse { | |
700 | local(*in); | |
701 | if (@_) { | |
702 | *in = $_[0]; | |
703 | } else { | |
704 | my $pkg = caller(); | |
705 | *in=*{"${pkg}::in"}; | |
706 | } | |
707 | tie(%in,CGI); | |
708 | } | |
709 | END_OF_FUNC | |
710 | ||
711 | 'PrintHeader' => <<'END_OF_FUNC', | |
712 | sub PrintHeader { | |
713 | my($self) = self_or_default(@_); | |
714 | return $self->header(); | |
715 | } | |
716 | END_OF_FUNC | |
717 | ||
718 | 'HtmlTop' => <<'END_OF_FUNC', | |
719 | sub HtmlTop { | |
720 | my($self,@p) = self_or_default(@_); | |
721 | return $self->start_html(@p); | |
722 | } | |
723 | END_OF_FUNC | |
724 | ||
725 | 'HtmlBot' => <<'END_OF_FUNC', | |
726 | sub HtmlBot { | |
727 | my($self,@p) = self_or_default(@_); | |
728 | return $self->end_html(@p); | |
729 | } | |
730 | END_OF_FUNC | |
731 | ||
732 | 'SplitParam' => <<'END_OF_FUNC', | |
733 | sub SplitParam { | |
734 | my ($param) = @_; | |
735 | my (@params) = split ("\0", $param); | |
736 | return (wantarray ? @params : $params[0]); | |
737 | } | |
738 | END_OF_FUNC | |
739 | ||
740 | 'MethGet' => <<'END_OF_FUNC', | |
741 | sub MethGet { | |
742 | return request_method() eq 'GET'; | |
743 | } | |
744 | END_OF_FUNC | |
745 | ||
746 | 'MethPost' => <<'END_OF_FUNC', | |
747 | sub MethPost { | |
748 | return request_method() eq 'POST'; | |
749 | } | |
750 | END_OF_FUNC | |
751 | ||
752 | 'TIEHASH' => <<'END_OF_FUNC', | |
753 | sub TIEHASH { | |
754 | return new CGI; | |
755 | } | |
756 | END_OF_FUNC | |
757 | ||
758 | 'STORE' => <<'END_OF_FUNC', | |
759 | sub STORE { | |
760 | $_[0]->param($_[1],split("\0",$_[2])); | |
761 | } | |
762 | END_OF_FUNC | |
763 | ||
764 | 'FETCH' => <<'END_OF_FUNC', | |
765 | sub FETCH { | |
766 | return $_[0] if $_[1] eq 'CGI'; | |
767 | return undef unless defined $_[0]->param($_[1]); | |
768 | return join("\0",$_[0]->param($_[1])); | |
769 | } | |
770 | END_OF_FUNC | |
771 | ||
772 | 'FIRSTKEY' => <<'END_OF_FUNC', | |
773 | sub FIRSTKEY { | |
774 | $_[0]->{'.iterator'}=0; | |
775 | $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; | |
776 | } | |
777 | END_OF_FUNC | |
778 | ||
779 | 'NEXTKEY' => <<'END_OF_FUNC', | |
780 | sub NEXTKEY { | |
781 | $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; | |
782 | } | |
783 | END_OF_FUNC | |
784 | ||
785 | 'EXISTS' => <<'END_OF_FUNC', | |
786 | sub EXISTS { | |
787 | exists $_[0]->{$_[1]}; | |
788 | } | |
789 | END_OF_FUNC | |
790 | ||
791 | 'DELETE' => <<'END_OF_FUNC', | |
792 | sub DELETE { | |
793 | $_[0]->delete($_[1]); | |
794 | } | |
795 | END_OF_FUNC | |
796 | ||
797 | 'CLEAR' => <<'END_OF_FUNC', | |
798 | sub CLEAR { | |
799 | %{$_[0]}=(); | |
800 | } | |
801 | #### | |
802 | END_OF_FUNC | |
803 | ||
804 | #### | |
805 | # Append a new value to an existing query | |
806 | #### | |
807 | 'append' => <<'EOF', | |
808 | sub append { | |
809 | my($self,@p) = @_; | |
810 | my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p); | |
811 | my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : (); | |
812 | if (@values) { | |
813 | $self->add_parameter($name); | |
814 | push(@{$self->{$name}},@values); | |
815 | } | |
816 | return $self->param($name); | |
817 | } | |
818 | EOF | |
819 | ||
820 | #### Method: delete_all | |
821 | # Delete all parameters | |
822 | #### | |
823 | 'delete_all' => <<'EOF', | |
824 | sub delete_all { | |
825 | my($self) = self_or_default(@_); | |
826 | undef %{$self}; | |
827 | } | |
828 | EOF | |
829 | ||
830 | #### Method: autoescape | |
831 | # If you want to turn off the autoescaping features, | |
832 | # call this method with undef as the argument | |
833 | 'autoEscape' => <<'END_OF_FUNC', | |
834 | sub autoEscape { | |
835 | my($self,$escape) = self_or_default(@_); | |
836 | $self->{'dontescape'}=!$escape; | |
837 | } | |
838 | END_OF_FUNC | |
839 | ||
840 | ||
841 | #### Method: version | |
842 | # Return the current version | |
843 | #### | |
844 | 'version' => <<'END_OF_FUNC', | |
845 | sub version { | |
846 | return $VERSION; | |
847 | } | |
848 | END_OF_FUNC | |
849 | ||
850 | 'make_attributes' => <<'END_OF_FUNC', | |
851 | sub make_attributes { | |
852 | my($self,$attr) = @_; | |
853 | return () unless $attr && ref($attr) && ref($attr) eq 'HASH'; | |
854 | my(@att); | |
855 | foreach (keys %{$attr}) { | |
856 | my($key) = $_; | |
857 | $key=~s/^\-//; # get rid of initial - if present | |
858 | $key=~tr/a-z/A-Z/; # parameters are upper case | |
859 | push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/); | |
860 | } | |
861 | return @att; | |
862 | } | |
863 | END_OF_FUNC | |
864 | ||
865 | #### Method: dump | |
866 | # Returns a string in which all the known parameter/value | |
867 | # pairs are represented as nested lists, mainly for the purposes | |
868 | # of debugging. | |
869 | #### | |
870 | 'dump' => <<'END_OF_FUNC', | |
871 | sub dump { | |
872 | my($self) = self_or_default(@_); | |
873 | my($param,$value,@result); | |
874 | return '<UL></UL>' unless $self->param; | |
875 | push(@result,"<UL>"); | |
876 | foreach $param ($self->param) { | |
877 | my($name)=$self->escapeHTML($param); | |
878 | push(@result,"<LI><STRONG>$param</STRONG>"); | |
879 | push(@result,"<UL>"); | |
880 | foreach $value ($self->param($param)) { | |
881 | $value = $self->escapeHTML($value); | |
882 | push(@result,"<LI>$value"); | |
883 | } | |
884 | push(@result,"</UL>"); | |
885 | } | |
886 | push(@result,"</UL>\n"); | |
887 | return join("\n",@result); | |
888 | } | |
889 | END_OF_FUNC | |
890 | ||
891 | ||
892 | #### Method: save | |
893 | # Write values out to a filehandle in such a way that they can | |
894 | # be reinitialized by the filehandle form of the new() method | |
895 | #### | |
896 | 'save' => <<'END_OF_FUNC', | |
897 | sub save { | |
898 | my($self,$filehandle) = self_or_default(@_); | |
899 | my($param); | |
900 | my($package) = caller; | |
901 | # Check that this still works! | |
902 | # $filehandle = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; | |
903 | $filehandle = to_filehandle($filehandle); | |
904 | foreach $param ($self->param) { | |
905 | my($escaped_param) = &escape($param); | |
906 | my($value); | |
907 | foreach $value ($self->param($param)) { | |
908 | print $filehandle "$escaped_param=",escape($value),"\n"; | |
909 | } | |
910 | } | |
911 | print $filehandle "=\n"; # end of record | |
912 | } | |
913 | END_OF_FUNC | |
914 | ||
915 | ||
916 | #### Method: header | |
917 | # Return a Content-Type: style header | |
918 | # | |
919 | #### | |
920 | 'header' => <<'END_OF_FUNC', | |
921 | sub header { | |
922 | my($self,@p) = self_or_default(@_); | |
923 | my(@header); | |
924 | ||
925 | my($type,$status,$cookie,$target,$expires,$nph,@other) = | |
926 | $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); | |
927 | ||
928 | # rearrange() was designed for the HTML portion, so we | |
929 | # need to fix it up a little. | |
930 | foreach (@other) { | |
931 | next unless my($header,$value) = /([^\s=]+)=(.+)/; | |
932 | substr($header,1,1000)=~tr/A-Z/a-z/; | |
933 | ($value)=$value=~/^"(.*)"$/; | |
934 | $_ = "$header: $value"; | |
935 | } | |
936 | ||
937 | $type = $type || 'text/html'; | |
938 | ||
939 | push(@header,'HTTP/1.0 ' . ($status || '200 OK')) if $nph || $NPH; | |
940 | push(@header,"Status: $status") if $status; | |
941 | push(@header,"Window-target: $target") if $target; | |
942 | # push all the cookies -- there may be several | |
943 | if ($cookie) { | |
944 | my(@cookie) = ref($cookie) ? @{$cookie} : $cookie; | |
945 | foreach (@cookie) { | |
946 | push(@header,"Set-cookie: $_"); | |
947 | } | |
948 | } | |
949 | # if the user indicates an expiration time, then we need | |
950 | # both an Expires and a Date header (so that the browser is | |
951 | # uses OUR clock) | |
952 | push(@header,"Expires: " . &expires($expires)) if $expires; | |
953 | push(@header,"Date: " . &expires(0)) if $expires; | |
954 | push(@header,"Pragma: no-cache") if $self->cache(); | |
955 | push(@header,@other); | |
956 | push(@header,"Content-type: $type"); | |
957 | ||
958 | my $header = join($CRLF,@header); | |
959 | return $header . "${CRLF}${CRLF}"; | |
960 | } | |
961 | END_OF_FUNC | |
962 | ||
963 | ||
964 | #### Method: cache | |
965 | # Control whether header() will produce the no-cache | |
966 | # Pragma directive. | |
967 | #### | |
968 | 'cache' => <<'END_OF_FUNC', | |
969 | sub cache { | |
970 | my($self,$new_value) = self_or_default(@_); | |
971 | $new_value = '' unless $new_value; | |
972 | if ($new_value ne '') { | |
973 | $self->{'cache'} = $new_value; | |
974 | } | |
975 | return $self->{'cache'}; | |
976 | } | |
977 | END_OF_FUNC | |
978 | ||
979 | ||
980 | #### Method: redirect | |
981 | # Return a Location: style header | |
982 | # | |
983 | #### | |
984 | 'redirect' => <<'END_OF_FUNC', | |
985 | sub redirect { | |
986 | my($self,@p) = self_or_default(@_); | |
12c5d27a | 987 | my($url,$target,$cookie,$nph,@other) = $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p); |
54310121 | 988 | $url = $url || $self->self_url; |
989 | my(@o); | |
990 | foreach (@other) { push(@o,split("=")); } | |
12c5d27a | 991 | if($MOD_PERL or exists $self->{'.req'}) { |
38b79821 CS |
992 | my $r = $self->{'.req'} || Apache->request; |
993 | $r->header_out(Location => $url); | |
994 | $r->err_header_out(Location => $url); | |
995 | $r->status(302); | |
996 | return; | |
997 | } | |
54310121 | 998 | push(@o, |
999 | '-Status'=>'302 Found', | |
1000 | '-Location'=>$url, | |
1001 | '-URI'=>$url, | |
1002 | '-nph'=>($nph||$NPH)); | |
1003 | push(@o,'-Target'=>$target) if $target; | |
1004 | push(@o,'-Cookie'=>$cookie) if $cookie; | |
1005 | return $self->header(@o); | |
1006 | } | |
1007 | END_OF_FUNC | |
1008 | ||
1009 | ||
1010 | #### Method: start_html | |
1011 | # Canned HTML header | |
1012 | # | |
1013 | # Parameters: | |
1014 | # $title -> (optional) The title for this HTML document (-title) | |
1015 | # $author -> (optional) e-mail address of the author (-author) | |
1016 | # $base -> (optional) if set to true, will enter the BASE address of this document | |
1017 | # for resolving relative references (-base) | |
1018 | # $xbase -> (optional) alternative base at some remote location (-xbase) | |
1019 | # $target -> (optional) target window to load all links into (-target) | |
1020 | # $script -> (option) Javascript code (-script) | |
1021 | # $meta -> (optional) Meta information tags | |
1022 | # @other -> (optional) any other named parameters you'd like to incorporate into | |
1023 | # the <BODY> tag. | |
1024 | #### | |
1025 | 'start_html' => <<'END_OF_FUNC', | |
1026 | sub start_html { | |
1027 | my($self,@p) = &self_or_default(@_); | |
1028 | my($title,$author,$base,$xbase,$script,$target,$meta,@other) = | |
1029 | $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,TARGET,META],@p); | |
1030 | ||
1031 | # strangely enough, the title needs to be escaped as HTML | |
1032 | # while the author needs to be escaped as a URL | |
1033 | $title = $self->escapeHTML($title || 'Untitled Document'); | |
1034 | $author = $self->escapeHTML($author); | |
1035 | my(@result); | |
1036 | push(@result,'<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">'); | |
1037 | push(@result,"<HTML><HEAD><TITLE>$title</TITLE>"); | |
1038 | push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if $author; | |
1039 | ||
1040 | if ($base || $xbase || $target) { | |
1041 | my $href = $xbase || $self->url(); | |
1042 | my $t = $target ? qq/ TARGET="$target"/ : ''; | |
1043 | push(@result,qq/<BASE HREF="$href"$t>/); | |
1044 | } | |
1045 | ||
1046 | if ($meta && ref($meta) && (ref($meta) eq 'HASH')) { | |
1047 | foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); } | |
1048 | } | |
1049 | push(@result,<<END) if $script; | |
1050 | <SCRIPT> | |
1051 | <!-- Hide script from HTML-compliant browsers | |
1052 | $script | |
1053 | // End script hiding. --> | |
1054 | </SCRIPT> | |
1055 | END | |
1056 | ; | |
1057 | my($other) = @other ? " @other" : ''; | |
1058 | push(@result,"</HEAD><BODY$other>"); | |
1059 | return join("\n",@result); | |
1060 | } | |
1061 | END_OF_FUNC | |
1062 | ||
1063 | ||
1064 | #### Method: end_html | |
1065 | # End an HTML document. | |
1066 | # Trivial method for completeness. Just returns "</BODY>" | |
1067 | #### | |
1068 | 'end_html' => <<'END_OF_FUNC', | |
1069 | sub end_html { | |
1070 | return "</BODY></HTML>"; | |
1071 | } | |
1072 | END_OF_FUNC | |
1073 | ||
1074 | ||
1075 | ################################ | |
1076 | # METHODS USED IN BUILDING FORMS | |
1077 | ################################ | |
1078 | ||
1079 | #### Method: isindex | |
1080 | # Just prints out the isindex tag. | |
1081 | # Parameters: | |
1082 | # $action -> optional URL of script to run | |
1083 | # Returns: | |
1084 | # A string containing a <ISINDEX> tag | |
1085 | 'isindex' => <<'END_OF_FUNC', | |
1086 | sub isindex { | |
1087 | my($self,@p) = self_or_default(@_); | |
1088 | my($action,@other) = $self->rearrange([ACTION],@p); | |
1089 | $action = qq/ACTION="$action"/ if $action; | |
1090 | my($other) = @other ? " @other" : ''; | |
1091 | return "<ISINDEX $action$other>"; | |
1092 | } | |
1093 | END_OF_FUNC | |
1094 | ||
1095 | ||
1096 | #### Method: startform | |
1097 | # Start a form | |
1098 | # Parameters: | |
1099 | # $method -> optional submission method to use (GET or POST) | |
1100 | # $action -> optional URL of script to run | |
1101 | # $enctype ->encoding to use (URL_ENCODED or MULTIPART) | |
1102 | 'startform' => <<'END_OF_FUNC', | |
1103 | sub startform { | |
1104 | my($self,@p) = self_or_default(@_); | |
1105 | ||
1106 | my($method,$action,$enctype,@other) = | |
1107 | $self->rearrange([METHOD,ACTION,ENCTYPE],@p); | |
1108 | ||
1109 | $method = $method || 'POST'; | |
1110 | $enctype = $enctype || &URL_ENCODED; | |
1111 | $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ? | |
1112 | 'ACTION="'.$self->script_name.'"' : ''; | |
1113 | my($other) = @other ? " @other" : ''; | |
1114 | $self->{'.parametersToAdd'}={}; | |
1115 | return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/; | |
1116 | } | |
1117 | END_OF_FUNC | |
1118 | ||
1119 | ||
1120 | #### Method: start_form | |
1121 | # synonym for startform | |
1122 | 'start_form' => <<'END_OF_FUNC', | |
1123 | sub start_form { | |
1124 | &startform; | |
1125 | } | |
1126 | END_OF_FUNC | |
1127 | ||
1128 | ||
1129 | #### Method: start_multipart_form | |
1130 | # synonym for startform | |
1131 | 'start_multipart_form' => <<'END_OF_FUNC', | |
1132 | sub start_multipart_form { | |
1133 | my($self,@p) = self_or_default(@_); | |
1134 | if ($self->use_named_parameters || | |
1135 | (defined($param[0]) && substr($param[0],0,1) eq '-')) { | |
1136 | my(%p) = @p; | |
1137 | $p{'-enctype'}=&MULTIPART; | |
1138 | return $self->startform(%p); | |
1139 | } else { | |
1140 | my($method,$action,@other) = | |
1141 | $self->rearrange([METHOD,ACTION],@p); | |
1142 | return $self->startform($method,$action,&MULTIPART,@other); | |
1143 | } | |
1144 | } | |
1145 | END_OF_FUNC | |
1146 | ||
1147 | ||
1148 | #### Method: endform | |
1149 | # End a form | |
1150 | 'endform' => <<'END_OF_FUNC', | |
1151 | sub endform { | |
1152 | my($self,@p) = self_or_default(@_); | |
1153 | return ($self->get_fields,"</FORM>"); | |
1154 | } | |
1155 | END_OF_FUNC | |
1156 | ||
1157 | ||
1158 | #### Method: end_form | |
1159 | # synonym for endform | |
1160 | 'end_form' => <<'END_OF_FUNC', | |
1161 | sub end_form { | |
1162 | &endform; | |
1163 | } | |
1164 | END_OF_FUNC | |
1165 | ||
1166 | ||
1167 | #### Method: textfield | |
1168 | # Parameters: | |
1169 | # $name -> Name of the text field | |
1170 | # $default -> Optional default value of the field if not | |
1171 | # already defined. | |
1172 | # $size -> Optional width of field in characaters. | |
1173 | # $maxlength -> Optional maximum number of characters. | |
1174 | # Returns: | |
1175 | # A string containing a <INPUT TYPE="text"> field | |
1176 | # | |
1177 | 'textfield' => <<'END_OF_FUNC', | |
1178 | sub textfield { | |
1179 | my($self,@p) = self_or_default(@_); | |
1180 | my($name,$default,$size,$maxlength,$override,@other) = | |
1181 | $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); | |
1182 | ||
1183 | my $current = $override ? $default : | |
1184 | (defined($self->param($name)) ? $self->param($name) : $default); | |
1185 | ||
1186 | $current = defined($current) ? $self->escapeHTML($current) : ''; | |
1187 | $name = defined($name) ? $self->escapeHTML($name) : ''; | |
1188 | my($s) = defined($size) ? qq/ SIZE=$size/ : ''; | |
1189 | my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; | |
1190 | my($other) = @other ? " @other" : ''; | |
1191 | return qq/<INPUT TYPE="text" NAME="$name" VALUE="$current"$s$m$other>/; | |
1192 | } | |
1193 | END_OF_FUNC | |
1194 | ||
1195 | ||
1196 | #### Method: filefield | |
1197 | # Parameters: | |
1198 | # $name -> Name of the file upload field | |
1199 | # $size -> Optional width of field in characaters. | |
1200 | # $maxlength -> Optional maximum number of characters. | |
1201 | # Returns: | |
1202 | # A string containing a <INPUT TYPE="text"> field | |
1203 | # | |
1204 | 'filefield' => <<'END_OF_FUNC', | |
1205 | sub filefield { | |
1206 | my($self,@p) = self_or_default(@_); | |
1207 | ||
1208 | my($name,$default,$size,$maxlength,$override,@other) = | |
1209 | $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); | |
1210 | ||
1211 | $current = $override ? $default : | |
1212 | (defined($self->param($name)) ? $self->param($name) : $default); | |
1213 | ||
1214 | $name = defined($name) ? $self->escapeHTML($name) : ''; | |
1215 | my($s) = defined($size) ? qq/ SIZE=$size/ : ''; | |
1216 | my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; | |
1217 | $current = defined($current) ? $self->escapeHTML($current) : ''; | |
1218 | $other = ' ' . join(" ",@other); | |
1219 | return qq/<INPUT TYPE="file" NAME="$name" VALUE="$current"$s$m$other>/; | |
1220 | } | |
1221 | END_OF_FUNC | |
1222 | ||
1223 | ||
1224 | #### Method: password | |
1225 | # Create a "secret password" entry field | |
1226 | # Parameters: | |
1227 | # $name -> Name of the field | |
1228 | # $default -> Optional default value of the field if not | |
1229 | # already defined. | |
1230 | # $size -> Optional width of field in characters. | |
1231 | # $maxlength -> Optional maximum characters that can be entered. | |
1232 | # Returns: | |
1233 | # A string containing a <INPUT TYPE="password"> field | |
1234 | # | |
1235 | 'password_field' => <<'END_OF_FUNC', | |
1236 | sub password_field { | |
1237 | my ($self,@p) = self_or_default(@_); | |
1238 | ||
1239 | my($name,$default,$size,$maxlength,$override,@other) = | |
1240 | $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); | |
1241 | ||
1242 | my($current) = $override ? $default : | |
1243 | (defined($self->param($name)) ? $self->param($name) : $default); | |
1244 | ||
1245 | $name = defined($name) ? $self->escapeHTML($name) : ''; | |
1246 | $current = defined($current) ? $self->escapeHTML($current) : ''; | |
1247 | my($s) = defined($size) ? qq/ SIZE=$size/ : ''; | |
1248 | my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; | |
1249 | my($other) = @other ? " @other" : ''; | |
1250 | return qq/<INPUT TYPE="password" NAME="$name" VALUE="$current"$s$m$other>/; | |
1251 | } | |
1252 | END_OF_FUNC | |
1253 | ||
1254 | ||
1255 | #### Method: textarea | |
1256 | # Parameters: | |
1257 | # $name -> Name of the text field | |
1258 | # $default -> Optional default value of the field if not | |
1259 | # already defined. | |
1260 | # $rows -> Optional number of rows in text area | |
1261 | # $columns -> Optional number of columns in text area | |
1262 | # Returns: | |
1263 | # A string containing a <TEXTAREA></TEXTAREA> tag | |
1264 | # | |
1265 | 'textarea' => <<'END_OF_FUNC', | |
1266 | sub textarea { | |
1267 | my($self,@p) = self_or_default(@_); | |
1268 | ||
1269 | my($name,$default,$rows,$cols,$override,@other) = | |
1270 | $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p); | |
1271 | ||
1272 | my($current)= $override ? $default : | |
1273 | (defined($self->param($name)) ? $self->param($name) : $default); | |
1274 | ||
1275 | $name = defined($name) ? $self->escapeHTML($name) : ''; | |
1276 | $current = defined($current) ? $self->escapeHTML($current) : ''; | |
1277 | my($r) = $rows ? " ROWS=$rows" : ''; | |
1278 | my($c) = $cols ? " COLS=$cols" : ''; | |
1279 | my($other) = @other ? " @other" : ''; | |
1280 | return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>}; | |
1281 | } | |
1282 | END_OF_FUNC | |
1283 | ||
1284 | ||
1285 | #### Method: button | |
1286 | # Create a javascript button. | |
1287 | # Parameters: | |
1288 | # $name -> (optional) Name for the button. (-name) | |
1289 | # $value -> (optional) Value of the button when selected (and visible name) (-value) | |
1290 | # $onclick -> (optional) Text of the JavaScript to run when the button is | |
1291 | # clicked. | |
1292 | # Returns: | |
1293 | # A string containing a <INPUT TYPE="button"> tag | |
1294 | #### | |
1295 | 'button' => <<'END_OF_FUNC', | |
1296 | sub button { | |
1297 | my($self,@p) = self_or_default(@_); | |
1298 | ||
1299 | my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL], | |
1300 | [ONCLICK,SCRIPT]],@p); | |
1301 | ||
1302 | $label=$self->escapeHTML($label); | |
1303 | $value=$self->escapeHTML($value); | |
1304 | $script=$self->escapeHTML($script); | |
1305 | ||
1306 | my($name) = ''; | |
1307 | $name = qq/ NAME="$label"/ if $label; | |
1308 | $value = $value || $label; | |
1309 | my($val) = ''; | |
1310 | $val = qq/ VALUE="$value"/ if $value; | |
1311 | $script = qq/ ONCLICK="$script"/ if $script; | |
1312 | my($other) = @other ? " @other" : ''; | |
1313 | return qq/<INPUT TYPE="button"$name$val$script$other>/; | |
1314 | } | |
1315 | END_OF_FUNC | |
1316 | ||
1317 | ||
1318 | #### Method: submit | |
1319 | # Create a "submit query" button. | |
1320 | # Parameters: | |
1321 | # $name -> (optional) Name for the button. | |
1322 | # $value -> (optional) Value of the button when selected (also doubles as label). | |
1323 | # $label -> (optional) Label printed on the button(also doubles as the value). | |
1324 | # Returns: | |
1325 | # A string containing a <INPUT TYPE="submit"> tag | |
1326 | #### | |
1327 | 'submit' => <<'END_OF_FUNC', | |
1328 | sub submit { | |
1329 | my($self,@p) = self_or_default(@_); | |
1330 | ||
1331 | my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p); | |
1332 | ||
1333 | $label=$self->escapeHTML($label); | |
1334 | $value=$self->escapeHTML($value); | |
1335 | ||
1336 | my($name) = ' NAME=".submit"'; | |
1337 | $name = qq/ NAME="$label"/ if $label; | |
1338 | $value = $value || $label; | |
1339 | my($val) = ''; | |
1340 | $val = qq/ VALUE="$value"/ if defined($value); | |
1341 | my($other) = @other ? " @other" : ''; | |
1342 | return qq/<INPUT TYPE="submit"$name$val$other>/; | |
1343 | } | |
1344 | END_OF_FUNC | |
1345 | ||
1346 | ||
1347 | #### Method: reset | |
1348 | # Create a "reset" button. | |
1349 | # Parameters: | |
1350 | # $name -> (optional) Name for the button. | |
1351 | # Returns: | |
1352 | # A string containing a <INPUT TYPE="reset"> tag | |
1353 | #### | |
1354 | 'reset' => <<'END_OF_FUNC', | |
1355 | sub reset { | |
1356 | my($self,@p) = self_or_default(@_); | |
1357 | my($label,@other) = $self->rearrange([NAME],@p); | |
1358 | $label=$self->escapeHTML($label); | |
1359 | my($value) = defined($label) ? qq/ VALUE="$label"/ : ''; | |
1360 | my($other) = @other ? " @other" : ''; | |
1361 | return qq/<INPUT TYPE="reset"$value$other>/; | |
1362 | } | |
1363 | END_OF_FUNC | |
1364 | ||
1365 | ||
1366 | #### Method: defaults | |
1367 | # Create a "defaults" button. | |
1368 | # Parameters: | |
1369 | # $name -> (optional) Name for the button. | |
1370 | # Returns: | |
1371 | # A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag | |
1372 | # | |
1373 | # Note: this button has a special meaning to the initialization script, | |
1374 | # and tells it to ERASE the current query string so that your defaults | |
1375 | # are used again! | |
1376 | #### | |
1377 | 'defaults' => <<'END_OF_FUNC', | |
1378 | sub defaults { | |
1379 | my($self,@p) = self_or_default(@_); | |
1380 | ||
1381 | my($label,@other) = $self->rearrange([[NAME,VALUE]],@p); | |
1382 | ||
1383 | $label=$self->escapeHTML($label); | |
1384 | $label = $label || "Defaults"; | |
1385 | my($value) = qq/ VALUE="$label"/; | |
1386 | my($other) = @other ? " @other" : ''; | |
1387 | return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/; | |
1388 | } | |
1389 | END_OF_FUNC | |
1390 | ||
1391 | ||
1392 | #### Method: checkbox | |
1393 | # Create a checkbox that is not logically linked to any others. | |
1394 | # The field value is "on" when the button is checked. | |
1395 | # Parameters: | |
1396 | # $name -> Name of the checkbox | |
1397 | # $checked -> (optional) turned on by default if true | |
1398 | # $value -> (optional) value of the checkbox, 'on' by default | |
1399 | # $label -> (optional) a user-readable label printed next to the box. | |
1400 | # Otherwise the checkbox name is used. | |
1401 | # Returns: | |
1402 | # A string containing a <INPUT TYPE="checkbox"> field | |
1403 | #### | |
1404 | 'checkbox' => <<'END_OF_FUNC', | |
1405 | sub checkbox { | |
1406 | my($self,@p) = self_or_default(@_); | |
1407 | ||
1408 | my($name,$checked,$value,$label,$override,@other) = | |
1409 | $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p); | |
1410 | ||
1411 | if (!$override && defined($self->param($name))) { | |
1412 | $value = $self->param($name) unless defined $value; | |
1413 | $checked = $self->param($name) eq $value ? ' CHECKED' : ''; | |
1414 | } else { | |
1415 | $checked = $checked ? ' CHECKED' : ''; | |
1416 | $value = defined $value ? $value : 'on'; | |
1417 | } | |
1418 | my($the_label) = defined $label ? $label : $name; | |
1419 | $name = $self->escapeHTML($name); | |
1420 | $value = $self->escapeHTML($value); | |
1421 | $the_label = $self->escapeHTML($the_label); | |
1422 | my($other) = @other ? " @other" : ''; | |
1423 | $self->register_parameter($name); | |
1424 | return <<END; | |
1425 | <INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label | |
1426 | END | |
1427 | } | |
1428 | END_OF_FUNC | |
1429 | ||
1430 | ||
1431 | #### Method: checkbox_group | |
1432 | # Create a list of logically-linked checkboxes. | |
1433 | # Parameters: | |
1434 | # $name -> Common name for all the check boxes | |
1435 | # $values -> A pointer to a regular array containing the | |
1436 | # values for each checkbox in the group. | |
1437 | # $defaults -> (optional) | |
1438 | # 1. If a pointer to a regular array of checkbox values, | |
1439 | # then this will be used to decide which | |
1440 | # checkboxes to turn on by default. | |
1441 | # 2. If a scalar, will be assumed to hold the | |
1442 | # value of a single checkbox in the group to turn on. | |
1443 | # $linebreak -> (optional) Set to true to place linebreaks | |
1444 | # between the buttons. | |
1445 | # $labels -> (optional) | |
1446 | # A pointer to an associative array of labels to print next to each checkbox | |
1447 | # in the form $label{'value'}="Long explanatory label". | |
1448 | # Otherwise the provided values are used as the labels. | |
1449 | # Returns: | |
1450 | # An ARRAY containing a series of <INPUT TYPE="checkbox"> fields | |
1451 | #### | |
1452 | 'checkbox_group' => <<'END_OF_FUNC', | |
1453 | sub checkbox_group { | |
1454 | my($self,@p) = self_or_default(@_); | |
1455 | ||
1456 | my($name,$values,$defaults,$linebreak,$labels,$rows,$columns, | |
1457 | $rowheaders,$colheaders,$override,$nolabels,@other) = | |
1458 | $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], | |
1459 | LINEBREAK,LABELS,ROWS,[COLUMNS,COLS], | |
1460 | ROWHEADERS,COLHEADERS, | |
1461 | [OVERRIDE,FORCE],NOLABELS],@p); | |
1462 | ||
1463 | my($checked,$break,$result,$label); | |
1464 | ||
1465 | my(%checked) = $self->previous_or_default($name,$defaults,$override); | |
1466 | ||
1467 | $break = $linebreak ? "<BR>" : ''; | |
1468 | $name=$self->escapeHTML($name); | |
1469 | ||
1470 | # Create the elements | |
1471 | my(@elements); | |
1472 | my(@values) = $values ? @$values : $self->param($name); | |
1473 | my($other) = @other ? " @other" : ''; | |
1474 | foreach (@values) { | |
1475 | $checked = $checked{$_} ? ' CHECKED' : ''; | |
1476 | $label = ''; | |
1477 | unless (defined($nolabels) && $nolabels) { | |
1478 | $label = $_; | |
1479 | $label = $labels->{$_} if defined($labels) && $labels->{$_}; | |
1480 | $label = $self->escapeHTML($label); | |
1481 | } | |
1482 | $_ = $self->escapeHTML($_); | |
1483 | push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label} ${break}/); | |
1484 | } | |
1485 | $self->register_parameter($name); | |
1486 | return wantarray ? @elements : join('',@elements) unless $columns; | |
1487 | return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); | |
1488 | } | |
1489 | END_OF_FUNC | |
1490 | ||
1491 | ||
1492 | # Escape HTML -- used internally | |
1493 | 'escapeHTML' => <<'END_OF_FUNC', | |
1494 | sub escapeHTML { | |
1495 | my($self,$toencode) = @_; | |
1496 | return undef unless defined($toencode); | |
1497 | return $toencode if $self->{'dontescape'}; | |
1498 | $toencode=~s/&/&/g; | |
1499 | $toencode=~s/\"/"/g; | |
1500 | $toencode=~s/>/>/g; | |
1501 | $toencode=~s/</</g; | |
1502 | return $toencode; | |
1503 | } | |
1504 | END_OF_FUNC | |
1505 | ||
1506 | ||
1507 | # Internal procedure - don't use | |
1508 | '_tableize' => <<'END_OF_FUNC', | |
1509 | sub _tableize { | |
1510 | my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; | |
1511 | my($result); | |
1512 | ||
1513 | $rows = int(0.99 + @elements/$columns) unless $rows; | |
1514 | # rearrange into a pretty table | |
1515 | $result = "<TABLE>"; | |
1516 | my($row,$column); | |
1517 | unshift(@$colheaders,'') if @$colheaders && @$rowheaders; | |
1518 | $result .= "<TR>" if @{$colheaders}; | |
1519 | foreach (@{$colheaders}) { | |
1520 | $result .= "<TH>$_</TH>"; | |
1521 | } | |
1522 | for ($row=0;$row<$rows;$row++) { | |
1523 | $result .= "<TR>"; | |
1524 | $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders; | |
1525 | for ($column=0;$column<$columns;$column++) { | |
1526 | $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>"; | |
1527 | } | |
1528 | $result .= "</TR>"; | |
1529 | } | |
1530 | $result .= "</TABLE>"; | |
1531 | return $result; | |
1532 | } | |
1533 | END_OF_FUNC | |
1534 | ||
1535 | ||
1536 | #### Method: radio_group | |
1537 | # Create a list of logically-linked radio buttons. | |
1538 | # Parameters: | |
1539 | # $name -> Common name for all the buttons. | |
1540 | # $values -> A pointer to a regular array containing the | |
1541 | # values for each button in the group. | |
1542 | # $default -> (optional) Value of the button to turn on by default. Pass '-' | |
1543 | # to turn _nothing_ on. | |
1544 | # $linebreak -> (optional) Set to true to place linebreaks | |
1545 | # between the buttons. | |
1546 | # $labels -> (optional) | |
1547 | # A pointer to an associative array of labels to print next to each checkbox | |
1548 | # in the form $label{'value'}="Long explanatory label". | |
1549 | # Otherwise the provided values are used as the labels. | |
1550 | # Returns: | |
1551 | # An ARRAY containing a series of <INPUT TYPE="radio"> fields | |
1552 | #### | |
1553 | 'radio_group' => <<'END_OF_FUNC', | |
1554 | sub radio_group { | |
1555 | my($self,@p) = self_or_default(@_); | |
1556 | ||
1557 | my($name,$values,$default,$linebreak,$labels, | |
1558 | $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) = | |
1559 | $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS, | |
1560 | ROWS,[COLUMNS,COLS], | |
1561 | ROWHEADERS,COLHEADERS, | |
1562 | [OVERRIDE,FORCE],NOLABELS],@p); | |
1563 | my($result,$checked); | |
1564 | ||
1565 | if (!$override && defined($self->param($name))) { | |
1566 | $checked = $self->param($name); | |
1567 | } else { | |
1568 | $checked = $default; | |
1569 | } | |
1570 | # If no check array is specified, check the first by default | |
1571 | $checked = $values->[0] unless $checked; | |
1572 | $name=$self->escapeHTML($name); | |
1573 | ||
1574 | my(@elements); | |
1575 | my(@values) = $values ? @$values : $self->param($name); | |
1576 | my($other) = @other ? " @other" : ''; | |
1577 | foreach (@values) { | |
1578 | my($checkit) = $checked eq $_ ? ' CHECKED' : ''; | |
1579 | my($break) = $linebreak ? '<BR>' : ''; | |
1580 | my($label)=''; | |
1581 | unless (defined($nolabels) && $nolabels) { | |
1582 | $label = $_; | |
1583 | $label = $labels->{$_} if defined($labels) && $labels->{$_}; | |
1584 | $label = $self->escapeHTML($label); | |
1585 | } | |
1586 | $_=$self->escapeHTML($_); | |
1587 | push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label} ${break}/); | |
1588 | } | |
1589 | $self->register_parameter($name); | |
1590 | return wantarray ? @elements : join('',@elements) unless $columns; | |
1591 | return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); | |
1592 | } | |
1593 | END_OF_FUNC | |
1594 | ||
1595 | ||
1596 | #### Method: popup_menu | |
1597 | # Create a popup menu. | |
1598 | # Parameters: | |
1599 | # $name -> Name for all the menu | |
1600 | # $values -> A pointer to a regular array containing the | |
1601 | # text of each menu item. | |
1602 | # $default -> (optional) Default item to display | |
1603 | # $labels -> (optional) | |
1604 | # A pointer to an associative array of labels to print next to each checkbox | |
1605 | # in the form $label{'value'}="Long explanatory label". | |
1606 | # Otherwise the provided values are used as the labels. | |
1607 | # Returns: | |
1608 | # A string containing the definition of a popup menu. | |
1609 | #### | |
1610 | 'popup_menu' => <<'END_OF_FUNC', | |
1611 | sub popup_menu { | |
1612 | my($self,@p) = self_or_default(@_); | |
1613 | ||
1614 | my($name,$values,$default,$labels,$override,@other) = | |
1615 | $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p); | |
1616 | my($result,$selected); | |
1617 | ||
1618 | if (!$override && defined($self->param($name))) { | |
1619 | $selected = $self->param($name); | |
1620 | } else { | |
1621 | $selected = $default; | |
1622 | } | |
1623 | $name=$self->escapeHTML($name); | |
1624 | my($other) = @other ? " @other" : ''; | |
1625 | ||
1626 | my(@values) = $values ? @$values : $self->param($name); | |
1627 | $result = qq/<SELECT NAME="$name"$other>\n/; | |
1628 | foreach (@values) { | |
1629 | my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : ''; | |
1630 | my($label) = $_; | |
1631 | $label = $labels->{$_} if defined($labels) && $labels->{$_}; | |
1632 | my($value) = $self->escapeHTML($_); | |
1633 | $label=$self->escapeHTML($label); | |
1634 | $result .= "<OPTION $selectit VALUE=\"$value\">$label\n"; | |
1635 | } | |
1636 | ||
1637 | $result .= "</SELECT>\n"; | |
1638 | return $result; | |
1639 | } | |
1640 | END_OF_FUNC | |
1641 | ||
1642 | ||
1643 | #### Method: scrolling_list | |
1644 | # Create a scrolling list. | |
1645 | # Parameters: | |
1646 | # $name -> name for the list | |
1647 | # $values -> A pointer to a regular array containing the | |
1648 | # values for each option line in the list. | |
1649 | # $defaults -> (optional) | |
1650 | # 1. If a pointer to a regular array of options, | |
1651 | # then this will be used to decide which | |
1652 | # lines to turn on by default. | |
1653 | # 2. Otherwise holds the value of the single line to turn on. | |
1654 | # $size -> (optional) Size of the list. | |
1655 | # $multiple -> (optional) If set, allow multiple selections. | |
1656 | # $labels -> (optional) | |
1657 | # A pointer to an associative array of labels to print next to each checkbox | |
1658 | # in the form $label{'value'}="Long explanatory label". | |
1659 | # Otherwise the provided values are used as the labels. | |
1660 | # Returns: | |
1661 | # A string containing the definition of a scrolling list. | |
1662 | #### | |
1663 | 'scrolling_list' => <<'END_OF_FUNC', | |
1664 | sub scrolling_list { | |
1665 | my($self,@p) = self_or_default(@_); | |
1666 | my($name,$values,$defaults,$size,$multiple,$labels,$override,@other) | |
1667 | = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], | |
1668 | SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p); | |
1669 | ||
1670 | my($result); | |
1671 | my(@values) = $values ? @$values : $self->param($name); | |
1672 | $size = $size || scalar(@values); | |
1673 | ||
1674 | my(%selected) = $self->previous_or_default($name,$defaults,$override); | |
1675 | my($is_multiple) = $multiple ? ' MULTIPLE' : ''; | |
1676 | my($has_size) = $size ? " SIZE=$size" : ''; | |
1677 | my($other) = @other ? " @other" : ''; | |
1678 | ||
1679 | $name=$self->escapeHTML($name); | |
1680 | $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/; | |
1681 | foreach (@values) { | |
1682 | my($selectit) = $selected{$_} ? 'SELECTED' : ''; | |
1683 | my($label) = $_; | |
1684 | $label = $labels->{$_} if defined($labels) && $labels->{$_}; | |
1685 | $label=$self->escapeHTML($label); | |
1686 | my($value)=$self->escapeHTML($_); | |
1687 | $result .= "<OPTION $selectit VALUE=\"$value\">$label\n"; | |
1688 | } | |
1689 | $result .= "</SELECT>\n"; | |
1690 | $self->register_parameter($name); | |
1691 | return $result; | |
1692 | } | |
1693 | END_OF_FUNC | |
1694 | ||
1695 | ||
1696 | #### Method: hidden | |
1697 | # Parameters: | |
1698 | # $name -> Name of the hidden field | |
1699 | # @default -> (optional) Initial values of field (may be an array) | |
1700 | # or | |
1701 | # $default->[initial values of field] | |
1702 | # Returns: | |
1703 | # A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value"> | |
1704 | #### | |
1705 | 'hidden' => <<'END_OF_FUNC', | |
1706 | sub hidden { | |
1707 | my($self,@p) = self_or_default(@_); | |
1708 | ||
1709 | # this is the one place where we departed from our standard | |
1710 | # calling scheme, so we have to special-case (darn) | |
1711 | my(@result,@value); | |
1712 | my($name,$default,$override,@other) = | |
1713 | $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); | |
1714 | ||
1715 | my $do_override = 0; | |
1716 | if ( substr($p[0],0,1) eq '-' || $self->use_named_parameters ) { | |
1717 | @value = ref($default) ? @{$default} : $default; | |
1718 | $do_override = $override; | |
1719 | } else { | |
1720 | foreach ($default,$override,@other) { | |
1721 | push(@value,$_) if defined($_); | |
1722 | } | |
1723 | } | |
1724 | ||
1725 | # use previous values if override is not set | |
1726 | my @prev = $self->param($name); | |
1727 | @value = @prev if !$do_override && @prev; | |
1728 | ||
1729 | $name=$self->escapeHTML($name); | |
1730 | foreach (@value) { | |
1731 | $_=$self->escapeHTML($_); | |
1732 | push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/); | |
1733 | } | |
1734 | return wantarray ? @result : join('',@result); | |
1735 | } | |
1736 | END_OF_FUNC | |
1737 | ||
1738 | ||
1739 | #### Method: image_button | |
1740 | # Parameters: | |
1741 | # $name -> Name of the button | |
1742 | # $src -> URL of the image source | |
1743 | # $align -> Alignment style (TOP, BOTTOM or MIDDLE) | |
1744 | # Returns: | |
1745 | # A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment"> | |
1746 | #### | |
1747 | 'image_button' => <<'END_OF_FUNC', | |
1748 | sub image_button { | |
1749 | my($self,@p) = self_or_default(@_); | |
1750 | ||
1751 | my($name,$src,$alignment,@other) = | |
1752 | $self->rearrange([NAME,SRC,ALIGN],@p); | |
1753 | ||
1754 | my($align) = $alignment ? " ALIGN=\U$alignment" : ''; | |
1755 | my($other) = @other ? " @other" : ''; | |
1756 | $name=$self->escapeHTML($name); | |
1757 | return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/; | |
1758 | } | |
1759 | END_OF_FUNC | |
1760 | ||
1761 | ||
1762 | #### Method: self_url | |
1763 | # Returns a URL containing the current script and all its | |
1764 | # param/value pairs arranged as a query. You can use this | |
1765 | # to create a link that, when selected, will reinvoke the | |
1766 | # script with all its state information preserved. | |
1767 | #### | |
1768 | 'self_url' => <<'END_OF_FUNC', | |
1769 | sub self_url { | |
1770 | my($self) = self_or_default(@_); | |
1771 | my($query_string) = $self->query_string; | |
1772 | my $protocol = $self->protocol(); | |
1773 | my $name = "$protocol://" . $self->server_name; | |
1774 | $name .= ":" . $self->server_port | |
1775 | unless $self->server_port == 80; | |
1776 | $name .= $self->script_name; | |
1777 | $name .= $self->path_info if $self->path_info; | |
1778 | return $name unless $query_string; | |
1779 | return "$name?$query_string"; | |
1780 | } | |
1781 | END_OF_FUNC | |
1782 | ||
1783 | ||
1784 | # This is provided as a synonym to self_url() for people unfortunate | |
1785 | # enough to have incorporated it into their programs already! | |
1786 | 'state' => <<'END_OF_FUNC', | |
1787 | sub state { | |
1788 | &self_url; | |
1789 | } | |
1790 | END_OF_FUNC | |
1791 | ||
1792 | ||
1793 | #### Method: url | |
1794 | # Like self_url, but doesn't return the query string part of | |
1795 | # the URL. | |
1796 | #### | |
1797 | 'url' => <<'END_OF_FUNC', | |
1798 | sub url { | |
1799 | my($self) = self_or_default(@_); | |
1800 | my $protocol = $self->protocol(); | |
1801 | my $name = "$protocol://" . $self->server_name; | |
1802 | $name .= ":" . $self->server_port | |
1803 | unless $self->server_port == 80; | |
1804 | $name .= $self->script_name; | |
1805 | return $name; | |
1806 | } | |
1807 | ||
1808 | END_OF_FUNC | |
1809 | ||
1810 | #### Method: cookie | |
1811 | # Set or read a cookie from the specified name. | |
1812 | # Cookie can then be passed to header(). | |
1813 | # Usual rules apply to the stickiness of -value. | |
1814 | # Parameters: | |
1815 | # -name -> name for this cookie (optional) | |
1816 | # -value -> value of this cookie (scalar, array or hash) | |
1817 | # -path -> paths for which this cookie is valid (optional) | |
1818 | # -domain -> internet domain in which this cookie is valid (optional) | |
1819 | # -secure -> if true, cookie only passed through secure channel (optional) | |
1820 | # -expires -> expiry date in format Wdy, DD-Mon-YY HH:MM:SS GMT (optional) | |
1821 | #### | |
1822 | 'cookie' => <<'END_OF_FUNC', | |
1823 | # temporary, for debugging. | |
1824 | sub cookie { | |
1825 | my($self,@p) = self_or_default(@_); | |
1826 | my($name,$value,$path,$domain,$secure,$expires) = | |
1827 | $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p); | |
1828 | ||
1829 | ||
1830 | # if no value is supplied, then we retrieve the | |
1831 | # value of the cookie, if any. For efficiency, we cache the parsed | |
1832 | # cookie in our state variables. | |
1833 | unless (defined($value)) { | |
1834 | unless ($self->{'.cookies'}) { | |
1835 | my(@pairs) = split("; ",$self->raw_cookie); | |
1836 | foreach (@pairs) { | |
1837 | my($key,$value) = split("="); | |
1838 | my(@values) = map unescape($_),split('&',$value); | |
1839 | $self->{'.cookies'}->{unescape($key)} = [@values]; | |
1840 | } | |
1841 | } | |
1842 | ||
1843 | # If no name is supplied, then retrieve the names of all our cookies. | |
1844 | return () unless $self->{'.cookies'}; | |
1845 | return wantarray ? @{$self->{'.cookies'}->{$name}} : $self->{'.cookies'}->{$name}->[0] | |
1846 | if defined($name) && $name ne ''; | |
1847 | return keys %{$self->{'.cookies'}}; | |
1848 | } | |
1849 | my(@values); | |
1850 | ||
1851 | # Pull out our parameters. | |
1852 | if (ref($value)) { | |
1853 | if (ref($value) eq 'ARRAY') { | |
1854 | @values = @$value; | |
1855 | } elsif (ref($value) eq 'HASH') { | |
1856 | @values = %$value; | |
1857 | } | |
1858 | } else { | |
1859 | @values = ($value); | |
1860 | } | |
1861 | @values = map escape($_),@values; | |
1862 | ||
1863 | # I.E. requires the path to be present. | |
1864 | ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $path; | |
1865 | ||
1866 | my(@constant_values); | |
1867 | push(@constant_values,"domain=$domain") if $domain; | |
1868 | push(@constant_values,"path=$path") if $path; | |
1869 | push(@constant_values,"expires=".&expires($expires)) if $expires; | |
1870 | push(@constant_values,'secure') if $secure; | |
1871 | ||
1872 | my($key) = &escape($name); | |
1873 | my($cookie) = join("=",$key,join("&",@values)); | |
1874 | return join("; ",$cookie,@constant_values); | |
1875 | } | |
1876 | END_OF_FUNC | |
1877 | ||
1878 | ||
1879 | # This internal routine creates an expires string exactly some number of | |
1880 | # hours from the current time in GMT. This is the format | |
1881 | # required by Netscape cookies, and I think it works for the HTTP | |
1882 | # Expires: header as well. | |
1883 | 'expires' => <<'END_OF_FUNC', | |
1884 | sub expires { | |
1885 | my($time) = @_; | |
1886 | my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; | |
1887 | my(@WDAY) = qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/; | |
1888 | my(%mult) = ('s'=>1, | |
1889 | 'm'=>60, | |
1890 | 'h'=>60*60, | |
1891 | 'd'=>60*60*24, | |
1892 | 'M'=>60*60*24*30, | |
1893 | 'y'=>60*60*24*365); | |
1894 | # format for time can be in any of the forms... | |
1895 | # "now" -- expire immediately | |
1896 | # "+180s" -- in 180 seconds | |
1897 | # "+2m" -- in 2 minutes | |
1898 | # "+12h" -- in 12 hours | |
1899 | # "+1d" -- in 1 day | |
1900 | # "+3M" -- in 3 months | |
1901 | # "+2y" -- in 2 years | |
1902 | # "-3m" -- 3 minutes ago(!) | |
1903 | # If you don't supply one of these forms, we assume you are | |
1904 | # specifying the date yourself | |
1905 | my($offset); | |
1906 | if (!$time || ($time eq 'now')) { | |
1907 | $offset = 0; | |
1908 | } elsif ($time=~/^([+-]?\d+)([mhdMy]?)/) { | |
1909 | $offset = ($mult{$2} || 1)*$1; | |
1910 | } else { | |
1911 | return $time; | |
1912 | } | |
1913 | my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime(time+$offset); | |
1914 | $year += 1900 unless $year < 100; | |
1915 | return sprintf("%s, %02d-%s-%02d %02d:%02d:%02d GMT", | |
1916 | $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec); | |
1917 | } | |
1918 | END_OF_FUNC | |
1919 | ||
1920 | ||
1921 | ############################################### | |
1922 | # OTHER INFORMATION PROVIDED BY THE ENVIRONMENT | |
1923 | ############################################### | |
1924 | ||
1925 | #### Method: path_info | |
1926 | # Return the extra virtual path information provided | |
1927 | # after the URL (if any) | |
1928 | #### | |
1929 | 'path_info' => <<'END_OF_FUNC', | |
1930 | sub path_info { | |
1931 | return $ENV{'PATH_INFO'}; | |
1932 | } | |
1933 | END_OF_FUNC | |
1934 | ||
1935 | ||
1936 | #### Method: request_method | |
1937 | # Returns 'POST', 'GET', 'PUT' or 'HEAD' | |
1938 | #### | |
1939 | 'request_method' => <<'END_OF_FUNC', | |
1940 | sub request_method { | |
1941 | return $ENV{'REQUEST_METHOD'}; | |
1942 | } | |
1943 | END_OF_FUNC | |
1944 | ||
1945 | #### Method: path_translated | |
1946 | # Return the physical path information provided | |
1947 | # by the URL (if any) | |
1948 | #### | |
1949 | 'path_translated' => <<'END_OF_FUNC', | |
1950 | sub path_translated { | |
1951 | return $ENV{'PATH_TRANSLATED'}; | |
1952 | } | |
1953 | END_OF_FUNC | |
1954 | ||
1955 | ||
1956 | #### Method: query_string | |
1957 | # Synthesize a query string from our current | |
1958 | # parameters | |
1959 | #### | |
1960 | 'query_string' => <<'END_OF_FUNC', | |
1961 | sub query_string { | |
1962 | my($self) = self_or_default(@_); | |
1963 | my($param,$value,@pairs); | |
1964 | foreach $param ($self->param) { | |
1965 | my($eparam) = &escape($param); | |
1966 | foreach $value ($self->param($param)) { | |
1967 | $value = &escape($value); | |
1968 | push(@pairs,"$eparam=$value"); | |
1969 | } | |
1970 | } | |
1971 | return join("&",@pairs); | |
1972 | } | |
1973 | END_OF_FUNC | |
1974 | ||
1975 | ||
1976 | #### Method: accept | |
1977 | # Without parameters, returns an array of the | |
1978 | # MIME types the browser accepts. | |
1979 | # With a single parameter equal to a MIME | |
1980 | # type, will return undef if the browser won't | |
1981 | # accept it, 1 if the browser accepts it but | |
1982 | # doesn't give a preference, or a floating point | |
1983 | # value between 0.0 and 1.0 if the browser | |
1984 | # declares a quantitative score for it. | |
1985 | # This handles MIME type globs correctly. | |
1986 | #### | |
1987 | 'accept' => <<'END_OF_FUNC', | |
1988 | sub accept { | |
1989 | my($self,$search) = self_or_CGI(@_); | |
1990 | my(%prefs,$type,$pref,$pat); | |
1991 | ||
1992 | my(@accept) = split(',',$self->http('accept')); | |
1993 | ||
1994 | foreach (@accept) { | |
1995 | ($pref) = /q=(\d\.\d+|\d+)/; | |
1996 | ($type) = m#(\S+/[^;]+)#; | |
1997 | next unless $type; | |
1998 | $prefs{$type}=$pref || 1; | |
1999 | } | |
2000 | ||
2001 | return keys %prefs unless $search; | |
2002 | ||
2003 | # if a search type is provided, we may need to | |
2004 | # perform a pattern matching operation. | |
2005 | # The MIME types use a glob mechanism, which | |
2006 | # is easily translated into a perl pattern match | |
2007 | ||
2008 | # First return the preference for directly supported | |
2009 | # types: | |
2010 | return $prefs{$search} if $prefs{$search}; | |
2011 | ||
2012 | # Didn't get it, so try pattern matching. | |
2013 | foreach (keys %prefs) { | |
2014 | next unless /\*/; # not a pattern match | |
2015 | ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters | |
2016 | $pat =~ s/\*/.*/g; # turn it into a pattern | |
2017 | return $prefs{$_} if $search=~/$pat/; | |
2018 | } | |
2019 | } | |
2020 | END_OF_FUNC | |
2021 | ||
2022 | ||
2023 | #### Method: user_agent | |
2024 | # If called with no parameters, returns the user agent. | |
2025 | # If called with one parameter, does a pattern match (case | |
2026 | # insensitive) on the user agent. | |
2027 | #### | |
2028 | 'user_agent' => <<'END_OF_FUNC', | |
2029 | sub user_agent { | |
2030 | my($self,$match)=self_or_CGI(@_); | |
2031 | return $self->http('user_agent') unless $match; | |
2032 | return $self->http('user_agent') =~ /$match/i; | |
2033 | } | |
2034 | END_OF_FUNC | |
2035 | ||
2036 | ||
2037 | #### Method: cookie | |
2038 | # Returns the magic cookie for the session. | |
2039 | # To set the magic cookie for new transations, | |
2040 | # try print $q->header('-Set-cookie'=>'my cookie') | |
2041 | #### | |
2042 | 'raw_cookie' => <<'END_OF_FUNC', | |
2043 | sub raw_cookie { | |
2044 | my($self) = self_or_CGI(@_); | |
2045 | return $self->http('cookie') || $ENV{'COOKIE'} || ''; | |
2046 | } | |
2047 | END_OF_FUNC | |
2048 | ||
2049 | #### Method: virtual_host | |
2050 | # Return the name of the virtual_host, which | |
2051 | # is not always the same as the server | |
2052 | ###### | |
2053 | 'virtual_host' => <<'END_OF_FUNC', | |
2054 | sub virtual_host { | |
2055 | return http('host') || server_name(); | |
2056 | } | |
2057 | END_OF_FUNC | |
2058 | ||
2059 | #### Method: remote_host | |
2060 | # Return the name of the remote host, or its IP | |
2061 | # address if unavailable. If this variable isn't | |
2062 | # defined, it returns "localhost" for debugging | |
2063 | # purposes. | |
2064 | #### | |
2065 | 'remote_host' => <<'END_OF_FUNC', | |
2066 | sub remote_host { | |
2067 | return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} | |
2068 | || 'localhost'; | |
2069 | } | |
2070 | END_OF_FUNC | |
2071 | ||
2072 | ||
2073 | #### Method: remote_addr | |
2074 | # Return the IP addr of the remote host. | |
2075 | #### | |
2076 | 'remote_addr' => <<'END_OF_FUNC', | |
2077 | sub remote_addr { | |
2078 | return $ENV{'REMOTE_ADDR'} || '127.0.0.1'; | |
2079 | } | |
2080 | END_OF_FUNC | |
2081 | ||
2082 | ||
2083 | #### Method: script_name | |
2084 | # Return the partial URL to this script for | |
2085 | # self-referencing scripts. Also see | |
2086 | # self_url(), which returns a URL with all state information | |
2087 | # preserved. | |
2088 | #### | |
2089 | 'script_name' => <<'END_OF_FUNC', | |
2090 | sub script_name { | |
2091 | return $ENV{'SCRIPT_NAME'} if $ENV{'SCRIPT_NAME'}; | |
2092 | # These are for debugging | |
2093 | return "/$0" unless $0=~/^\//; | |
2094 | return $0; | |
2095 | } | |
2096 | END_OF_FUNC | |
2097 | ||
2098 | ||
2099 | #### Method: referer | |
2100 | # Return the HTTP_REFERER: useful for generating | |
2101 | # a GO BACK button. | |
2102 | #### | |
2103 | 'referer' => <<'END_OF_FUNC', | |
2104 | sub referer { | |
2105 | my($self) = self_or_CGI(@_); | |
2106 | return $self->http('referer'); | |
2107 | } | |
2108 | END_OF_FUNC | |
2109 | ||
2110 | ||
2111 | #### Method: server_name | |
2112 | # Return the name of the server | |
2113 | #### | |
2114 | 'server_name' => <<'END_OF_FUNC', | |
2115 | sub server_name { | |
2116 | return $ENV{'SERVER_NAME'} || 'localhost'; | |
2117 | } | |
2118 | END_OF_FUNC | |
2119 | ||
2120 | #### Method: server_software | |
2121 | # Return the name of the server software | |
2122 | #### | |
2123 | 'server_software' => <<'END_OF_FUNC', | |
2124 | sub server_software { | |
2125 | return $ENV{'SERVER_SOFTWARE'} || 'cmdline'; | |
2126 | } | |
2127 | END_OF_FUNC | |
2128 | ||
2129 | #### Method: server_port | |
2130 | # Return the tcp/ip port the server is running on | |
2131 | #### | |
2132 | 'server_port' => <<'END_OF_FUNC', | |
2133 | sub server_port { | |
2134 | return $ENV{'SERVER_PORT'} || 80; # for debugging | |
2135 | } | |
2136 | END_OF_FUNC | |
2137 | ||
2138 | #### Method: server_protocol | |
2139 | # Return the protocol (usually HTTP/1.0) | |
2140 | #### | |
2141 | 'server_protocol' => <<'END_OF_FUNC', | |
2142 | sub server_protocol { | |
2143 | return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging | |
2144 | } | |
2145 | END_OF_FUNC | |
2146 | ||
2147 | #### Method: http | |
2148 | # Return the value of an HTTP variable, or | |
2149 | # the list of variables if none provided | |
2150 | #### | |
2151 | 'http' => <<'END_OF_FUNC', | |
2152 | sub http { | |
2153 | my ($self,$parameter) = self_or_CGI(@_); | |
2154 | return $ENV{$parameter} if $parameter=~/^HTTP/; | |
2155 | return $ENV{"HTTP_\U$parameter\E"} if $parameter; | |
2156 | my(@p); | |
2157 | foreach (keys %ENV) { | |
2158 | push(@p,$_) if /^HTTP/; | |
2159 | } | |
2160 | return @p; | |
2161 | } | |
2162 | END_OF_FUNC | |
2163 | ||
2164 | #### Method: https | |
2165 | # Return the value of HTTPS | |
2166 | #### | |
2167 | 'https' => <<'END_OF_FUNC', | |
2168 | sub https { | |
2169 | local($^W)=0; | |
2170 | my ($self,$parameter) = self_or_CGI(@_); | |
2171 | return $ENV{HTTPS} unless $parameter; | |
2172 | return $ENV{$parameter} if $parameter=~/^HTTPS/; | |
2173 | return $ENV{"HTTPS_\U$parameter\E"} if $parameter; | |
2174 | my(@p); | |
2175 | foreach (keys %ENV) { | |
2176 | push(@p,$_) if /^HTTPS/; | |
2177 | } | |
2178 | return @p; | |
2179 | } | |
2180 | END_OF_FUNC | |
2181 | ||
2182 | #### Method: protocol | |
2183 | # Return the protocol (http or https currently) | |
2184 | #### | |
2185 | 'protocol' => <<'END_OF_FUNC', | |
2186 | sub protocol { | |
2187 | local($^W)=0; | |
2188 | my $self = shift; | |
2189 | return 'https' if $self->https() eq 'ON'; | |
2190 | return 'https' if $self->server_port == 443; | |
2191 | my $prot = $self->server_protocol; | |
2192 | my($protocol,$version) = split('/',$prot); | |
2193 | return "\L$protocol\E"; | |
2194 | } | |
2195 | END_OF_FUNC | |
2196 | ||
2197 | #### Method: remote_ident | |
2198 | # Return the identity of the remote user | |
2199 | # (but only if his host is running identd) | |
2200 | #### | |
2201 | 'remote_ident' => <<'END_OF_FUNC', | |
2202 | sub remote_ident { | |
2203 | return $ENV{'REMOTE_IDENT'}; | |
2204 | } | |
2205 | END_OF_FUNC | |
2206 | ||
2207 | ||
2208 | #### Method: auth_type | |
2209 | # Return the type of use verification/authorization in use, if any. | |
2210 | #### | |
2211 | 'auth_type' => <<'END_OF_FUNC', | |
2212 | sub auth_type { | |
2213 | return $ENV{'AUTH_TYPE'}; | |
2214 | } | |
2215 | END_OF_FUNC | |
2216 | ||
2217 | ||
2218 | #### Method: remote_user | |
2219 | # Return the authorization name used for user | |
2220 | # verification. | |
2221 | #### | |
2222 | 'remote_user' => <<'END_OF_FUNC', | |
2223 | sub remote_user { | |
2224 | return $ENV{'REMOTE_USER'}; | |
2225 | } | |
2226 | END_OF_FUNC | |
2227 | ||
2228 | ||
2229 | #### Method: user_name | |
2230 | # Try to return the remote user's name by hook or by | |
2231 | # crook | |
2232 | #### | |
2233 | 'user_name' => <<'END_OF_FUNC', | |
2234 | sub user_name { | |
2235 | my ($self) = self_or_CGI(@_); | |
2236 | return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'}; | |
2237 | } | |
2238 | END_OF_FUNC | |
2239 | ||
2240 | #### Method: nph | |
2241 | # Set or return the NPH global flag | |
2242 | #### | |
2243 | 'nph' => <<'END_OF_FUNC', | |
2244 | sub nph { | |
2245 | my ($self,$param) = self_or_CGI(@_); | |
2246 | $CGI::nph = $param if defined($param); | |
2247 | return $CGI::nph; | |
2248 | } | |
2249 | END_OF_FUNC | |
2250 | ||
2251 | # -------------- really private subroutines ----------------- | |
2252 | 'previous_or_default' => <<'END_OF_FUNC', | |
2253 | sub previous_or_default { | |
2254 | my($self,$name,$defaults,$override) = @_; | |
2255 | my(%selected); | |
2256 | ||
2257 | if (!$override && ($self->{'.fieldnames'}->{$name} || | |
2258 | defined($self->param($name)) ) ) { | |
2259 | grep($selected{$_}++,$self->param($name)); | |
2260 | } elsif (defined($defaults) && ref($defaults) && | |
2261 | (ref($defaults) eq 'ARRAY')) { | |
2262 | grep($selected{$_}++,@{$defaults}); | |
2263 | } else { | |
2264 | $selected{$defaults}++ if defined($defaults); | |
2265 | } | |
2266 | ||
2267 | return %selected; | |
2268 | } | |
2269 | END_OF_FUNC | |
2270 | ||
2271 | 'register_parameter' => <<'END_OF_FUNC', | |
2272 | sub register_parameter { | |
2273 | my($self,$param) = @_; | |
2274 | $self->{'.parametersToAdd'}->{$param}++; | |
2275 | } | |
2276 | END_OF_FUNC | |
2277 | ||
2278 | 'get_fields' => <<'END_OF_FUNC', | |
2279 | sub get_fields { | |
2280 | my($self) = @_; | |
2281 | return $self->hidden('-name'=>'.cgifields', | |
2282 | '-values'=>[keys %{$self->{'.parametersToAdd'}}], | |
2283 | '-override'=>1); | |
2284 | } | |
2285 | END_OF_FUNC | |
2286 | ||
2287 | 'read_from_cmdline' => <<'END_OF_FUNC', | |
2288 | sub read_from_cmdline { | |
2289 | require "shellwords.pl"; | |
2290 | my($input,@words); | |
2291 | my($query_string); | |
2292 | if (@ARGV) { | |
2293 | $input = join(" ",@ARGV); | |
2294 | } else { | |
2295 | print STDERR "(offline mode: enter name=value pairs on standard input)\n"; | |
2296 | chomp(@lines = <>); # remove newlines | |
2297 | $input = join(" ",@lines); | |
2298 | } | |
2299 | ||
2300 | # minimal handling of escape characters | |
2301 | $input=~s/\\=/%3D/g; | |
2302 | $input=~s/\\&/%26/g; | |
2303 | ||
2304 | @words = &shellwords($input); | |
2305 | if ("@words"=~/=/) { | |
2306 | $query_string = join('&',@words); | |
2307 | } else { | |
2308 | $query_string = join('+',@words); | |
2309 | } | |
2310 | return $query_string; | |
2311 | } | |
2312 | END_OF_FUNC | |
2313 | ||
2314 | ##### | |
2315 | # subroutine: read_multipart | |
2316 | # | |
2317 | # Read multipart data and store it into our parameters. | |
2318 | # An interesting feature is that if any of the parts is a file, we | |
2319 | # create a temporary file and open up a filehandle on it so that the | |
2320 | # caller can read from it if necessary. | |
2321 | ##### | |
2322 | 'read_multipart' => <<'END_OF_FUNC', | |
2323 | sub read_multipart { | |
2324 | my($self,$boundary,$length) = @_; | |
2325 | my($buffer) = $self->new_MultipartBuffer($boundary,$length); | |
2326 | return unless $buffer; | |
2327 | my(%header,$body); | |
2328 | while (!$buffer->eof) { | |
2329 | %header = $buffer->readHeader; | |
2330 | ||
2331 | # In beta1 it was "Content-disposition". In beta2 it's "Content-Disposition" | |
2332 | # Sheesh. | |
2333 | my($key) = $header{'Content-disposition'} ? 'Content-disposition' : 'Content-Disposition'; | |
2334 | my($param)= $header{$key}=~/ name="([^\"]*)"/; | |
2335 | ||
2336 | # possible bug: our regular expression expects the filename= part to fall | |
2337 | # at the end of the line. Netscape doesn't escape quotation marks in file names!!! | |
2338 | my($filename) = $header{$key}=~/ filename="(.*)"$/; | |
2339 | ||
2340 | # add this parameter to our list | |
2341 | $self->add_parameter($param); | |
2342 | ||
2343 | # If no filename specified, then just read the data and assign it | |
2344 | # to our parameter list. | |
2345 | unless ($filename) { | |
2346 | my($value) = $buffer->readBody; | |
2347 | push(@{$self->{$param}},$value); | |
2348 | next; | |
2349 | } | |
2350 | ||
2351 | # If we get here, then we are dealing with a potentially large | |
2352 | # uploaded form. Save the data to a temporary file, then open | |
2353 | # the file for reading. | |
2354 | my($tmpfile) = new TempFile; | |
2355 | my $tmp = $tmpfile->as_string; | |
2356 | ||
2357 | open (OUT,">$tmp") || die "CGI open of $tmpfile: $!\n"; | |
2358 | $CGI::DefaultClass->binmode(OUT) if $CGI::needs_binmode; | |
2359 | chmod 0666,$tmp; # make sure anyone can delete it. | |
2360 | my $data; | |
2361 | while ($data = $buffer->read) { | |
2362 | print OUT $data; | |
2363 | } | |
2364 | close OUT; | |
2365 | ||
2366 | # Now create a new filehandle in the caller's namespace. | |
2367 | # The name of this filehandle just happens to be identical | |
2368 | # to the original filename (NOT the name of the temporary | |
2369 | # file, which is hidden!) | |
2370 | my($filehandle); | |
2371 | if ($filename=~/^[a-zA-Z_]/) { | |
2372 | my($frame,$cp)=(1); | |
2373 | do { $cp = caller($frame++); } until !eval("'$cp'->isaCGI()"); | |
2374 | $filehandle = "$cp\:\:$filename"; | |
2375 | } else { | |
2376 | $filehandle = "\:\:$filename"; | |
2377 | } | |
2378 | ||
2379 | open($filehandle,$tmp) || die "CGI open of $tmp: $!\n"; | |
2380 | $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; | |
2381 | ||
2382 | push(@{$self->{$param}},$filename); | |
2383 | ||
2384 | # Under Unix, it would be safe to let the temporary file | |
2385 | # be deleted immediately. However, I fear that other operating | |
2386 | # systems are not so forgiving. Therefore we save a reference | |
2387 | # to the temporary file in the CGI object so that the file | |
2388 | # isn't unlinked until the CGI object itself goes out of | |
2389 | # scope. This is a bit hacky, but it has the interesting side | |
2390 | # effect that one can access the name of the tmpfile by | |
2391 | # asking for $query->{$query->param('foo')}, where 'foo' | |
2392 | # is the name of the file upload field. | |
2393 | $self->{'.tmpfiles'}->{$filename}= { | |
2394 | name=>$tmpfile, | |
2395 | info=>{%header} | |
2396 | } | |
2397 | } | |
2398 | } | |
2399 | END_OF_FUNC | |
2400 | ||
2401 | 'tmpFileName' => <<'END_OF_FUNC', | |
2402 | sub tmpFileName { | |
2403 | my($self,$filename) = self_or_default(@_); | |
2404 | return $self->{'.tmpfiles'}->{$filename}->{name}->as_string; | |
2405 | } | |
2406 | END_OF_FUNC | |
2407 | ||
2408 | 'uploadInfo' => <<'END_OF_FUNC' | |
2409 | sub uploadInfo { | |
2410 | my($self,$filename) = self_or_default(@_); | |
2411 | return $self->{'.tmpfiles'}->{$filename}->{info}; | |
2412 | } | |
2413 | END_OF_FUNC | |
2414 | ||
2415 | ); | |
2416 | END_OF_AUTOLOAD | |
2417 | ; | |
2418 | ||
2419 | # Globals and stubs for other packages that we use | |
2420 | package MultipartBuffer; | |
2421 | ||
2422 | # how many bytes to read at a time. We use | |
2423 | # a 5K buffer by default. | |
2424 | $FILLUNIT = 1024 * 5; | |
2425 | $TIMEOUT = 10*60; # 10 minute timeout | |
2426 | $SPIN_LOOP_MAX = 1000; # bug fix for some Netscape servers | |
2427 | $CRLF=$CGI::CRLF; | |
2428 | ||
2429 | #reuse the autoload function | |
2430 | *MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD; | |
2431 | ||
2432 | ############################################################################### | |
2433 | ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### | |
2434 | ############################################################################### | |
2435 | $AUTOLOADED_ROUTINES = ''; # prevent -w error | |
2436 | $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; | |
2437 | %SUBS = ( | |
2438 | ||
2439 | 'new' => <<'END_OF_FUNC', | |
2440 | sub new { | |
2441 | my($package,$interface,$boundary,$length,$filehandle) = @_; | |
2442 | my $IN; | |
2443 | if ($filehandle) { | |
2444 | my($package) = caller; | |
2445 | # force into caller's package if necessary | |
2446 | $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; | |
2447 | } | |
2448 | $IN = "main::STDIN" unless $IN; | |
2449 | ||
2450 | $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode; | |
2451 | ||
2452 | # If the user types garbage into the file upload field, | |
2453 | # then Netscape passes NOTHING to the server (not good). | |
2454 | # We may hang on this read in that case. So we implement | |
2455 | # a read timeout. If nothing is ready to read | |
2456 | # by then, we return. | |
2457 | ||
2458 | # Netscape seems to be a little bit unreliable | |
2459 | # about providing boundary strings. | |
2460 | if ($boundary) { | |
2461 | ||
2462 | # Under the MIME spec, the boundary consists of the | |
2463 | # characters "--" PLUS the Boundary string | |
2464 | $boundary = "--$boundary"; | |
2465 | # Read the topmost (boundary) line plus the CRLF | |
2466 | my($null) = ''; | |
2467 | $length -= $interface->read_from_client($IN,\$null,length($boundary)+2,0); | |
2468 | ||
2469 | } else { # otherwise we find it ourselves | |
2470 | my($old); | |
2471 | ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line | |
2472 | $boundary = <$IN>; # BUG: This won't work correctly under mod_perl | |
2473 | $length -= length($boundary); | |
2474 | chomp($boundary); # remove the CRLF | |
2475 | $/ = $old; # restore old line separator | |
2476 | } | |
2477 | ||
2478 | my $self = {LENGTH=>$length, | |
2479 | BOUNDARY=>$boundary, | |
2480 | IN=>$IN, | |
2481 | INTERFACE=>$interface, | |
2482 | BUFFER=>'', | |
2483 | }; | |
2484 | ||
2485 | $FILLUNIT = length($boundary) | |
2486 | if length($boundary) > $FILLUNIT; | |
2487 | ||
2488 | return bless $self,ref $package || $package; | |
2489 | } | |
2490 | END_OF_FUNC | |
2491 | ||
2492 | 'readHeader' => <<'END_OF_FUNC', | |
2493 | sub readHeader { | |
2494 | my($self) = @_; | |
2495 | my($end); | |
2496 | my($ok) = 0; | |
2497 | do { | |
2498 | $self->fillBuffer($FILLUNIT); | |
2499 | $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0; | |
2500 | $ok++ if $self->{BUFFER} eq ''; | |
2501 | $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; | |
2502 | } until $ok; | |
2503 | ||
2504 | my($header) = substr($self->{BUFFER},0,$end+2); | |
2505 | substr($self->{BUFFER},0,$end+4) = ''; | |
2506 | my %return; | |
2507 | while ($header=~/^([\w-]+): (.*)$CRLF/mog) { | |
2508 | $return{$1}=$2; | |
2509 | } | |
2510 | return %return; | |
2511 | } | |
2512 | END_OF_FUNC | |
2513 | ||
2514 | # This reads and returns the body as a single scalar value. | |
2515 | 'readBody' => <<'END_OF_FUNC', | |
2516 | sub readBody { | |
2517 | my($self) = @_; | |
2518 | my($data); | |
2519 | my($returnval)=''; | |
2520 | while (defined($data = $self->read)) { | |
2521 | $returnval .= $data; | |
2522 | } | |
2523 | return $returnval; | |
2524 | } | |
2525 | END_OF_FUNC | |
2526 | ||
2527 | # This will read $bytes or until the boundary is hit, whichever happens | |
2528 | # first. After the boundary is hit, we return undef. The next read will | |
2529 | # skip over the boundary and begin reading again; | |
2530 | 'read' => <<'END_OF_FUNC', | |
2531 | sub read { | |
2532 | my($self,$bytes) = @_; | |
2533 | ||
2534 | # default number of bytes to read | |
2535 | $bytes = $bytes || $FILLUNIT; | |
2536 | ||
2537 | # Fill up our internal buffer in such a way that the boundary | |
2538 | # is never split between reads. | |
2539 | $self->fillBuffer($bytes); | |
2540 | ||
2541 | # Find the boundary in the buffer (it may not be there). | |
2542 | my $start = index($self->{BUFFER},$self->{BOUNDARY}); | |
2543 | ||
2544 | # If the boundary begins the data, then skip past it | |
2545 | # and return undef. The +2 here is a fiendish plot to | |
2546 | # remove the CR/LF pair at the end of the boundary. | |
2547 | if ($start == 0) { | |
2548 | ||
2549 | # clear us out completely if we've hit the last boundary. | |
2550 | if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) { | |
2551 | $self->{BUFFER}=''; | |
2552 | $self->{LENGTH}=0; | |
2553 | return undef; | |
2554 | } | |
2555 | ||
2556 | # just remove the boundary. | |
2557 | substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)=''; | |
2558 | return undef; | |
2559 | } | |
2560 | ||
2561 | my $bytesToReturn; | |
2562 | if ($start > 0) { # read up to the boundary | |
2563 | $bytesToReturn = $start > $bytes ? $bytes : $start; | |
2564 | } else { # read the requested number of bytes | |
2565 | # leave enough bytes in the buffer to allow us to read | |
2566 | # the boundary. Thanks to Kevin Hendrick for finding | |
2567 | # this one. | |
2568 | $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1); | |
2569 | } | |
2570 | ||
2571 | my $returnval=substr($self->{BUFFER},0,$bytesToReturn); | |
2572 | substr($self->{BUFFER},0,$bytesToReturn)=''; | |
2573 | ||
2574 | # If we hit the boundary, remove the CRLF from the end. | |
2575 | return ($start > 0) ? substr($returnval,0,-2) : $returnval; | |
2576 | } | |
2577 | END_OF_FUNC | |
2578 | ||
2579 | ||
2580 | # This fills up our internal buffer in such a way that the | |
2581 | # boundary is never split between reads | |
2582 | 'fillBuffer' => <<'END_OF_FUNC', | |
2583 | sub fillBuffer { | |
2584 | my($self,$bytes) = @_; | |
2585 | return unless $self->{LENGTH}; | |
2586 | ||
2587 | my($boundaryLength) = length($self->{BOUNDARY}); | |
2588 | my($bufferLength) = length($self->{BUFFER}); | |
2589 | my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2; | |
2590 | $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead; | |
2591 | ||
2592 | # Try to read some data. We may hang here if the browser is screwed up. | |
2593 | my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN}, | |
2594 | \$self->{BUFFER}, | |
2595 | $bytesToRead, | |
2596 | $bufferLength); | |
2597 | ||
2598 | # An apparent bug in the Netscape Commerce server causes the read() | |
2599 | # to return zero bytes repeatedly without blocking if the | |
2600 | # remote user aborts during a file transfer. I don't know how | |
2601 | # they manage this, but the workaround is to abort if we get | |
2602 | # more than SPIN_LOOP_MAX consecutive zero reads. | |
2603 | if ($bytesRead == 0) { | |
2604 | die "CGI.pm: Server closed socket during multipart read (client aborted?).\n" | |
2605 | if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX); | |
2606 | } else { | |
2607 | $self->{ZERO_LOOP_COUNTER}=0; | |
2608 | } | |
2609 | ||
2610 | $self->{LENGTH} -= $bytesRead; | |
2611 | } | |
2612 | END_OF_FUNC | |
2613 | ||
2614 | ||
2615 | # Return true when we've finished reading | |
2616 | 'eof' => <<'END_OF_FUNC' | |
2617 | sub eof { | |
2618 | my($self) = @_; | |
2619 | return 1 if (length($self->{BUFFER}) == 0) | |
2620 | && ($self->{LENGTH} <= 0); | |
2621 | undef; | |
2622 | } | |
2623 | END_OF_FUNC | |
2624 | ||
2625 | ); | |
2626 | END_OF_AUTOLOAD | |
2627 | ||
2628 | #################################################################################### | |
2629 | ################################## TEMPORARY FILES ################################# | |
2630 | #################################################################################### | |
2631 | package TempFile; | |
2632 | ||
2633 | $SL = $CGI::SL; | |
2634 | unless ($TMPDIRECTORY) { | |
2635 | @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp","${SL}tmp","${SL}temp","${SL}Temporary Items"); | |
2636 | foreach (@TEMP) { | |
2637 | do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; | |
2638 | } | |
2639 | } | |
2640 | ||
2641 | $TMPDIRECTORY = "." unless $TMPDIRECTORY; | |
2642 | $SEQUENCE="CGItemp${$}0000"; | |
2643 | ||
2644 | # cute feature, but overload implementation broke it | |
2645 | # %OVERLOAD = ('""'=>'as_string'); | |
2646 | *TempFile::AUTOLOAD = \&CGI::AUTOLOAD; | |
2647 | ||
2648 | ############################################################################### | |
2649 | ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### | |
2650 | ############################################################################### | |
2651 | $AUTOLOADED_ROUTINES = ''; # prevent -w error | |
2652 | $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; | |
2653 | %SUBS = ( | |
2654 | ||
2655 | 'new' => <<'END_OF_FUNC', | |
2656 | sub new { | |
2657 | my($package) = @_; | |
2658 | $SEQUENCE++; | |
2659 | my $directory = "${TMPDIRECTORY}${SL}${SEQUENCE}"; | |
2660 | return bless \$directory; | |
2661 | } | |
2662 | END_OF_FUNC | |
2663 | ||
2664 | 'DESTROY' => <<'END_OF_FUNC', | |
2665 | sub DESTROY { | |
2666 | my($self) = @_; | |
2667 | unlink $$self; # get rid of the file | |
2668 | } | |
2669 | END_OF_FUNC | |
2670 | ||
2671 | 'as_string' => <<'END_OF_FUNC' | |
2672 | sub as_string { | |
2673 | my($self) = @_; | |
2674 | return $$self; | |
2675 | } | |
2676 | END_OF_FUNC | |
2677 | ||
2678 | ); | |
2679 | END_OF_AUTOLOAD | |
2680 | ||
2681 | package CGI; | |
2682 | ||
2683 | # We get a whole bunch of warnings about "possibly uninitialized variables" | |
2684 | # when running with the -w switch. Touch them all once to get rid of the | |
2685 | # warnings. This is ugly and I hate it. | |
2686 | if ($^W) { | |
2687 | $CGI::CGI = ''; | |
2688 | $CGI::CGI=<<EOF; | |
2689 | $CGI::VERSION; | |
2690 | $MultipartBuffer::SPIN_LOOP_MAX; | |
2691 | $MultipartBuffer::CRLF; | |
2692 | $MultipartBuffer::TIMEOUT; | |
2693 | $MultipartBuffer::FILLUNIT; | |
2694 | $TempFile::SEQUENCE; | |
2695 | EOF | |
2696 | ; | |
2697 | } | |
2698 | ||
2699 | $revision; | |
2700 | ||
2701 | __END__ | |
2702 | ||
2703 | =head1 NAME | |
2704 | ||
2705 | CGI - Simple Common Gateway Interface Class | |
2706 | ||
dc848c6f | 2707 | =head1 SYNOPSIS |
2708 | ||
2709 | use CGI; | |
2710 | # the rest is too complicated for a synopsis; keep reading | |
2711 | ||
54310121 | 2712 | =head1 ABSTRACT |
2713 | ||
2714 | This perl library uses perl5 objects to make it easy to create | |
2715 | Web fill-out forms and parse their contents. This package | |
2716 | defines CGI objects, entities that contain the values of the | |
2717 | current query string and other state variables. | |
2718 | Using a CGI object's methods, you can examine keywords and parameters | |
2719 | passed to your script, and create forms whose initial values | |
2720 | are taken from the current query (thereby preserving state | |
2721 | information). | |
2722 | ||
2723 | The current version of CGI.pm is available at | |
2724 | ||
2725 | http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html | |
2726 | ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ | |
2727 | ||
2728 | =head1 INSTALLATION: | |
2729 | ||
2730 | To install this package, just change to the directory in which this | |
2731 | file is found and type the following: | |
2732 | ||
2733 | perl Makefile.PL | |
2734 | make | |
2735 | make install | |
2736 | ||
2737 | This will copy CGI.pm to your perl library directory for use by all | |
2738 | perl scripts. You probably must be root to do this. Now you can | |
2739 | load the CGI routines in your Perl scripts with the line: | |
2740 | ||
2741 | use CGI; | |
2742 | ||
2743 | If you don't have sufficient privileges to install CGI.pm in the Perl | |
2744 | library directory, you can put CGI.pm into some convenient spot, such | |
2745 | as your home directory, or in cgi-bin itself and prefix all Perl | |
2746 | scripts that call it with something along the lines of the following | |
2747 | preamble: | |
2748 | ||
2749 | use lib '/home/davis/lib'; | |
2750 | use CGI; | |
2751 | ||
2752 | If you are using a version of perl earlier than 5.002 (such as NT perl), use | |
2753 | this instead: | |
2754 | ||
2755 | BEGIN { | |
2756 | unshift(@INC,'/home/davis/lib'); | |
2757 | } | |
2758 | use CGI; | |
2759 | ||
2760 | The CGI distribution also comes with a cute module called L<CGI::Carp>. | |
2761 | It redefines the die(), warn(), confess() and croak() error routines | |
2762 | so that they write nicely formatted error messages into the server's | |
2763 | error log (or to the output stream of your choice). This avoids long | |
2764 | hours of groping through the error and access logs, trying to figure | |
2765 | out which CGI script is generating error messages. If you choose, | |
2766 | you can even have fatal error messages echoed to the browser to avoid | |
2767 | the annoying and uninformative "Server Error" message. | |
2768 | ||
2769 | =head1 DESCRIPTION | |
2770 | ||
2771 | =head2 CREATING A NEW QUERY OBJECT: | |
2772 | ||
2773 | $query = new CGI; | |
2774 | ||
2775 | This will parse the input (from both POST and GET methods) and store | |
2776 | it into a perl5 object called $query. | |
2777 | ||
2778 | =head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE | |
2779 | ||
2780 | $query = new CGI(INPUTFILE); | |
2781 | ||
2782 | If you provide a file handle to the new() method, it | |
2783 | will read parameters from the file (or STDIN, or whatever). The | |
2784 | file can be in any of the forms describing below under debugging | |
2785 | (i.e. a series of newline delimited TAG=VALUE pairs will work). | |
2786 | Conveniently, this type of file is created by the save() method | |
2787 | (see below). Multiple records can be saved and restored. | |
2788 | ||
2789 | Perl purists will be pleased to know that this syntax accepts | |
2790 | references to file handles, or even references to filehandle globs, | |
2791 | which is the "official" way to pass a filehandle: | |
2792 | ||
2793 | $query = new CGI(\*STDIN); | |
2794 | ||
2795 | You can also initialize the query object from an associative array | |
2796 | reference: | |
2797 | ||
2798 | $query = new CGI( {'dinosaur'=>'barney', | |
2799 | 'song'=>'I love you', | |
2800 | 'friends'=>[qw/Jessica George Nancy/]} | |
2801 | ); | |
2802 | ||
2803 | or from a properly formatted, URL-escaped query string: | |
2804 | ||
2805 | $query = new CGI('dinosaur=barney&color=purple'); | |
2806 | ||
2807 | To create an empty query, initialize it from an empty string or hash: | |
2808 | ||
2809 | $empty_query = new CGI(""); | |
2810 | -or- | |
2811 | $empty_query = new CGI({}); | |
2812 | ||
2813 | =head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY: | |
2814 | ||
2815 | @keywords = $query->keywords | |
2816 | ||
2817 | If the script was invoked as the result of an <ISINDEX> search, the | |
2818 | parsed keywords can be obtained as an array using the keywords() method. | |
2819 | ||
2820 | =head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT: | |
2821 | ||
2822 | @names = $query->param | |
2823 | ||
2824 | If the script was invoked with a parameter list | |
2825 | (e.g. "name1=value1&name2=value2&name3=value3"), the param() | |
2826 | method will return the parameter names as a list. If the | |
2827 | script was invoked as an <ISINDEX> script, there will be a | |
2828 | single parameter named 'keywords'. | |
2829 | ||
2830 | NOTE: As of version 1.5, the array of parameter names returned will | |
2831 | be in the same order as they were submitted by the browser. | |
2832 | Usually this order is the same as the order in which the | |
2833 | parameters are defined in the form (however, this isn't part | |
2834 | of the spec, and so isn't guaranteed). | |
2835 | ||
2836 | =head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER: | |
2837 | ||
2838 | @values = $query->param('foo'); | |
2839 | ||
2840 | -or- | |
2841 | ||
2842 | $value = $query->param('foo'); | |
2843 | ||
2844 | Pass the param() method a single argument to fetch the value of the | |
2845 | named parameter. If the parameter is multivalued (e.g. from multiple | |
2846 | selections in a scrolling list), you can ask to receive an array. Otherwise | |
2847 | the method will return a single value. | |
2848 | ||
2849 | =head2 SETTING THE VALUE(S) OF A NAMED PARAMETER: | |
2850 | ||
2851 | $query->param('foo','an','array','of','values'); | |
2852 | ||
2853 | This sets the value for the named parameter 'foo' to an array of | |
2854 | values. This is one way to change the value of a field AFTER | |
2855 | the script has been invoked once before. (Another way is with | |
2856 | the -override parameter accepted by all methods that generate | |
2857 | form elements.) | |
2858 | ||
2859 | param() also recognizes a named parameter style of calling described | |
2860 | in more detail later: | |
2861 | ||
2862 | $query->param(-name=>'foo',-values=>['an','array','of','values']); | |
2863 | ||
2864 | -or- | |
2865 | ||
2866 | $query->param(-name=>'foo',-value=>'the value'); | |
2867 | ||
2868 | =head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER: | |
2869 | ||
2870 | $query->append(-name=>;'foo',-values=>['yet','more','values']); | |
2871 | ||
2872 | This adds a value or list of values to the named parameter. The | |
2873 | values are appended to the end of the parameter if it already exists. | |
2874 | Otherwise the parameter is created. Note that this method only | |
2875 | recognizes the named argument calling syntax. | |
2876 | ||
2877 | =head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE: | |
2878 | ||
2879 | $query->import_names('R'); | |
2880 | ||
2881 | This creates a series of variables in the 'R' namespace. For example, | |
2882 | $R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear. | |
2883 | If no namespace is given, this method will assume 'Q'. | |
2884 | WARNING: don't import anything into 'main'; this is a major security | |
2885 | risk!!!! | |
2886 | ||
2887 | In older versions, this method was called B<import()>. As of version 2.20, | |
2888 | this name has been removed completely to avoid conflict with the built-in | |
2889 | Perl module B<import> operator. | |
2890 | ||
2891 | =head2 DELETING A PARAMETER COMPLETELY: | |
2892 | ||
2893 | $query->delete('foo'); | |
2894 | ||
2895 | This completely clears a parameter. It sometimes useful for | |
2896 | resetting parameters that you don't want passed down between | |
2897 | script invocations. | |
2898 | ||
2899 | =head2 DELETING ALL PARAMETERS: | |
2900 | ||
2901 | $query->delete_all(); | |
2902 | ||
2903 | This clears the CGI object completely. It might be useful to ensure | |
2904 | that all the defaults are taken when you create a fill-out form. | |
2905 | ||
2906 | =head2 SAVING THE STATE OF THE FORM TO A FILE: | |
2907 | ||
2908 | $query->save(FILEHANDLE) | |
2909 | ||
2910 | This will write the current state of the form to the provided | |
2911 | filehandle. You can read it back in by providing a filehandle | |
2912 | to the new() method. Note that the filehandle can be a file, a pipe, | |
2913 | or whatever! | |
2914 | ||
2915 | The format of the saved file is: | |
2916 | ||
2917 | NAME1=VALUE1 | |
2918 | NAME1=VALUE1' | |
2919 | NAME2=VALUE2 | |
2920 | NAME3=VALUE3 | |
2921 | = | |
2922 | ||
2923 | Both name and value are URL escaped. Multi-valued CGI parameters are | |
2924 | represented as repeated names. A session record is delimited by a | |
2925 | single = symbol. You can write out multiple records and read them | |
2926 | back in with several calls to B<new>. You can do this across several | |
2927 | sessions by opening the file in append mode, allowing you to create | |
2928 | primitive guest books, or to keep a history of users' queries. Here's | |
2929 | a short example of creating multiple session records: | |
2930 | ||
2931 | use CGI; | |
2932 | ||
2933 | open (OUT,">>test.out") || die; | |
2934 | $records = 5; | |
2935 | foreach (0..$records) { | |
2936 | my $q = new CGI; | |
2937 | $q->param(-name=>'counter',-value=>$_); | |
2938 | $q->save(OUT); | |
2939 | } | |
2940 | close OUT; | |
2941 | ||
2942 | # reopen for reading | |
2943 | open (IN,"test.out") || die; | |
2944 | while (!eof(IN)) { | |
2945 | my $q = new CGI(IN); | |
2946 | print $q->param('counter'),"\n"; | |
2947 | } | |
2948 | ||
2949 | The file format used for save/restore is identical to that used by the | |
2950 | Whitehead Genome Center's data exchange format "Boulderio", and can be | |
2951 | manipulated and even databased using Boulderio utilities. See | |
2952 | ||
2953 | http://www.genome.wi.mit.edu/genome_software/other/boulder.html | |
2954 | ||
2955 | for further details. | |
2956 | ||
2957 | =head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION: | |
2958 | ||
2959 | $myself = $query->self_url; | |
2960 | print "<A HREF=$myself>I'm talking to myself.</A>"; | |
2961 | ||
2962 | self_url() will return a URL, that, when selected, will reinvoke | |
2963 | this script with all its state information intact. This is most | |
2964 | useful when you want to jump around within the document using | |
2965 | internal anchors but you don't want to disrupt the current contents | |
2966 | of the form(s). Something like this will do the trick. | |
2967 | ||
2968 | $myself = $query->self_url; | |
2969 | print "<A HREF=$myself#table1>See table 1</A>"; | |
2970 | print "<A HREF=$myself#table2>See table 2</A>"; | |
2971 | print "<A HREF=$myself#yourself>See for yourself</A>"; | |
2972 | ||
2973 | If you don't want to get the whole query string, call | |
2974 | the method url() to return just the URL for the script: | |
2975 | ||
2976 | $myself = $query->url; | |
2977 | print "<A HREF=$myself>No query string in this baby!</A>\n"; | |
2978 | ||
2979 | You can also retrieve the unprocessed query string with query_string(): | |
2980 | ||
2981 | $the_string = $query->query_string; | |
2982 | ||
2983 | =head2 COMPATIBILITY WITH CGI-LIB.PL | |
2984 | ||
2985 | To make it easier to port existing programs that use cgi-lib.pl | |
2986 | the compatibility routine "ReadParse" is provided. Porting is | |
2987 | simple: | |
2988 | ||
2989 | OLD VERSION | |
2990 | require "cgi-lib.pl"; | |
2991 | &ReadParse; | |
2992 | print "The value of the antique is $in{antique}.\n"; | |
2993 | ||
2994 | NEW VERSION | |
2995 | use CGI; | |
2996 | CGI::ReadParse | |
2997 | print "The value of the antique is $in{antique}.\n"; | |
2998 | ||
2999 | CGI.pm's ReadParse() routine creates a tied variable named %in, | |
3000 | which can be accessed to obtain the query variables. Like | |
3001 | ReadParse, you can also provide your own variable. Infrequently | |
3002 | used features of ReadParse, such as the creation of @in and $in | |
3003 | variables, are not supported. | |
3004 | ||
3005 | Once you use ReadParse, you can retrieve the query object itself | |
3006 | this way: | |
3007 | ||
3008 | $q = $in{CGI}; | |
3009 | print $q->textfield(-name=>'wow', | |
3010 | -value=>'does this really work?'); | |
3011 | ||
3012 | This allows you to start using the more interesting features | |
3013 | of CGI.pm without rewriting your old scripts from scratch. | |
3014 | ||
3015 | =head2 CALLING CGI FUNCTIONS THAT TAKE MULTIPLE ARGUMENTS | |
3016 | ||
3017 | In versions of CGI.pm prior to 2.0, it could get difficult to remember | |
3018 | the proper order of arguments in CGI function calls that accepted five | |
3019 | or six different arguments. As of 2.0, there's a better way to pass | |
3020 | arguments to the various CGI functions. In this style, you pass a | |
3021 | series of name=>argument pairs, like this: | |
3022 | ||
3023 | $field = $query->radio_group(-name=>'OS', | |
3024 | -values=>[Unix,Windows,Macintosh], | |
3025 | -default=>'Unix'); | |
3026 | ||
3027 | The advantages of this style are that you don't have to remember the | |
3028 | exact order of the arguments, and if you leave out a parameter, in | |
3029 | most cases it will default to some reasonable value. If you provide | |
3030 | a parameter that the method doesn't recognize, it will usually do | |
3031 | something useful with it, such as incorporating it into the HTML form | |
3032 | tag. For example if Netscape decides next week to add a new | |
3033 | JUSTIFICATION parameter to the text field tags, you can start using | |
3034 | the feature without waiting for a new version of CGI.pm: | |
3035 | ||
3036 | $field = $query->textfield(-name=>'State', | |
3037 | -default=>'gaseous', | |
3038 | -justification=>'RIGHT'); | |
3039 | ||
3040 | This will result in an HTML tag that looks like this: | |
3041 | ||
3042 | <INPUT TYPE="textfield" NAME="State" VALUE="gaseous" | |
3043 | JUSTIFICATION="RIGHT"> | |
3044 | ||
3045 | Parameter names are case insensitive: you can use -name, or -Name or | |
3046 | -NAME. You don't have to use the hyphen if you don't want to. After | |
3047 | creating a CGI object, call the B<use_named_parameters()> method with | |
3048 | a nonzero value. This will tell CGI.pm that you intend to use named | |
3049 | parameters exclusively: | |
3050 | ||
3051 | $query = new CGI; | |
3052 | $query->use_named_parameters(1); | |
3053 | $field = $query->radio_group('name'=>'OS', | |
3054 | 'values'=>['Unix','Windows','Macintosh'], | |
3055 | 'default'=>'Unix'); | |
3056 | ||
3057 | Actually, CGI.pm only looks for a hyphen in the first parameter. So | |
3058 | you can leave it off subsequent parameters if you like. Something to | |
3059 | be wary of is the potential that a string constant like "values" will | |
3060 | collide with a keyword (and in fact it does!) While Perl usually | |
3061 | figures out when you're referring to a function and when you're | |
3062 | referring to a string, you probably should put quotation marks around | |
3063 | all string constants just to play it safe. | |
3064 | ||
3065 | =head2 CREATING THE HTTP HEADER: | |
3066 | ||
3067 | print $query->header; | |
3068 | ||
3069 | -or- | |
3070 | ||
3071 | print $query->header('image/gif'); | |
3072 | ||
3073 | -or- | |
3074 | ||
3075 | print $query->header('text/html','204 No response'); | |
3076 | ||
3077 | -or- | |
3078 | ||
3079 | print $query->header(-type=>'image/gif', | |
3080 | -nph=>1, | |
3081 | -status=>'402 Payment required', | |
3082 | -expires=>'+3d', | |
3083 | -cookie=>$cookie, | |
3084 | -Cost=>'$2.00'); | |
3085 | ||
3086 | header() returns the Content-type: header. You can provide your own | |
3087 | MIME type if you choose, otherwise it defaults to text/html. An | |
3088 | optional second parameter specifies the status code and a human-readable | |
3089 | message. For example, you can specify 204, "No response" to create a | |
3090 | script that tells the browser to do nothing at all. If you want to | |
3091 | add additional fields to the header, just tack them on to the end: | |
3092 | ||
3093 | print $query->header('text/html','200 OK','Content-Length: 3002'); | |
3094 | ||
3095 | The last example shows the named argument style for passing arguments | |
3096 | to the CGI methods using named parameters. Recognized parameters are | |
3097 | B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other | |
3098 | parameters will be stripped of their initial hyphens and turned into | |
3099 | header fields, allowing you to specify any HTTP header you desire. | |
3100 | ||
3101 | Most browsers will not cache the output from CGI scripts. Every time | |
3102 | the browser reloads the page, the script is invoked anew. You can | |
3103 | change this behavior with the B<-expires> parameter. When you specify | |
3104 | an absolute or relative expiration interval with this parameter, some | |
3105 | browsers and proxy servers will cache the script's output until the | |
3106 | indicated expiration date. The following forms are all valid for the | |
3107 | -expires field: | |
3108 | ||
3109 | +30s 30 seconds from now | |
3110 | +10m ten minutes from now | |
3111 | +1h one hour from now | |
3112 | -1d yesterday (i.e. "ASAP!") | |
3113 | now immediately | |
3114 | +3M in three months | |
3115 | +10y in ten years time | |
3116 | Thursday, 25-Apr-96 00:40:33 GMT at the indicated time & date | |
3117 | ||
3118 | (CGI::expires() is the static function call used internally that turns | |
3119 | relative time intervals into HTTP dates. You can call it directly if | |
3120 | you wish.) | |
3121 | ||
3122 | The B<-cookie> parameter generates a header that tells the browser to provide | |
3123 | a "magic cookie" during all subsequent transactions with your script. | |
3124 | Netscape cookies have a special format that includes interesting attributes | |
3125 | such as expiration time. Use the cookie() method to create and retrieve | |
3126 | session cookies. | |
3127 | ||
3128 | The B<-nph> parameter, if set to a true value, will issue the correct | |
3129 | headers to work with a NPH (no-parse-header) script. This is important | |
3130 | to use with certain servers, such as Microsoft Internet Explorer, which | |
3131 | expect all their scripts to be NPH. | |
3132 | ||
3133 | =head2 GENERATING A REDIRECTION INSTRUCTION | |
3134 | ||
3135 | print $query->redirect('http://somewhere.else/in/movie/land'); | |
3136 | ||
3137 | redirects the browser elsewhere. If you use redirection like this, | |
3138 | you should B<not> print out a header as well. As of version 2.0, we | |
3139 | produce both the unofficial Location: header and the official URI: | |
3140 | header. This should satisfy most servers and browsers. | |
3141 | ||
3142 | One hint I can offer is that relative links may not work correctly | |
7a2e2cd6 | 3143 | when you generate a redirection to another document on your site. |
54310121 | 3144 | This is due to a well-intentioned optimization that some servers use. |
3145 | The solution to this is to use the full URL (including the http: part) | |
3146 | of the document you are redirecting to. | |
3147 | ||
3148 | You can use named parameters: | |
3149 | ||
3150 | print $query->redirect(-uri=>'http://somewhere.else/in/movie/land', | |
3151 | -nph=>1); | |
3152 | ||
3153 | The B<-nph> parameter, if set to a true value, will issue the correct | |
3154 | headers to work with a NPH (no-parse-header) script. This is important | |
3155 | to use with certain servers, such as Microsoft Internet Explorer, which | |
3156 | expect all their scripts to be NPH. | |
3157 | ||
3158 | ||
3159 | =head2 CREATING THE HTML HEADER: | |
3160 | ||
3161 | print $query->start_html(-title=>'Secrets of the Pyramids', | |
3162 | -author=>'fred@capricorn.org', | |
3163 | -base=>'true', | |
3164 | -target=>'_blank', | |
3165 | -meta=>{'keywords'=>'pharaoh secret mummy', | |
3166 | 'copyright'=>'copyright 1996 King Tut'}, | |
3167 | -BGCOLOR=>'blue'); | |
3168 | ||
3169 | -or- | |
3170 | ||
3171 | print $query->start_html('Secrets of the Pyramids', | |
3172 | 'fred@capricorn.org','true', | |
3173 | 'BGCOLOR="blue"'); | |
3174 | ||
3175 | This will return a canned HTML header and the opening <BODY> tag. | |
3176 | All parameters are optional. In the named parameter form, recognized | |
3177 | parameters are -title, -author, -base, -xbase and -target (see below for the | |
3178 | explanation). Any additional parameters you provide, such as the | |
3179 | Netscape unofficial BGCOLOR attribute, are added to the <BODY> tag. | |
3180 | ||
3181 | The argument B<-xbase> allows you to provide an HREF for the <BASE> tag | |
3182 | different from the current location, as in | |
3183 | ||
3184 | -xbase=>"http://home.mcom.com/" | |
3185 | ||
3186 | All relative links will be interpreted relative to this tag. | |
3187 | ||
3188 | The argument B<-target> allows you to provide a default target frame | |
3189 | for all the links and fill-out forms on the page. See the Netscape | |
3190 | documentation on frames for details of how to manipulate this. | |
3191 | ||
3192 | -target=>"answer_window" | |
3193 | ||
3194 | All relative links will be interpreted relative to this tag. | |
3195 | You add arbitrary meta information to the header with the B<-meta> | |
3196 | argument. This argument expects a reference to an associative array | |
3197 | containing name/value pairs of meta information. These will be turned | |
3198 | into a series of header <META> tags that look something like this: | |
3199 | ||
3200 | <META NAME="keywords" CONTENT="pharaoh secret mummy"> | |
3201 | <META NAME="description" CONTENT="copyright 1996 King Tut"> | |
3202 | ||
3203 | There is no support for the HTTP-EQUIV type of <META> tag. This is | |
3204 | because you can modify the HTTP header directly with the B<header()> | |
3205 | method. | |
3206 | ||
3207 | JAVASCRIPTING: The B<-script>, B<-onLoad> and B<-onUnload> parameters | |
3208 | are used to add Netscape JavaScript calls to your pages. B<-script> | |
3209 | should point to a block of text containing JavaScript function | |
3210 | definitions. This block will be placed within a <SCRIPT> block inside | |
3211 | the HTML (not HTTP) header. The block is placed in the header in | |
3212 | order to give your page a fighting chance of having all its JavaScript | |
3213 | functions in place even if the user presses the stop button before the | |
3214 | page has loaded completely. CGI.pm attempts to format the script in | |
3215 | such a way that JavaScript-naive browsers will not choke on the code: | |
3216 | unfortunately there are some browsers, such as Chimera for Unix, that | |
3217 | get confused by it nevertheless. | |
3218 | ||
3219 | The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript | |
3220 | code to execute when the page is respectively opened and closed by the | |
3221 | browser. Usually these parameters are calls to functions defined in the | |
3222 | B<-script> field: | |
3223 | ||
3224 | $query = new CGI; | |
3225 | print $query->header; | |
3226 | $JSCRIPT=<<END; | |
3227 | // Ask a silly question | |
3228 | function riddle_me_this() { | |
3229 | var r = prompt("What walks on four legs in the morning, " + | |
3230 | "two legs in the afternoon, " + | |
3231 | "and three legs in the evening?"); | |
3232 | response(r); | |
3233 | } | |
3234 | // Get a silly answer | |
3235 | function response(answer) { | |
3236 | if (answer == "man") | |
3237 | alert("Right you are!"); | |
3238 | else | |
3239 | alert("Wrong! Guess again."); | |
3240 | } | |
3241 | END | |
3242 | print $query->start_html(-title=>'The Riddle of the Sphinx', | |
3243 | -script=>$JSCRIPT); | |
3244 | ||
3245 | See | |
3246 | ||
3247 | http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/ | |
3248 | ||
3249 | for more information about JavaScript. | |
3250 | ||
3251 | The old-style positional parameters are as follows: | |
3252 | ||
3253 | =over 4 | |
3254 | ||
3255 | =item B<Parameters:> | |
3256 | ||
3257 | =item 1. | |
3258 | ||
3259 | The title | |
3260 | ||
3261 | =item 2. | |
3262 | ||
3263 | The author's e-mail address (will create a <LINK REV="MADE"> tag if present | |
3264 | ||
3265 | =item 3. | |
3266 | ||
3267 | A 'true' flag if you want to include a <BASE> tag in the header. This | |
3268 | helps resolve relative addresses to absolute ones when the document is moved, | |
3269 | but makes the document hierarchy non-portable. Use with care! | |
3270 | ||
3271 | =item 4, 5, 6... | |
3272 | ||
3273 | Any other parameters you want to include in the <BODY> tag. This is a good | |
3274 | place to put Netscape extensions, such as colors and wallpaper patterns. | |
3275 | ||
3276 | =back | |
3277 | ||
3278 | =head2 ENDING THE HTML DOCUMENT: | |
3279 | ||
3280 | print $query->end_html | |
3281 | ||
3282 | This ends an HTML document by printing the </BODY></HTML> tags. | |
3283 | ||
3284 | =head1 CREATING FORMS: | |
3285 | ||
3286 | I<General note> The various form-creating methods all return strings | |
3287 | to the caller, containing the tag or tags that will create the requested | |
3288 | form element. You are responsible for actually printing out these strings. | |
3289 | It's set up this way so that you can place formatting tags | |
3290 | around the form elements. | |
3291 | ||
3292 | I<Another note> The default values that you specify for the forms are only | |
3293 | used the B<first> time the script is invoked (when there is no query | |
3294 | string). On subsequent invocations of the script (when there is a query | |
3295 | string), the former values are used even if they are blank. | |
3296 | ||
3297 | If you want to change the value of a field from its previous value, you have two | |
3298 | choices: | |
3299 | ||
3300 | (1) call the param() method to set it. | |
3301 | ||
3302 | (2) use the -override (alias -force) parameter (a new feature in version 2.15). | |
3303 | This forces the default value to be used, regardless of the previous value: | |
3304 | ||
3305 | print $query->textfield(-name=>'field_name', | |
3306 | -default=>'starting value', | |
3307 | -override=>1, | |
3308 | -size=>50, | |
3309 | -maxlength=>80); | |
3310 | ||
3311 | I<Yet another note> By default, the text and labels of form elements are | |
3312 | escaped according to HTML rules. This means that you can safely use | |
3313 | "<CLICK ME>" as the label for a button. However, it also interferes with | |
3314 | your ability to incorporate special HTML character sequences, such as Á, | |
3315 | into your fields. If you wish to turn off automatic escaping, call the | |
3316 | autoEscape() method with a false value immediately after creating the CGI object: | |
3317 | ||
3318 | $query = new CGI; | |
3319 | $query->autoEscape(undef); | |
3320 | ||
3321 | ||
3322 | =head2 CREATING AN ISINDEX TAG | |
3323 | ||
3324 | print $query->isindex(-action=>$action); | |
3325 | ||
3326 | -or- | |
3327 | ||
3328 | print $query->isindex($action); | |
3329 | ||
3330 | Prints out an <ISINDEX> tag. Not very exciting. The parameter | |
3331 | -action specifies the URL of the script to process the query. The | |
3332 | default is to process the query with the current script. | |
3333 | ||
3334 | =head2 STARTING AND ENDING A FORM | |
3335 | ||
3336 | print $query->startform(-method=>$method, | |
3337 | -action=>$action, | |
3338 | -encoding=>$encoding); | |
3339 | <... various form stuff ...> | |
3340 | print $query->endform; | |
3341 | ||
3342 | -or- | |
3343 | ||
3344 | print $query->startform($method,$action,$encoding); | |
3345 | <... various form stuff ...> | |
3346 | print $query->endform; | |
3347 | ||
3348 | startform() will return a <FORM> tag with the optional method, | |
3349 | action and form encoding that you specify. The defaults are: | |
3350 | ||
3351 | method: POST | |
3352 | action: this script | |
3353 | encoding: application/x-www-form-urlencoded | |
3354 | ||
3355 | endform() returns the closing </FORM> tag. | |
3356 | ||
3357 | Startform()'s encoding method tells the browser how to package the various | |
3358 | fields of the form before sending the form to the server. Two | |
3359 | values are possible: | |
3360 | ||
3361 | =over 4 | |
3362 | ||
3363 | =item B<application/x-www-form-urlencoded> | |
3364 | ||
3365 | This is the older type of encoding used by all browsers prior to | |
3366 | Netscape 2.0. It is compatible with many CGI scripts and is | |
3367 | suitable for short fields containing text data. For your | |
3368 | convenience, CGI.pm stores the name of this encoding | |
3369 | type in B<$CGI::URL_ENCODED>. | |
3370 | ||
3371 | =item B<multipart/form-data> | |
3372 | ||
3373 | This is the newer type of encoding introduced by Netscape 2.0. | |
3374 | It is suitable for forms that contain very large fields or that | |
3375 | are intended for transferring binary data. Most importantly, | |
3376 | it enables the "file upload" feature of Netscape 2.0 forms. For | |
3377 | your convenience, CGI.pm stores the name of this encoding type | |
3378 | in B<$CGI::MULTIPART> | |
3379 | ||
3380 | Forms that use this type of encoding are not easily interpreted | |
3381 | by CGI scripts unless they use CGI.pm or another library designed | |
3382 | to handle them. | |
3383 | ||
3384 | =back | |
3385 | ||
3386 | For compatibility, the startform() method uses the older form of | |
3387 | encoding by default. If you want to use the newer form of encoding | |
3388 | by default, you can call B<start_multipart_form()> instead of | |
3389 | B<startform()>. | |
3390 | ||
3391 | JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided | |
3392 | for use with JavaScript. The -name parameter gives the | |
3393 | form a name so that it can be identified and manipulated by | |
3394 | JavaScript functions. -onSubmit should point to a JavaScript | |
3395 | function that will be executed just before the form is submitted to your | |
3396 | server. You can use this opportunity to check the contents of the form | |
3397 | for consistency and completeness. If you find something wrong, you | |
3398 | can put up an alert box or maybe fix things up yourself. You can | |
3399 | abort the submission by returning false from this function. | |
3400 | ||
3401 | Usually the bulk of JavaScript functions are defined in a <SCRIPT> | |
3402 | block in the HTML header and -onSubmit points to one of these function | |
3403 | call. See start_html() for details. | |
3404 | ||
3405 | =head2 CREATING A TEXT FIELD | |
3406 | ||
3407 | print $query->textfield(-name=>'field_name', | |
3408 | -default=>'starting value', | |
3409 | -size=>50, | |
3410 | -maxlength=>80); | |
3411 | -or- | |
3412 | ||
3413 | print $query->textfield('field_name','starting value',50,80); | |
3414 | ||
3415 | textfield() will return a text input field. | |
3416 | ||
3417 | =over 4 | |
3418 | ||
3419 | =item B<Parameters> | |
3420 | ||
3421 | =item 1. | |
3422 | ||
3423 | The first parameter is the required name for the field (-name). | |
3424 | ||
3425 | =item 2. | |
3426 | ||
3427 | The optional second parameter is the default starting value for the field | |
3428 | contents (-default). | |
3429 | ||
3430 | =item 3. | |
3431 | ||
3432 | The optional third parameter is the size of the field in | |
3433 | characters (-size). | |
3434 | ||
3435 | =item 4. | |
3436 | ||
3437 | The optional fourth parameter is the maximum number of characters the | |
3438 | field will accept (-maxlength). | |
3439 | ||
3440 | =back | |
3441 | ||
3442 | As with all these methods, the field will be initialized with its | |
3443 | previous contents from earlier invocations of the script. | |
3444 | When the form is processed, the value of the text field can be | |
3445 | retrieved with: | |
3446 | ||
3447 | $value = $query->param('foo'); | |
3448 | ||
3449 | If you want to reset it from its initial value after the script has been | |
3450 | called once, you can do so like this: | |
3451 | ||
3452 | $query->param('foo',"I'm taking over this value!"); | |
3453 | ||
3454 | NEW AS OF VERSION 2.15: If you don't want the field to take on its previous | |
3455 | value, you can force its current value by using the -override (alias -force) | |
3456 | parameter: | |
3457 | ||
3458 | print $query->textfield(-name=>'field_name', | |
3459 | -default=>'starting value', | |
3460 | -override=>1, | |
3461 | -size=>50, | |
3462 | -maxlength=>80); | |
3463 | ||
3464 | JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>, B<-onBlur> | |
3465 | and B<-onSelect> parameters to register JavaScript event handlers. | |
3466 | The onChange handler will be called whenever the user changes the | |
3467 | contents of the text field. You can do text validation if you like. | |
3468 | onFocus and onBlur are called respectively when the insertion point | |
3469 | moves into and out of the text field. onSelect is called when the | |
3470 | user changes the portion of the text that is selected. | |
3471 | ||
3472 | =head2 CREATING A BIG TEXT FIELD | |
3473 | ||
3474 | print $query->textarea(-name=>'foo', | |
3475 | -default=>'starting value', | |
3476 | -rows=>10, | |
3477 | -columns=>50); | |
3478 | ||
3479 | -or | |
3480 | ||
3481 | print $query->textarea('foo','starting value',10,50); | |
3482 | ||
3483 | textarea() is just like textfield, but it allows you to specify | |
3484 | rows and columns for a multiline text entry box. You can provide | |
3485 | a starting value for the field, which can be long and contain | |
3486 | multiple lines. | |
3487 | ||
3488 | JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> | |
3489 | and B<-onSelect> parameters are recognized. See textfield(). | |
3490 | ||
3491 | =head2 CREATING A PASSWORD FIELD | |
3492 | ||
3493 | print $query->password_field(-name=>'secret', | |
3494 | -value=>'starting value', | |
3495 | -size=>50, | |
3496 | -maxlength=>80); | |
3497 | -or- | |
3498 | ||
3499 | print $query->password_field('secret','starting value',50,80); | |
3500 | ||
3501 | password_field() is identical to textfield(), except that its contents | |
3502 | will be starred out on the web page. | |
3503 | ||
3504 | JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> | |
3505 | and B<-onSelect> parameters are recognized. See textfield(). | |
3506 | ||
3507 | =head2 CREATING A FILE UPLOAD FIELD | |
3508 | ||
3509 | print $query->filefield(-name=>'uploaded_file', | |
3510 | -default=>'starting value', | |
3511 | -size=>50, | |
3512 | -maxlength=>80); | |
3513 | -or- | |
3514 | ||
3515 | print $query->filefield('uploaded_file','starting value',50,80); | |
3516 | ||
3517 | filefield() will return a file upload field for Netscape 2.0 browsers. | |
3518 | In order to take full advantage of this I<you must use the new | |
3519 | multipart encoding scheme> for the form. You can do this either | |
3520 | by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>, | |
3521 | or by calling the new method B<start_multipart_form()> instead of | |
3522 | vanilla B<startform()>. | |
3523 | ||
3524 | =over 4 | |
3525 | ||
3526 | =item B<Parameters> | |
3527 | ||
3528 | =item 1. | |
3529 | ||
3530 | The first parameter is the required name for the field (-name). | |
3531 | ||
3532 | =item 2. | |
3533 | ||
3534 | The optional second parameter is the starting value for the field contents | |
3535 | to be used as the default file name (-default). | |
3536 | ||
3537 | The beta2 version of Netscape 2.0 currently doesn't pay any attention | |
3538 | to this field, and so the starting value will always be blank. Worse, | |
3539 | the field loses its "sticky" behavior and forgets its previous | |
3540 | contents. The starting value field is called for in the HTML | |
3541 | specification, however, and possibly later versions of Netscape will | |
3542 | honor it. | |
3543 | ||
3544 | =item 3. | |
3545 | ||
3546 | The optional third parameter is the size of the field in | |
3547 | characters (-size). | |
3548 | ||
3549 | =item 4. | |
3550 | ||
3551 | The optional fourth parameter is the maximum number of characters the | |
3552 | field will accept (-maxlength). | |
3553 | ||
3554 | =back | |
3555 | ||
3556 | When the form is processed, you can retrieve the entered filename | |
3557 | by calling param(). | |
3558 | ||
3559 | $filename = $query->param('uploaded_file'); | |
3560 | ||
3561 | In Netscape Gold, the filename that gets returned is the full local filename | |
3562 | on the B<remote user's> machine. If the remote user is on a Unix | |
3563 | machine, the filename will follow Unix conventions: | |
3564 | ||
3565 | /path/to/the/file | |
3566 | ||
3567 | On an MS-DOS/Windows and OS/2 machines, the filename will follow DOS conventions: | |
3568 | ||
3569 | C:\PATH\TO\THE\FILE.MSW | |
3570 | ||
3571 | On a Macintosh machine, the filename will follow Mac conventions: | |
3572 | ||
3573 | HD 40:Desktop Folder:Sort Through:Reminders | |
3574 | ||
3575 | The filename returned is also a file handle. You can read the contents | |
3576 | of the file using standard Perl file reading calls: | |
3577 | ||
3578 | # Read a text file and print it out | |
3579 | while (<$filename>) { | |
3580 | print; | |
3581 | } | |
3582 | ||
3583 | # Copy a binary file to somewhere safe | |
3584 | open (OUTFILE,">>/usr/local/web/users/feedback"); | |
3585 | while ($bytesread=read($filename,$buffer,1024)) { | |
3586 | print OUTFILE $buffer; | |
3587 | } | |
3588 | ||
3589 | When a file is uploaded the browser usually sends along some | |
3590 | information along with it in the format of headers. The information | |
3591 | usually includes the MIME content type. Future browsers may send | |
3592 | other information as well (such as modification date and size). To | |
3593 | retrieve this information, call uploadInfo(). It returns a reference to | |
3594 | an associative array containing all the document headers. | |
3595 | ||
3596 | $filename = $query->param('uploaded_file'); | |
3597 | $type = $query->uploadInfo($filename)->{'Content-Type'}; | |
3598 | unless ($type eq 'text/html') { | |
3599 | die "HTML FILES ONLY!"; | |
3600 | } | |
3601 | ||
3602 | If you are using a machine that recognizes "text" and "binary" data | |
3603 | modes, be sure to understand when and how to use them (see the Camel book). | |
3604 | Otherwise you may find that binary files are corrupted during file uploads. | |
3605 | ||
3606 | JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> | |
3607 | and B<-onSelect> parameters are recognized. See textfield() | |
3608 | for details. | |
3609 | ||
3610 | =head2 CREATING A POPUP MENU | |
3611 | ||
3612 | print $query->popup_menu('menu_name', | |
3613 | ['eenie','meenie','minie'], | |
3614 | 'meenie'); | |
3615 | ||
3616 | -or- | |
3617 | ||
3618 | %labels = ('eenie'=>'your first choice', | |
3619 | 'meenie'=>'your second choice', | |
3620 | 'minie'=>'your third choice'); | |
3621 | print $query->popup_menu('menu_name', | |
3622 | ['eenie','meenie','minie'], | |
3623 | 'meenie',\%labels); | |
3624 | ||
3625 | -or (named parameter style)- | |
3626 | ||
3627 | print $query->popup_menu(-name=>'menu_name', | |
3628 | -values=>['eenie','meenie','minie'], | |
3629 | -default=>'meenie', | |
3630 | -labels=>\%labels); | |
3631 | ||
3632 | popup_menu() creates a menu. | |
3633 | ||
3634 | =over 4 | |
3635 | ||
3636 | =item 1. | |
3637 | ||
3638 | The required first argument is the menu's name (-name). | |
3639 | ||
3640 | =item 2. | |
3641 | ||
3642 | The required second argument (-values) is an array B<reference> | |
3643 | containing the list of menu items in the menu. You can pass the | |
3644 | method an anonymous array, as shown in the example, or a reference to | |
3645 | a named array, such as "\@foo". | |
3646 | ||
3647 | =item 3. | |
3648 | ||
3649 | The optional third parameter (-default) is the name of the default | |
3650 | menu choice. If not specified, the first item will be the default. | |
3651 | The values of the previous choice will be maintained across queries. | |
3652 | ||
3653 | =item 4. | |
3654 | ||
3655 | The optional fourth parameter (-labels) is provided for people who | |
3656 | want to use different values for the user-visible label inside the | |
3657 | popup menu nd the value returned to your script. It's a pointer to an | |
3658 | associative array relating menu values to user-visible labels. If you | |
3659 | leave this parameter blank, the menu values will be displayed by | |
3660 | default. (You can also leave a label undefined if you want to). | |
3661 | ||
3662 | =back | |
3663 | ||
3664 | When the form is processed, the selected value of the popup menu can | |
3665 | be retrieved using: | |
3666 | ||
3667 | $popup_menu_value = $query->param('menu_name'); | |
3668 | ||
3669 | JAVASCRIPTING: popup_menu() recognizes the following event handlers: | |
3670 | B<-onChange>, B<-onFocus>, and B<-onBlur>. See the textfield() | |
3671 | section for details on when these handlers are called. | |
3672 | ||
3673 | =head2 CREATING A SCROLLING LIST | |
3674 | ||
3675 | print $query->scrolling_list('list_name', | |
3676 | ['eenie','meenie','minie','moe'], | |
3677 | ['eenie','moe'],5,'true'); | |
3678 | -or- | |
3679 | ||
3680 | print $query->scrolling_list('list_name', | |
3681 | ['eenie','meenie','minie','moe'], | |
3682 | ['eenie','moe'],5,'true', | |
3683 | \%labels); | |
3684 | ||
3685 | -or- | |
3686 | ||
3687 | print $query->scrolling_list(-name=>'list_name', | |
3688 | -values=>['eenie','meenie','minie','moe'], | |
3689 | -default=>['eenie','moe'], | |
3690 | -size=>5, | |
3691 | -multiple=>'true', | |
3692 | -labels=>\%labels); | |
3693 | ||
3694 | scrolling_list() creates a scrolling list. | |
3695 | ||
3696 | =over 4 | |
3697 | ||
3698 | =item B<Parameters:> | |
3699 | ||
3700 | =item 1. | |
3701 | ||
3702 | The first and second arguments are the list name (-name) and values | |
3703 | (-values). As in the popup menu, the second argument should be an | |
3704 | array reference. | |
3705 | ||
3706 | =item 2. | |
3707 | ||
3708 | The optional third argument (-default) can be either a reference to a | |
3709 | list containing the values to be selected by default, or can be a | |
3710 | single value to select. If this argument is missing or undefined, | |
3711 | then nothing is selected when the list first appears. In the named | |
3712 | parameter version, you can use the synonym "-defaults" for this | |
3713 | parameter. | |
3714 | ||
3715 | =item 3. | |
3716 | ||
3717 | The optional fourth argument is the size of the list (-size). | |
3718 | ||
3719 | =item 4. | |
3720 | ||
3721 | The optional fifth argument can be set to true to allow multiple | |
3722 | simultaneous selections (-multiple). Otherwise only one selection | |
3723 | will be allowed at a time. | |
3724 | ||
3725 | =item 5. | |
3726 | ||
3727 | The optional sixth argument is a pointer to an associative array | |
3728 | containing long user-visible labels for the list items (-labels). | |
3729 | If not provided, the values will be displayed. | |
3730 | ||
3731 | When this form is processed, all selected list items will be returned as | |
3732 | a list under the parameter name 'list_name'. The values of the | |
3733 | selected items can be retrieved with: | |
3734 | ||
3735 | @selected = $query->param('list_name'); | |
3736 | ||
3737 | =back | |
3738 | ||
3739 | JAVASCRIPTING: scrolling_list() recognizes the following event handlers: | |
3740 | B<-onChange>, B<-onFocus>, and B<-onBlur>. See textfield() for | |
3741 | the description of when these handlers are called. | |
3742 | ||
3743 | =head2 CREATING A GROUP OF RELATED CHECKBOXES | |
3744 | ||
3745 | print $query->checkbox_group(-name=>'group_name', | |
3746 | -values=>['eenie','meenie','minie','moe'], | |
3747 | -default=>['eenie','moe'], | |
3748 | -linebreak=>'true', | |
3749 | -labels=>\%labels); | |
3750 | ||
3751 | print $query->checkbox_group('group_name', | |
3752 | ['eenie','meenie','minie','moe'], | |
3753 | ['eenie','moe'],'true',\%labels); | |
3754 | ||
3755 | HTML3-COMPATIBLE BROWSERS ONLY: | |
3756 | ||
3757 | print $query->checkbox_group(-name=>'group_name', | |
3758 | -values=>['eenie','meenie','minie','moe'], | |
3759 | -rows=2,-columns=>2); | |
3760 | ||
3761 | ||
3762 | checkbox_group() creates a list of checkboxes that are related | |
3763 | by the same name. | |
3764 | ||
3765 | =over 4 | |
3766 | ||
3767 | =item B<Parameters:> | |
3768 | ||
3769 | =item 1. | |
3770 | ||
3771 | The first and second arguments are the checkbox name and values, | |
3772 | respectively (-name and -values). As in the popup menu, the second | |
3773 | argument should be an array reference. These values are used for the | |
3774 | user-readable labels printed next to the checkboxes as well as for the | |
3775 | values passed to your script in the query string. | |
3776 | ||
3777 | =item 2. | |
3778 | ||
3779 | The optional third argument (-default) can be either a reference to a | |
3780 | list containing the values to be checked by default, or can be a | |
3781 | single value to checked. If this argument is missing or undefined, | |
3782 | then nothing is selected when the list first appears. | |
3783 | ||
3784 | =item 3. | |
3785 | ||
3786 | The optional fourth argument (-linebreak) can be set to true to place | |
3787 | line breaks between the checkboxes so that they appear as a vertical | |
3788 | list. Otherwise, they will be strung together on a horizontal line. | |
3789 | ||
3790 | =item 4. | |
3791 | ||
3792 | The optional fifth argument is a pointer to an associative array | |
7a2e2cd6 | 3793 | relating the checkbox values to the user-visible labels that will |
54310121 | 3794 | be printed next to them (-labels). If not provided, the values will |
3795 | be used as the default. | |
3796 | ||
3797 | =item 5. | |
3798 | ||
3799 | B<HTML3-compatible browsers> (such as Netscape) can take advantage | |
3800 | of the optional | |
3801 | parameters B<-rows>, and B<-columns>. These parameters cause | |
3802 | checkbox_group() to return an HTML3 compatible table containing | |
3803 | the checkbox group formatted with the specified number of rows | |
3804 | and columns. You can provide just the -columns parameter if you | |
3805 | wish; checkbox_group will calculate the correct number of rows | |
3806 | for you. | |
3807 | ||
3808 | To include row and column headings in the returned table, you | |
3809 | can use the B<-rowheader> and B<-colheader> parameters. Both | |
3810 | of these accept a pointer to an array of headings to use. | |
3811 | The headings are just decorative. They don't reorganize the | |
3812 | interpretation of the checkboxes -- they're still a single named | |
3813 | unit. | |
3814 | ||
3815 | =back | |
3816 | ||
3817 | When the form is processed, all checked boxes will be returned as | |
3818 | a list under the parameter name 'group_name'. The values of the | |
3819 | "on" checkboxes can be retrieved with: | |
3820 | ||
3821 | @turned_on = $query->param('group_name'); | |
3822 | ||
3823 | The value returned by checkbox_group() is actually an array of button | |
3824 | elements. You can capture them and use them within tables, lists, | |
3825 | or in other creative ways: | |
3826 | ||
3827 | @h = $query->checkbox_group(-name=>'group_name',-values=>\@values); | |
3828 | &use_in_creative_way(@h); | |
3829 | ||
3830 | JAVASCRIPTING: checkbox_group() recognizes the B<-onClick> | |
3831 | parameter. This specifies a JavaScript code fragment or | |
3832 | function call to be executed every time the user clicks on | |
3833 | any of the buttons in the group. You can retrieve the identity | |
3834 | of the particular button clicked on using the "this" variable. | |
3835 | ||
3836 | =head2 CREATING A STANDALONE CHECKBOX | |
3837 | ||
3838 | print $query->checkbox(-name=>'checkbox_name', | |
3839 | -checked=>'checked', | |
3840 | -value=>'ON', | |
3841 | -label=>'CLICK ME'); | |
3842 | ||
3843 | -or- | |
3844 | ||
3845 | print $query->checkbox('checkbox_name','checked','ON','CLICK ME'); | |
3846 | ||
3847 | checkbox() is used to create an isolated checkbox that isn't logically | |
3848 | related to any others. | |
3849 | ||
3850 | =over 4 | |
3851 | ||
3852 | =item B<Parameters:> | |
3853 | ||
3854 | =item 1. | |
3855 | ||
3856 | The first parameter is the required name for the checkbox (-name). It | |
3857 | will also be used for the user-readable label printed next to the | |
3858 | checkbox. | |
3859 | ||
3860 | =item 2. | |
3861 | ||
3862 | The optional second parameter (-checked) specifies that the checkbox | |
3863 | is turned on by default. Synonyms are -selected and -on. | |
3864 | ||
3865 | =item 3. | |
3866 | ||
3867 | The optional third parameter (-value) specifies the value of the | |
3868 | checkbox when it is checked. If not provided, the word "on" is | |
3869 | assumed. | |
3870 | ||
3871 | =item 4. | |
3872 | ||
3873 | The optional fourth parameter (-label) is the user-readable label to | |
3874 | be attached to the checkbox. If not provided, the checkbox name is | |
3875 | used. | |
3876 | ||
3877 | =back | |
3878 | ||
3879 | The value of the checkbox can be retrieved using: | |
3880 | ||
3881 | $turned_on = $query->param('checkbox_name'); | |
3882 | ||
3883 | JAVASCRIPTING: checkbox() recognizes the B<-onClick> | |
3884 | parameter. See checkbox_group() for further details. | |
3885 | ||
3886 | =head2 CREATING A RADIO BUTTON GROUP | |
3887 | ||
3888 | print $query->radio_group(-name=>'group_name', | |
3889 | -values=>['eenie','meenie','minie'], | |
3890 | -default=>'meenie', | |
3891 | -linebreak=>'true', | |
3892 | -labels=>\%labels); | |
3893 | ||
3894 | -or- | |
3895 | ||
3896 | print $query->radio_group('group_name',['eenie','meenie','minie'], | |
3897 | 'meenie','true',\%labels); | |
3898 | ||
3899 | ||
3900 | HTML3-COMPATIBLE BROWSERS ONLY: | |
3901 | ||
3902 | print $query->radio_group(-name=>'group_name', | |
3903 | -values=>['eenie','meenie','minie','moe'], | |
3904 | -rows=2,-columns=>2); | |
3905 | ||
3906 | radio_group() creates a set of logically-related radio buttons | |
3907 | (turning one member of the group on turns the others off) | |
3908 | ||
3909 | =over 4 | |
3910 | ||
3911 | =item B<Parameters:> | |
3912 | ||
3913 | =item 1. | |
3914 | ||
3915 | The first argument is the name of the group and is required (-name). | |
3916 | ||
3917 | =item 2. | |
3918 | ||
3919 | The second argument (-values) is the list of values for the radio | |
3920 | buttons. The values and the labels that appear on the page are | |
3921 | identical. Pass an array I<reference> in the second argument, either | |
3922 | using an anonymous array, as shown, or by referencing a named array as | |
3923 | in "\@foo". | |
3924 | ||
3925 | =item 3. | |
3926 | ||
3927 | The optional third parameter (-default) is the name of the default | |
3928 | button to turn on. If not specified, the first item will be the | |
3929 | default. You can provide a nonexistent button name, such as "-" to | |
3930 | start up with no buttons selected. | |
3931 | ||
3932 | =item 4. | |
3933 | ||
3934 | The optional fourth parameter (-linebreak) can be set to 'true' to put | |
3935 | line breaks between the buttons, creating a vertical list. | |
3936 | ||
3937 | =item 5. | |
3938 | ||
3939 | The optional fifth parameter (-labels) is a pointer to an associative | |
3940 | array relating the radio button values to user-visible labels to be | |
3941 | used in the display. If not provided, the values themselves are | |
3942 | displayed. | |
3943 | ||
3944 | =item 6. | |
3945 | ||
3946 | B<HTML3-compatible browsers> (such as Netscape) can take advantage | |
3947 | of the optional | |
3948 | parameters B<-rows>, and B<-columns>. These parameters cause | |
3949 | radio_group() to return an HTML3 compatible table containing | |
3950 | the radio group formatted with the specified number of rows | |
3951 | and columns. You can provide just the -columns parameter if you | |
3952 | wish; radio_group will calculate the correct number of rows | |
3953 | for you. | |
3954 | ||
3955 | To include row and column headings in the returned table, you | |
3956 | can use the B<-rowheader> and B<-colheader> parameters. Both | |
3957 | of these accept a pointer to an array of headings to use. | |
3958 | The headings are just decorative. They don't reorganize the | |
3959 | interpetation of the radio buttons -- they're still a single named | |
3960 | unit. | |
3961 | ||
3962 | =back | |
3963 | ||
3964 | When the form is processed, the selected radio button can | |
3965 | be retrieved using: | |
3966 | ||
3967 | $which_radio_button = $query->param('group_name'); | |
3968 | ||
3969 | The value returned by radio_group() is actually an array of button | |
3970 | elements. You can capture them and use them within tables, lists, | |
3971 | or in other creative ways: | |
3972 | ||
3973 | @h = $query->radio_group(-name=>'group_name',-values=>\@values); | |
3974 | &use_in_creative_way(@h); | |
3975 | ||
3976 | =head2 CREATING A SUBMIT BUTTON | |
3977 | ||
3978 | print $query->submit(-name=>'button_name', | |
3979 | -value=>'value'); | |
3980 | ||
3981 | -or- | |
3982 | ||
3983 | print $query->submit('button_name','value'); | |
3984 | ||
3985 | submit() will create the query submission button. Every form | |
3986 | should have one of these. | |
3987 | ||
3988 | =over 4 | |
3989 | ||
3990 | =item B<Parameters:> | |
3991 | ||
3992 | =item 1. | |
3993 | ||
3994 | The first argument (-name) is optional. You can give the button a | |
3995 | name if you have several submission buttons in your form and you want | |
3996 | to distinguish between them. The name will also be used as the | |
3997 | user-visible label. Be aware that a few older browsers don't deal with this correctly and | |
3998 | B<never> send back a value from a button. | |
3999 | ||
4000 | =item 2. | |
4001 | ||
4002 | The second argument (-value) is also optional. This gives the button | |
4003 | a value that will be passed to your script in the query string. | |
4004 | ||
4005 | =back | |
4006 | ||
4007 | You can figure out which button was pressed by using different | |
4008 | values for each one: | |
4009 | ||
4010 | $which_one = $query->param('button_name'); | |
4011 | ||
4012 | JAVASCRIPTING: radio_group() recognizes the B<-onClick> | |
4013 | parameter. See checkbox_group() for further details. | |
4014 | ||
4015 | =head2 CREATING A RESET BUTTON | |
4016 | ||
4017 | print $query->reset | |
4018 | ||
4019 | reset() creates the "reset" button. Note that it restores the | |
4020 | form to its value from the last time the script was called, | |
4021 | NOT necessarily to the defaults. | |
4022 | ||
4023 | =head2 CREATING A DEFAULT BUTTON | |
4024 | ||
4025 | print $query->defaults('button_label') | |
4026 | ||
4027 | defaults() creates a button that, when invoked, will cause the | |
4028 | form to be completely reset to its defaults, wiping out all the | |
4029 | changes the user ever made. | |
4030 | ||
4031 | =head2 CREATING A HIDDEN FIELD | |
4032 | ||
4033 | print $query->hidden(-name=>'hidden_name', | |
4034 | -default=>['value1','value2'...]); | |
4035 | ||
4036 | -or- | |
4037 | ||
4038 | print $query->hidden('hidden_name','value1','value2'...); | |
4039 | ||
4040 | hidden() produces a text field that can't be seen by the user. It | |
4041 | is useful for passing state variable information from one invocation | |
4042 | of the script to the next. | |
4043 | ||
4044 | =over 4 | |
4045 | ||
4046 | =item B<Parameters:> | |
4047 | ||
4048 | =item 1. | |
4049 | ||
4050 | The first argument is required and specifies the name of this | |
4051 | field (-name). | |
4052 | ||
4053 | =item 2. | |
4054 | ||
4055 | The second argument is also required and specifies its value | |
4056 | (-default). In the named parameter style of calling, you can provide | |
4057 | a single value here or a reference to a whole list | |
4058 | ||
4059 | =back | |
4060 | ||
4061 | Fetch the value of a hidden field this way: | |
4062 | ||
4063 | $hidden_value = $query->param('hidden_name'); | |
4064 | ||
4065 | Note, that just like all the other form elements, the value of a | |
4066 | hidden field is "sticky". If you want to replace a hidden field with | |
4067 | some other values after the script has been called once you'll have to | |
4068 | do it manually: | |
4069 | ||
4070 | $query->param('hidden_name','new','values','here'); | |
4071 | ||
4072 | =head2 CREATING A CLICKABLE IMAGE BUTTON | |
4073 | ||
4074 | print $query->image_button(-name=>'button_name', | |
4075 | -src=>'/source/URL', | |
4076 | -align=>'MIDDLE'); | |
4077 | ||
4078 | -or- | |
4079 | ||
4080 | print $query->image_button('button_name','/source/URL','MIDDLE'); | |
4081 | ||
4082 | image_button() produces a clickable image. When it's clicked on the | |
4083 | position of the click is returned to your script as "button_name.x" | |
4084 | and "button_name.y", where "button_name" is the name you've assigned | |
4085 | to it. | |
4086 | ||
4087 | JAVASCRIPTING: image_button() recognizes the B<-onClick> | |
4088 | parameter. See checkbox_group() for further details. | |
4089 | ||
4090 | =over 4 | |
4091 | ||
4092 | =item B<Parameters:> | |
4093 | ||
4094 | =item 1. | |
4095 | ||
4096 | The first argument (-name) is required and specifies the name of this | |
4097 | field. | |
4098 | ||
4099 | =item 2. | |
4100 | ||
4101 | The second argument (-src) is also required and specifies the URL | |
4102 | ||
4103 | =item 3. | |
4104 | The third option (-align, optional) is an alignment type, and may be | |
4105 | TOP, BOTTOM or MIDDLE | |
4106 | ||
4107 | =back | |
4108 | ||
4109 | Fetch the value of the button this way: | |
4110 | $x = $query->param('button_name.x'); | |
4111 | $y = $query->param('button_name.y'); | |
4112 | ||
4113 | =head2 CREATING A JAVASCRIPT ACTION BUTTON | |
4114 | ||
4115 | print $query->button(-name=>'button_name', | |
4116 | -value=>'user visible label', | |
4117 | -onClick=>"do_something()"); | |
4118 | ||
4119 | -or- | |
4120 | ||
4121 | print $query->button('button_name',"do_something()"); | |
4122 | ||
4123 | button() produces a button that is compatible with Netscape 2.0's | |
4124 | JavaScript. When it's pressed the fragment of JavaScript code | |
4125 | pointed to by the B<-onClick> parameter will be executed. On | |
4126 | non-Netscape browsers this form element will probably not even | |
4127 | display. | |
4128 | ||
4129 | =head1 NETSCAPE COOKIES | |
4130 | ||
4131 | Netscape browsers versions 1.1 and higher support a so-called | |
4132 | "cookie" designed to help maintain state within a browser session. | |
4133 | CGI.pm has several methods that support cookies. | |
4134 | ||
4135 | A cookie is a name=value pair much like the named parameters in a CGI | |
4136 | query string. CGI scripts create one or more cookies and send | |
4137 | them to the browser in the HTTP header. The browser maintains a list | |
4138 | of cookies that belong to a particular Web server, and returns them | |
4139 | to the CGI script during subsequent interactions. | |
4140 | ||
4141 | In addition to the required name=value pair, each cookie has several | |
4142 | optional attributes: | |
4143 | ||
4144 | =over 4 | |
4145 | ||
4146 | =item 1. an expiration time | |
4147 | ||
4148 | This is a time/date string (in a special GMT format) that indicates | |
4149 | when a cookie expires. The cookie will be saved and returned to your | |
4150 | script until this expiration date is reached if the user exits | |
4151 | Netscape and restarts it. If an expiration date isn't specified, the cookie | |
4152 | will remain active until the user quits Netscape. | |
4153 | ||
4154 | =item 2. a domain | |
4155 | ||
4156 | This is a partial or complete domain name for which the cookie is | |
4157 | valid. The browser will return the cookie to any host that matches | |
4158 | the partial domain name. For example, if you specify a domain name | |
4159 | of ".capricorn.com", then Netscape will return the cookie to | |
4160 | Web servers running on any of the machines "www.capricorn.com", | |
4161 | "www2.capricorn.com", "feckless.capricorn.com", etc. Domain names | |
4162 | must contain at least two periods to prevent attempts to match | |
4163 | on top level domains like ".edu". If no domain is specified, then | |
4164 | the browser will only return the cookie to servers on the host the | |
4165 | cookie originated from. | |
4166 | ||
4167 | =item 3. a path | |
4168 | ||
4169 | If you provide a cookie path attribute, the browser will check it | |
4170 | against your script's URL before returning the cookie. For example, | |
4171 | if you specify the path "/cgi-bin", then the cookie will be returned | |
4172 | to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", | |
4173 | and "/cgi-bin/customer_service/complain.pl", but not to the script | |
4174 | "/cgi-private/site_admin.pl". By default, path is set to "/", which | |
4175 | causes the cookie to be sent to any CGI script on your site. | |
4176 | ||
4177 | =item 4. a "secure" flag | |
4178 | ||
4179 | If the "secure" attribute is set, the cookie will only be sent to your | |
4180 | script if the CGI request is occurring on a secure channel, such as SSL. | |
4181 | ||
4182 | =back | |
4183 | ||
4184 | The interface to Netscape cookies is the B<cookie()> method: | |
4185 | ||
4186 | $cookie = $query->cookie(-name=>'sessionID', | |
4187 | -value=>'xyzzy', | |
4188 | -expires=>'+1h', | |
4189 | -path=>'/cgi-bin/database', | |
4190 | -domain=>'.capricorn.org', | |
4191 | -secure=>1); | |
4192 | print $query->header(-cookie=>$cookie); | |
4193 | ||
4194 | B<cookie()> creates a new cookie. Its parameters include: | |
4195 | ||
4196 | =over 4 | |
4197 | ||
4198 | =item B<-name> | |
4199 | ||
4200 | The name of the cookie (required). This can be any string at all. | |
4201 | Although Netscape limits its cookie names to non-whitespace | |
4202 | alphanumeric characters, CGI.pm removes this restriction by escaping | |
4203 | and unescaping cookies behind the scenes. | |
4204 | ||
4205 | =item B<-value> | |
4206 | ||
4207 | The value of the cookie. This can be any scalar value, | |
4208 | array reference, or even associative array reference. For example, | |
4209 | you can store an entire associative array into a cookie this way: | |
4210 | ||
4211 | $cookie=$query->cookie(-name=>'family information', | |
4212 | -value=>\%childrens_ages); | |
4213 | ||
4214 | =item B<-path> | |
4215 | ||
4216 | The optional partial path for which this cookie will be valid, as described | |
4217 | above. | |
4218 | ||
4219 | =item B<-domain> | |
4220 | ||
4221 | The optional partial domain for which this cookie will be valid, as described | |
4222 | above. | |
4223 | ||
4224 | =item B<-expires> | |
4225 | ||
4226 | The optional expiration date for this cookie. The format is as described | |
4227 | in the section on the B<header()> method: | |
4228 | ||
4229 | "+1h" one hour from now | |
4230 | ||
4231 | =item B<-secure> | |
4232 | ||
4233 | If set to true, this cookie will only be used within a secure | |
4234 | SSL session. | |
4235 | ||
4236 | =back | |
4237 | ||
4238 | The cookie created by cookie() must be incorporated into the HTTP | |
4239 | header within the string returned by the header() method: | |
4240 | ||
4241 | print $query->header(-cookie=>$my_cookie); | |
4242 | ||
4243 | To create multiple cookies, give header() an array reference: | |
4244 | ||
4245 | $cookie1 = $query->cookie(-name=>'riddle_name', | |
4246 | -value=>"The Sphynx's Question"); | |
4247 | $cookie2 = $query->cookie(-name=>'answers', | |
4248 | -value=>\%answers); | |
4249 | print $query->header(-cookie=>[$cookie1,$cookie2]); | |
4250 | ||
4251 | To retrieve a cookie, request it by name by calling cookie() | |
4252 | method without the B<-value> parameter: | |
4253 | ||
4254 | use CGI; | |
4255 | $query = new CGI; | |
4256 | %answers = $query->cookie(-name=>'answers'); | |
4257 | # $query->cookie('answers') will work too! | |
4258 | ||
4259 | The cookie and CGI namespaces are separate. If you have a parameter | |
4260 | named 'answers' and a cookie named 'answers', the values retrieved by | |
4261 | param() and cookie() are independent of each other. However, it's | |
4262 | simple to turn a CGI parameter into a cookie, and vice-versa: | |
4263 | ||
4264 | # turn a CGI parameter into a cookie | |
4265 | $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]); | |
4266 | # vice-versa | |
4267 | $q->param(-name=>'answers',-value=>[$q->cookie('answers')]); | |
4268 | ||
4269 | See the B<cookie.cgi> example script for some ideas on how to use | |
4270 | cookies effectively. | |
4271 | ||
4272 | B<NOTE:> There appear to be some (undocumented) restrictions on | |
4273 | Netscape cookies. In Netscape 2.01, at least, I haven't been able to | |
4274 | set more than three cookies at a time. There may also be limits on | |
4275 | the length of cookies. If you need to store a lot of information, | |
4276 | it's probably better to create a unique session ID, store it in a | |
4277 | cookie, and use the session ID to locate an external file/database | |
4278 | saved on the server's side of the connection. | |
4279 | ||
4280 | =head1 WORKING WITH NETSCAPE FRAMES | |
4281 | ||
4282 | It's possible for CGI.pm scripts to write into several browser | |
4283 | panels and windows using Netscape's frame mechanism. | |
4284 | There are three techniques for defining new frames programmatically: | |
4285 | ||
4286 | =over 4 | |
4287 | ||
4288 | =item 1. Create a <Frameset> document | |
4289 | ||
4290 | After writing out the HTTP header, instead of creating a standard | |
4291 | HTML document using the start_html() call, create a <FRAMESET> | |
4292 | document that defines the frames on the page. Specify your script(s) | |
4293 | (with appropriate parameters) as the SRC for each of the frames. | |
4294 | ||
4295 | There is no specific support for creating <FRAMESET> sections | |
4296 | in CGI.pm, but the HTML is very simple to write. See the frame | |
4297 | documentation in Netscape's home pages for details | |
4298 | ||
4299 | http://home.netscape.com/assist/net_sites/frames.html | |
4300 | ||
4301 | =item 2. Specify the destination for the document in the HTTP header | |
4302 | ||
4303 | You may provide a B<-target> parameter to the header() method: | |
4304 | ||
4305 | print $q->header(-target=>'ResultsWindow'); | |
4306 | ||
4307 | This will tell Netscape to load the output of your script into the | |
4308 | frame named "ResultsWindow". If a frame of that name doesn't | |
4309 | already exist, Netscape will pop up a new window and load your | |
4310 | script's document into that. There are a number of magic names | |
4311 | that you can use for targets. See the frame documents on Netscape's | |
4312 | home pages for details. | |
4313 | ||
4314 | =item 3. Specify the destination for the document in the <FORM> tag | |
4315 | ||
4316 | You can specify the frame to load in the FORM tag itself. With | |
4317 | CGI.pm it looks like this: | |
4318 | ||
4319 | print $q->startform(-target=>'ResultsWindow'); | |
4320 | ||
4321 | When your script is reinvoked by the form, its output will be loaded | |
4322 | into the frame named "ResultsWindow". If one doesn't already exist | |
4323 | a new window will be created. | |
4324 | ||
4325 | =back | |
4326 | ||
4327 | The script "frameset.cgi" in the examples directory shows one way to | |
4328 | create pages in which the fill-out form and the response live in | |
4329 | side-by-side frames. | |
4330 | ||
4331 | =head1 DEBUGGING | |
4332 | ||
4333 | If you are running the script | |
4334 | from the command line or in the perl debugger, you can pass the script | |
4335 | a list of keywords or parameter=value pairs on the command line or | |
4336 | from standard input (you don't have to worry about tricking your | |
4337 | script into reading from environment variables). | |
4338 | You can pass keywords like this: | |
4339 | ||
4340 | your_script.pl keyword1 keyword2 keyword3 | |
4341 | ||
4342 | or this: | |
4343 | ||
4344 | your_script.pl keyword1+keyword2+keyword3 | |
4345 | ||
4346 | or this: | |
4347 | ||
4348 | your_script.pl name1=value1 name2=value2 | |
4349 | ||
4350 | or this: | |
4351 | ||
4352 | your_script.pl name1=value1&name2=value2 | |
4353 | ||
4354 | or even as newline-delimited parameters on standard input. | |
4355 | ||
4356 | When debugging, you can use quotes and backslashes to escape | |
4357 | characters in the familiar shell manner, letting you place | |
4358 | spaces and other funny characters in your parameter=value | |
4359 | pairs: | |
4360 | ||
4361 | your_script.pl "name1='I am a long value'" "name2=two\ words" | |
4362 | ||
4363 | =head2 DUMPING OUT ALL THE NAME/VALUE PAIRS | |
4364 | ||
4365 | The dump() method produces a string consisting of all the query's | |
4366 | name/value pairs formatted nicely as a nested list. This is useful | |
4367 | for debugging purposes: | |
4368 | ||
4369 | print $query->dump | |
4370 | ||
4371 | ||
4372 | Produces something that looks like: | |
4373 | ||
4374 | <UL> | |
4375 | <LI>name1 | |
4376 | <UL> | |
4377 | <LI>value1 | |
4378 | <LI>value2 | |
4379 | </UL> | |
4380 | <LI>name2 | |
4381 | <UL> | |
4382 | <LI>value1 | |
4383 | </UL> | |
4384 | </UL> | |
4385 | ||
4386 | You can pass a value of 'true' to dump() in order to get it to | |
4387 | print the results out as plain text, suitable for incorporating | |
4388 | into a <PRE> section. | |
4389 | ||
7a2e2cd6 | 4390 | As a shortcut, as of version 1.56 you can interpolate the entire CGI |
4391 | object into a string and it will be replaced with the a nice HTML dump | |
4392 | shown above: | |
54310121 | 4393 | |
4394 | $query=new CGI; | |
4395 | print "<H2>Current Values</H2> $query\n"; | |
4396 | ||
4397 | =head1 FETCHING ENVIRONMENT VARIABLES | |
4398 | ||
4399 | Some of the more useful environment variables can be fetched | |
4400 | through this interface. The methods are as follows: | |
4401 | ||
4402 | =over 4 | |
4403 | ||
4404 | =item B<accept()> | |
4405 | ||
4406 | Return a list of MIME types that the remote browser | |
4407 | accepts. If you give this method a single argument | |
4408 | corresponding to a MIME type, as in | |
4409 | $query->accept('text/html'), it will return a | |
4410 | floating point value corresponding to the browser's | |
4411 | preference for this type from 0.0 (don't want) to 1.0. | |
4412 | Glob types (e.g. text/*) in the browser's accept list | |
4413 | are handled correctly. | |
4414 | ||
4415 | =item B<raw_cookie()> | |
4416 | ||
4417 | Returns the HTTP_COOKIE variable, an HTTP extension | |
4418 | implemented by Netscape browsers version 1.1 | |
4419 | and higher. Cookies have a special format, and this | |
4420 | method call just returns the raw form (?cookie dough). | |
4421 | See cookie() for ways of setting and retrieving | |
4422 | cooked cookies. | |
4423 | ||
4424 | =item B<user_agent()> | |
4425 | ||
4426 | Returns the HTTP_USER_AGENT variable. If you give | |
4427 | this method a single argument, it will attempt to | |
4428 | pattern match on it, allowing you to do something | |
4429 | like $query->user_agent(netscape); | |
4430 | ||
4431 | =item B<path_info()> | |
4432 | ||
4433 | Returns additional path information from the script URL. | |
4434 | E.G. fetching /cgi-bin/your_script/additional/stuff will | |
4435 | result in $query->path_info() returning | |
4436 | "additional/stuff". | |
4437 | ||
4438 | NOTE: The Microsoft Internet Information Server | |
4439 | is broken with respect to additional path information. If | |
4440 | you use the Perl DLL library, the IIS server will attempt to | |
4441 | execute the additional path information as a Perl script. | |
4442 | If you use the ordinary file associations mapping, the | |
4443 | path information will be present in the environment, | |
4444 | but incorrect. The best thing to do is to avoid using additional | |
4445 | path information in CGI scripts destined for use with IIS. | |
4446 | ||
4447 | =item B<path_translated()> | |
4448 | ||
4449 | As per path_info() but returns the additional | |
4450 | path information translated into a physical path, e.g. | |
4451 | "/usr/local/etc/httpd/htdocs/additional/stuff". | |
4452 | ||
4453 | The Microsoft IIS is broken with respect to the translated | |
4454 | path as well. | |
4455 | ||
4456 | =item B<remote_host()> | |
4457 | ||
4458 | Returns either the remote host name or IP address. | |
4459 | if the former is unavailable. | |
4460 | ||
4461 | =item B<script_name()> | |
4462 | Return the script name as a partial URL, for self-refering | |
4463 | scripts. | |
4464 | ||
4465 | =item B<referer()> | |
4466 | ||
4467 | Return the URL of the page the browser was viewing | |
4468 | prior to fetching your script. Not available for all | |
4469 | browsers. | |
4470 | ||
4471 | =item B<auth_type ()> | |
4472 | ||
4473 | Return the authorization/verification method in use for this | |
4474 | script, if any. | |
4475 | ||
4476 | =item B<server_name ()> | |
4477 | ||
4478 | Returns the name of the server, usually the machine's host | |
4479 | name. | |
4480 | ||
4481 | =item B<virtual_host ()> | |
4482 | ||
4483 | When using virtual hosts, returns the name of the host that | |
4484 | the browser attempted to contact | |
4485 | ||
4486 | =item B<server_software ()> | |
4487 | ||
4488 | Returns the server software and version number. | |
4489 | ||
4490 | =item B<remote_user ()> | |
4491 | ||
4492 | Return the authorization/verification name used for user | |
4493 | verification, if this script is protected. | |
4494 | ||
4495 | =item B<user_name ()> | |
4496 | ||
4497 | Attempt to obtain the remote user's name, using a variety | |
4498 | of different techniques. This only works with older browsers | |
4499 | such as Mosaic. Netscape does not reliably report the user | |
4500 | name! | |
4501 | ||
4502 | =item B<request_method()> | |
4503 | ||
4504 | Returns the method used to access your script, usually | |
4505 | one of 'POST', 'GET' or 'HEAD'. | |
4506 | ||
4507 | =back | |
4508 | ||
4509 | =head1 CREATING HTML ELEMENTS: | |
4510 | ||
4511 | In addition to its shortcuts for creating form elements, CGI.pm | |
4512 | defines general HTML shortcut methods as well. HTML shortcuts are | |
4513 | named after a single HTML element and return a fragment of HTML text | |
4514 | that you can then print or manipulate as you like. | |
4515 | ||
4516 | This example shows how to use the HTML methods: | |
4517 | ||
4518 | $q = new CGI; | |
4519 | print $q->blockquote( | |
4520 | "Many years ago on the island of", | |
4521 | $q->a({href=>"http://crete.org/"},"Crete"), | |
4522 | "there lived a minotaur named", | |
4523 | $q->strong("Fred."), | |
4524 | ), | |
4525 | $q->hr; | |
4526 | ||
4527 | This results in the following HTML code (extra newlines have been | |
4528 | added for readability): | |
4529 | ||
4530 | <blockquote> | |
4531 | Many years ago on the island of | |
4532 | <a HREF="http://crete.org/">Crete</a> there lived | |
4533 | a minotaur named <strong>Fred.</strong> | |
4534 | </blockquote> | |
4535 | <hr> | |
4536 | ||
4537 | If you find the syntax for calling the HTML shortcuts awkward, you can | |
4538 | import them into your namespace and dispense with the object syntax | |
4539 | completely (see the next section for more details): | |
4540 | ||
4541 | use CGI shortcuts; # IMPORT HTML SHORTCUTS | |
4542 | print blockquote( | |
4543 | "Many years ago on the island of", | |
4544 | a({href=>"http://crete.org/"},"Crete"), | |
4545 | "there lived a minotaur named", | |
4546 | strong("Fred."), | |
4547 | ), | |
4548 | hr; | |
4549 | ||
4550 | =head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS | |
4551 | ||
4552 | The HTML methods will accept zero, one or multiple arguments. If you | |
4553 | provide no arguments, you get a single tag: | |
4554 | ||
4555 | print hr; | |
4556 | # gives "<hr>" | |
4557 | ||
4558 | If you provide one or more string arguments, they are concatenated | |
4559 | together with spaces and placed between opening and closing tags: | |
4560 | ||
4561 | print h1("Chapter","1"); | |
4562 | # gives "<h1>Chapter 1</h1>" | |
4563 | ||
4564 | If the first argument is an associative array reference, then the keys | |
4565 | and values of the associative array become the HTML tag's attributes: | |
4566 | ||
4567 | print a({href=>'fred.html',target=>'_new'}, | |
4568 | "Open a new frame"); | |
4569 | # gives <a href="fred.html",target="_new">Open a new frame</a> | |
4570 | ||
4571 | You are free to use CGI.pm-style dashes in front of the attribute | |
4572 | names if you prefer: | |
4573 | ||
4574 | print img {-src=>'fred.gif',-align=>'LEFT'}; | |
4575 | # gives <img ALIGN="LEFT" SRC="fred.gif"> | |
4576 | ||
4577 | =head2 Generating new HTML tags | |
4578 | ||
4579 | Since no mere mortal can keep up with Netscape and Microsoft as they | |
4580 | battle it out for control of HTML, the code that generates HTML tags | |
4581 | is general and extensible. You can create new HTML tags freely just | |
4582 | by referring to them on the import line: | |
4583 | ||
4584 | use CGI shortcuts,winkin,blinkin,nod; | |
4585 | ||
4586 | Now, in addition to the standard CGI shortcuts, you've created HTML | |
4587 | tags named "winkin", "blinkin" and "nod". You can use them like this: | |
4588 | ||
4589 | print blinkin {color=>'blue',rate=>'fast'},"Yahoo!"; | |
4590 | # <blinkin COLOR="blue" RATE="fast">Yahoo!</blinkin> | |
4591 | ||
4592 | =head1 IMPORTING CGI METHOD CALLS INTO YOUR NAME SPACE | |
4593 | ||
4594 | As a convenience, you can import most of the CGI method calls directly | |
4595 | into your name space. The syntax for doing this is: | |
4596 | ||
4597 | use CGI <list of methods>; | |
4598 | ||
4599 | The listed methods will be imported into the current package; you can | |
4600 | call them directly without creating a CGI object first. This example | |
4601 | shows how to import the B<param()> and B<header()> | |
4602 | methods, and then use them directly: | |
4603 | ||
4604 | use CGI param,header; | |
4605 | print header('text/plain'); | |
4606 | $zipcode = param('zipcode'); | |
4607 | ||
4608 | You can import groups of methods by referring to a number of special | |
4609 | names: | |
4610 | ||
4611 | =over 4 | |
4612 | ||
4613 | =item B<cgi> | |
4614 | ||
4615 | Import all CGI-handling methods, such as B<param()>, B<path_info()> | |
4616 | and the like. | |
4617 | ||
4618 | =item B<form> | |
4619 | ||
4620 | Import all fill-out form generating methods, such as B<textfield()>. | |
4621 | ||
4622 | =item B<html2> | |
4623 | ||
4624 | Import all methods that generate HTML 2.0 standard elements. | |
4625 | ||
4626 | =item B<html3> | |
4627 | ||
4628 | Import all methods that generate HTML 3.0 proposed elements (such as | |
4629 | <table>, <super> and <sub>). | |
4630 | ||
4631 | =item B<netscape> | |
4632 | ||
4633 | Import all methods that generate Netscape-specific HTML extensions. | |
4634 | ||
4635 | =item B<shortcuts> | |
4636 | ||
4637 | Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' + | |
4638 | 'netscape')... | |
4639 | ||
4640 | =item B<standard> | |
4641 | ||
4642 | Import "standard" features, 'html2', 'form' and 'cgi'. | |
4643 | ||
4644 | =item B<all> | |
4645 | ||
4646 | Import all the available methods. For the full list, see the CGI.pm | |
4647 | code, where the variable %TAGS is defined. | |
4648 | ||
4649 | =back | |
4650 | ||
4651 | Note that in the interests of execution speed CGI.pm does B<not> use | |
4652 | the standard L<Exporter> syntax for specifying load symbols. This may | |
4653 | change in the future. | |
4654 | ||
4655 | If you import any of the state-maintaining CGI or form-generating | |
4656 | methods, a default CGI object will be created and initialized | |
4657 | automatically the first time you use any of the methods that require | |
4658 | one to be present. This includes B<param()>, B<textfield()>, | |
4659 | B<submit()> and the like. (If you need direct access to the CGI | |
4660 | object, you can find it in the global variable B<$CGI::Q>). By | |
4661 | importing CGI.pm methods, you can create visually elegant scripts: | |
4662 | ||
4663 | use CGI standard,html2; | |
4664 | ||
4665 | header, | |
4666 | start_html('Simple Script'), | |
4667 | h1('Simple Script'), | |
4668 | start_form, | |
4669 | "What's your name? ",textfield('name'),p, | |
4670 | "What's the combination?", | |
4671 | checkbox_group(-name=>'words', | |
4672 | -values=>['eenie','meenie','minie','moe'], | |
4673 | -defaults=>['eenie','moe']),p, | |
4674 | "What's your favorite color?", | |
4675 | popup_menu(-name=>'color', | |
4676 | -values=>['red','green','blue','chartreuse']),p, | |
4677 | submit, | |
4678 | end_form, | |
4679 | hr,"\n"; | |
4680 | ||
4681 | if (param) { | |
4682 | ||
4683 | "Your name is ",em(param('name')),p, | |
4684 | "The keywords are: ",em(join(", ",param('words'))),p, | |
4685 | "Your favorite color is ",em(param('color')),".\n"; | |
4686 | } | |
4687 | print end_html; | |
4688 | ||
4689 | =head1 USING NPH SCRIPTS | |
4690 | ||
4691 | NPH, or "no-parsed-header", scripts bypass the server completely by | |
4692 | sending the complete HTTP header directly to the browser. This has | |
4693 | slight performance benefits, but is of most use for taking advantage | |
4694 | of HTTP extensions that are not directly supported by your server, | |
4695 | such as server push and PICS headers. | |
4696 | ||
4697 | Servers use a variety of conventions for designating CGI scripts as | |
4698 | NPH. Many Unix servers look at the beginning of the script's name for | |
4699 | the prefix "nph-". The Macintosh WebSTAR server and Microsoft's | |
4700 | Internet Information Server, in contrast, try to decide whether a | |
4701 | program is an NPH script by examining the first line of script output. | |
4702 | ||
4703 | ||
4704 | CGI.pm supports NPH scripts with a special NPH mode. When in this | |
4705 | mode, CGI.pm will output the necessary extra header information when | |
4706 | the header() and redirect() methods are | |
4707 | called. | |
4708 | ||
4709 | The Microsoft Internet Information Server requires NPH mode. As of version | |
4710 | 2.30, CGI.pm will automatically detect when the script is running under IIS | |
4711 | and put itself into this mode. You do not need to do this manually, although | |
4712 | it won't hurt anything if you do. | |
4713 | ||
4714 | There are a number of ways to put CGI.pm into NPH mode: | |
4715 | ||
4716 | =over 4 | |
4717 | ||
4718 | =item In the B<use> statement | |
4719 | Simply add ":nph" to the list of symbols to be imported into your script: | |
4720 | ||
4721 | use CGI qw(:standard :nph) | |
4722 | ||
4723 | =item By calling the B<nph()> method: | |
4724 | ||
4725 | Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program. | |
4726 | ||
4727 | CGI->nph(1) | |
4728 | ||
4729 | =item By using B<-nph> parameters in the B<header()> and B<redirect()> statements: | |
4730 | ||
4731 | print $q->header(-nph=>1); | |
4732 | ||
4733 | =back | |
4734 | ||
4735 | =head1 AUTHOR INFORMATION | |
4736 | ||
4737 | Copyright 1995,1996, Lincoln D. Stein. All rights reserved. It may | |
4738 | be used and modified freely, but I do request that this copyright | |
4739 | notice remain attached to the file. You may modify this module as you | |
4740 | wish, but if you redistribute a modified version, please attach a note | |
4741 | listing the modifications you have made. | |
4742 | ||
4743 | Address bug reports and comments to: | |
4744 | lstein@genome.wi.mit.edu | |
4745 | ||
4746 | =head1 CREDITS | |
4747 | ||
4748 | Thanks very much to: | |
4749 | ||
4750 | =over 4 | |
4751 | ||
4752 | =item Matt Heffron (heffron@falstaff.css.beckman.com) | |
4753 | ||
4754 | =item James Taylor (james.taylor@srs.gov) | |
4755 | ||
4756 | =item Scott Anguish <sanguish@digifix.com> | |
4757 | ||
4758 | =item Mike Jewell (mlj3u@virginia.edu) | |
4759 | ||
4760 | =item Timothy Shimmin (tes@kbs.citri.edu.au) | |
4761 | ||
4762 | =item Joergen Haegg (jh@axis.se) | |
4763 | ||
4764 | =item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu) | |
4765 | ||
4766 | =item Richard Resnick (applepi1@aol.com) | |
4767 | ||
4768 | =item Craig Bishop (csb@barwonwater.vic.gov.au) | |
4769 | ||
4770 | =item Tony Curtis (tc@vcpc.univie.ac.at) | |
4771 | ||
4772 | =item Tim Bunce (Tim.Bunce@ig.co.uk) | |
4773 | ||
4774 | =item Tom Christiansen (tchrist@convex.com) | |
4775 | ||
4776 | =item Andreas Koenig (k@franz.ww.TU-Berlin.DE) | |
4777 | ||
4778 | =item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au) | |
4779 | ||
4780 | =item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu) | |
4781 | ||
4782 | =item Stephen Dahmen (joyfire@inxpress.net) | |
4783 | ||
4784 | =item Ed Jordan (ed@fidalgo.net) | |
4785 | ||
4786 | =item David Alan Pisoni (david@cnation.com) | |
4787 | ||
4788 | =item ...and many many more... | |
4789 | ||
4790 | for suggestions and bug fixes. | |
4791 | ||
4792 | =back | |
4793 | ||
4794 | =head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT | |
4795 | ||
4796 | ||
4797 | #!/usr/local/bin/perl | |
4798 | ||
4799 | use CGI; | |
4800 | ||
4801 | $query = new CGI; | |
4802 | ||
4803 | print $query->header; | |
4804 | print $query->start_html("Example CGI.pm Form"); | |
4805 | print "<H1> Example CGI.pm Form</H1>\n"; | |
4806 | &print_prompt($query); | |
4807 | &do_work($query); | |
4808 | &print_tail; | |
4809 | print $query->end_html; | |
4810 | ||
4811 | sub print_prompt { | |
4812 | my($query) = @_; | |
4813 | ||
4814 | print $query->startform; | |
4815 | print "<EM>What's your name?</EM><BR>"; | |
4816 | print $query->textfield('name'); | |
4817 | print $query->checkbox('Not my real name'); | |
4818 | ||
4819 | print "<P><EM>Where can you find English Sparrows?</EM><BR>"; | |
4820 | print $query->checkbox_group( | |
4821 | -name=>'Sparrow locations', | |
4822 | -values=>[England,France,Spain,Asia,Hoboken], | |
4823 | -linebreak=>'yes', | |
4824 | -defaults=>[England,Asia]); | |
4825 | ||
4826 | print "<P><EM>How far can they fly?</EM><BR>", | |
4827 | $query->radio_group( | |
4828 | -name=>'how far', | |
4829 | -values=>['10 ft','1 mile','10 miles','real far'], | |
4830 | -default=>'1 mile'); | |
4831 | ||
4832 | print "<P><EM>What's your favorite color?</EM> "; | |
4833 | print $query->popup_menu(-name=>'Color', | |
4834 | -values=>['black','brown','red','yellow'], | |
4835 | -default=>'red'); | |
4836 | ||
4837 | print $query->hidden('Reference','Monty Python and the Holy Grail'); | |
4838 | ||
4839 | print "<P><EM>What have you got there?</EM><BR>"; | |
4840 | print $query->scrolling_list( | |
4841 | -name=>'possessions', | |
4842 | -values=>['A Coconut','A Grail','An Icon', | |
4843 | 'A Sword','A Ticket'], | |
4844 | -size=>5, | |
4845 | -multiple=>'true'); | |
4846 | ||
4847 | print "<P><EM>Any parting comments?</EM><BR>"; | |
4848 | print $query->textarea(-name=>'Comments', | |
4849 | -rows=>10, | |
4850 | -columns=>50); | |
4851 | ||
4852 | print "<P>",$query->reset; | |
4853 | print $query->submit('Action','Shout'); | |
4854 | print $query->submit('Action','Scream'); | |
4855 | print $query->endform; | |
4856 | print "<HR>\n"; | |
4857 | } | |
4858 | ||
4859 | sub do_work { | |
4860 | my($query) = @_; | |
4861 | my(@values,$key); | |
4862 | ||
4863 | print "<H2>Here are the current settings in this form</H2>"; | |
4864 | ||
4865 | foreach $key ($query->param) { | |
4866 | print "<STRONG>$key</STRONG> -> "; | |
4867 | @values = $query->param($key); | |
4868 | print join(", ",@values),"<BR>\n"; | |
4869 | } | |
4870 | } | |
4871 | ||
4872 | sub print_tail { | |
4873 | print <<END; | |
4874 | <HR> | |
4875 | <ADDRESS>Lincoln D. Stein</ADDRESS><BR> | |
4876 | <A HREF="/">Home Page</A> | |
4877 | END | |
4878 | } | |
4879 | ||
4880 | =head1 BUGS | |
4881 | ||
4882 | This module has grown large and monolithic. Furthermore it's doing many | |
4883 | things, such as handling URLs, parsing CGI input, writing HTML, etc., that | |
4884 | are also done in the LWP modules. It should be discarded in favor of | |
4885 | the CGI::* modules, but somehow I continue to work on it. | |
4886 | ||
4887 | Note that the code is truly contorted in order to avoid spurious | |
4888 | warnings when programs are run with the B<-w> switch. | |
4889 | ||
4890 | =head1 SEE ALSO | |
4891 | ||
4892 | L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>, | |
4893 | L<CGI::Base>, L<CGI::Form>, L<CGI::Apache>, L<CGI::Switch>, | |
4894 | L<CGI::Push>, L<CGI::Fast> | |
4895 | ||
4896 | =cut | |
4897 |