summaryrefslogtreecommitdiffstats
path: root/contrib/perl5/lib/CGI.pm
diff options
context:
space:
mode:
authormarkm <markm@FreeBSD.org>2002-03-16 22:35:55 +0000
committermarkm <markm@FreeBSD.org>2002-03-16 22:35:55 +0000
commit0461d253df33e5f57be9816f42946f63a61854d1 (patch)
treebfa3c40437ffce8409065d8fff06dba8b2eaabb7 /contrib/perl5/lib/CGI.pm
parent6921b1a9a737ac64d864891f28e25abc5fad97a6 (diff)
downloadFreeBSD-src-0461d253df33e5f57be9816f42946f63a61854d1.zip
FreeBSD-src-0461d253df33e5f57be9816f42946f63a61854d1.tar.gz
Punt to attic files not in 5.6.1 OR not needed by FreeBSD.
Diffstat (limited to 'contrib/perl5/lib/CGI.pm')
-rw-r--r--contrib/perl5/lib/CGI.pm6481
1 files changed, 0 insertions, 6481 deletions
diff --git a/contrib/perl5/lib/CGI.pm b/contrib/perl5/lib/CGI.pm
deleted file mode 100644
index 3e03257..0000000
--- a/contrib/perl5/lib/CGI.pm
+++ /dev/null
@@ -1,6481 +0,0 @@
-package CGI;
-require 5.004;
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-# You can run this file through either pod2man or pod2html to produce pretty
-# documentation in manual or html file format (these utilities are part of the
-# Perl 5 distribution).
-
-# Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
-# It may be used and modified freely, but I do request that this copyright
-# notice remain attached to the file. You may modify this module as you
-# wish, but if you redistribute a modified version, please attach a note
-# listing the modifications you have made.
-
-# The most recent version and complete docs are available at:
-# http://stein.cshl.org/WWW/software/CGI/
-
-$CGI::revision = '$Id: CGI.pm,v 1.19 1999/08/31 17:04:37 lstein Exp $';
-$CGI::VERSION='2.56';
-
-# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
-# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
-# $TempFile::TMPDIRECTORY = '/usr/tmp';
-
-# >>>>> Here are some globals that you might want to adjust <<<<<<
-sub initialize_globals {
- # Set this to 1 to enable copious autoloader debugging messages
- $AUTOLOAD_DEBUG = 0;
-
- # Change this to the preferred DTD to print in start_html()
- # or use default_dtd('text of DTD to use');
- $DEFAULT_DTD = '-//IETF//DTD HTML//EN';
-
- # Set this to 1 to enable NPH scripts
- # or:
- # 1) use CGI qw(-nph)
- # 2) $CGI::nph(1)
- # 3) print header(-nph=>1)
- $NPH = 0;
-
- # Set this to 1 to disable debugging from the
- # command line
- $NO_DEBUG = 0;
-
- # Set this to 1 to make the temporary files created
- # during file uploads safe from prying eyes
- # or do...
- # 1) use CGI qw(:private_tempfiles)
- # 2) $CGI::private_tempfiles(1);
- $PRIVATE_TEMPFILES = 0;
-
- # Set this to a positive value to limit the size of a POSTing
- # to a certain number of bytes:
- $POST_MAX = -1;
-
- # Change this to 1 to disable uploads entirely:
- $DISABLE_UPLOADS = 0;
-
- # Automatically determined -- don't change
- $EBCDIC = 0;
-
- # Change this to 1 to suppress redundant HTTP headers
- $HEADERS_ONCE = 0;
-
- # separate the name=value pairs by semicolons rather than ampersands
- $USE_PARAM_SEMICOLONS = 0;
-
- # Other globals that you shouldn't worry about.
- undef $Q;
- $BEEN_THERE = 0;
- undef @QUERY_PARAM;
- undef %EXPORT;
-
- # prevent complaints by mod_perl
- 1;
-}
-
-# ------------------ START OF THE LIBRARY ------------
-
-# make mod_perlhappy
-initialize_globals();
-
-# FIGURE OUT THE OS WE'RE RUNNING UNDER
-# Some systems support the $^O variable. If not
-# available then require() the Config library
-unless ($OS) {
- unless ($OS = $^O) {
- require Config;
- $OS = $Config::Config{'osname'};
- }
-}
-if ($OS=~/Win/i) {
- $OS = 'WINDOWS';
-} elsif ($OS=~/vms/i) {
- $OS = 'VMS';
-} elsif ($OS=~/bsdos/i) {
- $OS = 'UNIX';
-} elsif ($OS=~/dos/i) {
- $OS = 'DOS';
-} elsif ($OS=~/^MacOS$/i) {
- $OS = 'MACINTOSH';
-} elsif ($OS=~/os2/i) {
- $OS = 'OS2';
-} else {
- $OS = 'UNIX';
-}
-
-# Some OS logic. Binary mode enabled on DOS, NT and VMS
-$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/;
-
-# This is the default class for the CGI object to use when all else fails.
-$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
-
-# This is where to look for autoloaded routines.
-$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
-
-# The path separator is a slash, backslash or semicolon, depending
-# on the paltform.
-$SL = {
- UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
- }->{$OS};
-
-# This no longer seems to be necessary
-# Turn on NPH scripts by default when running under IIS server!
-# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
-$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
-
-# Turn on special checking for Doug MacEachern's modperl
-if (exists $ENV{'GATEWAY_INTERFACE'}
- &&
- ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
-{
- $| = 1;
- require Apache;
-}
-# Turn on special checking for ActiveState's PerlEx
-$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
-
-# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
-# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
-# and sometimes CR). The most popular VMS web server
-# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
-# use ASCII, so \015\012 means something different. I find this all
-# really annoying.
-$EBCDIC = "\t" ne "\011";
-if ($OS eq 'VMS') {
- $CRLF = "\n";
-} elsif ($EBCDIC) {
- $CRLF= "\r\n";
-} else {
- $CRLF = "\015\012";
-}
-
-if ($EBCDIC) {
-@A2E = (
- 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
- 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
- 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
-240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
-124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
-215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
-121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
-151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7,
- 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27,
- 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255,
- 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
-144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
-100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
-172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
- 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
-140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
- );
-}
-
-if ($needs_binmode) {
- $CGI::DefaultClass->binmode(main::STDOUT);
- $CGI::DefaultClass->binmode(main::STDIN);
- $CGI::DefaultClass->binmode(main::STDERR);
-}
-
-%EXPORT_TAGS = (
- ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
- tt u i b blockquote pre img a address cite samp dfn html head
- base body Link nextid title meta kbd start_html end_html
- input Select option comment/],
- ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param
- embed basefont style span layer ilayer font frameset frame script small big/],
- ':netscape'=>[qw/blink fontsize center/],
- ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
- submit reset defaults radio_group popup_menu button autoEscape
- scrolling_list image_button start_form end_form startform endform
- start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
- ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump
- raw_cookie request_method query_string Accept user_agent remote_host content_type
- remote_addr referer server_name server_software server_port server_protocol
- virtual_host remote_ident auth_type http use_named_parameters
- save_parameters restore_parameters param_fetch
- remote_user user_name header redirect import_names put
- Delete Delete_all url_param cgi_error/],
- ':ssl' => [qw/https/],
- ':imagemap' => [qw/Area Map/],
- ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
- ':html' => [qw/:html2 :html3 :netscape/],
- ':standard' => [qw/:html2 :html3 :form :cgi/],
- ':push' => [qw/multipart_init multipart_start multipart_end/],
- ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/]
- );
-
-# to import symbols into caller
-sub import {
- my $self = shift;
-
-# This causes modules to clash.
-# undef %EXPORT_OK;
-# undef %EXPORT;
-
- $self->_setup_symbols(@_);
- my ($callpack, $callfile, $callline) = caller;
-
- # To allow overriding, search through the packages
- # Till we find one in which the correct subroutine is defined.
- my @packages = ($self,@{"$self\:\:ISA"});
- foreach $sym (keys %EXPORT) {
- my $pck;
- my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
- foreach $pck (@packages) {
- if (defined(&{"$pck\:\:$sym"})) {
- $def = $pck;
- last;
- }
- }
- *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
- }
-}
-
-sub compile {
- my $pack = shift;
- $pack->_setup_symbols('-compile',@_);
-}
-
-sub expand_tags {
- my($tag) = @_;
- return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
- my(@r);
- return ($tag) unless $EXPORT_TAGS{$tag};
- foreach (@{$EXPORT_TAGS{$tag}}) {
- push(@r,&expand_tags($_));
- }
- return @r;
-}
-
-#### Method: new
-# The new routine. This will check the current environment
-# for an existing query string, and initialize itself, if so.
-####
-sub new {
- my($class,$initializer) = @_;
- my $self = {};
- bless $self,ref $class || $class || $DefaultClass;
- if ($MOD_PERL) {
- Apache->request->register_cleanup(\&CGI::_reset_globals);
- undef $NPH;
- }
- $self->_reset_globals if $PERLEX;
- $self->init($initializer);
- return $self;
-}
-
-# We provide a DESTROY method so that the autoloader
-# doesn't bother trying to find it.
-sub DESTROY { }
-
-#### Method: param
-# Returns the value(s)of a named parameter.
-# If invoked in a list context, returns the
-# entire list. Otherwise returns the first
-# member of the list.
-# If name is not provided, return a list of all
-# the known parameters names available.
-# If more than one argument is provided, the
-# second and subsequent arguments are used to
-# set the value of the parameter.
-####
-sub param {
- my($self,@p) = self_or_default(@_);
- return $self->all_parameters unless @p;
- my($name,$value,@other);
-
- # For compatibility between old calling style and use_named_parameters() style,
- # we have to special case for a single parameter present.
- if (@p > 1) {
- ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
- my(@values);
-
- if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
- @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
- } else {
- foreach ($value,@other) {
- push(@values,$_) if defined($_);
- }
- }
- # If values is provided, then we set it.
- if (@values) {
- $self->add_parameter($name);
- $self->{$name}=[@values];
- }
- } else {
- $name = $p[0];
- }
-
- return unless defined($name) && $self->{$name};
- return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
-}
-
-sub self_or_default {
- return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
- unless (defined($_[0]) &&
- (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
- ) {
- $Q = $CGI::DefaultClass->new unless defined($Q);
- unshift(@_,$Q);
- }
- return @_;
-}
-
-sub self_or_CGI {
- local $^W=0; # prevent a warning
- if (defined($_[0]) &&
- (substr(ref($_[0]),0,3) eq 'CGI'
- || UNIVERSAL::isa($_[0],'CGI'))) {
- return @_;
- } else {
- return ($DefaultClass,@_);
- }
-}
-
-########################################
-# THESE METHODS ARE MORE OR LESS PRIVATE
-# GO TO THE __DATA__ SECTION TO SEE MORE
-# PUBLIC METHODS
-########################################
-
-# Initialize the query object from the environment.
-# If a parameter list is found, this object will be set
-# to an associative array in which parameter names are keys
-# and the values are stored as lists
-# If a keyword list is found, this method creates a bogus
-# parameter list with the single parameter 'keywords'.
-
-sub init {
- my($self,$initializer) = @_;
- my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
- local($/) = "\n";
-
- # if we get called more than once, we want to initialize
- # ourselves from the original query (which may be gone
- # if it was read from STDIN originally.)
- if (@QUERY_PARAM && !defined($initializer)) {
- foreach (@QUERY_PARAM) {
- $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
- }
- return;
- }
-
- $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
- $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
-
- $fh = to_filehandle($initializer) if $initializer;
-
- METHOD: {
-
- # avoid unreasonably large postings
- if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
- $self->cgi_error("413 Request entity too large");
- last METHOD;
- }
-
- # Process multipart postings, but only if the initializer is
- # not defined.
- if ($meth eq 'POST'
- && defined($ENV{'CONTENT_TYPE'})
- && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
- && !defined($initializer)
- ) {
- my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
- $self->read_multipart($boundary,$content_length);
- last METHOD;
- }
-
- # If initializer is defined, then read parameters
- # from it.
- if (defined($initializer)) {
- if (UNIVERSAL::isa($initializer,'CGI')) {
- $query_string = $initializer->query_string;
- last METHOD;
- }
- if (ref($initializer) && ref($initializer) eq 'HASH') {
- foreach (keys %$initializer) {
- $self->param('-name'=>$_,'-value'=>$initializer->{$_});
- }
- last METHOD;
- }
-
- if (defined($fh) && ($fh ne '')) {
- while (<$fh>) {
- chomp;
- last if /^=/;
- push(@lines,$_);
- }
- # massage back into standard format
- if ("@lines" =~ /=/) {
- $query_string=join("&",@lines);
- } else {
- $query_string=join("+",@lines);
- }
- last METHOD;
- }
-
- # last chance -- treat it as a string
- $initializer = $$initializer if ref($initializer) eq 'SCALAR';
- $query_string = $initializer;
-
- last METHOD;
- }
-
- # If method is GET or HEAD, fetch the query from
- # the environment.
- if ($meth=~/^(GET|HEAD)$/) {
- if ($MOD_PERL) {
- $query_string = Apache->request->args;
- } else {
- $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
- }
- last METHOD;
- }
-
- if ($meth eq 'POST') {
- $self->read_from_client(\*STDIN,\$query_string,$content_length,0)
- if $content_length > 0;
- # Some people want to have their cake and eat it too!
- # Uncomment this line to have the contents of the query string
- # APPENDED to the POST data.
- # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
- last METHOD;
- }
-
- # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
- # Check the command line and then the standard input for data.
- # We use the shellwords package in order to behave the way that
- # UN*X programmers expect.
- $query_string = read_from_cmdline() unless $NO_DEBUG;
- }
-
- # We now have the query string in hand. We do slightly
- # different things for keyword lists and parameter lists.
- if (defined $query_string && $query_string) {
- if ($query_string =~ /=/) {
- $self->parse_params($query_string);
- } else {
- $self->add_parameter('keywords');
- $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
- }
- }
-
- # Special case. Erase everything if there is a field named
- # .defaults.
- if ($self->param('.defaults')) {
- undef %{$self};
- }
-
- # Associative array containing our defined fieldnames
- $self->{'.fieldnames'} = {};
- foreach ($self->param('.cgifields')) {
- $self->{'.fieldnames'}->{$_}++;
- }
-
- # Clear out our default submission button flag if present
- $self->delete('.submit');
- $self->delete('.cgifields');
- $self->save_request unless $initializer;
-}
-
-# FUNCTIONS TO OVERRIDE:
-# Turn a string into a filehandle
-sub to_filehandle {
- my $thingy = shift;
- return undef unless $thingy;
- return $thingy if UNIVERSAL::isa($thingy,'GLOB');
- return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
- if (!ref($thingy)) {
- my $caller = 1;
- while (my $package = caller($caller++)) {
- my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
- return $tmp if defined(fileno($tmp));
- }
- }
- return undef;
-}
-
-# send output to the browser
-sub put {
- my($self,@p) = self_or_default(@_);
- $self->print(@p);
-}
-
-# print to standard output (for overriding in mod_perl)
-sub print {
- shift;
- CORE::print(@_);
-}
-
-# get/set last cgi_error
-sub cgi_error {
- my ($self,$err) = self_or_default(@_);
- $self->{'.cgi_error'} = $err if defined $err;
- return $self->{'.cgi_error'};
-}
-
-# unescape URL-encoded data
-sub unescape {
- shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass);
- my $todecode = shift;
- return undef unless defined($todecode);
- $todecode =~ tr/+/ /; # pluses become spaces
- if ($EBCDIC) {
- $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",$A2E[hex($1)])/ge;
- } else {
- $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
- }
- return $todecode;
-}
-
-# URL-encode data
-sub escape {
- shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass);
- my $toencode = shift;
- return undef unless defined($toencode);
- $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
- return $toencode;
-}
-
-sub save_request {
- my($self) = @_;
- # We're going to play with the package globals now so that if we get called
- # again, we initialize ourselves in exactly the same way. This allows
- # us to have several of these objects.
- @QUERY_PARAM = $self->param; # save list of parameters
- foreach (@QUERY_PARAM) {
- $QUERY_PARAM{$_}=$self->{$_};
- }
-}
-
-sub parse_params {
- my($self,$tosplit) = @_;
- my(@pairs) = split(/[&;]/,$tosplit);
- my($param,$value);
- foreach (@pairs) {
- ($param,$value) = split('=',$_,2);
- $param = unescape($param);
- $value = unescape($value);
- $self->add_parameter($param);
- push (@{$self->{$param}},$value);
- }
-}
-
-sub add_parameter {
- my($self,$param)=@_;
- push (@{$self->{'.parameters'}},$param)
- unless defined($self->{$param});
-}
-
-sub all_parameters {
- my $self = shift;
- return () unless defined($self) && $self->{'.parameters'};
- return () unless @{$self->{'.parameters'}};
- return @{$self->{'.parameters'}};
-}
-
-# put a filehandle into binary mode (DOS)
-sub binmode {
- CORE::binmode($_[1]);
-}
-
-sub _make_tag_func {
- my ($self,$tagname) = @_;
- my $func = qq(
- sub $tagname {
- shift if \$_[0] &&
-# (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) ||
- (ref(\$_[0]) &&
- (substr(ref(\$_[0]),0,3) eq 'CGI' ||
- UNIVERSAL::isa(\$_[0],'CGI')));
-
- my(\$attr) = '';
- if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') {
- my(\@attr) = make_attributes( '',shift() );
- \$attr = " \@attr" if \@attr;
- }
- );
- if ($tagname=~/start_(\w+)/i) {
- $func .= qq! return "<\U$1\E\$attr>";} !;
- } elsif ($tagname=~/end_(\w+)/i) {
- $func .= qq! return "<\U/$1\E>"; } !;
- } else {
- $func .= qq#
- my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U</$tagname>\E");
- return \$tag unless \@_;
- my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
- return "\@result";
- }#;
- }
-return $func;
-}
-
-sub AUTOLOAD {
- print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
- my $func = &_compile;
- goto &$func;
-}
-
-# PRIVATE SUBROUTINE
-# Smart rearrangement of parameters to allow named parameter
-# calling. We do the rearangement if:
-# 1. The first parameter begins with a -
-# 2. The use_named_parameters() method returns true
-sub rearrange {
- my($self,$order,@param) = @_;
- return () unless @param;
-
- if (ref($param[0]) eq 'HASH') {
- @param = %{$param[0]};
- } else {
- return @param
- unless (defined($param[0]) && substr($param[0],0,1) eq '-')
- || $self->use_named_parameters;
- }
-
- # map parameters into positional indices
- my ($i,%pos);
- $i = 0;
- foreach (@$order) {
- foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; }
- $i++;
- }
-
- my (@result,%leftover);
- $#result = $#$order; # preextend
- while (@param) {
- my $key = uc(shift(@param));
- $key =~ s/^\-//;
- if (exists $pos{$key}) {
- $result[$pos{$key}] = shift(@param);
- } else {
- $leftover{$key} = shift(@param);
- }
- }
-
- push (@result,$self->make_attributes(\%leftover)) if %leftover;
- @result;
-}
-
-sub _compile {
- my($func) = $AUTOLOAD;
- my($pack,$func_name);
- {
- local($1,$2); # this fixes an obscure variable suicide problem.
- $func=~/(.+)::([^:]+)$/;
- ($pack,$func_name) = ($1,$2);
- $pack=~s/::SUPER$//; # fix another obscure problem
- $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
- unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
-
- my($sub) = \%{"$pack\:\:SUBS"};
- unless (%$sub) {
- my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
- eval "package $pack; $$auto";
- die $@ if $@;
- $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
- }
- my($code) = $sub->{$func_name};
-
- $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
- if (!$code) {
- (my $base = $func_name) =~ s/^(start_|end_)//i;
- if ($EXPORT{':any'} ||
- $EXPORT{'-any'} ||
- $EXPORT{$base} ||
- (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
- && $EXPORT_OK{$base}) {
- $code = $CGI::DefaultClass->_make_tag_func($func_name);
- }
- }
- die "Undefined subroutine $AUTOLOAD\n" unless $code;
- eval "package $pack; $code";
- if ($@) {
- $@ =~ s/ at .*\n//;
- die $@;
- }
- }
- CORE::delete($sub->{$func_name}); #free storage
- return "$pack\:\:$func_name";
-}
-
-sub _reset_globals { initialize_globals(); }
-
-sub _setup_symbols {
- my $self = shift;
- my $compile = 0;
- foreach (@_) {
- $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
- $NPH++, next if /^[:-]nph$/;
- $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/;
- $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
- $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
- $EXPORT{$_}++, next if /^[:-]any$/;
- $compile++, next if /^[:-]compile$/;
-
- # This is probably extremely evil code -- to be deleted some day.
- if (/^[-]autoload$/) {
- my($pkg) = caller(1);
- *{"${pkg}::AUTOLOAD"} = sub {
- my($routine) = $AUTOLOAD;
- $routine =~ s/^.*::/CGI::/;
- &$routine;
- };
- next;
- }
-
- foreach (&expand_tags($_)) {
- tr/a-zA-Z0-9_//cd; # don't allow weird function names
- $EXPORT{$_}++;
- }
- }
- _compile_all(keys %EXPORT) if $compile;
-}
-
-###############################################################################
-################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
-###############################################################################
-$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
-$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
-
-%SUBS = (
-
-'URL_ENCODED'=> <<'END_OF_FUNC',
-sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
-END_OF_FUNC
-
-'MULTIPART' => <<'END_OF_FUNC',
-sub MULTIPART { 'multipart/form-data'; }
-END_OF_FUNC
-
-'SERVER_PUSH' => <<'END_OF_FUNC',
-sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; }
-END_OF_FUNC
-
-'use_named_parameters' => <<'END_OF_FUNC',
-#### Method: use_named_parameters
-# Force CGI.pm to use named parameter-style method calls
-# rather than positional parameters. The same effect
-# will happen automatically if the first parameter
-# begins with a -.
-sub use_named_parameters {
- my($self,$use_named) = self_or_default(@_);
- return $self->{'.named'} unless defined ($use_named);
-
- # stupidity to avoid annoying warnings
- return $self->{'.named'}=$use_named;
-}
-END_OF_FUNC
-
-'new_MultipartBuffer' => <<'END_OF_FUNC',
-# Create a new multipart buffer
-sub new_MultipartBuffer {
- my($self,$boundary,$length,$filehandle) = @_;
- return MultipartBuffer->new($self,$boundary,$length,$filehandle);
-}
-END_OF_FUNC
-
-'read_from_client' => <<'END_OF_FUNC',
-# Read data from a file handle
-sub read_from_client {
- my($self, $fh, $buff, $len, $offset) = @_;
- local $^W=0; # prevent a warning
- return undef unless defined($fh);
- return read($fh, $$buff, $len, $offset);
-}
-END_OF_FUNC
-
-'delete' => <<'END_OF_FUNC',
-#### Method: delete
-# Deletes the named parameter entirely.
-####
-sub delete {
- my($self,$name) = self_or_default(@_);
- CORE::delete $self->{$name};
- CORE::delete $self->{'.fieldnames'}->{$name};
- @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
- return wantarray ? () : undef;
-}
-END_OF_FUNC
-
-#### Method: import_names
-# Import all parameters into the given namespace.
-# Assumes namespace 'Q' if not specified
-####
-'import_names' => <<'END_OF_FUNC',
-sub import_names {
- my($self,$namespace,$delete) = self_or_default(@_);
- $namespace = 'Q' unless defined($namespace);
- die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
- if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
- # can anyone find an easier way to do this?
- foreach (keys %{"${namespace}::"}) {
- local *symbol = "${namespace}::${_}";
- undef $symbol;
- undef @symbol;
- undef %symbol;
- }
- }
- my($param,@value,$var);
- foreach $param ($self->param) {
- # protect against silly names
- ($var = $param)=~tr/a-zA-Z0-9_/_/c;
- $var =~ s/^(?=\d)/_/;
- local *symbol = "${namespace}::$var";
- @value = $self->param($param);
- @symbol = @value;
- $symbol = $value[0];
- }
-}
-END_OF_FUNC
-
-#### Method: keywords
-# Keywords acts a bit differently. Calling it in a list context
-# returns the list of keywords.
-# Calling it in a scalar context gives you the size of the list.
-####
-'keywords' => <<'END_OF_FUNC',
-sub keywords {
- my($self,@values) = self_or_default(@_);
- # If values is provided, then we set it.
- $self->{'keywords'}=[@values] if @values;
- my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
- @result;
-}
-END_OF_FUNC
-
-# These are some tie() interfaces for compatibility
-# with Steve Brenner's cgi-lib.pl routines
-'Vars' => <<'END_OF_FUNC',
-sub Vars {
- my $q = shift;
- my %in;
- tie(%in,CGI,$q);
- return %in if wantarray;
- return \%in;
-}
-END_OF_FUNC
-
-# These are some tie() interfaces for compatibility
-# with Steve Brenner's cgi-lib.pl routines
-'ReadParse' => <<'END_OF_FUNC',
-sub ReadParse {
- local(*in);
- if (@_) {
- *in = $_[0];
- } else {
- my $pkg = caller();
- *in=*{"${pkg}::in"};
- }
- tie(%in,CGI);
- return scalar(keys %in);
-}
-END_OF_FUNC
-
-'PrintHeader' => <<'END_OF_FUNC',
-sub PrintHeader {
- my($self) = self_or_default(@_);
- return $self->header();
-}
-END_OF_FUNC
-
-'HtmlTop' => <<'END_OF_FUNC',
-sub HtmlTop {
- my($self,@p) = self_or_default(@_);
- return $self->start_html(@p);
-}
-END_OF_FUNC
-
-'HtmlBot' => <<'END_OF_FUNC',
-sub HtmlBot {
- my($self,@p) = self_or_default(@_);
- return $self->end_html(@p);
-}
-END_OF_FUNC
-
-'SplitParam' => <<'END_OF_FUNC',
-sub SplitParam {
- my ($param) = @_;
- my (@params) = split ("\0", $param);
- return (wantarray ? @params : $params[0]);
-}
-END_OF_FUNC
-
-'MethGet' => <<'END_OF_FUNC',
-sub MethGet {
- return request_method() eq 'GET';
-}
-END_OF_FUNC
-
-'MethPost' => <<'END_OF_FUNC',
-sub MethPost {
- return request_method() eq 'POST';
-}
-END_OF_FUNC
-
-'TIEHASH' => <<'END_OF_FUNC',
-sub TIEHASH {
- return $_[1] if defined $_[1];
- return $Q || new shift;
-}
-END_OF_FUNC
-
-'STORE' => <<'END_OF_FUNC',
-sub STORE {
- $_[0]->param($_[1],split("\0",$_[2]));
-}
-END_OF_FUNC
-
-'FETCH' => <<'END_OF_FUNC',
-sub FETCH {
- return $_[0] if $_[1] eq 'CGI';
- return undef unless defined $_[0]->param($_[1]);
- return join("\0",$_[0]->param($_[1]));
-}
-END_OF_FUNC
-
-'FIRSTKEY' => <<'END_OF_FUNC',
-sub FIRSTKEY {
- $_[0]->{'.iterator'}=0;
- $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
-}
-END_OF_FUNC
-
-'NEXTKEY' => <<'END_OF_FUNC',
-sub NEXTKEY {
- $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
-}
-END_OF_FUNC
-
-'EXISTS' => <<'END_OF_FUNC',
-sub EXISTS {
- exists $_[0]->{$_[1]};
-}
-END_OF_FUNC
-
-'DELETE' => <<'END_OF_FUNC',
-sub DELETE {
- $_[0]->delete($_[1]);
-}
-END_OF_FUNC
-
-'CLEAR' => <<'END_OF_FUNC',
-sub CLEAR {
- %{$_[0]}=();
-}
-####
-END_OF_FUNC
-
-####
-# Append a new value to an existing query
-####
-'append' => <<'EOF',
-sub append {
- my($self,@p) = @_;
- my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
- my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
- if (@values) {
- $self->add_parameter($name);
- push(@{$self->{$name}},@values);
- }
- return $self->param($name);
-}
-EOF
-
-#### Method: delete_all
-# Delete all parameters
-####
-'delete_all' => <<'EOF',
-sub delete_all {
- my($self) = self_or_default(@_);
- undef %{$self};
-}
-EOF
-
-'Delete' => <<'EOF',
-sub Delete {
- my($self,@p) = self_or_default(@_);
- $self->delete(@p);
-}
-EOF
-
-'Delete_all' => <<'EOF',
-sub Delete_all {
- my($self,@p) = self_or_default(@_);
- $self->delete_all(@p);
-}
-EOF
-
-#### Method: autoescape
-# If you want to turn off the autoescaping features,
-# call this method with undef as the argument
-'autoEscape' => <<'END_OF_FUNC',
-sub autoEscape {
- my($self,$escape) = self_or_default(@_);
- $self->{'dontescape'}=!$escape;
-}
-END_OF_FUNC
-
-
-#### Method: version
-# Return the current version
-####
-'version' => <<'END_OF_FUNC',
-sub version {
- return $VERSION;
-}
-END_OF_FUNC
-
-'make_attributes' => <<'END_OF_FUNC',
-sub make_attributes {
- my($self,$attr) = @_;
- return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
- my(@att);
- foreach (keys %{$attr}) {
- my($key) = $_;
- $key=~s/^\-//; # get rid of initial - if present
- $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
- push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/);
- }
- return @att;
-}
-END_OF_FUNC
-
-#### Method: url_param
-# Return a parameter in the QUERY_STRING, regardless of
-# whether this was a POST or a GET
-####
-'url_param' => <<'END_OF_FUNC',
-sub url_param {
- my ($self,@p) = self_or_default(@_);
- my $name = shift(@p);
- return undef unless exists($ENV{QUERY_STRING});
- unless (exists($self->{'.url_param'})) {
- $self->{'.url_param'}={}; # empty hash
- if ($ENV{QUERY_STRING} =~ /=/) {
- my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
- my($param,$value);
- foreach (@pairs) {
- ($param,$value) = split('=',$_,2);
- $param = unescape($param);
- $value = unescape($value);
- push(@{$self->{'.url_param'}->{$param}},$value);
- }
- } else {
- $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
- }
- }
- return keys %{$self->{'.url_param'}} unless defined($name);
- return () unless $self->{'.url_param'}->{$name};
- return wantarray ? @{$self->{'.url_param'}->{$name}}
- : $self->{'.url_param'}->{$name}->[0];
-}
-END_OF_FUNC
-
-#### Method: dump
-# Returns a string in which all the known parameter/value
-# pairs are represented as nested lists, mainly for the purposes
-# of debugging.
-####
-'dump' => <<'END_OF_FUNC',
-sub dump {
- my($self) = self_or_default(@_);
- my($param,$value,@result);
- return '<UL></UL>' unless $self->param;
- push(@result,"<UL>");
- foreach $param ($self->param) {
- my($name)=$self->escapeHTML($param);
- push(@result,"<LI><STRONG>$param</STRONG>");
- push(@result,"<UL>");
- foreach $value ($self->param($param)) {
- $value = $self->escapeHTML($value);
- $value =~ s/\n/<BR>\n/g;
- push(@result,"<LI>$value");
- }
- push(@result,"</UL>");
- }
- push(@result,"</UL>\n");
- return join("\n",@result);
-}
-END_OF_FUNC
-
-#### Method as_string
-#
-# synonym for "dump"
-####
-'as_string' => <<'END_OF_FUNC',
-sub as_string {
- &dump(@_);
-}
-END_OF_FUNC
-
-#### Method: save
-# Write values out to a filehandle in such a way that they can
-# be reinitialized by the filehandle form of the new() method
-####
-'save' => <<'END_OF_FUNC',
-sub save {
- my($self,$filehandle) = self_or_default(@_);
- $filehandle = to_filehandle($filehandle);
- my($param);
- local($,) = ''; # set print field separator back to a sane value
- local($\) = ''; # set output line separator to a sane value
- foreach $param ($self->param) {
- my($escaped_param) = escape($param);
- my($value);
- foreach $value ($self->param($param)) {
- print $filehandle "$escaped_param=",escape("$value"),"\n";
- }
- }
- print $filehandle "=\n"; # end of record
-}
-END_OF_FUNC
-
-
-#### Method: save_parameters
-# An alias for save() that is a better name for exportation.
-# Only intended to be used with the function (non-OO) interface.
-####
-'save_parameters' => <<'END_OF_FUNC',
-sub save_parameters {
- my $fh = shift;
- return save(to_filehandle($fh));
-}
-END_OF_FUNC
-
-#### Method: restore_parameters
-# A way to restore CGI parameters from an initializer.
-# Only intended to be used with the function (non-OO) interface.
-####
-'restore_parameters' => <<'END_OF_FUNC',
-sub restore_parameters {
- $Q = $CGI::DefaultClass->new(@_);
-}
-END_OF_FUNC
-
-#### Method: multipart_init
-# Return a Content-Type: style header for server-push
-# This has to be NPH, and it is advisable to set $| = 1
-#
-# Many thanks to Ed Jordan <ed@fidalgo.net> for this
-# contribution
-####
-'multipart_init' => <<'END_OF_FUNC',
-sub multipart_init {
- my($self,@p) = self_or_default(@_);
- my($boundary,@other) = $self->rearrange([BOUNDARY],@p);
- $boundary = $boundary || '------- =_aaaaaaaaaa0';
- $self->{'separator'} = "\n--$boundary\n";
- $type = SERVER_PUSH($boundary);
- return $self->header(
- -nph => 1,
- -type => $type,
- (map { split "=", $_, 2 } @other),
- ) . $self->multipart_end;
-}
-END_OF_FUNC
-
-
-#### Method: multipart_start
-# Return a Content-Type: style header for server-push, start of section
-#
-# Many thanks to Ed Jordan <ed@fidalgo.net> for this
-# contribution
-####
-'multipart_start' => <<'END_OF_FUNC',
-sub multipart_start {
- my($self,@p) = self_or_default(@_);
- my($type,@other) = $self->rearrange([TYPE],@p);
- $type = $type || 'text/html';
- return $self->header(
- -type => $type,
- (map { split "=", $_, 2 } @other),
- );
-}
-END_OF_FUNC
-
-
-#### Method: multipart_end
-# Return a Content-Type: style header for server-push, end of section
-#
-# Many thanks to Ed Jordan <ed@fidalgo.net> for this
-# contribution
-####
-'multipart_end' => <<'END_OF_FUNC',
-sub multipart_end {
- my($self,@p) = self_or_default(@_);
- return $self->{'separator'};
-}
-END_OF_FUNC
-
-
-#### Method: header
-# Return a Content-Type: style header
-#
-####
-'header' => <<'END_OF_FUNC',
-sub header {
- my($self,@p) = self_or_default(@_);
- my(@header);
-
- return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
-
- my($type,$status,$cookie,$target,$expires,$nph,@other) =
- $self->rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
- STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
-
- $nph ||= $NPH;
- # rearrange() was designed for the HTML portion, so we
- # need to fix it up a little.
- foreach (@other) {
- next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
- ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e;
- }
-
- $type ||= 'text/html' unless defined($type);
-
- # Maybe future compatibility. Maybe not.
- my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
- push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
-
- push(@header,"Status: $status") if $status;
- push(@header,"Window-Target: $target") if $target;
- # push all the cookies -- there may be several
- if ($cookie) {
- my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
- foreach (@cookie) {
- my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
- push(@header,"Set-Cookie: $cs") if $cs ne '';
- }
- }
- # if the user indicates an expiration time, then we need
- # both an Expires and a Date header (so that the browser is
- # uses OUR clock)
- push(@header,"Expires: " . expires($expires,'http'))
- if $expires;
- push(@header,"Date: " . expires(0,'http')) if $expires || $cookie;
- push(@header,"Pragma: no-cache") if $self->cache();
- push(@header,@other);
- push(@header,"Content-Type: $type") if $type ne '';
-
- my $header = join($CRLF,@header)."${CRLF}${CRLF}";
- if ($MOD_PERL and not $nph) {
- my $r = Apache->request;
- $r->send_cgi_header($header);
- return '';
- }
- return $header;
-}
-END_OF_FUNC
-
-
-#### Method: cache
-# Control whether header() will produce the no-cache
-# Pragma directive.
-####
-'cache' => <<'END_OF_FUNC',
-sub cache {
- my($self,$new_value) = self_or_default(@_);
- $new_value = '' unless $new_value;
- if ($new_value ne '') {
- $self->{'cache'} = $new_value;
- }
- return $self->{'cache'};
-}
-END_OF_FUNC
-
-
-#### Method: redirect
-# Return a Location: style header
-#
-####
-'redirect' => <<'END_OF_FUNC',
-sub redirect {
- my($self,@p) = self_or_default(@_);
- my($url,$target,$cookie,$nph,@other) = $self->rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p);
- $url = $url || $self->self_url;
- my(@o);
- foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
- unshift(@o,
- '-Status'=>'302 Moved',
- '-Location'=>$url,
- '-nph'=>$nph);
- unshift(@o,'-Target'=>$target) if $target;
- unshift(@o,'-Cookie'=>$cookie) if $cookie;
- unshift(@o,'-Type'=>'');
- return $self->header(@o);
-}
-END_OF_FUNC
-
-
-#### Method: start_html
-# Canned HTML header
-#
-# Parameters:
-# $title -> (optional) The title for this HTML document (-title)
-# $author -> (optional) e-mail address of the author (-author)
-# $base -> (optional) if set to true, will enter the BASE address of this document
-# for resolving relative references (-base)
-# $xbase -> (optional) alternative base at some remote location (-xbase)
-# $target -> (optional) target window to load all links into (-target)
-# $script -> (option) Javascript code (-script)
-# $no_script -> (option) Javascript <noscript> tag (-noscript)
-# $meta -> (optional) Meta information tags
-# $head -> (optional) any other elements you'd like to incorporate into the <HEAD> tag
-# (a scalar or array ref)
-# $style -> (optional) reference to an external style sheet
-# @other -> (optional) any other named parameters you'd like to incorporate into
-# the <BODY> tag.
-####
-'start_html' => <<'END_OF_FUNC',
-sub start_html {
- my($self,@p) = &self_or_default(@_);
- my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,@other) =
- $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD],@p);
-
- # strangely enough, the title needs to be escaped as HTML
- # while the author needs to be escaped as a URL
- $title = $self->escapeHTML($title || 'Untitled Document');
- $author = $self->escape($author);
- my(@result);
- $dtd = $DEFAULT_DTD unless $dtd && $dtd =~ m|^-//|;
- push(@result,qq(<!DOCTYPE HTML PUBLIC "$dtd">)) if $dtd;
- push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
- push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if defined $author;
-
- if ($base || $xbase || $target) {
- my $href = $xbase || $self->url('-path'=>1);
- my $t = $target ? qq/ TARGET="$target"/ : '';
- push(@result,qq/<BASE HREF="$href"$t>/);
- }
-
- if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
- foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
- }
-
- push(@result,ref($head) ? @$head : $head) if $head;
-
- # handle the infrequently-used -style and -script parameters
- push(@result,$self->_style($style)) if defined $style;
- push(@result,$self->_script($script)) if defined $script;
-
- # handle -noscript parameter
- push(@result,<<END) if $noscript;
-<NOSCRIPT>
-$noscript
-</NOSCRIPT>
-END
- ;
- my($other) = @other ? " @other" : '';
- push(@result,"</HEAD><BODY$other>");
- return join("\n",@result);
-}
-END_OF_FUNC
-
-### Method: _style
-# internal method for generating a CSS style section
-####
-'_style' => <<'END_OF_FUNC',
-sub _style {
- my ($self,$style) = @_;
- my (@result);
- my $type = 'text/css';
- if (ref($style)) {
- my($src,$code,$stype,@other) =
- $self->rearrange([SRC,CODE,TYPE],
- '-foo'=>'bar', # a trick to allow the '-' to be omitted
- ref($style) eq 'ARRAY' ? @$style : %$style);
- $type = $stype if $stype;
- push(@result,qq/<LINK REL="stylesheet" TYPE="$type" HREF="$src">/) if $src;
- push(@result,style({'type'=>$type},"<!--\n$code\n-->")) if $code;
- } else {
- push(@result,style({'type'=>$type},"<!--\n$style\n-->"));
- }
- @result;
-}
-END_OF_FUNC
-
-
-'_script' => <<'END_OF_FUNC',
-sub _script {
- my ($self,$script) = @_;
- my (@result);
- my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
- foreach $script (@scripts) {
- my($src,$code,$language);
- if (ref($script)) { # script is a hash
- ($src,$code,$language) =
- $self->rearrange([SRC,CODE,LANGUAGE],
- '-foo'=>'bar', # a trick to allow the '-' to be omitted
- ref($script) eq 'ARRAY' ? @$script : %$script);
-
- } else {
- ($src,$code,$language) = ('',$script,'JavaScript');
- }
- my(@satts);
- push(@satts,'src'=>$src) if $src;
- push(@satts,'language'=>$language || 'JavaScript');
- $code = "<!-- Hide script\n$code\n// End script hiding -->"
- if $code && $language=~/javascript/i;
- $code = "<!-- Hide script\n$code\n\# End script hiding -->"
- if $code && $language=~/perl/i;
- push(@result,script({@satts},$code || ''));
- }
- @result;
-}
-END_OF_FUNC
-
-#### Method: end_html
-# End an HTML document.
-# Trivial method for completeness. Just returns "</BODY>"
-####
-'end_html' => <<'END_OF_FUNC',
-sub end_html {
- return "</BODY></HTML>";
-}
-END_OF_FUNC
-
-
-################################
-# METHODS USED IN BUILDING FORMS
-################################
-
-#### Method: isindex
-# Just prints out the isindex tag.
-# Parameters:
-# $action -> optional URL of script to run
-# Returns:
-# A string containing a <ISINDEX> tag
-'isindex' => <<'END_OF_FUNC',
-sub isindex {
- my($self,@p) = self_or_default(@_);
- my($action,@other) = $self->rearrange([ACTION],@p);
- $action = qq/ACTION="$action"/ if $action;
- my($other) = @other ? " @other" : '';
- return "<ISINDEX $action$other>";
-}
-END_OF_FUNC
-
-
-#### Method: startform
-# Start a form
-# Parameters:
-# $method -> optional submission method to use (GET or POST)
-# $action -> optional URL of script to run
-# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
-'startform' => <<'END_OF_FUNC',
-sub startform {
- my($self,@p) = self_or_default(@_);
-
- my($method,$action,$enctype,@other) =
- $self->rearrange([METHOD,ACTION,ENCTYPE],@p);
-
- $method = $method || 'POST';
- $enctype = $enctype || &URL_ENCODED;
- $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
- 'ACTION="'.$self->script_name.'"' : '';
- my($other) = @other ? " @other" : '';
- $self->{'.parametersToAdd'}={};
- return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
-}
-END_OF_FUNC
-
-
-#### Method: start_form
-# synonym for startform
-'start_form' => <<'END_OF_FUNC',
-sub start_form {
- &startform;
-}
-END_OF_FUNC
-
-'end_multipart_form' => <<'END_OF_FUNC',
-sub end_multipart_form {
- &endform;
-}
-END_OF_FUNC
-
-#### Method: start_multipart_form
-# synonym for startform
-'start_multipart_form' => <<'END_OF_FUNC',
-sub start_multipart_form {
- my($self,@p) = self_or_default(@_);
- if ($self->use_named_parameters ||
- (defined($param[0]) && substr($param[0],0,1) eq '-')) {
- my(%p) = @p;
- $p{'-enctype'}=&MULTIPART;
- return $self->startform(%p);
- } else {
- my($method,$action,@other) =
- $self->rearrange([METHOD,ACTION],@p);
- return $self->startform($method,$action,&MULTIPART,@other);
- }
-}
-END_OF_FUNC
-
-
-#### Method: endform
-# End a form
-'endform' => <<'END_OF_FUNC',
-sub endform {
- my($self,@p) = self_or_default(@_);
- return wantarray ? ($self->get_fields,"</FORM>") :
- $self->get_fields ."\n</FORM>";
-}
-END_OF_FUNC
-
-
-#### Method: end_form
-# synonym for endform
-'end_form' => <<'END_OF_FUNC',
-sub end_form {
- &endform;
-}
-END_OF_FUNC
-
-
-'_textfield' => <<'END_OF_FUNC',
-sub _textfield {
- my($self,$tag,@p) = self_or_default(@_);
- my($name,$default,$size,$maxlength,$override,@other) =
- $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
-
- my $current = $override ? $default :
- (defined($self->param($name)) ? $self->param($name) : $default);
-
- $current = defined($current) ? $self->escapeHTML($current) : '';
- $name = defined($name) ? $self->escapeHTML($name) : '';
- my($s) = defined($size) ? qq/ SIZE=$size/ : '';
- my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
- my($other) = @other ? " @other" : '';
- # this entered at cristy's request to fix problems with file upload fields
- # and WebTV -- not sure it won't break stuff
- my($value) = $current ne '' ? qq(VALUE="$current") : '';
- return qq/<INPUT TYPE="$tag" NAME="$name" $value$s$m$other>/;
-}
-END_OF_FUNC
-
-#### Method: textfield
-# Parameters:
-# $name -> Name of the text field
-# $default -> Optional default value of the field if not
-# already defined.
-# $size -> Optional width of field in characaters.
-# $maxlength -> Optional maximum number of characters.
-# Returns:
-# A string containing a <INPUT TYPE="text"> field
-#
-'textfield' => <<'END_OF_FUNC',
-sub textfield {
- my($self,@p) = self_or_default(@_);
- $self->_textfield('text',@p);
-}
-END_OF_FUNC
-
-
-#### Method: filefield
-# Parameters:
-# $name -> Name of the file upload field
-# $size -> Optional width of field in characaters.
-# $maxlength -> Optional maximum number of characters.
-# Returns:
-# A string containing a <INPUT TYPE="text"> field
-#
-'filefield' => <<'END_OF_FUNC',
-sub filefield {
- my($self,@p) = self_or_default(@_);
- $self->_textfield('file',@p);
-}
-END_OF_FUNC
-
-
-#### Method: password
-# Create a "secret password" entry field
-# Parameters:
-# $name -> Name of the field
-# $default -> Optional default value of the field if not
-# already defined.
-# $size -> Optional width of field in characters.
-# $maxlength -> Optional maximum characters that can be entered.
-# Returns:
-# A string containing a <INPUT TYPE="password"> field
-#
-'password_field' => <<'END_OF_FUNC',
-sub password_field {
- my ($self,@p) = self_or_default(@_);
- $self->_textfield('password',@p);
-}
-END_OF_FUNC
-
-#### Method: textarea
-# Parameters:
-# $name -> Name of the text field
-# $default -> Optional default value of the field if not
-# already defined.
-# $rows -> Optional number of rows in text area
-# $columns -> Optional number of columns in text area
-# Returns:
-# A string containing a <TEXTAREA></TEXTAREA> tag
-#
-'textarea' => <<'END_OF_FUNC',
-sub textarea {
- my($self,@p) = self_or_default(@_);
-
- my($name,$default,$rows,$cols,$override,@other) =
- $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
-
- my($current)= $override ? $default :
- (defined($self->param($name)) ? $self->param($name) : $default);
-
- $name = defined($name) ? $self->escapeHTML($name) : '';
- $current = defined($current) ? $self->escapeHTML($current) : '';
- my($r) = $rows ? " ROWS=$rows" : '';
- my($c) = $cols ? " COLS=$cols" : '';
- my($other) = @other ? " @other" : '';
- return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
-}
-END_OF_FUNC
-
-
-#### Method: button
-# Create a javascript button.
-# Parameters:
-# $name -> (optional) Name for the button. (-name)
-# $value -> (optional) Value of the button when selected (and visible name) (-value)
-# $onclick -> (optional) Text of the JavaScript to run when the button is
-# clicked.
-# Returns:
-# A string containing a <INPUT TYPE="button"> tag
-####
-'button' => <<'END_OF_FUNC',
-sub button {
- my($self,@p) = self_or_default(@_);
-
- my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
- [ONCLICK,SCRIPT]],@p);
-
- $label=$self->escapeHTML($label);
- $value=$self->escapeHTML($value);
- $script=$self->escapeHTML($script);
-
- my($name) = '';
- $name = qq/ NAME="$label"/ if $label;
- $value = $value || $label;
- my($val) = '';
- $val = qq/ VALUE="$value"/ if $value;
- $script = qq/ ONCLICK="$script"/ if $script;
- my($other) = @other ? " @other" : '';
- return qq/<INPUT TYPE="button"$name$val$script$other>/;
-}
-END_OF_FUNC
-
-
-#### Method: submit
-# Create a "submit query" button.
-# Parameters:
-# $name -> (optional) Name for the button.
-# $value -> (optional) Value of the button when selected (also doubles as label).
-# $label -> (optional) Label printed on the button(also doubles as the value).
-# Returns:
-# A string containing a <INPUT TYPE="submit"> tag
-####
-'submit' => <<'END_OF_FUNC',
-sub submit {
- my($self,@p) = self_or_default(@_);
-
- my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p);
-
- $label=$self->escapeHTML($label);
- $value=$self->escapeHTML($value);
-
- my($name) = ' NAME=".submit"';
- $name = qq/ NAME="$label"/ if defined($label);
- $value = defined($value) ? $value : $label;
- my($val) = '';
- $val = qq/ VALUE="$value"/ if defined($value);
- my($other) = @other ? " @other" : '';
- return qq/<INPUT TYPE="submit"$name$val$other>/;
-}
-END_OF_FUNC
-
-
-#### Method: reset
-# Create a "reset" button.
-# Parameters:
-# $name -> (optional) Name for the button.
-# Returns:
-# A string containing a <INPUT TYPE="reset"> tag
-####
-'reset' => <<'END_OF_FUNC',
-sub reset {
- my($self,@p) = self_or_default(@_);
- my($label,@other) = $self->rearrange([NAME],@p);
- $label=$self->escapeHTML($label);
- my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
- my($other) = @other ? " @other" : '';
- return qq/<INPUT TYPE="reset"$value$other>/;
-}
-END_OF_FUNC
-
-
-#### Method: defaults
-# Create a "defaults" button.
-# Parameters:
-# $name -> (optional) Name for the button.
-# Returns:
-# A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
-#
-# Note: this button has a special meaning to the initialization script,
-# and tells it to ERASE the current query string so that your defaults
-# are used again!
-####
-'defaults' => <<'END_OF_FUNC',
-sub defaults {
- my($self,@p) = self_or_default(@_);
-
- my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
-
- $label=$self->escapeHTML($label);
- $label = $label || "Defaults";
- my($value) = qq/ VALUE="$label"/;
- my($other) = @other ? " @other" : '';
- return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
-}
-END_OF_FUNC
-
-
-#### Method: comment
-# Create an HTML <!-- comment -->
-# Parameters: a string
-'comment' => <<'END_OF_FUNC',
-sub comment {
- my($self,@p) = self_or_CGI(@_);
- return "<!-- @p -->";
-}
-END_OF_FUNC
-
-#### Method: checkbox
-# Create a checkbox that is not logically linked to any others.
-# The field value is "on" when the button is checked.
-# Parameters:
-# $name -> Name of the checkbox
-# $checked -> (optional) turned on by default if true
-# $value -> (optional) value of the checkbox, 'on' by default
-# $label -> (optional) a user-readable label printed next to the box.
-# Otherwise the checkbox name is used.
-# Returns:
-# A string containing a <INPUT TYPE="checkbox"> field
-####
-'checkbox' => <<'END_OF_FUNC',
-sub checkbox {
- my($self,@p) = self_or_default(@_);
-
- my($name,$checked,$value,$label,$override,@other) =
- $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
-
- $value = defined $value ? $value : 'on';
-
- if (!$override && ($self->{'.fieldnames'}->{$name} ||
- defined $self->param($name))) {
- $checked = grep($_ eq $value,$self->param($name)) ? ' CHECKED' : '';
- } else {
- $checked = $checked ? ' CHECKED' : '';
- }
- my($the_label) = defined $label ? $label : $name;
- $name = $self->escapeHTML($name);
- $value = $self->escapeHTML($value);
- $the_label = $self->escapeHTML($the_label);
- my($other) = @other ? " @other" : '';
- $self->register_parameter($name);
- return qq{<INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label};
-}
-END_OF_FUNC
-
-
-#### Method: checkbox_group
-# Create a list of logically-linked checkboxes.
-# Parameters:
-# $name -> Common name for all the check boxes
-# $values -> A pointer to a regular array containing the
-# values for each checkbox in the group.
-# $defaults -> (optional)
-# 1. If a pointer to a regular array of checkbox values,
-# then this will be used to decide which
-# checkboxes to turn on by default.
-# 2. If a scalar, will be assumed to hold the
-# value of a single checkbox in the group to turn on.
-# $linebreak -> (optional) Set to true to place linebreaks
-# between the buttons.
-# $labels -> (optional)
-# A pointer to an associative array of labels to print next to each checkbox
-# in the form $label{'value'}="Long explanatory label".
-# Otherwise the provided values are used as the labels.
-# Returns:
-# An ARRAY containing a series of <INPUT TYPE="checkbox"> fields
-####
-'checkbox_group' => <<'END_OF_FUNC',
-sub checkbox_group {
- my($self,@p) = self_or_default(@_);
-
- my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
- $rowheaders,$colheaders,$override,$nolabels,@other) =
- $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
- LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
- ROWHEADERS,COLHEADERS,
- [OVERRIDE,FORCE],NOLABELS],@p);
-
- my($checked,$break,$result,$label);
-
- my(%checked) = $self->previous_or_default($name,$defaults,$override);
-
- $break = $linebreak ? "<BR>" : '';
- $name=$self->escapeHTML($name);
-
- # Create the elements
- my(@elements,@values);
-
- @values = $self->_set_values_and_labels($values,\$labels,$name);
-
- my($other) = @other ? " @other" : '';
- foreach (@values) {
- $checked = $checked{$_} ? ' CHECKED' : '';
- $label = '';
- unless (defined($nolabels) && $nolabels) {
- $label = $_;
- $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- $label = $self->escapeHTML($label);
- }
- $_ = $self->escapeHTML($_);
- push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label}${break}/);
- }
- $self->register_parameter($name);
- return wantarray ? @elements : join(' ',@elements)
- unless defined($columns) || defined($rows);
- return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
-}
-END_OF_FUNC
-
-# Escape HTML -- used internally
-'escapeHTML' => <<'END_OF_FUNC',
-sub escapeHTML {
- my ($self,$toencode) = self_or_default(@_);
- return undef unless defined($toencode);
- return $toencode if ref($self) && $self->{'dontescape'};
-
- $toencode=~s/&/&amp;/g;
- $toencode=~s/\"/&quot;/g;
- $toencode=~s/>/&gt;/g;
- $toencode=~s/</&lt;/g;
- return $toencode;
-}
-END_OF_FUNC
-
-# unescape HTML -- used internally
-'unescapeHTML' => <<'END_OF_FUNC',
-sub unescapeHTML {
- my $string = ref($_[0]) ? $_[1] : $_[0];
- return undef unless defined($string);
- # thanks to Randal Schwartz for the correct solution to this one
- $string=~ s[&(.*?);]{
- local $_ = $1;
- /^amp$/i ? "&" :
- /^quot$/i ? '"' :
- /^gt$/i ? ">" :
- /^lt$/i ? "<" :
- /^#(\d+)$/ ? chr($1) :
- /^#x([0-9a-f]+)$/i ? chr(hex($1)) :
- $_
- }gex;
- return $string;
-}
-END_OF_FUNC
-
-# Internal procedure - don't use
-'_tableize' => <<'END_OF_FUNC',
-sub _tableize {
- my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
- my($result);
-
- if (defined($columns)) {
- $rows = int(0.99 + @elements/$columns) unless defined($rows);
- }
- if (defined($rows)) {
- $columns = int(0.99 + @elements/$rows) unless defined($columns);
- }
-
- # rearrange into a pretty table
- $result = "<TABLE>";
- my($row,$column);
- unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
- $result .= "<TR>" if @$colheaders;
- foreach (@{$colheaders}) {
- $result .= "<TH>$_</TH>";
- }
- for ($row=0;$row<$rows;$row++) {
- $result .= "<TR>";
- $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
- for ($column=0;$column<$columns;$column++) {
- $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>"
- if defined($elements[$column*$rows + $row]);
- }
- $result .= "</TR>";
- }
- $result .= "</TABLE>";
- return $result;
-}
-END_OF_FUNC
-
-
-#### Method: radio_group
-# Create a list of logically-linked radio buttons.
-# Parameters:
-# $name -> Common name for all the buttons.
-# $values -> A pointer to a regular array containing the
-# values for each button in the group.
-# $default -> (optional) Value of the button to turn on by default. Pass '-'
-# to turn _nothing_ on.
-# $linebreak -> (optional) Set to true to place linebreaks
-# between the buttons.
-# $labels -> (optional)
-# A pointer to an associative array of labels to print next to each checkbox
-# in the form $label{'value'}="Long explanatory label".
-# Otherwise the provided values are used as the labels.
-# Returns:
-# An ARRAY containing a series of <INPUT TYPE="radio"> fields
-####
-'radio_group' => <<'END_OF_FUNC',
-sub radio_group {
- my($self,@p) = self_or_default(@_);
-
- my($name,$values,$default,$linebreak,$labels,
- $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
- $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
- ROWS,[COLUMNS,COLS],
- ROWHEADERS,COLHEADERS,
- [OVERRIDE,FORCE],NOLABELS],@p);
- my($result,$checked);
-
- if (!$override && defined($self->param($name))) {
- $checked = $self->param($name);
- } else {
- $checked = $default;
- }
- my(@elements,@values);
- @values = $self->_set_values_and_labels($values,\$labels,$name);
-
- # If no check array is specified, check the first by default
- $checked = $values[0] unless defined($checked) && $checked ne '';
- $name=$self->escapeHTML($name);
-
- my($other) = @other ? " @other" : '';
- foreach (@values) {
- my($checkit) = $checked eq $_ ? ' CHECKED' : '';
- my($break) = $linebreak ? '<BR>' : '';
- my($label)='';
- unless (defined($nolabels) && $nolabels) {
- $label = $_;
- $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- $label = $self->escapeHTML($label);
- }
- $_=$self->escapeHTML($_);
- push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label}${break}/);
- }
- $self->register_parameter($name);
- return wantarray ? @elements : join(' ',@elements)
- unless defined($columns) || defined($rows);
- return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
-}
-END_OF_FUNC
-
-
-#### Method: popup_menu
-# Create a popup menu.
-# Parameters:
-# $name -> Name for all the menu
-# $values -> A pointer to a regular array containing the
-# text of each menu item.
-# $default -> (optional) Default item to display
-# $labels -> (optional)
-# A pointer to an associative array of labels to print next to each checkbox
-# in the form $label{'value'}="Long explanatory label".
-# Otherwise the provided values are used as the labels.
-# Returns:
-# A string containing the definition of a popup menu.
-####
-'popup_menu' => <<'END_OF_FUNC',
-sub popup_menu {
- my($self,@p) = self_or_default(@_);
-
- my($name,$values,$default,$labels,$override,@other) =
- $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
- my($result,$selected);
-
- if (!$override && defined($self->param($name))) {
- $selected = $self->param($name);
- } else {
- $selected = $default;
- }
- $name=$self->escapeHTML($name);
- my($other) = @other ? " @other" : '';
-
- my(@values);
- @values = $self->_set_values_and_labels($values,\$labels,$name);
-
- $result = qq/<SELECT NAME="$name"$other>\n/;
- foreach (@values) {
- my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
- my($label) = $_;
- $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- my($value) = $self->escapeHTML($_);
- $label=$self->escapeHTML($label);
- $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
- }
-
- $result .= "</SELECT>\n";
- return $result;
-}
-END_OF_FUNC
-
-
-#### Method: scrolling_list
-# Create a scrolling list.
-# Parameters:
-# $name -> name for the list
-# $values -> A pointer to a regular array containing the
-# values for each option line in the list.
-# $defaults -> (optional)
-# 1. If a pointer to a regular array of options,
-# then this will be used to decide which
-# lines to turn on by default.
-# 2. Otherwise holds the value of the single line to turn on.
-# $size -> (optional) Size of the list.
-# $multiple -> (optional) If set, allow multiple selections.
-# $labels -> (optional)
-# A pointer to an associative array of labels to print next to each checkbox
-# in the form $label{'value'}="Long explanatory label".
-# Otherwise the provided values are used as the labels.
-# Returns:
-# A string containing the definition of a scrolling list.
-####
-'scrolling_list' => <<'END_OF_FUNC',
-sub scrolling_list {
- my($self,@p) = self_or_default(@_);
- my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
- = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
- SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
-
- my($result,@values);
- @values = $self->_set_values_and_labels($values,\$labels,$name);
-
- $size = $size || scalar(@values);
-
- my(%selected) = $self->previous_or_default($name,$defaults,$override);
- my($is_multiple) = $multiple ? ' MULTIPLE' : '';
- my($has_size) = $size ? " SIZE=$size" : '';
- my($other) = @other ? " @other" : '';
-
- $name=$self->escapeHTML($name);
- $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
- foreach (@values) {
- my($selectit) = $selected{$_} ? 'SELECTED' : '';
- my($label) = $_;
- $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- $label=$self->escapeHTML($label);
- my($value)=$self->escapeHTML($_);
- $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
- }
- $result .= "</SELECT>\n";
- $self->register_parameter($name);
- return $result;
-}
-END_OF_FUNC
-
-
-#### Method: hidden
-# Parameters:
-# $name -> Name of the hidden field
-# @default -> (optional) Initial values of field (may be an array)
-# or
-# $default->[initial values of field]
-# Returns:
-# A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
-####
-'hidden' => <<'END_OF_FUNC',
-sub hidden {
- my($self,@p) = self_or_default(@_);
-
- # this is the one place where we departed from our standard
- # calling scheme, so we have to special-case (darn)
- my(@result,@value);
- my($name,$default,$override,@other) =
- $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
-
- my $do_override = 0;
- if ( ref($p[0]) || substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
- @value = ref($default) ? @{$default} : $default;
- $do_override = $override;
- } else {
- foreach ($default,$override,@other) {
- push(@value,$_) if defined($_);
- }
- }
-
- # use previous values if override is not set
- my @prev = $self->param($name);
- @value = @prev if !$do_override && @prev;
-
- $name=$self->escapeHTML($name);
- foreach (@value) {
- $_ = defined($_) ? $self->escapeHTML($_) : '';
- push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
- }
- return wantarray ? @result : join('',@result);
-}
-END_OF_FUNC
-
-
-#### Method: image_button
-# Parameters:
-# $name -> Name of the button
-# $src -> URL of the image source
-# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
-# Returns:
-# A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment">
-####
-'image_button' => <<'END_OF_FUNC',
-sub image_button {
- my($self,@p) = self_or_default(@_);
-
- my($name,$src,$alignment,@other) =
- $self->rearrange([NAME,SRC,ALIGN],@p);
-
- my($align) = $alignment ? " ALIGN=\U$alignment" : '';
- my($other) = @other ? " @other" : '';
- $name=$self->escapeHTML($name);
- return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/;
-}
-END_OF_FUNC
-
-
-#### Method: self_url
-# Returns a URL containing the current script and all its
-# param/value pairs arranged as a query. You can use this
-# to create a link that, when selected, will reinvoke the
-# script with all its state information preserved.
-####
-'self_url' => <<'END_OF_FUNC',
-sub self_url {
- my($self,@p) = self_or_default(@_);
- return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
-}
-END_OF_FUNC
-
-
-# This is provided as a synonym to self_url() for people unfortunate
-# enough to have incorporated it into their programs already!
-'state' => <<'END_OF_FUNC',
-sub state {
- &self_url;
-}
-END_OF_FUNC
-
-
-#### Method: url
-# Like self_url, but doesn't return the query string part of
-# the URL.
-####
-'url' => <<'END_OF_FUNC',
-sub url {
- my($self,@p) = self_or_default(@_);
- my ($relative,$absolute,$full,$path_info,$query) =
- $self->rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING']],@p);
- my $url;
- $full++ if !($relative || $absolute);
-
- my $path = $self->path_info;
- my $script_name;
- if (exists($ENV{REQUEST_URI})) {
- my $index;
- $script_name = $ENV{REQUEST_URI};
- # strip query string
- substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0;
- # and path
- substr($script_name,$index) = '' if exists($ENV{PATH_INFO})
- and ($index = rindex($script_name,$ENV{PATH_INFO})) >= 0;
- } else {
- $script_name = $self->script_name;
- }
-
- if ($full) {
- my $protocol = $self->protocol();
- $url = "$protocol://";
- my $vh = http('host');
- if ($vh) {
- $url .= $vh;
- } else {
- $url .= server_name();
- my $port = $self->server_port;
- $url .= ":" . $port
- unless (lc($protocol) eq 'http' && $port == 80)
- || (lc($protocol) eq 'https' && $port == 443);
- }
- $url .= $script_name;
- } elsif ($relative) {
- ($url) = $script_name =~ m!([^/]+)$!;
- } elsif ($absolute) {
- $url = $script_name;
- }
- $url .= $path if $path_info and defined $path;
- $url .= "?" . $self->query_string if $query and $self->query_string;
- return $url;
-}
-
-END_OF_FUNC
-
-#### Method: cookie
-# Set or read a cookie from the specified name.
-# Cookie can then be passed to header().
-# Usual rules apply to the stickiness of -value.
-# Parameters:
-# -name -> name for this cookie (optional)
-# -value -> value of this cookie (scalar, array or hash)
-# -path -> paths for which this cookie is valid (optional)
-# -domain -> internet domain in which this cookie is valid (optional)
-# -secure -> if true, cookie only passed through secure channel (optional)
-# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
-####
-'cookie' => <<'END_OF_FUNC',
-sub cookie {
- my($self,@p) = self_or_default(@_);
- my($name,$value,$path,$domain,$secure,$expires) =
- $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
-
- require CGI::Cookie;
-
- # if no value is supplied, then we retrieve the
- # value of the cookie, if any. For efficiency, we cache the parsed
- # cookies in our state variables.
- unless ( defined($value) ) {
- $self->{'.cookies'} = CGI::Cookie->fetch
- unless $self->{'.cookies'};
-
- # If no name is supplied, then retrieve the names of all our cookies.
- return () unless $self->{'.cookies'};
- return keys %{$self->{'.cookies'}} unless $name;
- return () unless $self->{'.cookies'}->{$name};
- return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
- }
-
- # If we get here, we're creating a new cookie
- return undef unless $name; # this is an error
-
- my @param;
- push(@param,'-name'=>$name);
- push(@param,'-value'=>$value);
- push(@param,'-domain'=>$domain) if $domain;
- push(@param,'-path'=>$path) if $path;
- push(@param,'-expires'=>$expires) if $expires;
- push(@param,'-secure'=>$secure) if $secure;
-
- return CGI::Cookie->new(@param);
-}
-END_OF_FUNC
-
-# This internal routine creates an expires time exactly some number of
-# hours from the current time. It incorporates modifications from
-# Mark Fisher.
-'expire_calc' => <<'END_OF_FUNC',
-sub expire_calc {
- my($time) = @_;
- my(%mult) = ('s'=>1,
- 'm'=>60,
- 'h'=>60*60,
- 'd'=>60*60*24,
- 'M'=>60*60*24*30,
- 'y'=>60*60*24*365);
- # format for time can be in any of the forms...
- # "now" -- expire immediately
- # "+180s" -- in 180 seconds
- # "+2m" -- in 2 minutes
- # "+12h" -- in 12 hours
- # "+1d" -- in 1 day
- # "+3M" -- in 3 months
- # "+2y" -- in 2 years
- # "-3m" -- 3 minutes ago(!)
- # If you don't supply one of these forms, we assume you are
- # specifying the date yourself
- my($offset);
- if (!$time || (lc($time) eq 'now')) {
- $offset = 0;
- } elsif ($time=~/^\d+/) {
- return $time;
- } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
- $offset = ($mult{$2} || 1)*$1;
- } else {
- return $time;
- }
- return (time+$offset);
-}
-END_OF_FUNC
-
-# This internal routine creates date strings suitable for use in
-# cookies and HTTP headers. (They differ, unfortunately.)
-# Thanks to Mark Fisher for this.
-'expires' => <<'END_OF_FUNC',
-sub expires {
- my($time,$format) = @_;
- $format ||= 'http';
-
- my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
- my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
-
- # pass through preformatted dates for the sake of expire_calc()
- $time = expire_calc($time);
- return $time unless $time =~ /^\d+$/;
-
- # make HTTP/cookie date string from GMT'ed time
- # (cookies use '-' as date separator, HTTP uses ' ')
- my($sc) = ' ';
- $sc = '-' if $format eq "cookie";
- my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
- $year += 1900;
- return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
- $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
-}
-END_OF_FUNC
-
-'parse_keywordlist' => <<'END_OF_FUNC',
-sub parse_keywordlist {
- my($self,$tosplit) = @_;
- $tosplit = unescape($tosplit); # unescape the keywords
- $tosplit=~tr/+/ /; # pluses to spaces
- my(@keywords) = split(/\s+/,$tosplit);
- return @keywords;
-}
-END_OF_FUNC
-
-'param_fetch' => <<'END_OF_FUNC',
-sub param_fetch {
- my($self,@p) = self_or_default(@_);
- my($name) = $self->rearrange([NAME],@p);
- unless (exists($self->{$name})) {
- $self->add_parameter($name);
- $self->{$name} = [];
- }
-
- return $self->{$name};
-}
-END_OF_FUNC
-
-###############################################
-# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
-###############################################
-
-#### Method: path_info
-# Return the extra virtual path information provided
-# after the URL (if any)
-####
-'path_info' => <<'END_OF_FUNC',
-sub path_info {
- my ($self,$info) = self_or_default(@_);
- if (defined($info)) {
- $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
- $self->{'.path_info'} = $info;
- } elsif (! defined($self->{'.path_info'}) ) {
- $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ?
- $ENV{'PATH_INFO'} : '';
-
- # hack to fix broken path info in IIS
- $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
-
- }
- return $self->{'.path_info'};
-}
-END_OF_FUNC
-
-
-#### Method: request_method
-# Returns 'POST', 'GET', 'PUT' or 'HEAD'
-####
-'request_method' => <<'END_OF_FUNC',
-sub request_method {
- return $ENV{'REQUEST_METHOD'};
-}
-END_OF_FUNC
-
-#### Method: content_type
-# Returns the content_type string
-####
-'content_type' => <<'END_OF_FUNC',
-sub content_type {
- return $ENV{'CONTENT_TYPE'};
-}
-END_OF_FUNC
-
-#### Method: path_translated
-# Return the physical path information provided
-# by the URL (if any)
-####
-'path_translated' => <<'END_OF_FUNC',
-sub path_translated {
- return $ENV{'PATH_TRANSLATED'};
-}
-END_OF_FUNC
-
-
-#### Method: query_string
-# Synthesize a query string from our current
-# parameters
-####
-'query_string' => <<'END_OF_FUNC',
-sub query_string {
- my($self) = self_or_default(@_);
- my($param,$value,@pairs);
- foreach $param ($self->param) {
- my($eparam) = escape($param);
- foreach $value ($self->param($param)) {
- $value = escape($value);
- next unless defined $value;
- push(@pairs,"$eparam=$value");
- }
- }
- return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
-}
-END_OF_FUNC
-
-
-#### Method: accept
-# Without parameters, returns an array of the
-# MIME types the browser accepts.
-# With a single parameter equal to a MIME
-# type, will return undef if the browser won't
-# accept it, 1 if the browser accepts it but
-# doesn't give a preference, or a floating point
-# value between 0.0 and 1.0 if the browser
-# declares a quantitative score for it.
-# This handles MIME type globs correctly.
-####
-'Accept' => <<'END_OF_FUNC',
-sub Accept {
- my($self,$search) = self_or_CGI(@_);
- my(%prefs,$type,$pref,$pat);
-
- my(@accept) = split(',',$self->http('accept'));
-
- foreach (@accept) {
- ($pref) = /q=(\d\.\d+|\d+)/;
- ($type) = m#(\S+/[^;]+)#;
- next unless $type;
- $prefs{$type}=$pref || 1;
- }
-
- return keys %prefs unless $search;
-
- # if a search type is provided, we may need to
- # perform a pattern matching operation.
- # The MIME types use a glob mechanism, which
- # is easily translated into a perl pattern match
-
- # First return the preference for directly supported
- # types:
- return $prefs{$search} if $prefs{$search};
-
- # Didn't get it, so try pattern matching.
- foreach (keys %prefs) {
- next unless /\*/; # not a pattern match
- ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
- $pat =~ s/\*/.*/g; # turn it into a pattern
- return $prefs{$_} if $search=~/$pat/;
- }
-}
-END_OF_FUNC
-
-
-#### Method: user_agent
-# If called with no parameters, returns the user agent.
-# If called with one parameter, does a pattern match (case
-# insensitive) on the user agent.
-####
-'user_agent' => <<'END_OF_FUNC',
-sub user_agent {
- my($self,$match)=self_or_CGI(@_);
- return $self->http('user_agent') unless $match;
- return $self->http('user_agent') =~ /$match/i;
-}
-END_OF_FUNC
-
-
-#### Method: raw_cookie
-# Returns the magic cookies for the session.
-# The cookies are not parsed or altered in any way, i.e.
-# cookies are returned exactly as given in the HTTP
-# headers. If a cookie name is given, only that cookie's
-# value is returned, otherwise the entire raw cookie
-# is returned.
-####
-'raw_cookie' => <<'END_OF_FUNC',
-sub raw_cookie {
- my($self,$key) = self_or_CGI(@_);
-
- require CGI::Cookie;
-
- if (defined($key)) {
- $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
- unless $self->{'.raw_cookies'};
-
- return () unless $self->{'.raw_cookies'};
- return () unless $self->{'.raw_cookies'}->{$key};
- return $self->{'.raw_cookies'}->{$key};
- }
- return $self->http('cookie') || $ENV{'COOKIE'} || '';
-}
-END_OF_FUNC
-
-#### Method: virtual_host
-# Return the name of the virtual_host, which
-# is not always the same as the server
-######
-'virtual_host' => <<'END_OF_FUNC',
-sub virtual_host {
- my $vh = http('host') || server_name();
- $vh =~ s/:\d+$//; # get rid of port number
- return $vh;
-}
-END_OF_FUNC
-
-#### Method: remote_host
-# Return the name of the remote host, or its IP
-# address if unavailable. If this variable isn't
-# defined, it returns "localhost" for debugging
-# purposes.
-####
-'remote_host' => <<'END_OF_FUNC',
-sub remote_host {
- return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
- || 'localhost';
-}
-END_OF_FUNC
-
-
-#### Method: remote_addr
-# Return the IP addr of the remote host.
-####
-'remote_addr' => <<'END_OF_FUNC',
-sub remote_addr {
- return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
-}
-END_OF_FUNC
-
-
-#### Method: script_name
-# Return the partial URL to this script for
-# self-referencing scripts. Also see
-# self_url(), which returns a URL with all state information
-# preserved.
-####
-'script_name' => <<'END_OF_FUNC',
-sub script_name {
- return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'});
- # These are for debugging
- return "/$0" unless $0=~/^\//;
- return $0;
-}
-END_OF_FUNC
-
-
-#### Method: referer
-# Return the HTTP_REFERER: useful for generating
-# a GO BACK button.
-####
-'referer' => <<'END_OF_FUNC',
-sub referer {
- my($self) = self_or_CGI(@_);
- return $self->http('referer');
-}
-END_OF_FUNC
-
-
-#### Method: server_name
-# Return the name of the server
-####
-'server_name' => <<'END_OF_FUNC',
-sub server_name {
- return $ENV{'SERVER_NAME'} || 'localhost';
-}
-END_OF_FUNC
-
-#### Method: server_software
-# Return the name of the server software
-####
-'server_software' => <<'END_OF_FUNC',
-sub server_software {
- return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
-}
-END_OF_FUNC
-
-#### Method: server_port
-# Return the tcp/ip port the server is running on
-####
-'server_port' => <<'END_OF_FUNC',
-sub server_port {
- return $ENV{'SERVER_PORT'} || 80; # for debugging
-}
-END_OF_FUNC
-
-#### Method: server_protocol
-# Return the protocol (usually HTTP/1.0)
-####
-'server_protocol' => <<'END_OF_FUNC',
-sub server_protocol {
- return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
-}
-END_OF_FUNC
-
-#### Method: http
-# Return the value of an HTTP variable, or
-# the list of variables if none provided
-####
-'http' => <<'END_OF_FUNC',
-sub http {
- my ($self,$parameter) = self_or_CGI(@_);
- return $ENV{$parameter} if $parameter=~/^HTTP/;
- $parameter =~ tr/-/_/;
- return $ENV{"HTTP_\U$parameter\E"} if $parameter;
- my(@p);
- foreach (keys %ENV) {
- push(@p,$_) if /^HTTP/;
- }
- return @p;
-}
-END_OF_FUNC
-
-#### Method: https
-# Return the value of HTTPS
-####
-'https' => <<'END_OF_FUNC',
-sub https {
- local($^W)=0;
- my ($self,$parameter) = self_or_CGI(@_);
- return $ENV{HTTPS} unless $parameter;
- return $ENV{$parameter} if $parameter=~/^HTTPS/;
- $parameter =~ tr/-/_/;
- return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
- my(@p);
- foreach (keys %ENV) {
- push(@p,$_) if /^HTTPS/;
- }
- return @p;
-}
-END_OF_FUNC
-
-#### Method: protocol
-# Return the protocol (http or https currently)
-####
-'protocol' => <<'END_OF_FUNC',
-sub protocol {
- local($^W)=0;
- my $self = shift;
- return 'https' if uc($self->https()) eq 'ON';
- return 'https' if $self->server_port == 443;
- my $prot = $self->server_protocol;
- my($protocol,$version) = split('/',$prot);
- return "\L$protocol\E";
-}
-END_OF_FUNC
-
-#### Method: remote_ident
-# Return the identity of the remote user
-# (but only if his host is running identd)
-####
-'remote_ident' => <<'END_OF_FUNC',
-sub remote_ident {
- return $ENV{'REMOTE_IDENT'};
-}
-END_OF_FUNC
-
-
-#### Method: auth_type
-# Return the type of use verification/authorization in use, if any.
-####
-'auth_type' => <<'END_OF_FUNC',
-sub auth_type {
- return $ENV{'AUTH_TYPE'};
-}
-END_OF_FUNC
-
-
-#### Method: remote_user
-# Return the authorization name used for user
-# verification.
-####
-'remote_user' => <<'END_OF_FUNC',
-sub remote_user {
- return $ENV{'REMOTE_USER'};
-}
-END_OF_FUNC
-
-
-#### Method: user_name
-# Try to return the remote user's name by hook or by
-# crook
-####
-'user_name' => <<'END_OF_FUNC',
-sub user_name {
- my ($self) = self_or_CGI(@_);
- return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
-}
-END_OF_FUNC
-
-#### Method: nph
-# Set or return the NPH global flag
-####
-'nph' => <<'END_OF_FUNC',
-sub nph {
- my ($self,$param) = self_or_CGI(@_);
- $CGI::NPH = $param if defined($param);
- return $CGI::NPH;
-}
-END_OF_FUNC
-
-#### Method: private_tempfiles
-# Set or return the private_tempfiles global flag
-####
-'private_tempfiles' => <<'END_OF_FUNC',
-sub private_tempfiles {
- my ($self,$param) = self_or_CGI(@_);
- $CGI::PRIVATE_TEMPFILES = $param if defined($param);
- return $CGI::PRIVATE_TEMPFILES;
-}
-END_OF_FUNC
-
-#### Method: default_dtd
-# Set or return the default_dtd global
-####
-'default_dtd' => <<'END_OF_FUNC',
-sub default_dtd {
- my ($self,$param) = self_or_CGI(@_);
- $CGI::DEFAULT_DTD = $param if defined($param);
- return $CGI::DEFAULT_DTD;
-}
-END_OF_FUNC
-
-# -------------- really private subroutines -----------------
-'previous_or_default' => <<'END_OF_FUNC',
-sub previous_or_default {
- my($self,$name,$defaults,$override) = @_;
- my(%selected);
-
- if (!$override && ($self->{'.fieldnames'}->{$name} ||
- defined($self->param($name)) ) ) {
- grep($selected{$_}++,$self->param($name));
- } elsif (defined($defaults) && ref($defaults) &&
- (ref($defaults) eq 'ARRAY')) {
- grep($selected{$_}++,@{$defaults});
- } else {
- $selected{$defaults}++ if defined($defaults);
- }
-
- return %selected;
-}
-END_OF_FUNC
-
-'register_parameter' => <<'END_OF_FUNC',
-sub register_parameter {
- my($self,$param) = @_;
- $self->{'.parametersToAdd'}->{$param}++;
-}
-END_OF_FUNC
-
-'get_fields' => <<'END_OF_FUNC',
-sub get_fields {
- my($self) = @_;
- return $self->CGI::hidden('-name'=>'.cgifields',
- '-values'=>[keys %{$self->{'.parametersToAdd'}}],
- '-override'=>1);
-}
-END_OF_FUNC
-
-'read_from_cmdline' => <<'END_OF_FUNC',
-sub read_from_cmdline {
- my($input,@words);
- my($query_string);
- if (@ARGV) {
- @words = @ARGV;
- } else {
- require "shellwords.pl";
- print STDERR "(offline mode: enter name=value pairs on standard input)\n";
- chomp(@lines = <STDIN>); # remove newlines
- $input = join(" ",@lines);
- @words = &shellwords($input);
- }
- foreach (@words) {
- s/\\=/%3D/g;
- s/\\&/%26/g;
- }
-
- if ("@words"=~/=/) {
- $query_string = join('&',@words);
- } else {
- $query_string = join('+',@words);
- }
- return $query_string;
-}
-END_OF_FUNC
-
-#####
-# subroutine: read_multipart
-#
-# Read multipart data and store it into our parameters.
-# An interesting feature is that if any of the parts is a file, we
-# create a temporary file and open up a filehandle on it so that the
-# caller can read from it if necessary.
-#####
-'read_multipart' => <<'END_OF_FUNC',
-sub read_multipart {
- my($self,$boundary,$length,$filehandle) = @_;
- my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle);
- return unless $buffer;
- my(%header,$body);
- my $filenumber = 0;
- while (!$buffer->eof) {
- %header = $buffer->readHeader;
-
- unless (%header) {
- $self->cgi_error("400 Bad request (malformed multipart POST)");
- return;
- }
-
- my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
-
- # Bug: Netscape doesn't escape quotation marks in file names!!!
- my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/;
-
- # add this parameter to our list
- $self->add_parameter($param);
-
- # If no filename specified, then just read the data and assign it
- # to our parameter list.
- if ( !defined($filename) || $filename eq '' ) {
- my($value) = $buffer->readBody;
- push(@{$self->{$param}},$value);
- next;
- }
-
- my ($tmpfile,$tmp,$filehandle);
- UPLOADS: {
- # If we get here, then we are dealing with a potentially large
- # uploaded form. Save the data to a temporary file, then open
- # the file for reading.
-
- # skip the file if uploads disabled
- if ($DISABLE_UPLOADS) {
- while (defined($data = $buffer->read)) { }
- last UPLOADS;
- }
-
- # choose a relatively unpredictable tmpfile sequence number
- my $seqno = unpack("%16C*",join('',localtime,values %ENV));
- for (my $cnt=10;$cnt>0;$cnt--) {
- next unless $tmpfile = new TempFile($seqno);
- $tmp = $tmpfile->as_string;
- last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
- $seqno += int rand(100);
- }
- die "CGI open of tmpfile: $!\n" unless $filehandle;
- $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
-
- my ($data);
- local($\) = '';
- while (defined($data = $buffer->read)) {
- print $filehandle $data;
- }
-
- # back up to beginning of file
- seek($filehandle,0,0);
- $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
-
- # Save some information about the uploaded file where we can get
- # at it later.
- $self->{'.tmpfiles'}->{fileno($filehandle)}= {
- name => $tmpfile,
- info => {%header},
- };
- push(@{$self->{$param}},$filehandle);
- }
- }
-}
-END_OF_FUNC
-
-'upload' =><<'END_OF_FUNC',
-sub upload {
- my($self,$param_name) = self_or_default(@_);
- my $param = $self->param($param_name);
- return unless $param;
- return unless ref($param) && fileno($param);
- return $param;
-}
-END_OF_FUNC
-
-'tmpFileName' => <<'END_OF_FUNC',
-sub tmpFileName {
- my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ?
- $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string
- : '';
-}
-END_OF_FUNC
-
-'uploadInfo' => <<'END_OF_FUNC',
-sub uploadInfo {
- my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{fileno($filename)}->{info};
-}
-END_OF_FUNC
-
-# internal routine, don't use
-'_set_values_and_labels' => <<'END_OF_FUNC',
-sub _set_values_and_labels {
- my $self = shift;
- my ($v,$l,$n) = @_;
- $$l = $v if ref($v) eq 'HASH' && !ref($$l);
- return $self->param($n) if !defined($v);
- return $v if !ref($v);
- return ref($v) eq 'HASH' ? keys %$v : @$v;
-}
-END_OF_FUNC
-
-'_compile_all' => <<'END_OF_FUNC',
-sub _compile_all {
- foreach (@_) {
- next if defined(&$_);
- $AUTOLOAD = "CGI::$_";
- _compile();
- }
-}
-END_OF_FUNC
-
-);
-END_OF_AUTOLOAD
-;
-
-#########################################################
-# Globals and stubs for other packages that we use.
-#########################################################
-
-################### Fh -- lightweight filehandle ###############
-package Fh;
-use overload
- '""' => \&asString,
- 'cmp' => \&compare,
- 'fallback'=>1;
-
-$FH='fh00000';
-
-*Fh::AUTOLOAD = \&CGI::AUTOLOAD;
-
-$AUTOLOADED_ROUTINES = ''; # prevent -w error
-$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
-%SUBS = (
-'asString' => <<'END_OF_FUNC',
-sub asString {
- my $self = shift;
- # get rid of package name
- (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
- $i =~ s/\\(.)/$1/g;
- return $i;
-# BEGIN DEAD CODE
-# This was an extremely clever patch that allowed "use strict refs".
-# Unfortunately it relied on another bug that caused leaky file descriptors.
-# The underlying bug has been fixed, so this no longer works. However
-# "strict refs" still works for some reason.
-# my $self = shift;
-# return ${*{$self}{SCALAR}};
-# END DEAD CODE
-}
-END_OF_FUNC
-
-'compare' => <<'END_OF_FUNC',
-sub compare {
- my $self = shift;
- my $value = shift;
- return "$self" cmp $value;
-}
-END_OF_FUNC
-
-'new' => <<'END_OF_FUNC',
-sub new {
- my($pack,$name,$file,$delete) = @_;
- require Fcntl unless defined &Fcntl::O_RDWR;
- my $ref = \*{'Fh::' . ++$FH . quotemeta($name)};
- sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
- unlink($file) if $delete;
- CORE::delete $Fh::{$FH};
- return bless $ref,$pack;
-}
-END_OF_FUNC
-
-'DESTROY' => <<'END_OF_FUNC',
-sub DESTROY {
- my $self = shift;
- close $self;
-}
-END_OF_FUNC
-
-);
-END_OF_AUTOLOAD
-
-######################## MultipartBuffer ####################
-package MultipartBuffer;
-
-# how many bytes to read at a time. We use
-# a 4K buffer by default.
-$INITIAL_FILLUNIT = 1024 * 4;
-$TIMEOUT = 240*60; # 4 hour timeout for big files
-$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
-$CRLF=$CGI::CRLF;
-
-#reuse the autoload function
-*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
-
-# avoid autoloader warnings
-sub DESTROY {}
-
-###############################################################################
-################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
-###############################################################################
-$AUTOLOADED_ROUTINES = ''; # prevent -w error
-$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
-%SUBS = (
-
-'new' => <<'END_OF_FUNC',
-sub new {
- my($package,$interface,$boundary,$length,$filehandle) = @_;
- $FILLUNIT = $INITIAL_FILLUNIT;
- my $IN;
- if ($filehandle) {
- my($package) = caller;
- # force into caller's package if necessary
- $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
- }
- $IN = "main::STDIN" unless $IN;
-
- $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
-
- # If the user types garbage into the file upload field,
- # then Netscape passes NOTHING to the server (not good).
- # We may hang on this read in that case. So we implement
- # a read timeout. If nothing is ready to read
- # by then, we return.
-
- # Netscape seems to be a little bit unreliable
- # about providing boundary strings.
- if ($boundary) {
-
- # Under the MIME spec, the boundary consists of the
- # characters "--" PLUS the Boundary string
-
- # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
- # the two extra hyphens. We do a special case here on the user-agent!!!!
- $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac');
-
- } else { # otherwise we find it ourselves
- my($old);
- ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
- $boundary = <$IN>; # BUG: This won't work correctly under mod_perl
- $length -= length($boundary);
- chomp($boundary); # remove the CRLF
- $/ = $old; # restore old line separator
- }
-
- my $self = {LENGTH=>$length,
- BOUNDARY=>$boundary,
- IN=>$IN,
- INTERFACE=>$interface,
- BUFFER=>'',
- };
-
- $FILLUNIT = length($boundary)
- if length($boundary) > $FILLUNIT;
-
- my $retval = bless $self,ref $package || $package;
-
- # Read the preamble and the topmost (boundary) line plus the CRLF.
- while ($self->read(0)) { }
- die "Malformed multipart POST\n" if $self->eof;
-
- return $retval;
-}
-END_OF_FUNC
-
-'readHeader' => <<'END_OF_FUNC',
-sub readHeader {
- my($self) = @_;
- my($end);
- my($ok) = 0;
- my($bad) = 0;
-
- if ($CGI::OS eq 'VMS') { # tssk, tssk: inconsistency alert!
- local($CRLF) = "\015\012";
- }
-
- do {
- $self->fillBuffer($FILLUNIT);
- $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
- $ok++ if $self->{BUFFER} eq '';
- $bad++ if !$ok && $self->{LENGTH} <= 0;
- # this was a bad idea
- # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
- } until $ok || $bad;
- return () if $bad;
-
- my($header) = substr($self->{BUFFER},0,$end+2);
- substr($self->{BUFFER},0,$end+4) = '';
- my %return;
-
-
- # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
- # (Folding Long Header Fields), 3.4.3 (Comments)
- # and 3.4.5 (Quoted-Strings).
-
- my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
- $header=~s/$CRLF\s+/ /og; # merge continuation lines
- while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
- my ($field_name,$field_value) = ($1,$2); # avoid taintedness
- $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
- $return{$field_name}=$field_value;
- }
- return %return;
-}
-END_OF_FUNC
-
-# This reads and returns the body as a single scalar value.
-'readBody' => <<'END_OF_FUNC',
-sub readBody {
- my($self) = @_;
- my($data);
- my($returnval)='';
- while (defined($data = $self->read)) {
- $returnval .= $data;
- }
- return $returnval;
-}
-END_OF_FUNC
-
-# This will read $bytes or until the boundary is hit, whichever happens
-# first. After the boundary is hit, we return undef. The next read will
-# skip over the boundary and begin reading again;
-'read' => <<'END_OF_FUNC',
-sub read {
- my($self,$bytes) = @_;
-
- # default number of bytes to read
- $bytes = $bytes || $FILLUNIT;
-
- # Fill up our internal buffer in such a way that the boundary
- # is never split between reads.
- $self->fillBuffer($bytes);
-
- # Find the boundary in the buffer (it may not be there).
- my $start = index($self->{BUFFER},$self->{BOUNDARY});
- # protect against malformed multipart POST operations
- die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
-
- # If the boundary begins the data, then skip past it
- # and return undef. The +2 here is a fiendish plot to
- # remove the CR/LF pair at the end of the boundary.
- if ($start == 0) {
-
- # clear us out completely if we've hit the last boundary.
- if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
- $self->{BUFFER}='';
- $self->{LENGTH}=0;
- return undef;
- }
-
- # just remove the boundary.
- substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
- return undef;
- }
-
- my $bytesToReturn;
- if ($start > 0) { # read up to the boundary
- $bytesToReturn = $start > $bytes ? $bytes : $start;
- } else { # read the requested number of bytes
- # leave enough bytes in the buffer to allow us to read
- # the boundary. Thanks to Kevin Hendrick for finding
- # this one.
- $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
- }
-
- my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
- substr($self->{BUFFER},0,$bytesToReturn)='';
-
- # If we hit the boundary, remove the CRLF from the end.
- return ($start > 0) ? substr($returnval,0,-2) : $returnval;
-}
-END_OF_FUNC
-
-
-# This fills up our internal buffer in such a way that the
-# boundary is never split between reads
-'fillBuffer' => <<'END_OF_FUNC',
-sub fillBuffer {
- my($self,$bytes) = @_;
- return unless $self->{LENGTH};
-
- my($boundaryLength) = length($self->{BOUNDARY});
- my($bufferLength) = length($self->{BUFFER});
- my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
- $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
-
- # Try to read some data. We may hang here if the browser is screwed up.
- my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN},
- \$self->{BUFFER},
- $bytesToRead,
- $bufferLength);
- $self->{BUFFER} = '' unless defined $self->{BUFFER};
-
- # An apparent bug in the Apache server causes the read()
- # to return zero bytes repeatedly without blocking if the
- # remote user aborts during a file transfer. I don't know how
- # they manage this, but the workaround is to abort if we get
- # more than SPIN_LOOP_MAX consecutive zero reads.
- if ($bytesRead == 0) {
- die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
- if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
- } else {
- $self->{ZERO_LOOP_COUNTER}=0;
- }
-
- $self->{LENGTH} -= $bytesRead;
-}
-END_OF_FUNC
-
-
-# Return true when we've finished reading
-'eof' => <<'END_OF_FUNC'
-sub eof {
- my($self) = @_;
- return 1 if (length($self->{BUFFER}) == 0)
- && ($self->{LENGTH} <= 0);
- undef;
-}
-END_OF_FUNC
-
-);
-END_OF_AUTOLOAD
-
-####################################################################################
-################################## TEMPORARY FILES #################################
-####################################################################################
-package TempFile;
-
-$SL = $CGI::SL;
-$MAC = $CGI::OS eq 'MACINTOSH';
-my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
-unless ($TMPDIRECTORY) {
- @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
- "C:${SL}temp","${SL}tmp","${SL}temp",
- "${vol}${SL}Temporary Items","${SL}sys\$scratch",
- "${SL}WWW_ROOT");
- unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'};
-
- #
- # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
- # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
- # : can generate a 'getpwuid() not implemented' exception, even though
- # : it's never called. Found under DOS/Win with the DJGPP perl port.
- # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
- unshift(@TEMP,(eval {(getpwuid($<))[7]}).'/tmp') if $CGI::OS eq 'UNIX';
-
- foreach (@TEMP) {
- do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
- }
-}
-
-$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
-$MAXTRIES = 5000;
-
-# cute feature, but overload implementation broke it
-# %OVERLOAD = ('""'=>'as_string');
-*TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
-
-###############################################################################
-################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
-###############################################################################
-$AUTOLOADED_ROUTINES = ''; # prevent -w error
-$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
-%SUBS = (
-
-'new' => <<'END_OF_FUNC',
-sub new {
- my($package,$sequence) = @_;
- my $filename;
- for (my $i = 0; $i < $MAXTRIES; $i++) {
- last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
- }
- # untaint the darn thing
- return unless $filename =~ m!^([a-zA-Z0-9_ '":/\\]+)$!;
- $filename = $1;
- return bless \$filename;
-}
-END_OF_FUNC
-
-'DESTROY' => <<'END_OF_FUNC',
-sub DESTROY {
- my($self) = @_;
- unlink $$self; # get rid of the file
-}
-END_OF_FUNC
-
-'as_string' => <<'END_OF_FUNC'
-sub as_string {
- my($self) = @_;
- return $$self;
-}
-END_OF_FUNC
-
-);
-END_OF_AUTOLOAD
-
-package CGI;
-
-# We get a whole bunch of warnings about "possibly uninitialized variables"
-# when running with the -w switch. Touch them all once to get rid of the
-# warnings. This is ugly and I hate it.
-if ($^W) {
- $CGI::CGI = '';
- $CGI::CGI=<<EOF;
- $CGI::VERSION;
- $MultipartBuffer::SPIN_LOOP_MAX;
- $MultipartBuffer::CRLF;
- $MultipartBuffer::TIMEOUT;
- $MultipartBuffer::INITIAL_FILLUNIT;
-EOF
- ;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-CGI - Simple Common Gateway Interface Class
-
-=head1 SYNOPSIS
-
- # CGI script that creates a fill-out form
- # and echoes back its values.
-
- use CGI qw/:standard/;
- print header,
- start_html('A Simple Example'),
- h1('A Simple Example'),
- start_form,
- "What's your name? ",textfield('name'),p,
- "What's the combination?", p,
- checkbox_group(-name=>'words',
- -values=>['eenie','meenie','minie','moe'],
- -defaults=>['eenie','minie']), p,
- "What's your favorite color? ",
- popup_menu(-name=>'color',
- -values=>['red','green','blue','chartreuse']),p,
- submit,
- end_form,
- hr;
-
- if (param()) {
- print "Your name is",em(param('name')),p,
- "The keywords are: ",em(join(", ",param('words'))),p,
- "Your favorite color is ",em(param('color')),
- hr;
- }
-
-=head1 ABSTRACT
-
-This perl library uses perl5 objects to make it easy to create Web
-fill-out forms and parse their contents. This package defines CGI
-objects, entities that contain the values of the current query string
-and other state variables. Using a CGI object's methods, you can
-examine keywords and parameters passed to your script, and create
-forms whose initial values are taken from the current query (thereby
-preserving state information). The module provides shortcut functions
-that produce boilerplate HTML, reducing typing and coding errors. It
-also provides functionality for some of the more advanced features of
-CGI scripting, including support for file uploads, cookies, cascading
-style sheets, server push, and frames.
-
-CGI.pm also provides a simple function-oriented programming style for
-those who don't need its object-oriented features.
-
-The current version of CGI.pm is available at
-
- http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
- ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
-
-=head1 DESCRIPTION
-
-=head2 PROGRAMMING STYLE
-
-There are two styles of programming with CGI.pm, an object-oriented
-style and a function-oriented style. In the object-oriented style you
-create one or more CGI objects and then use object methods to create
-the various elements of the page. Each CGI object starts out with the
-list of named parameters that were passed to your CGI script by the
-server. You can modify the objects, save them to a file or database
-and recreate them. Because each object corresponds to the "state" of
-the CGI script, and because each object's parameter list is
-independent of the others, this allows you to save the state of the
-script and restore it later.
-
-For example, using the object oriented style, here is how you create
-a simple "Hello World" HTML page:
-
- #!/usr/local/bin/perl -w
- use CGI; # load CGI routines
- $q = new CGI; # create new CGI object
- print $q->header, # create the HTTP header
- $q->start_html('hello world'), # start the HTML
- $q->h1('hello world'), # level 1 header
- $q->end_html; # end the HTML
-
-In the function-oriented style, there is one default CGI object that
-you rarely deal with directly. Instead you just call functions to
-retrieve CGI parameters, create HTML tags, manage cookies, and so
-on. This provides you with a cleaner programming interface, but
-limits you to using one CGI object at a time. The following example
-prints the same page, but uses the function-oriented interface.
-The main differences are that we now need to import a set of functions
-into our name space (usually the "standard" functions), and we don't
-need to create the CGI object.
-
- #!/usr/local/bin/perl
- use CGI qw/:standard/; # load standard CGI routines
- print header, # create the HTTP header
- start_html('hello world'), # start the HTML
- h1('hello world'), # level 1 header
- end_html; # end the HTML
-
-The examples in this document mainly use the object-oriented style.
-See HOW TO IMPORT FUNCTIONS for important information on
-function-oriented programming in CGI.pm
-
-=head2 CALLING CGI.PM ROUTINES
-
-Most CGI.pm routines accept several arguments, sometimes as many as 20
-optional ones! To simplify this interface, all routines use a named
-argument calling style that looks like this:
-
- print $q->header(-type=>'image/gif',-expires=>'+3d');
-
-Each argument name is preceded by a dash. Neither case nor order
-matters in the argument list. -type, -Type, and -TYPE are all
-acceptable. In fact, only the first argument needs to begin with a
-dash. If a dash is present in the first argument, CGI.pm assumes
-dashes for the subsequent ones.
-
-You don't have to use the hyphen at all if you don't want to. After
-creating a CGI object, call the B<use_named_parameters()> method with
-a nonzero value. This will tell CGI.pm that you intend to use named
-parameters exclusively:
-
- $query = new CGI;
- $query->use_named_parameters(1);
- $field = $query->radio_group('name'=>'OS',
- 'values'=>['Unix','Windows','Macintosh'],
- 'default'=>'Unix');
-
-Several routines are commonly called with just one argument. In the
-case of these routines you can provide the single argument without an
-argument name. header() happens to be one of these routines. In this
-case, the single argument is the document type.
-
- print $q->header('text/html');
-
-Other such routines are documented below.
-
-Sometimes named arguments expect a scalar, sometimes a reference to an
-array, and sometimes a reference to a hash. Often, you can pass any
-type of argument and the routine will do whatever is most appropriate.
-For example, the param() routine is used to set a CGI parameter to a
-single or a multi-valued value. The two cases are shown below:
-
- $q->param(-name=>'veggie',-value=>'tomato');
- $q->param(-name=>'veggie',-value=>'[tomato','tomahto','potato','potahto']);
-
-A large number of routines in CGI.pm actually aren't specifically
-defined in the module, but are generated automatically as needed.
-These are the "HTML shortcuts," routines that generate HTML tags for
-use in dynamically-generated pages. HTML tags have both attributes
-(the attribute="value" pairs within the tag itself) and contents (the
-part between the opening and closing pairs.) To distinguish between
-attributes and contents, CGI.pm uses the convention of passing HTML
-attributes as a hash reference as the first argument, and the
-contents, if any, as any subsequent arguments. It works out like
-this:
-
- Code Generated HTML
- ---- --------------
- h1() <H1>
- h1('some','contents'); <H1>some contents</H1>
- h1({-align=>left}); <H1 ALIGN="LEFT">
- h1({-align=>left},'contents'); <H1 ALIGN="LEFT">contents</H1>
-
-HTML tags are described in more detail later.
-
-Many newcomers to CGI.pm are puzzled by the difference between the
-calling conventions for the HTML shortcuts, which require curly braces
-around the HTML tag attributes, and the calling conventions for other
-routines, which manage to generate attributes without the curly
-brackets. Don't be confused. As a convenience the curly braces are
-optional in all but the HTML shortcuts. If you like, you can use
-curly braces when calling any routine that takes named arguments. For
-example:
-
- print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
-
-If you use the B<-w> switch, you will be warned that some CGI.pm argument
-names conflict with built-in Perl functions. The most frequent of
-these is the -values argument, used to create multi-valued menus,
-radio button clusters and the like. To get around this warning, you
-have several choices:
-
-=over 4
-
-=item 1. Use another name for the argument, if one is available. For
-example, -value is an alias for -values.
-
-=item 2. Change the capitalization, e.g. -Values
-
-=item 3. Put quotes around the argument name, e.g. '-values'
-
-=back
-
-Many routines will do something useful with a named argument that it
-doesn't recognize. For example, you can produce non-standard HTTP
-header fields by providing them as named arguments:
-
- print $q->header(-type => 'text/html',
- -cost => 'Three smackers',
- -annoyance_level => 'high',
- -complaints_to => 'bit bucket');
-
-This will produce the following nonstandard HTTP header:
-
- HTTP/1.0 200 OK
- Cost: Three smackers
- Annoyance-level: high
- Complaints-to: bit bucket
- Content-type: text/html
-
-Notice the way that underscores are translated automatically into
-hyphens. HTML-generating routines perform a different type of
-translation.
-
-This feature allows you to keep up with the rapidly changing HTTP and
-HTML "standards".
-
-=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
-
- $query = new CGI;
-
-This will parse the input (from both POST and GET methods) and store
-it into a perl5 object called $query.
-
-=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
-
- $query = new CGI(INPUTFILE);
-
-If you provide a file handle to the new() method, it will read
-parameters from the file (or STDIN, or whatever). The file can be in
-any of the forms describing below under debugging (i.e. a series of
-newline delimited TAG=VALUE pairs will work). Conveniently, this type
-of file is created by the save() method (see below). Multiple records
-can be saved and restored.
-
-Perl purists will be pleased to know that this syntax accepts
-references to file handles, or even references to filehandle globs,
-which is the "official" way to pass a filehandle:
-
- $query = new CGI(\*STDIN);
-
-You can also initialize the CGI object with a FileHandle or IO::File
-object.
-
-If you are using the function-oriented interface and want to
-initialize CGI state from a file handle, the way to do this is with
-B<restore_parameters()>. This will (re)initialize the
-default CGI object from the indicated file handle.
-
- open (IN,"test.in") || die;
- restore_parameters(IN);
- close IN;
-
-You can also initialize the query object from an associative array
-reference:
-
- $query = new CGI( {'dinosaur'=>'barney',
- 'song'=>'I love you',
- 'friends'=>[qw/Jessica George Nancy/]}
- );
-
-or from a properly formatted, URL-escaped query string:
-
- $query = new CGI('dinosaur=barney&color=purple');
-
-or from a previously existing CGI object (currently this clones the
-parameter list, but none of the other object-specific fields, such as
-autoescaping):
-
- $old_query = new CGI;
- $new_query = new CGI($old_query);
-
-To create an empty query, initialize it from an empty string or hash:
-
- $empty_query = new CGI("");
-
- -or-
-
- $empty_query = new CGI({});
-
-=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
-
- @keywords = $query->keywords
-
-If the script was invoked as the result of an <ISINDEX> search, the
-parsed keywords can be obtained as an array using the keywords() method.
-
-=head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
-
- @names = $query->param
-
-If the script was invoked with a parameter list
-(e.g. "name1=value1&name2=value2&name3=value3"), the param()
-method will return the parameter names as a list. If the
-script was invoked as an <ISINDEX> script, there will be a
-single parameter named 'keywords'.
-
-NOTE: As of version 1.5, the array of parameter names returned will
-be in the same order as they were submitted by the browser.
-Usually this order is the same as the order in which the
-parameters are defined in the form (however, this isn't part
-of the spec, and so isn't guaranteed).
-
-=head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
-
- @values = $query->param('foo');
-
- -or-
-
- $value = $query->param('foo');
-
-Pass the param() method a single argument to fetch the value of the
-named parameter. If the parameter is multivalued (e.g. from multiple
-selections in a scrolling list), you can ask to receive an array. Otherwise
-the method will return a single value.
-
-=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
-
- $query->param('foo','an','array','of','values');
-
-This sets the value for the named parameter 'foo' to an array of
-values. This is one way to change the value of a field AFTER
-the script has been invoked once before. (Another way is with
-the -override parameter accepted by all methods that generate
-form elements.)
-
-param() also recognizes a named parameter style of calling described
-in more detail later:
-
- $query->param(-name=>'foo',-values=>['an','array','of','values']);
-
- -or-
-
- $query->param(-name=>'foo',-value=>'the value');
-
-=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
-
- $query->append(-name=>'foo',-values=>['yet','more','values']);
-
-This adds a value or list of values to the named parameter. The
-values are appended to the end of the parameter if it already exists.
-Otherwise the parameter is created. Note that this method only
-recognizes the named argument calling syntax.
-
-=head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
-
- $query->import_names('R');
-
-This creates a series of variables in the 'R' namespace. For example,
-$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
-If no namespace is given, this method will assume 'Q'.
-WARNING: don't import anything into 'main'; this is a major security
-risk!!!!
-
-In older versions, this method was called B<import()>. As of version 2.20,
-this name has been removed completely to avoid conflict with the built-in
-Perl module B<import> operator.
-
-=head2 DELETING A PARAMETER COMPLETELY:
-
- $query->delete('foo');
-
-This completely clears a parameter. It sometimes useful for
-resetting parameters that you don't want passed down between
-script invocations.
-
-If you are using the function call interface, use "Delete()" instead
-to avoid conflicts with Perl's built-in delete operator.
-
-=head2 DELETING ALL PARAMETERS:
-
- $query->delete_all();
-
-This clears the CGI object completely. It might be useful to ensure
-that all the defaults are taken when you create a fill-out form.
-
-Use Delete_all() instead if you are using the function call interface.
-
-=head2 DIRECT ACCESS TO THE PARAMETER LIST:
-
- $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
- unshift @{$q->param_fetch(-name=>'address')},'George Munster';
-
-If you need access to the parameter list in a way that isn't covered
-by the methods above, you can obtain a direct reference to it by
-calling the B<param_fetch()> method with the name of the . This
-will return an array reference to the named parameters, which you then
-can manipulate in any way you like.
-
-You can also use a named argument style using the B<-name> argument.
-
-=head2 FETCHING THE PARAMETER LIST AS A HASH:
-
- $params = $q->Vars;
- print $params->{'address'};
- @foo = split("\0",$params->{'foo'});
- %params = $q->Vars;
-
- use CGI ':cgi-lib';
- $params = Vars;
-
-Many people want to fetch the entire parameter list as a hash in which
-the keys are the names of the CGI parameters, and the values are the
-parameters' values. The Vars() method does this. Called in a scalar
-context, it returns the parameter list as a tied hash reference.
-Changing a key changes the value of the parameter in the underlying
-CGI parameter list. Called in an array context, it returns the
-parameter list as an ordinary hash. This allows you to read the
-contents of the parameter list, but not to change it.
-
-When using this, the thing you must watch out for are multivalued CGI
-parameters. Because a hash cannot distinguish between scalar and
-array context, multivalued parameters will be returned as a packed
-string, separated by the "\0" (null) character. You must split this
-packed string in order to get at the individual values. This is the
-convention introduced long ago by Steve Brenner in his cgi-lib.pl
-module for Perl version 4.
-
-If you wish to use Vars() as a function, import the I<:cgi-lib> set of
-function calls (also see the section on CGI-LIB compatibility).
-
-=head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
-
- $query->save(FILEHANDLE)
-
-This will write the current state of the form to the provided
-filehandle. You can read it back in by providing a filehandle
-to the new() method. Note that the filehandle can be a file, a pipe,
-or whatever!
-
-The format of the saved file is:
-
- NAME1=VALUE1
- NAME1=VALUE1'
- NAME2=VALUE2
- NAME3=VALUE3
- =
-
-Both name and value are URL escaped. Multi-valued CGI parameters are
-represented as repeated names. A session record is delimited by a
-single = symbol. You can write out multiple records and read them
-back in with several calls to B<new>. You can do this across several
-sessions by opening the file in append mode, allowing you to create
-primitive guest books, or to keep a history of users' queries. Here's
-a short example of creating multiple session records:
-
- use CGI;
-
- open (OUT,">>test.out") || die;
- $records = 5;
- foreach (0..$records) {
- my $q = new CGI;
- $q->param(-name=>'counter',-value=>$_);
- $q->save(OUT);
- }
- close OUT;
-
- # reopen for reading
- open (IN,"test.out") || die;
- while (!eof(IN)) {
- my $q = new CGI(IN);
- print $q->param('counter'),"\n";
- }
-
-The file format used for save/restore is identical to that used by the
-Whitehead Genome Center's data exchange format "Boulderio", and can be
-manipulated and even databased using Boulderio utilities. See
-
- http://stein.cshl.org/boulder/
-
-for further details.
-
-If you wish to use this method from the function-oriented (non-OO)
-interface, the exported name for this method is B<save_parameters()>.
-
-=head2 RETRIEVING CGI ERRORS
-
-Errors can occur while processing user input, particularly when
-processing uploaded files. When these errors occur, CGI will stop
-processing and return an empty parameter list. You can test for
-the existence and nature of errors using the I<cgi_error()> function.
-The error messages are formatted as HTTP status codes. You can either
-incorporate the error text into an HTML page, or use it as the value
-of the HTTP status:
-
- my $error = $q->cgi_error;
- if ($error) {
- print $q->header(-status=>$error),
- $q->start_html('Problems'),
- $q->h2('Request not processed'),
- $q->strong($error);
- exit 0;
- }
-
-When using the function-oriented interface (see the next section),
-errors may only occur the first time you call I<param()>. Be ready
-for this!
-
-=head2 USING THE FUNCTION-ORIENTED INTERFACE
-
-To use the function-oriented interface, you must specify which CGI.pm
-routines or sets of routines to import into your script's namespace.
-There is a small overhead associated with this importation, but it
-isn't much.
-
- use CGI <list of methods>;
-
-The listed methods will be imported into the current package; you can
-call them directly without creating a CGI object first. This example
-shows how to import the B<param()> and B<header()>
-methods, and then use them directly:
-
- use CGI 'param','header';
- print header('text/plain');
- $zipcode = param('zipcode');
-
-More frequently, you'll import common sets of functions by referring
-to the groups by name. All function sets are preceded with a ":"
-character as in ":html3" (for tags defined in the HTML 3 standard).
-
-Here is a list of the function sets you can import:
-
-=over 4
-
-=item B<:cgi>
-
-Import all CGI-handling methods, such as B<param()>, B<path_info()>
-and the like.
-
-=item B<:form>
-
-Import all fill-out form generating methods, such as B<textfield()>.
-
-=item B<:html2>
-
-Import all methods that generate HTML 2.0 standard elements.
-
-=item B<:html3>
-
-Import all methods that generate HTML 3.0 proposed elements (such as
-<table>, <super> and <sub>).
-
-=item B<:netscape>
-
-Import all methods that generate Netscape-specific HTML extensions.
-
-=item B<:html>
-
-Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
-'netscape')...
-
-=item B<:standard>
-
-Import "standard" features, 'html2', 'html3', 'form' and 'cgi'.
-
-=item B<:all>
-
-Import all the available methods. For the full list, see the CGI.pm
-code, where the variable %EXPORT_TAGS is defined.
-
-=back
-
-If you import a function name that is not part of CGI.pm, the module
-will treat it as a new HTML tag and generate the appropriate
-subroutine. You can then use it like any other HTML tag. This is to
-provide for the rapidly-evolving HTML "standard." For example, say
-Microsoft comes out with a new tag called <GRADIENT> (which causes the
-user's desktop to be flooded with a rotating gradient fill until his
-machine reboots). You don't need to wait for a new version of CGI.pm
-to start using it immediately:
-
- use CGI qw/:standard :html3 gradient/;
- print gradient({-start=>'red',-end=>'blue'});
-
-Note that in the interests of execution speed CGI.pm does B<not> use
-the standard L<Exporter> syntax for specifying load symbols. This may
-change in the future.
-
-If you import any of the state-maintaining CGI or form-generating
-methods, a default CGI object will be created and initialized
-automatically the first time you use any of the methods that require
-one to be present. This includes B<param()>, B<textfield()>,
-B<submit()> and the like. (If you need direct access to the CGI
-object, you can find it in the global variable B<$CGI::Q>). By
-importing CGI.pm methods, you can create visually elegant scripts:
-
- use CGI qw/:standard/;
- print
- header,
- start_html('Simple Script'),
- h1('Simple Script'),
- start_form,
- "What's your name? ",textfield('name'),p,
- "What's the combination?",
- checkbox_group(-name=>'words',
- -values=>['eenie','meenie','minie','moe'],
- -defaults=>['eenie','moe']),p,
- "What's your favorite color?",
- popup_menu(-name=>'color',
- -values=>['red','green','blue','chartreuse']),p,
- submit,
- end_form,
- hr,"\n";
-
- if (param) {
- print
- "Your name is ",em(param('name')),p,
- "The keywords are: ",em(join(", ",param('words'))),p,
- "Your favorite color is ",em(param('color')),".\n";
- }
- print end_html;
-
-=head2 PRAGMAS
-
-In addition to the function sets, there are a number of pragmas that
-you can import. Pragmas, which are always preceded by a hyphen,
-change the way that CGI.pm functions in various ways. Pragmas,
-function sets, and individual functions can all be imported in the
-same use() line. For example, the following use statement imports the
-standard set of functions and disables debugging mode (pragma
--no_debug):
-
- use CGI qw/:standard -no_debug/;
-
-The current list of pragmas is as follows:
-
-=over 4
-
-=item -any
-
-When you I<use CGI -any>, then any method that the query object
-doesn't recognize will be interpreted as a new HTML tag. This allows
-you to support the next I<ad hoc> Netscape or Microsoft HTML
-extension. This lets you go wild with new and unsupported tags:
-
- use CGI qw(-any);
- $q=new CGI;
- print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
-
-Since using <cite>any</cite> causes any mistyped method name
-to be interpreted as an HTML tag, use it with care or not at
-all.
-
-=item -compile
-
-This causes the indicated autoloaded methods to be compiled up front,
-rather than deferred to later. This is useful for scripts that run
-for an extended period of time under FastCGI or mod_perl, and for
-those destined to be crunched by Malcom Beattie's Perl compiler. Use
-it in conjunction with the methods or method families you plan to use.
-
- use CGI qw(-compile :standard :html3);
-
-or even
-
- use CGI qw(-compile :all);
-
-Note that using the -compile pragma in this way will always have
-the effect of importing the compiled functions into the current
-namespace. If you want to compile without importing use the
-compile() method instead (see below).
-
-=item -nph
-
-This makes CGI.pm produce a header appropriate for an NPH (no
-parsed header) script. You may need to do other things as well
-to tell the server that the script is NPH. See the discussion
-of NPH scripts below.
-
-=item -newstyle_urls
-
-Separate the name=value pairs in CGI parameter query strings with
-semicolons rather than ampersands. For example:
-
- ?name=fred;age=24;favorite_color=3
-
-Semicolon-delimited query strings are always accepted, but will not be
-emitted by self_url() and query_string() unless the -newstyle_urls
-pragma is specified.
-
-=item -autoload
-
-This overrides the autoloader so that any function in your program
-that is not recognized is referred to CGI.pm for possible evaluation.
-This allows you to use all the CGI.pm functions without adding them to
-your symbol table, which is of concern for mod_perl users who are
-worried about memory consumption. I<Warning:> when
-I<-autoload> is in effect, you cannot use "poetry mode"
-(functions without the parenthesis). Use I<hr()> rather
-than I<hr>, or add something like I<use subs qw/hr p header/>
-to the top of your script.
-
-=item -no_debug
-
-This turns off the command-line processing features. If you want to
-run a CGI.pm script from the command line to produce HTML, and you
-don't want it pausing to request CGI parameters from standard input or
-the command line, then use this pragma:
-
- use CGI qw(-no_debug :standard);
-
-If you'd like to process the command-line parameters but not standard
-input, this should work:
-
- use CGI qw(-no_debug :standard);
- restore_parameters(join('&',@ARGV));
-
-See the section on debugging for more details.
-
-=item -private_tempfiles
-
-CGI.pm can process uploaded file. Ordinarily it spools the uploaded
-file to a temporary directory, then deletes the file when done.
-However, this opens the risk of eavesdropping as described in the file
-upload section. Another CGI script author could peek at this data
-during the upload, even if it is confidential information. On Unix
-systems, the -private_tempfiles pragma will cause the temporary file
-to be unlinked as soon as it is opened and before any data is written
-into it, reducing, but not eliminating the risk of eavesdropping
-(there is still a potential race condition). To make life harder for
-the attacker, the program chooses tempfile names by calculating a 32
-bit checksum of the incoming HTTP headers.
-
-To ensure that the temporary file cannot be read by other CGI scripts,
-use suEXEC or a CGI wrapper program to run your script. The temporary
-file is created with mode 0600 (neither world nor group readable).
-
-The temporary directory is selected using the following algorithm:
-
- 1. if the current user (e.g. "nobody") has a directory named
- "tmp" in its home directory, use that (Unix systems only).
-
- 2. if the environment variable TMPDIR exists, use the location
- indicated.
-
- 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp,
- /tmp, /temp, ::Temporary Items, and \WWW_ROOT.
-
-Each of these locations is checked that it is a directory and is
-writable. If not, the algorithm tries the next choice.
-
-=back
-
-=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS
-
-Many of the methods generate HTML tags. As described below, tag
-functions automatically generate both the opening and closing tags.
-For example:
-
- print h1('Level 1 Header');
-
-produces
-
- <H1>Level 1 Header</H1>
-
-There will be some times when you want to produce the start and end
-tags yourself. In this case, you can use the form start_I<tag_name>
-and end_I<tag_name>, as in:
-
- print start_h1,'Level 1 Header',end_h1;
-
-With a few exceptions (described below), start_I<tag_name> and
-end_I<tag_name> functions are not generated automatically when you
-I<use CGI>. However, you can specify the tags you want to generate
-I<start/end> functions for by putting an asterisk in front of their
-name, or, alternatively, requesting either "start_I<tag_name>" or
-"end_I<tag_name>" in the import list.
-
-Example:
-
- use CGI qw/:standard *table start_ul/;
-
-In this example, the following functions are generated in addition to
-the standard ones:
-
-=over 4
-
-=item 1. start_table() (generates a <TABLE> tag)
-
-=item 2. end_table() (generates a </TABLE> tag)
-
-=item 3. start_ul() (generates a <UL> tag)
-
-=item 4. end_ul() (generates a </UL> tag)
-
-=back
-
-=head1 GENERATING DYNAMIC DOCUMENTS
-
-Most of CGI.pm's functions deal with creating documents on the fly.
-Generally you will produce the HTTP header first, followed by the
-document itself. CGI.pm provides functions for generating HTTP
-headers of various types as well as for generating HTML. For creating
-GIF images, see the GD.pm module.
-
-Each of these functions produces a fragment of HTML or HTTP which you
-can print out directly so that it displays in the browser window,
-append to a string, or save to a file for later use.
-
-=head2 CREATING A STANDARD HTTP HEADER:
-
-Normally the first thing you will do in any CGI script is print out an
-HTTP header. This tells the browser what type of document to expect,
-and gives other optional information, such as the language, expiration
-date, and whether to cache the document. The header can also be
-manipulated for special purposes, such as server push and pay per view
-pages.
-
- print $query->header;
-
- -or-
-
- print $query->header('image/gif');
-
- -or-
-
- print $query->header('text/html','204 No response');
-
- -or-
-
- print $query->header(-type=>'image/gif',
- -nph=>1,
- -status=>'402 Payment required',
- -expires=>'+3d',
- -cookie=>$cookie,
- -Cost=>'$2.00');
-
-header() returns the Content-type: header. You can provide your own
-MIME type if you choose, otherwise it defaults to text/html. An
-optional second parameter specifies the status code and a human-readable
-message. For example, you can specify 204, "No response" to create a
-script that tells the browser to do nothing at all.
-
-The last example shows the named argument style for passing arguments
-to the CGI methods using named parameters. Recognized parameters are
-B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named
-parameters will be stripped of their initial hyphens and turned into
-header fields, allowing you to specify any HTTP header you desire.
-Internal underscores will be turned into hyphens:
-
- print $query->header(-Content_length=>3002);
-
-Most browsers will not cache the output from CGI scripts. Every time
-the browser reloads the page, the script is invoked anew. You can
-change this behavior with the B<-expires> parameter. When you specify
-an absolute or relative expiration interval with this parameter, some
-browsers and proxy servers will cache the script's output until the
-indicated expiration date. The following forms are all valid for the
--expires field:
-
- +30s 30 seconds from now
- +10m ten minutes from now
- +1h one hour from now
- -1d yesterday (i.e. "ASAP!")
- now immediately
- +3M in three months
- +10y in ten years time
- Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date
-
-The B<-cookie> parameter generates a header that tells the browser to provide
-a "magic cookie" during all subsequent transactions with your script.
-Netscape cookies have a special format that includes interesting attributes
-such as expiration time. Use the cookie() method to create and retrieve
-session cookies.
-
-The B<-nph> parameter, if set to a true value, will issue the correct
-headers to work with a NPH (no-parse-header) script. This is important
-to use with certain servers, such as Microsoft Internet Explorer, which
-expect all their scripts to be NPH.
-
-=head2 GENERATING A REDIRECTION HEADER
-
- print $query->redirect('http://somewhere.else/in/movie/land');
-
-Sometimes you don't want to produce a document yourself, but simply
-redirect the browser elsewhere, perhaps choosing a URL based on the
-time of day or the identity of the user.
-
-The redirect() function redirects the browser to a different URL. If
-you use redirection like this, you should B<not> print out a header as
-well. As of version 2.0, we produce both the unofficial Location:
-header and the official URI: header. This should satisfy most servers
-and browsers.
-
-One hint I can offer is that relative links may not work correctly
-when you generate a redirection to another document on your site.
-This is due to a well-intentioned optimization that some servers use.
-The solution to this is to use the full URL (including the http: part)
-of the document you are redirecting to.
-
-You can also use named arguments:
-
- print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
- -nph=>1);
-
-The B<-nph> parameter, if set to a true value, will issue the correct
-headers to work with a NPH (no-parse-header) script. This is important
-to use with certain servers, such as Microsoft Internet Explorer, which
-expect all their scripts to be NPH.
-
-=head2 CREATING THE HTML DOCUMENT HEADER
-
- print $query->start_html(-title=>'Secrets of the Pyramids',
- -author=>'fred@capricorn.org',
- -base=>'true',
- -target=>'_blank',
- -meta=>{'keywords'=>'pharaoh secret mummy',
- 'copyright'=>'copyright 1996 King Tut'},
- -style=>{'src'=>'/styles/style1.css'},
- -BGCOLOR=>'blue');
-
-After creating the HTTP header, most CGI scripts will start writing
-out an HTML document. The start_html() routine creates the top of the
-page, along with a lot of optional information that controls the
-page's appearance and behavior.
-
-This method returns a canned HTML header and the opening <BODY> tag.
-All parameters are optional. In the named parameter form, recognized
-parameters are -title, -author, -base, -xbase and -target (see below
-for the explanation). Any additional parameters you provide, such as
-the Netscape unofficial BGCOLOR attribute, are added to the <BODY>
-tag. Additional parameters must be proceeded by a hyphen.
-
-The argument B<-xbase> allows you to provide an HREF for the <BASE> tag
-different from the current location, as in
-
- -xbase=>"http://home.mcom.com/"
-
-All relative links will be interpreted relative to this tag.
-
-The argument B<-target> allows you to provide a default target frame
-for all the links and fill-out forms on the page. See the Netscape
-documentation on frames for details of how to manipulate this.
-
- -target=>"answer_window"
-
-All relative links will be interpreted relative to this tag.
-You add arbitrary meta information to the header with the B<-meta>
-argument. This argument expects a reference to an associative array
-containing name/value pairs of meta information. These will be turned
-into a series of header <META> tags that look something like this:
-
- <META NAME="keywords" CONTENT="pharaoh secret mummy">
- <META NAME="description" CONTENT="copyright 1996 King Tut">
-
-There is no support for the HTTP-EQUIV type of <META> tag. This is
-because you can modify the HTTP header directly with the B<header()>
-method. For example, if you want to send the Refresh: header, do it
-in the header() method:
-
- print $q->header(-Refresh=>'10; URL=http://www.capricorn.com');
-
-The B<-style> tag is used to incorporate cascading stylesheets into
-your code. See the section on CASCADING STYLESHEETS for more information.
-
-You can place other arbitrary HTML elements to the <HEAD> section with the
-B<-head> tag. For example, to place the rarely-used <LINK> element in the
-head section, use this:
-
- print start_html(-head=>Link({-rel=>'next',
- -href=>'http://www.capricorn.com/s2.html'}));
-
-To incorporate multiple HTML elements into the <HEAD> section, just pass an
-array reference:
-
- print start_html(-head=>[
- Link({-rel=>'next',
- -href=>'http://www.capricorn.com/s2.html'}),
- Link({-rel=>'previous',
- -href=>'http://www.capricorn.com/s1.html'})
- ]
- );
-
-JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
-B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
-to add Netscape JavaScript calls to your pages. B<-script> should
-point to a block of text containing JavaScript function definitions.
-This block will be placed within a <SCRIPT> block inside the HTML (not
-HTTP) header. The block is placed in the header in order to give your
-page a fighting chance of having all its JavaScript functions in place
-even if the user presses the stop button before the page has loaded
-completely. CGI.pm attempts to format the script in such a way that
-JavaScript-naive browsers will not choke on the code: unfortunately
-there are some browsers, such as Chimera for Unix, that get confused
-by it nevertheless.
-
-The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
-code to execute when the page is respectively opened and closed by the
-browser. Usually these parameters are calls to functions defined in the
-B<-script> field:
-
- $query = new CGI;
- print $query->header;
- $JSCRIPT=<<END;
- // Ask a silly question
- function riddle_me_this() {
- var r = prompt("What walks on four legs in the morning, " +
- "two legs in the afternoon, " +
- "and three legs in the evening?");
- response(r);
- }
- // Get a silly answer
- function response(answer) {
- if (answer == "man")
- alert("Right you are!");
- else
- alert("Wrong! Guess again.");
- }
- END
- print $query->start_html(-title=>'The Riddle of the Sphinx',
- -script=>$JSCRIPT);
-
-Use the B<-noScript> parameter to pass some HTML text that will be displayed on
-browsers that do not have JavaScript (or browsers where JavaScript is turned
-off).
-
-Netscape 3.0 recognizes several attributes of the <SCRIPT> tag,
-including LANGUAGE and SRC. The latter is particularly interesting,
-as it allows you to keep the JavaScript code in a file or CGI script
-rather than cluttering up each page with the source. To use these
-attributes pass a HASH reference in the B<-script> parameter containing
-one or more of -language, -src, or -code:
-
- print $q->start_html(-title=>'The Riddle of the Sphinx',
- -script=>{-language=>'JAVASCRIPT',
- -src=>'/javascript/sphinx.js'}
- );
-
- print $q->(-title=>'The Riddle of the Sphinx',
- -script=>{-language=>'PERLSCRIPT',
- -code=>'print "hello world!\n;"'}
- );
-
-
-A final feature allows you to incorporate multiple <SCRIPT> sections into the
-header. Just pass the list of script sections as an array reference.
-this allows you to specify different source files for different dialects
-of JavaScript. Example:
-
- print $q->start_html(-title=>'The Riddle of the Sphinx',
- -script=>[
- { -language => 'JavaScript1.0',
- -src => '/javascript/utilities10.js'
- },
- { -language => 'JavaScript1.1',
- -src => '/javascript/utilities11.js'
- },
- { -language => 'JavaScript1.2',
- -src => '/javascript/utilities12.js'
- },
- { -language => 'JavaScript28.2',
- -src => '/javascript/utilities219.js'
- }
- ]
- );
- </pre>
-
-If this looks a bit extreme, take my advice and stick with straight CGI scripting.
-
-See
-
- http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
-
-for more information about JavaScript.
-
-The old-style positional parameters are as follows:
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The title
-
-=item 2.
-
-The author's e-mail address (will create a <LINK REV="MADE"> tag if present
-
-=item 3.
-
-A 'true' flag if you want to include a <BASE> tag in the header. This
-helps resolve relative addresses to absolute ones when the document is moved,
-but makes the document hierarchy non-portable. Use with care!
-
-=item 4, 5, 6...
-
-Any other parameters you want to include in the <BODY> tag. This is a good
-place to put Netscape extensions, such as colors and wallpaper patterns.
-
-=back
-
-=head2 ENDING THE HTML DOCUMENT:
-
- print $query->end_html
-
-This ends an HTML document by printing the </BODY></HTML> tags.
-
-=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
-
- $myself = $query->self_url;
- print "<A HREF=$myself>I'm talking to myself.</A>";
-
-self_url() will return a URL, that, when selected, will reinvoke
-this script with all its state information intact. This is most
-useful when you want to jump around within the document using
-internal anchors but you don't want to disrupt the current contents
-of the form(s). Something like this will do the trick.
-
- $myself = $query->self_url;
- print "<A HREF=$myself#table1>See table 1</A>";
- print "<A HREF=$myself#table2>See table 2</A>";
- print "<A HREF=$myself#yourself>See for yourself</A>";
-
-If you want more control over what's returned, using the B<url()>
-method instead.
-
-You can also retrieve the unprocessed query string with query_string():
-
- $the_string = $query->query_string;
-
-=head2 OBTAINING THE SCRIPT'S URL
-
- $full_url = $query->url();
- $full_url = $query->url(-full=>1); #alternative syntax
- $relative_url = $query->url(-relative=>1);
- $absolute_url = $query->url(-absolute=>1);
- $url_with_path = $query->url(-path_info=>1);
- $url_with_path_and_query = $query->url(-path_info=>1,-query=>1);
-
-B<url()> returns the script's URL in a variety of formats. Called
-without any arguments, it returns the full form of the URL, including
-host name and port number
-
- http://your.host.com/path/to/script.cgi
-
-You can modify this format with the following named arguments:
-
-=over 4
-
-=item B<-absolute>
-
-If true, produce an absolute URL, e.g.
-
- /path/to/script.cgi
-
-=item B<-relative>
-
-Produce a relative URL. This is useful if you want to reinvoke your
-script with different parameters. For example:
-
- script.cgi
-
-=item B<-full>
-
-Produce the full URL, exactly as if called without any arguments.
-This overrides the -relative and -absolute arguments.
-
-=item B<-path> (B<-path_info>)
-
-Append the additional path information to the URL. This can be
-combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info>
-is provided as a synonym.
-
-=item B<-query> (B<-query_string>)
-
-Append the query string to the URL. This can be combined with
-B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
-as a synonym.
-
-=back
-
-=head2 MIXING POST AND URL PARAMETERS
-
- $color = $query-&gt;url_param('color');
-
-It is possible for a script to receive CGI parameters in the URL as
-well as in the fill-out form by creating a form that POSTs to a URL
-containing a query string (a "?" mark followed by arguments). The
-B<param()> method will always return the contents of the POSTed
-fill-out form, ignoring the URL's query string. To retrieve URL
-parameters, call the B<url_param()> method. Use it in the same way as
-B<param()>. The main difference is that it allows you to read the
-parameters, but not set them.
-
-
-Under no circumstances will the contents of the URL query string
-interfere with similarly-named CGI parameters in POSTed forms. If you
-try to mix a URL query string with a form submitted with the GET
-method, the results will not be what you expect.
-
-=head1 CREATING STANDARD HTML ELEMENTS:
-
-CGI.pm defines general HTML shortcut methods for most, if not all of
-the HTML 3 and HTML 4 tags. HTML shortcuts are named after a single
-HTML element and return a fragment of HTML text that you can then
-print or manipulate as you like. Each shortcut returns a fragment of
-HTML code that you can append to a string, save to a file, or, most
-commonly, print out so that it displays in the browser window.
-
-This example shows how to use the HTML methods:
-
- $q = new CGI;
- print $q->blockquote(
- "Many years ago on the island of",
- $q->a({href=>"http://crete.org/"},"Crete"),
- "there lived a Minotaur named",
- $q->strong("Fred."),
- ),
- $q->hr;
-
-This results in the following HTML code (extra newlines have been
-added for readability):
-
- <blockquote>
- Many years ago on the island of
- <a HREF="http://crete.org/">Crete</a> there lived
- a minotaur named <strong>Fred.</strong>
- </blockquote>
- <hr>
-
-If you find the syntax for calling the HTML shortcuts awkward, you can
-import them into your namespace and dispense with the object syntax
-completely (see the next section for more details):
-
- use CGI ':standard';
- print blockquote(
- "Many years ago on the island of",
- a({href=>"http://crete.org/"},"Crete"),
- "there lived a minotaur named",
- strong("Fred."),
- ),
- hr;
-
-=head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
-
-The HTML methods will accept zero, one or multiple arguments. If you
-provide no arguments, you get a single tag:
-
- print hr; # <HR>
-
-If you provide one or more string arguments, they are concatenated
-together with spaces and placed between opening and closing tags:
-
- print h1("Chapter","1"); # <H1>Chapter 1</H1>"
-
-If the first argument is an associative array reference, then the keys
-and values of the associative array become the HTML tag's attributes:
-
- print a({-href=>'fred.html',-target=>'_new'},
- "Open a new frame");
-
- <A HREF="fred.html",TARGET="_new">Open a new frame</A>
-
-You may dispense with the dashes in front of the attribute names if
-you prefer:
-
- print img {src=>'fred.gif',align=>'LEFT'};
-
- <IMG ALIGN="LEFT" SRC="fred.gif">
-
-Sometimes an HTML tag attribute has no argument. For example, ordered
-lists can be marked as COMPACT. The syntax for this is an argument that
-that points to an undef string:
-
- print ol({compact=>undef},li('one'),li('two'),li('three'));
-
-Prior to CGI.pm version 2.41, providing an empty ('') string as an
-attribute argument was the same as providing undef. However, this has
-changed in order to accommodate those who want to create tags of the form
-<IMG ALT="">. The difference is shown in these two pieces of code:
-
- CODE RESULT
- img({alt=>undef}) <IMG ALT>
- img({alt=>''}) <IMT ALT="">
-
-=head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
-
-One of the cool features of the HTML shortcuts is that they are
-distributive. If you give them an argument consisting of a
-B<reference> to a list, the tag will be distributed across each
-element of the list. For example, here's one way to make an ordered
-list:
-
- print ul(
- li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']);
- );
-
-This example will result in HTML output that looks like this:
-
- <UL>
- <LI TYPE="disc">Sneezy</LI>
- <LI TYPE="disc">Doc</LI>
- <LI TYPE="disc">Sleepy</LI>
- <LI TYPE="disc">Happy</LI>
- </UL>
-
-This is extremely useful for creating tables. For example:
-
- print table({-border=>undef},
- caption('When Should You Eat Your Vegetables?'),
- Tr({-align=>CENTER,-valign=>TOP},
- [
- th(['Vegetable', 'Breakfast','Lunch','Dinner']),
- td(['Tomatoes' , 'no', 'yes', 'yes']),
- td(['Broccoli' , 'no', 'no', 'yes']),
- td(['Onions' , 'yes','yes', 'yes'])
- ]
- )
- );
-
-=head2 HTML SHORTCUTS AND LIST INTERPOLATION
-
-Consider this bit of code:
-
- print blockquote(em('Hi'),'mom!'));
-
-It will ordinarily return the string that you probably expect, namely:
-
- <BLOCKQUOTE><EM>Hi</EM> mom!</BLOCKQUOTE>
-
-Note the space between the element "Hi" and the element "mom!".
-CGI.pm puts the extra space there using array interpolation, which is
-controlled by the magic $" variable. Sometimes this extra space is
-not what you want, for example, when you are trying to align a series
-of images. In this case, you can simply change the value of $" to an
-empty string.
-
- {
- local($") = '';
- print blockquote(em('Hi'),'mom!'));
- }
-
-I suggest you put the code in a block as shown here. Otherwise the
-change to $" will affect all subsequent code until you explicitly
-reset it.
-
-=head2 NON-STANDARD HTML SHORTCUTS
-
-A few HTML tags don't follow the standard pattern for various
-reasons.
-
-B<comment()> generates an HTML comment (<!-- comment -->). Call it
-like
-
- print comment('here is my comment');
-
-Because of conflicts with built-in Perl functions, the following functions
-begin with initial caps:
-
- Select
- Tr
- Link
- Delete
- Accept
- Sub
-
-In addition, start_html(), end_html(), start_form(), end_form(),
-start_multipart_form() and all the fill-out form tags are special.
-See their respective sections.
-
-=head2 PRETTY-PRINTING HTML
-
-By default, all the HTML produced by these functions comes out as one
-long line without carriage returns or indentation. This is yuck, but
-it does reduce the size of the documents by 10-20%. To get
-pretty-printed output, please use L<CGI::Pretty>, a subclass
-contributed by Brian Paulsen.
-
-=head1 CREATING FILL-OUT FORMS:
-
-I<General note> The various form-creating methods all return strings
-to the caller, containing the tag or tags that will create the requested
-form element. You are responsible for actually printing out these strings.
-It's set up this way so that you can place formatting tags
-around the form elements.
-
-I<Another note> The default values that you specify for the forms are only
-used the B<first> time the script is invoked (when there is no query
-string). On subsequent invocations of the script (when there is a query
-string), the former values are used even if they are blank.
-
-If you want to change the value of a field from its previous value, you have two
-choices:
-
-(1) call the param() method to set it.
-
-(2) use the -override (alias -force) parameter (a new feature in version 2.15).
-This forces the default value to be used, regardless of the previous value:
-
- print $query->textfield(-name=>'field_name',
- -default=>'starting value',
- -override=>1,
- -size=>50,
- -maxlength=>80);
-
-I<Yet another note> By default, the text and labels of form elements are
-escaped according to HTML rules. This means that you can safely use
-"<CLICK ME>" as the label for a button. However, it also interferes with
-your ability to incorporate special HTML character sequences, such as &Aacute;,
-into your fields. If you wish to turn off automatic escaping, call the
-autoEscape() method with a false value immediately after creating the CGI object:
-
- $query = new CGI;
- $query->autoEscape(undef);
-
-
-=head2 CREATING AN ISINDEX TAG
-
- print $query->isindex(-action=>$action);
-
- -or-
-
- print $query->isindex($action);
-
-Prints out an <ISINDEX> tag. Not very exciting. The parameter
--action specifies the URL of the script to process the query. The
-default is to process the query with the current script.
-
-=head2 STARTING AND ENDING A FORM
-
- print $query->startform(-method=>$method,
- -action=>$action,
- -enctype=>$encoding);
- <... various form stuff ...>
- print $query->endform;
-
- -or-
-
- print $query->startform($method,$action,$encoding);
- <... various form stuff ...>
- print $query->endform;
-
-startform() will return a <FORM> tag with the optional method,
-action and form encoding that you specify. The defaults are:
-
- method: POST
- action: this script
- enctype: application/x-www-form-urlencoded
-
-endform() returns the closing </FORM> tag.
-
-Startform()'s enctype argument tells the browser how to package the various
-fields of the form before sending the form to the server. Two
-values are possible:
-
-=over 4
-
-=item B<application/x-www-form-urlencoded>
-
-This is the older type of encoding used by all browsers prior to
-Netscape 2.0. It is compatible with many CGI scripts and is
-suitable for short fields containing text data. For your
-convenience, CGI.pm stores the name of this encoding
-type in B<$CGI::URL_ENCODED>.
-
-=item B<multipart/form-data>
-
-This is the newer type of encoding introduced by Netscape 2.0.
-It is suitable for forms that contain very large fields or that
-are intended for transferring binary data. Most importantly,
-it enables the "file upload" feature of Netscape 2.0 forms. For
-your convenience, CGI.pm stores the name of this encoding type
-in B<&CGI::MULTIPART>
-
-Forms that use this type of encoding are not easily interpreted
-by CGI scripts unless they use CGI.pm or another library designed
-to handle them.
-
-=back
-
-For compatibility, the startform() method uses the older form of
-encoding by default. If you want to use the newer form of encoding
-by default, you can call B<start_multipart_form()> instead of
-B<startform()>.
-
-JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
-for use with JavaScript. The -name parameter gives the
-form a name so that it can be identified and manipulated by
-JavaScript functions. -onSubmit should point to a JavaScript
-function that will be executed just before the form is submitted to your
-server. You can use this opportunity to check the contents of the form
-for consistency and completeness. If you find something wrong, you
-can put up an alert box or maybe fix things up yourself. You can
-abort the submission by returning false from this function.
-
-Usually the bulk of JavaScript functions are defined in a <SCRIPT>
-block in the HTML header and -onSubmit points to one of these function
-call. See start_html() for details.
-
-=head2 CREATING A TEXT FIELD
-
- print $query->textfield(-name=>'field_name',
- -default=>'starting value',
- -size=>50,
- -maxlength=>80);
- -or-
-
- print $query->textfield('field_name','starting value',50,80);
-
-textfield() will return a text input field.
-
-=over 4
-
-=item B<Parameters>
-
-=item 1.
-
-The first parameter is the required name for the field (-name).
-
-=item 2.
-
-The optional second parameter is the default starting value for the field
-contents (-default).
-
-=item 3.
-
-The optional third parameter is the size of the field in
- characters (-size).
-
-=item 4.
-
-The optional fourth parameter is the maximum number of characters the
- field will accept (-maxlength).
-
-=back
-
-As with all these methods, the field will be initialized with its
-previous contents from earlier invocations of the script.
-When the form is processed, the value of the text field can be
-retrieved with:
-
- $value = $query->param('foo');
-
-If you want to reset it from its initial value after the script has been
-called once, you can do so like this:
-
- $query->param('foo',"I'm taking over this value!");
-
-NEW AS OF VERSION 2.15: If you don't want the field to take on its previous
-value, you can force its current value by using the -override (alias -force)
-parameter:
-
- print $query->textfield(-name=>'field_name',
- -default=>'starting value',
- -override=>1,
- -size=>50,
- -maxlength=>80);
-
-JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>,
-B<-onBlur>, B<-onMouseOver>, B<-onMouseOut> and B<-onSelect>
-parameters to register JavaScript event handlers. The onChange
-handler will be called whenever the user changes the contents of the
-text field. You can do text validation if you like. onFocus and
-onBlur are called respectively when the insertion point moves into and
-out of the text field. onSelect is called when the user changes the
-portion of the text that is selected.
-
-=head2 CREATING A BIG TEXT FIELD
-
- print $query->textarea(-name=>'foo',
- -default=>'starting value',
- -rows=>10,
- -columns=>50);
-
- -or
-
- print $query->textarea('foo','starting value',10,50);
-
-textarea() is just like textfield, but it allows you to specify
-rows and columns for a multiline text entry box. You can provide
-a starting value for the field, which can be long and contain
-multiple lines.
-
-JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> ,
-B<-onMouseOver>, B<-onMouseOut>, and B<-onSelect> parameters are
-recognized. See textfield().
-
-=head2 CREATING A PASSWORD FIELD
-
- print $query->password_field(-name=>'secret',
- -value=>'starting value',
- -size=>50,
- -maxlength=>80);
- -or-
-
- print $query->password_field('secret','starting value',50,80);
-
-password_field() is identical to textfield(), except that its contents
-will be starred out on the web page.
-
-JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
-B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
-recognized. See textfield().
-
-=head2 CREATING A FILE UPLOAD FIELD
-
- print $query->filefield(-name=>'uploaded_file',
- -default=>'starting value',
- -size=>50,
- -maxlength=>80);
- -or-
-
- print $query->filefield('uploaded_file','starting value',50,80);
-
-filefield() will return a file upload field for Netscape 2.0 browsers.
-In order to take full advantage of this I<you must use the new
-multipart encoding scheme> for the form. You can do this either
-by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>,
-or by calling the new method B<start_multipart_form()> instead of
-vanilla B<startform()>.
-
-=over 4
-
-=item B<Parameters>
-
-=item 1.
-
-The first parameter is the required name for the field (-name).
-
-=item 2.
-
-The optional second parameter is the starting value for the field contents
-to be used as the default file name (-default).
-
-For security reasons, browsers don't pay any attention to this field,
-and so the starting value will always be blank. Worse, the field
-loses its "sticky" behavior and forgets its previous contents. The
-starting value field is called for in the HTML specification, however,
-and possibly some browser will eventually provide support for it.
-
-=item 3.
-
-The optional third parameter is the size of the field in
-characters (-size).
-
-=item 4.
-
-The optional fourth parameter is the maximum number of characters the
-field will accept (-maxlength).
-
-=back
-
-When the form is processed, you can retrieve the entered filename
-by calling param():
-
- $filename = $query->param('uploaded_file');
-
-Different browsers will return slightly different things for the
-name. Some browsers return the filename only. Others return the full
-path to the file, using the path conventions of the user's machine.
-Regardless, the name returned is always the name of the file on the
-I<user's> machine, and is unrelated to the name of the temporary file
-that CGI.pm creates during upload spooling (see below).
-
-The filename returned is also a file handle. You can read the contents
-of the file using standard Perl file reading calls:
-
- # Read a text file and print it out
- while (<$filename>) {
- print;
- }
-
- # Copy a binary file to somewhere safe
- open (OUTFILE,">>/usr/local/web/users/feedback");
- while ($bytesread=read($filename,$buffer,1024)) {
- print OUTFILE $buffer;
- }
-
-However, there are problems with the dual nature of the upload fields.
-If you C<use strict>, then Perl will complain when you try to use a
-string as a filehandle. You can get around this by placing the file
-reading code in a block containing the C<no strict> pragma. More
-seriously, it is possible for the remote user to type garbage into the
-upload field, in which case what you get from param() is not a
-filehandle at all, but a string.
-
-To be safe, use the I<upload()> function (new in version 2.47). When
-called with the name of an upload field, I<upload()> returns a
-filehandle, or undef if the parameter is not a valid filehandle.
-
- $fh = $query->upload('uploaded_file');
- while (<$fh>) {
- print;
- }
-
-This is the recommended idiom.
-
-When a file is uploaded the browser usually sends along some
-information along with it in the format of headers. The information
-usually includes the MIME content type. Future browsers may send
-other information as well (such as modification date and size). To
-retrieve this information, call uploadInfo(). It returns a reference to
-an associative array containing all the document headers.
-
- $filename = $query->param('uploaded_file');
- $type = $query->uploadInfo($filename)->{'Content-Type'};
- unless ($type eq 'text/html') {
- die "HTML FILES ONLY!";
- }
-
-If you are using a machine that recognizes "text" and "binary" data
-modes, be sure to understand when and how to use them (see the Camel book).
-Otherwise you may find that binary files are corrupted during file
-uploads.
-
-There are occasionally problems involving parsing the uploaded file.
-This usually happens when the user presses "Stop" before the upload is
-finished. In this case, CGI.pm will return undef for the name of the
-uploaded file and set I<cgi_error()> to the string "400 Bad request
-(malformed multipart POST)". This error message is designed so that
-you can incorporate it into a status code to be sent to the browser.
-Example:
-
- $file = $query->upload('uploaded_file');
- if (!$file && $query->cgi_error) {
- print $query->header(-status=>$query->cgi_error);
- exit 0;
- }
-
-You are free to create a custom HTML page to complain about the error,
-if you wish.
-
-JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
-B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
-recognized. See textfield() for details.
-
-=head2 CREATING A POPUP MENU
-
- print $query->popup_menu('menu_name',
- ['eenie','meenie','minie'],
- 'meenie');
-
- -or-
-
- %labels = ('eenie'=>'your first choice',
- 'meenie'=>'your second choice',
- 'minie'=>'your third choice');
- print $query->popup_menu('menu_name',
- ['eenie','meenie','minie'],
- 'meenie',\%labels);
-
- -or (named parameter style)-
-
- print $query->popup_menu(-name=>'menu_name',
- -values=>['eenie','meenie','minie'],
- -default=>'meenie',
- -labels=>\%labels);
-
-popup_menu() creates a menu.
-
-=over 4
-
-=item 1.
-
-The required first argument is the menu's name (-name).
-
-=item 2.
-
-The required second argument (-values) is an array B<reference>
-containing the list of menu items in the menu. You can pass the
-method an anonymous array, as shown in the example, or a reference to
-a named array, such as "\@foo".
-
-=item 3.
-
-The optional third parameter (-default) is the name of the default
-menu choice. If not specified, the first item will be the default.
-The values of the previous choice will be maintained across queries.
-
-=item 4.
-
-The optional fourth parameter (-labels) is provided for people who
-want to use different values for the user-visible label inside the
-popup menu nd the value returned to your script. It's a pointer to an
-associative array relating menu values to user-visible labels. If you
-leave this parameter blank, the menu values will be displayed by
-default. (You can also leave a label undefined if you want to).
-
-=back
-
-When the form is processed, the selected value of the popup menu can
-be retrieved using:
-
- $popup_menu_value = $query->param('menu_name');
-
-JAVASCRIPTING: popup_menu() recognizes the following event handlers:
-B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>, and
-B<-onBlur>. See the textfield() section for details on when these
-handlers are called.
-
-=head2 CREATING A SCROLLING LIST
-
- print $query->scrolling_list('list_name',
- ['eenie','meenie','minie','moe'],
- ['eenie','moe'],5,'true');
- -or-
-
- print $query->scrolling_list('list_name',
- ['eenie','meenie','minie','moe'],
- ['eenie','moe'],5,'true',
- \%labels);
-
- -or-
-
- print $query->scrolling_list(-name=>'list_name',
- -values=>['eenie','meenie','minie','moe'],
- -default=>['eenie','moe'],
- -size=>5,
- -multiple=>'true',
- -labels=>\%labels);
-
-scrolling_list() creates a scrolling list.
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The first and second arguments are the list name (-name) and values
-(-values). As in the popup menu, the second argument should be an
-array reference.
-
-=item 2.
-
-The optional third argument (-default) can be either a reference to a
-list containing the values to be selected by default, or can be a
-single value to select. If this argument is missing or undefined,
-then nothing is selected when the list first appears. In the named
-parameter version, you can use the synonym "-defaults" for this
-parameter.
-
-=item 3.
-
-The optional fourth argument is the size of the list (-size).
-
-=item 4.
-
-The optional fifth argument can be set to true to allow multiple
-simultaneous selections (-multiple). Otherwise only one selection
-will be allowed at a time.
-
-=item 5.
-
-The optional sixth argument is a pointer to an associative array
-containing long user-visible labels for the list items (-labels).
-If not provided, the values will be displayed.
-
-When this form is processed, all selected list items will be returned as
-a list under the parameter name 'list_name'. The values of the
-selected items can be retrieved with:
-
- @selected = $query->param('list_name');
-
-=back
-
-JAVASCRIPTING: scrolling_list() recognizes the following event
-handlers: B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>
-and B<-onBlur>. See textfield() for the description of when these
-handlers are called.
-
-=head2 CREATING A GROUP OF RELATED CHECKBOXES
-
- print $query->checkbox_group(-name=>'group_name',
- -values=>['eenie','meenie','minie','moe'],
- -default=>['eenie','moe'],
- -linebreak=>'true',
- -labels=>\%labels);
-
- print $query->checkbox_group('group_name',
- ['eenie','meenie','minie','moe'],
- ['eenie','moe'],'true',\%labels);
-
- HTML3-COMPATIBLE BROWSERS ONLY:
-
- print $query->checkbox_group(-name=>'group_name',
- -values=>['eenie','meenie','minie','moe'],
- -rows=2,-columns=>2);
-
-
-checkbox_group() creates a list of checkboxes that are related
-by the same name.
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The first and second arguments are the checkbox name and values,
-respectively (-name and -values). As in the popup menu, the second
-argument should be an array reference. These values are used for the
-user-readable labels printed next to the checkboxes as well as for the
-values passed to your script in the query string.
-
-=item 2.
-
-The optional third argument (-default) can be either a reference to a
-list containing the values to be checked by default, or can be a
-single value to checked. If this argument is missing or undefined,
-then nothing is selected when the list first appears.
-
-=item 3.
-
-The optional fourth argument (-linebreak) can be set to true to place
-line breaks between the checkboxes so that they appear as a vertical
-list. Otherwise, they will be strung together on a horizontal line.
-
-=item 4.
-
-The optional fifth argument is a pointer to an associative array
-relating the checkbox values to the user-visible labels that will
-be printed next to them (-labels). If not provided, the values will
-be used as the default.
-
-=item 5.
-
-B<HTML3-compatible browsers> (such as Netscape) can take advantage of
-the optional parameters B<-rows>, and B<-columns>. These parameters
-cause checkbox_group() to return an HTML3 compatible table containing
-the checkbox group formatted with the specified number of rows and
-columns. You can provide just the -columns parameter if you wish;
-checkbox_group will calculate the correct number of rows for you.
-
-To include row and column headings in the returned table, you
-can use the B<-rowheaders> and B<-colheaders> parameters. Both
-of these accept a pointer to an array of headings to use.
-The headings are just decorative. They don't reorganize the
-interpretation of the checkboxes -- they're still a single named
-unit.
-
-=back
-
-When the form is processed, all checked boxes will be returned as
-a list under the parameter name 'group_name'. The values of the
-"on" checkboxes can be retrieved with:
-
- @turned_on = $query->param('group_name');
-
-The value returned by checkbox_group() is actually an array of button
-elements. You can capture them and use them within tables, lists,
-or in other creative ways:
-
- @h = $query->checkbox_group(-name=>'group_name',-values=>\@values);
- &use_in_creative_way(@h);
-
-JAVASCRIPTING: checkbox_group() recognizes the B<-onClick>
-parameter. This specifies a JavaScript code fragment or
-function call to be executed every time the user clicks on
-any of the buttons in the group. You can retrieve the identity
-of the particular button clicked on using the "this" variable.
-
-=head2 CREATING A STANDALONE CHECKBOX
-
- print $query->checkbox(-name=>'checkbox_name',
- -checked=>'checked',
- -value=>'ON',
- -label=>'CLICK ME');
-
- -or-
-
- print $query->checkbox('checkbox_name','checked','ON','CLICK ME');
-
-checkbox() is used to create an isolated checkbox that isn't logically
-related to any others.
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The first parameter is the required name for the checkbox (-name). It
-will also be used for the user-readable label printed next to the
-checkbox.
-
-=item 2.
-
-The optional second parameter (-checked) specifies that the checkbox
-is turned on by default. Synonyms are -selected and -on.
-
-=item 3.
-
-The optional third parameter (-value) specifies the value of the
-checkbox when it is checked. If not provided, the word "on" is
-assumed.
-
-=item 4.
-
-The optional fourth parameter (-label) is the user-readable label to
-be attached to the checkbox. If not provided, the checkbox name is
-used.
-
-=back
-
-The value of the checkbox can be retrieved using:
-
- $turned_on = $query->param('checkbox_name');
-
-JAVASCRIPTING: checkbox() recognizes the B<-onClick>
-parameter. See checkbox_group() for further details.
-
-=head2 CREATING A RADIO BUTTON GROUP
-
- print $query->radio_group(-name=>'group_name',
- -values=>['eenie','meenie','minie'],
- -default=>'meenie',
- -linebreak=>'true',
- -labels=>\%labels);
-
- -or-
-
- print $query->radio_group('group_name',['eenie','meenie','minie'],
- 'meenie','true',\%labels);
-
-
- HTML3-COMPATIBLE BROWSERS ONLY:
-
- print $query->radio_group(-name=>'group_name',
- -values=>['eenie','meenie','minie','moe'],
- -rows=2,-columns=>2);
-
-radio_group() creates a set of logically-related radio buttons
-(turning one member of the group on turns the others off)
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The first argument is the name of the group and is required (-name).
-
-=item 2.
-
-The second argument (-values) is the list of values for the radio
-buttons. The values and the labels that appear on the page are
-identical. Pass an array I<reference> in the second argument, either
-using an anonymous array, as shown, or by referencing a named array as
-in "\@foo".
-
-=item 3.
-
-The optional third parameter (-default) is the name of the default
-button to turn on. If not specified, the first item will be the
-default. You can provide a nonexistent button name, such as "-" to
-start up with no buttons selected.
-
-=item 4.
-
-The optional fourth parameter (-linebreak) can be set to 'true' to put
-line breaks between the buttons, creating a vertical list.
-
-=item 5.
-
-The optional fifth parameter (-labels) is a pointer to an associative
-array relating the radio button values to user-visible labels to be
-used in the display. If not provided, the values themselves are
-displayed.
-
-=item 6.
-
-B<HTML3-compatible browsers> (such as Netscape) can take advantage
-of the optional
-parameters B<-rows>, and B<-columns>. These parameters cause
-radio_group() to return an HTML3 compatible table containing
-the radio group formatted with the specified number of rows
-and columns. You can provide just the -columns parameter if you
-wish; radio_group will calculate the correct number of rows
-for you.
-
-To include row and column headings in the returned table, you
-can use the B<-rowheader> and B<-colheader> parameters. Both
-of these accept a pointer to an array of headings to use.
-The headings are just decorative. They don't reorganize the
-interpretation of the radio buttons -- they're still a single named
-unit.
-
-=back
-
-When the form is processed, the selected radio button can
-be retrieved using:
-
- $which_radio_button = $query->param('group_name');
-
-The value returned by radio_group() is actually an array of button
-elements. You can capture them and use them within tables, lists,
-or in other creative ways:
-
- @h = $query->radio_group(-name=>'group_name',-values=>\@values);
- &use_in_creative_way(@h);
-
-=head2 CREATING A SUBMIT BUTTON
-
- print $query->submit(-name=>'button_name',
- -value=>'value');
-
- -or-
-
- print $query->submit('button_name','value');
-
-submit() will create the query submission button. Every form
-should have one of these.
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The first argument (-name) is optional. You can give the button a
-name if you have several submission buttons in your form and you want
-to distinguish between them. The name will also be used as the
-user-visible label. Be aware that a few older browsers don't deal with this correctly and
-B<never> send back a value from a button.
-
-=item 2.
-
-The second argument (-value) is also optional. This gives the button
-a value that will be passed to your script in the query string.
-
-=back
-
-You can figure out which button was pressed by using different
-values for each one:
-
- $which_one = $query->param('button_name');
-
-JAVASCRIPTING: radio_group() recognizes the B<-onClick>
-parameter. See checkbox_group() for further details.
-
-=head2 CREATING A RESET BUTTON
-
- print $query->reset
-
-reset() creates the "reset" button. Note that it restores the
-form to its value from the last time the script was called,
-NOT necessarily to the defaults.
-
-Note that this conflicts with the Perl reset() built-in. Use
-CORE::reset() to get the original reset function.
-
-=head2 CREATING A DEFAULT BUTTON
-
- print $query->defaults('button_label')
-
-defaults() creates a button that, when invoked, will cause the
-form to be completely reset to its defaults, wiping out all the
-changes the user ever made.
-
-=head2 CREATING A HIDDEN FIELD
-
- print $query->hidden(-name=>'hidden_name',
- -default=>['value1','value2'...]);
-
- -or-
-
- print $query->hidden('hidden_name','value1','value2'...);
-
-hidden() produces a text field that can't be seen by the user. It
-is useful for passing state variable information from one invocation
-of the script to the next.
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The first argument is required and specifies the name of this
-field (-name).
-
-=item 2.
-
-The second argument is also required and specifies its value
-(-default). In the named parameter style of calling, you can provide
-a single value here or a reference to a whole list
-
-=back
-
-Fetch the value of a hidden field this way:
-
- $hidden_value = $query->param('hidden_name');
-
-Note, that just like all the other form elements, the value of a
-hidden field is "sticky". If you want to replace a hidden field with
-some other values after the script has been called once you'll have to
-do it manually:
-
- $query->param('hidden_name','new','values','here');
-
-=head2 CREATING A CLICKABLE IMAGE BUTTON
-
- print $query->image_button(-name=>'button_name',
- -src=>'/source/URL',
- -align=>'MIDDLE');
-
- -or-
-
- print $query->image_button('button_name','/source/URL','MIDDLE');
-
-image_button() produces a clickable image. When it's clicked on the
-position of the click is returned to your script as "button_name.x"
-and "button_name.y", where "button_name" is the name you've assigned
-to it.
-
-JAVASCRIPTING: image_button() recognizes the B<-onClick>
-parameter. See checkbox_group() for further details.
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The first argument (-name) is required and specifies the name of this
-field.
-
-=item 2.
-
-The second argument (-src) is also required and specifies the URL
-
-=item 3.
-The third option (-align, optional) is an alignment type, and may be
-TOP, BOTTOM or MIDDLE
-
-=back
-
-Fetch the value of the button this way:
- $x = $query->param('button_name.x');
- $y = $query->param('button_name.y');
-
-=head2 CREATING A JAVASCRIPT ACTION BUTTON
-
- print $query->button(-name=>'button_name',
- -value=>'user visible label',
- -onClick=>"do_something()");
-
- -or-
-
- print $query->button('button_name',"do_something()");
-
-button() produces a button that is compatible with Netscape 2.0's
-JavaScript. When it's pressed the fragment of JavaScript code
-pointed to by the B<-onClick> parameter will be executed. On
-non-Netscape browsers this form element will probably not even
-display.
-
-=head1 HTTP COOKIES
-
-Netscape browsers versions 1.1 and higher, and all versions of
-Internet Explorer, support a so-called "cookie" designed to help
-maintain state within a browser session. CGI.pm has several methods
-that support cookies.
-
-A cookie is a name=value pair much like the named parameters in a CGI
-query string. CGI scripts create one or more cookies and send
-them to the browser in the HTTP header. The browser maintains a list
-of cookies that belong to a particular Web server, and returns them
-to the CGI script during subsequent interactions.
-
-In addition to the required name=value pair, each cookie has several
-optional attributes:
-
-=over 4
-
-=item 1. an expiration time
-
-This is a time/date string (in a special GMT format) that indicates
-when a cookie expires. The cookie will be saved and returned to your
-script until this expiration date is reached if the user exits
-the browser and restarts it. If an expiration date isn't specified, the cookie
-will remain active until the user quits the browser.
-
-=item 2. a domain
-
-This is a partial or complete domain name for which the cookie is
-valid. The browser will return the cookie to any host that matches
-the partial domain name. For example, if you specify a domain name
-of ".capricorn.com", then the browser will return the cookie to
-Web servers running on any of the machines "www.capricorn.com",
-"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
-must contain at least two periods to prevent attempts to match
-on top level domains like ".edu". If no domain is specified, then
-the browser will only return the cookie to servers on the host the
-cookie originated from.
-
-=item 3. a path
-
-If you provide a cookie path attribute, the browser will check it
-against your script's URL before returning the cookie. For example,
-if you specify the path "/cgi-bin", then the cookie will be returned
-to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
-and "/cgi-bin/customer_service/complain.pl", but not to the script
-"/cgi-private/site_admin.pl". By default, path is set to "/", which
-causes the cookie to be sent to any CGI script on your site.
-
-=item 4. a "secure" flag
-
-If the "secure" attribute is set, the cookie will only be sent to your
-script if the CGI request is occurring on a secure channel, such as SSL.
-
-=back
-
-The interface to HTTP cookies is the B<cookie()> method:
-
- $cookie = $query->cookie(-name=>'sessionID',
- -value=>'xyzzy',
- -expires=>'+1h',
- -path=>'/cgi-bin/database',
- -domain=>'.capricorn.org',
- -secure=>1);
- print $query->header(-cookie=>$cookie);
-
-B<cookie()> creates a new cookie. Its parameters include:
-
-=over 4
-
-=item B<-name>
-
-The name of the cookie (required). This can be any string at all.
-Although browsers limit their cookie names to non-whitespace
-alphanumeric characters, CGI.pm removes this restriction by escaping
-and unescaping cookies behind the scenes.
-
-=item B<-value>
-
-The value of the cookie. This can be any scalar value,
-array reference, or even associative array reference. For example,
-you can store an entire associative array into a cookie this way:
-
- $cookie=$query->cookie(-name=>'family information',
- -value=>\%childrens_ages);
-
-=item B<-path>
-
-The optional partial path for which this cookie will be valid, as described
-above.
-
-=item B<-domain>
-
-The optional partial domain for which this cookie will be valid, as described
-above.
-
-=item B<-expires>
-
-The optional expiration date for this cookie. The format is as described
-in the section on the B<header()> method:
-
- "+1h" one hour from now
-
-=item B<-secure>
-
-If set to true, this cookie will only be used within a secure
-SSL session.
-
-=back
-
-The cookie created by cookie() must be incorporated into the HTTP
-header within the string returned by the header() method:
-
- print $query->header(-cookie=>$my_cookie);
-
-To create multiple cookies, give header() an array reference:
-
- $cookie1 = $query->cookie(-name=>'riddle_name',
- -value=>"The Sphynx's Question");
- $cookie2 = $query->cookie(-name=>'answers',
- -value=>\%answers);
- print $query->header(-cookie=>[$cookie1,$cookie2]);
-
-To retrieve a cookie, request it by name by calling cookie()
-method without the B<-value> parameter:
-
- use CGI;
- $query = new CGI;
- %answers = $query->cookie(-name=>'answers');
- # $query->cookie('answers') will work too!
-
-The cookie and CGI namespaces are separate. If you have a parameter
-named 'answers' and a cookie named 'answers', the values retrieved by
-param() and cookie() are independent of each other. However, it's
-simple to turn a CGI parameter into a cookie, and vice-versa:
-
- # turn a CGI parameter into a cookie
- $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]);
- # vice-versa
- $q->param(-name=>'answers',-value=>[$q->cookie('answers')]);
-
-See the B<cookie.cgi> example script for some ideas on how to use
-cookies effectively.
-
-=head1 WORKING WITH FRAMES
-
-It's possible for CGI.pm scripts to write into several browser panels
-and windows using the HTML 4 frame mechanism. There are three
-techniques for defining new frames programmatically:
-
-=over 4
-
-=item 1. Create a <Frameset> document
-
-After writing out the HTTP header, instead of creating a standard
-HTML document using the start_html() call, create a <FRAMESET>
-document that defines the frames on the page. Specify your script(s)
-(with appropriate parameters) as the SRC for each of the frames.
-
-There is no specific support for creating <FRAMESET> sections
-in CGI.pm, but the HTML is very simple to write. See the frame
-documentation in Netscape's home pages for details
-
- http://home.netscape.com/assist/net_sites/frames.html
-
-=item 2. Specify the destination for the document in the HTTP header
-
-You may provide a B<-target> parameter to the header() method:
-
- print $q->header(-target=>'ResultsWindow');
-
-This will tell the browser to load the output of your script into the
-frame named "ResultsWindow". If a frame of that name doesn't already
-exist, the browser will pop up a new window and load your script's
-document into that. There are a number of magic names that you can
-use for targets. See the frame documents on Netscape's home pages for
-details.
-
-=item 3. Specify the destination for the document in the <FORM> tag
-
-You can specify the frame to load in the FORM tag itself. With
-CGI.pm it looks like this:
-
- print $q->startform(-target=>'ResultsWindow');
-
-When your script is reinvoked by the form, its output will be loaded
-into the frame named "ResultsWindow". If one doesn't already exist
-a new window will be created.
-
-=back
-
-The script "frameset.cgi" in the examples directory shows one way to
-create pages in which the fill-out form and the response live in
-side-by-side frames.
-
-=head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
-
-CGI.pm has limited support for HTML3's cascading style sheets (css).
-To incorporate a stylesheet into your document, pass the
-start_html() method a B<-style> parameter. The value of this
-parameter may be a scalar, in which case it is incorporated directly
-into a <STYLE> section, or it may be a hash reference. In the latter
-case you should provide the hash with one or more of B<-src> or
-B<-code>. B<-src> points to a URL where an externally-defined
-stylesheet can be found. B<-code> points to a scalar value to be
-incorporated into a <STYLE> section. Style definitions in B<-code>
-override similarly-named ones in B<-src>, hence the name "cascading."
-
-You may also specify the type of the stylesheet by adding the optional
-B<-type> parameter to the hash pointed to by B<-style>. If not
-specified, the style defaults to 'text/css'.
-
-To refer to a style within the body of your document, add the
-B<-class> parameter to any HTML element:
-
- print h1({-class=>'Fancy'},'Welcome to the Party');
-
-Or define styles on the fly with the B<-style> parameter:
-
- print h1({-style=>'Color: red;'},'Welcome to Hell');
-
-You may also use the new B<span()> element to apply a style to a
-section of text:
-
- print span({-style=>'Color: red;'},
- h1('Welcome to Hell'),
- "Where did that handbasket get to?"
- );
-
-Note that you must import the ":html3" definitions to have the
-B<span()> method available. Here's a quick and dirty example of using
-CSS's. See the CSS specification at
-http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
-
- use CGI qw/:standard :html3/;
-
- #here's a stylesheet incorporated directly into the page
- $newStyle=<<END;
- <!--
- P.Tip {
- margin-right: 50pt;
- margin-left: 50pt;
- color: red;
- }
- P.Alert {
- font-size: 30pt;
- font-family: sans-serif;
- color: red;
- }
- -->
- END
- print header();
- print start_html( -title=>'CGI with Style',
- -style=>{-src=>'http://www.capricorn.com/style/st1.css',
- -code=>$newStyle}
- );
- print h1('CGI with Style'),
- p({-class=>'Tip'},
- "Better read the cascading style sheet spec before playing with this!"),
- span({-style=>'color: magenta'},
- "Look Mom, no hands!",
- p(),
- "Whooo wee!"
- );
- print end_html;
-
-=head1 DEBUGGING
-
-If you are running the script
-from the command line or in the perl debugger, you can pass the script
-a list of keywords or parameter=value pairs on the command line or
-from standard input (you don't have to worry about tricking your
-script into reading from environment variables).
-You can pass keywords like this:
-
- your_script.pl keyword1 keyword2 keyword3
-
-or this:
-
- your_script.pl keyword1+keyword2+keyword3
-
-or this:
-
- your_script.pl name1=value1 name2=value2
-
-or this:
-
- your_script.pl name1=value1&name2=value2
-
-or even as newline-delimited parameters on standard input.
-
-When debugging, you can use quotes and backslashes to escape
-characters in the familiar shell manner, letting you place
-spaces and other funny characters in your parameter=value
-pairs:
-
- your_script.pl "name1='I am a long value'" "name2=two\ words"
-
-=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
-
-The dump() method produces a string consisting of all the query's
-name/value pairs formatted nicely as a nested list. This is useful
-for debugging purposes:
-
- print $query->dump
-
-
-Produces something that looks like:
-
- <UL>
- <LI>name1
- <UL>
- <LI>value1
- <LI>value2
- </UL>
- <LI>name2
- <UL>
- <LI>value1
- </UL>
- </UL>
-
-As a shortcut, you can interpolate the entire CGI object into a string
-and it will be replaced with the a nice HTML dump shown above:
-
- $query=new CGI;
- print "<H2>Current Values</H2> $query\n";
-
-=head1 FETCHING ENVIRONMENT VARIABLES
-
-Some of the more useful environment variables can be fetched
-through this interface. The methods are as follows:
-
-=over 4
-
-=item B<Accept()>
-
-Return a list of MIME types that the remote browser accepts. If you
-give this method a single argument corresponding to a MIME type, as in
-$query->Accept('text/html'), it will return a floating point value
-corresponding to the browser's preference for this type from 0.0
-(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept
-list are handled correctly.
-
-Note that the capitalization changed between version 2.43 and 2.44 in
-order to avoid conflict with Perl's accept() function.
-
-=item B<raw_cookie()>
-
-Returns the HTTP_COOKIE variable, an HTTP extension implemented by
-Netscape browsers version 1.1 and higher, and all versions of Internet
-Explorer. Cookies have a special format, and this method call just
-returns the raw form (?cookie dough). See cookie() for ways of
-setting and retrieving cooked cookies.
-
-Called with no parameters, raw_cookie() returns the packed cookie
-structure. You can separate it into individual cookies by splitting
-on the character sequence "; ". Called with the name of a cookie,
-retrieves the B<unescaped> form of the cookie. You can use the
-regular cookie() method to get the names, or use the raw_fetch()
-method from the CGI::Cookie module.
-
-=item B<user_agent()>
-
-Returns the HTTP_USER_AGENT variable. If you give
-this method a single argument, it will attempt to
-pattern match on it, allowing you to do something
-like $query->user_agent(netscape);
-
-=item B<path_info()>
-
-Returns additional path information from the script URL.
-E.G. fetching /cgi-bin/your_script/additional/stuff will
-result in $query->path_info() returning
-"additional/stuff".
-
-NOTE: The Microsoft Internet Information Server
-is broken with respect to additional path information. If
-you use the Perl DLL library, the IIS server will attempt to
-execute the additional path information as a Perl script.
-If you use the ordinary file associations mapping, the
-path information will be present in the environment,
-but incorrect. The best thing to do is to avoid using additional
-path information in CGI scripts destined for use with IIS.
-
-=item B<path_translated()>
-
-As per path_info() but returns the additional
-path information translated into a physical path, e.g.
-"/usr/local/etc/httpd/htdocs/additional/stuff".
-
-The Microsoft IIS is broken with respect to the translated
-path as well.
-
-=item B<remote_host()>
-
-Returns either the remote host name or IP address.
-if the former is unavailable.
-
-=item B<script_name()>
-Return the script name as a partial URL, for self-refering
-scripts.
-
-=item B<referer()>
-
-Return the URL of the page the browser was viewing
-prior to fetching your script. Not available for all
-browsers.
-
-=item B<auth_type ()>
-
-Return the authorization/verification method in use for this
-script, if any.
-
-=item B<server_name ()>
-
-Returns the name of the server, usually the machine's host
-name.
-
-=item B<virtual_host ()>
-
-When using virtual hosts, returns the name of the host that
-the browser attempted to contact
-
-=item B<server_software ()>
-
-Returns the server software and version number.
-
-=item B<remote_user ()>
-
-Return the authorization/verification name used for user
-verification, if this script is protected.
-
-=item B<user_name ()>
-
-Attempt to obtain the remote user's name, using a variety of different
-techniques. This only works with older browsers such as Mosaic.
-Newer browsers do not report the user name for privacy reasons!
-
-=item B<request_method()>
-
-Returns the method used to access your script, usually
-one of 'POST', 'GET' or 'HEAD'.
-
-=item B<content_type()>
-
-Returns the content_type of data submitted in a POST, generally
-multipart/form-data or application/x-www-form-urlencoded
-
-=item B<http()>
-
-Called with no arguments returns the list of HTTP environment
-variables, including such things as HTTP_USER_AGENT,
-HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the
-like-named HTTP header fields in the request. Called with the name of
-an HTTP header field, returns its value. Capitalization and the use
-of hyphens versus underscores are not significant.
-
-For example, all three of these examples are equivalent:
-
- $requested_language = $q->http('Accept-language');
- $requested_language = $q->http('Accept_language');
- $requested_language = $q->http('HTTP_ACCEPT_LANGUAGE');
-
-=item B<https()>
-
-The same as I<http()>, but operates on the HTTPS environment variables
-present when the SSL protocol is in effect. Can be used to determine
-whether SSL is turned on.
-
-=back
-
-=head1 USING NPH SCRIPTS
-
-NPH, or "no-parsed-header", scripts bypass the server completely by
-sending the complete HTTP header directly to the browser. This has
-slight performance benefits, but is of most use for taking advantage
-of HTTP extensions that are not directly supported by your server,
-such as server push and PICS headers.
-
-Servers use a variety of conventions for designating CGI scripts as
-NPH. Many Unix servers look at the beginning of the script's name for
-the prefix "nph-". The Macintosh WebSTAR server and Microsoft's
-Internet Information Server, in contrast, try to decide whether a
-program is an NPH script by examining the first line of script output.
-
-
-CGI.pm supports NPH scripts with a special NPH mode. When in this
-mode, CGI.pm will output the necessary extra header information when
-the header() and redirect() methods are
-called.
-
-The Microsoft Internet Information Server requires NPH mode. As of version
-2.30, CGI.pm will automatically detect when the script is running under IIS
-and put itself into this mode. You do not need to do this manually, although
-it won't hurt anything if you do.
-
-There are a number of ways to put CGI.pm into NPH mode:
-
-=over 4
-
-=item In the B<use> statement
-
-Simply add the "-nph" pragmato the list of symbols to be imported into
-your script:
-
- use CGI qw(:standard -nph)
-
-=item By calling the B<nph()> method:
-
-Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
-
- CGI->nph(1)
-
-=item By using B<-nph> parameters in the B<header()> and B<redirect()> statements:
-
- print $q->header(-nph=>1);
-
-=back
-
-=head1 Server Push
-
-CGI.pm provides three simple functions for producing multipart
-documents of the type needed to implement server push. These
-functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To
-import these into your namespace, you must import the ":push" set.
-You are also advised to put the script into NPH mode and to set $| to
-1 to avoid buffering problems.
-
-Here is a simple script that demonstrates server push:
-
- #!/usr/local/bin/perl
- use CGI qw/:push -nph/;
- $| = 1;
- print multipart_init(-boundary=>'----------------here we go!');
- while (1) {
- print multipart_start(-type=>'text/plain'),
- "The current time is ",scalar(localtime),"\n",
- multipart_end;
- sleep 1;
- }
-
-This script initializes server push by calling B<multipart_init()>.
-It then enters an infinite loop in which it begins a new multipart
-section by calling B<multipart_start()>, prints the current local time,
-and ends a multipart section with B<multipart_end()>. It then sleeps
-a second, and begins again.
-
-=over 4
-
-=item multipart_init()
-
- multipart_init(-boundary=>$boundary);
-
-Initialize the multipart system. The -boundary argument specifies
-what MIME boundary string to use to separate parts of the document.
-If not provided, CGI.pm chooses a reasonable boundary for you.
-
-=item multipart_start()
-
- multipart_start(-type=>$type)
-
-Start a new part of the multipart document using the specified MIME
-type. If not specified, text/html is assumed.
-
-=item multipart_end()
-
- multipart_end()
-
-End a part. You must remember to call multipart_end() once for each
-multipart_start().
-
-=back
-
-Users interested in server push applications should also have a look
-at the CGI::Push module.
-
-=head1 Avoiding Denial of Service Attacks
-
-A potential problem with CGI.pm is that, by default, it attempts to
-process form POSTings no matter how large they are. A wily hacker
-could attack your site by sending a CGI script a huge POST of many
-megabytes. CGI.pm will attempt to read the entire POST into a
-variable, growing hugely in size until it runs out of memory. While
-the script attempts to allocate the memory the system may slow down
-dramatically. This is a form of denial of service attack.
-
-Another possible attack is for the remote user to force CGI.pm to
-accept a huge file upload. CGI.pm will accept the upload and store it
-in a temporary directory even if your script doesn't expect to receive
-an uploaded file. CGI.pm will delete the file automatically when it
-terminates, but in the meantime the remote user may have filled up the
-server's disk space, causing problems for other programs.
-
-The best way to avoid denial of service attacks is to limit the amount
-of memory, CPU time and disk space that CGI scripts can use. Some Web
-servers come with built-in facilities to accomplish this. In other
-cases, you can use the shell I<limit> or I<ulimit>
-commands to put ceilings on CGI resource usage.
-
-
-CGI.pm also has some simple built-in protections against denial of
-service attacks, but you must activate them before you can use them.
-These take the form of two global variables in the CGI name space:
-
-=over 4
-
-=item B<$CGI::POST_MAX>
-
-If set to a non-negative integer, this variable puts a ceiling
-on the size of POSTings, in bytes. If CGI.pm detects a POST
-that is greater than the ceiling, it will immediately exit with an error
-message. This value will affect both ordinary POSTs and
-multipart POSTs, meaning that it limits the maximum size of file
-uploads as well. You should set this to a reasonably high
-value, such as 1 megabyte.
-
-=item B<$CGI::DISABLE_UPLOADS>
-
-If set to a non-zero value, this will disable file uploads
-completely. Other fill-out form values will work as usual.
-
-=back
-
-You can use these variables in either of two ways.
-
-=over 4
-
-=item B<1. On a script-by-script basis>
-
-Set the variable at the top of the script, right after the "use" statement:
-
- use CGI qw/:standard/;
- use CGI::Carp 'fatalsToBrowser';
- $CGI::POST_MAX=1024 * 100; # max 100K posts
- $CGI::DISABLE_UPLOADS = 1; # no uploads
-
-=item B<2. Globally for all scripts>
-
-Open up CGI.pm, find the definitions for $POST_MAX and
-$DISABLE_UPLOADS, and set them to the desired values. You'll
-find them towards the top of the file in a subroutine named
-initialize_globals().
-
-=back
-
-An attempt to send a POST larger than $POST_MAX bytes will cause
-I<param()> to return an empty CGI parameter list. You can test for
-this event by checking I<cgi_error()>, either after you create the CGI
-object or, if you are using the function-oriented interface, call
-<param()> for the first time. If the POST was intercepted, then
-cgi_error() will return the message "413 POST too large".
-
-This error message is actually defined by the HTTP protocol, and is
-designed to be returned to the browser as the CGI script's status
- code. For example:
-
- $uploaded_file = param('upload');
- if (!$uploaded_file && cgi_error()) {
- print header(-status=>cgi_error());
- exit 0;
- }
-
-However it isn't clear that any browser currently knows what to do
-with this status code. It might be better just to create an
-HTML page that warns the user of the problem.
-
-=head1 COMPATIBILITY WITH CGI-LIB.PL
-
-To make it easier to port existing programs that use cgi-lib.pl the
-compatibility routine "ReadParse" is provided. Porting is simple:
-
-OLD VERSION
- require "cgi-lib.pl";
- &ReadParse;
- print "The value of the antique is $in{antique}.\n";
-
-NEW VERSION
- use CGI;
- CGI::ReadParse
- print "The value of the antique is $in{antique}.\n";
-
-CGI.pm's ReadParse() routine creates a tied variable named %in,
-which can be accessed to obtain the query variables. Like
-ReadParse, you can also provide your own variable. Infrequently
-used features of ReadParse, such as the creation of @in and $in
-variables, are not supported.
-
-Once you use ReadParse, you can retrieve the query object itself
-this way:
-
- $q = $in{CGI};
- print $q->textfield(-name=>'wow',
- -value=>'does this really work?');
-
-This allows you to start using the more interesting features
-of CGI.pm without rewriting your old scripts from scratch.
-
-=head1 AUTHOR INFORMATION
-
-Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-Address bug reports and comments to: lstein@cshl.org. When sending
-bug reports, please provide the version of CGI.pm, the version of
-Perl, the name and version of your Web server, and the name and
-version of the operating system you are using. If the problem is even
-remotely browser dependent, please provide information about the
-affected browers as well.
-
-=head1 CREDITS
-
-Thanks very much to:
-
-=over 4
-
-=item Matt Heffron (heffron@falstaff.css.beckman.com)
-
-=item James Taylor (james.taylor@srs.gov)
-
-=item Scott Anguish <sanguish@digifix.com>
-
-=item Mike Jewell (mlj3u@virginia.edu)
-
-=item Timothy Shimmin (tes@kbs.citri.edu.au)
-
-=item Joergen Haegg (jh@axis.se)
-
-=item Laurent Delfosse (delfosse@delfosse.com)
-
-=item Richard Resnick (applepi1@aol.com)
-
-=item Craig Bishop (csb@barwonwater.vic.gov.au)
-
-=item Tony Curtis (tc@vcpc.univie.ac.at)
-
-=item Tim Bunce (Tim.Bunce@ig.co.uk)
-
-=item Tom Christiansen (tchrist@convex.com)
-
-=item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
-
-=item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
-
-=item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
-
-=item Stephen Dahmen (joyfire@inxpress.net)
-
-=item Ed Jordan (ed@fidalgo.net)
-
-=item David Alan Pisoni (david@cnation.com)
-
-=item Doug MacEachern (dougm@opengroup.org)
-
-=item Robin Houston (robin@oneworld.org)
-
-=item ...and many many more...
-
-for suggestions and bug fixes.
-
-=back
-
-=head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
-
-
- #!/usr/local/bin/perl
-
- use CGI;
-
- $query = new CGI;
-
- print $query->header;
- print $query->start_html("Example CGI.pm Form");
- print "<H1> Example CGI.pm Form</H1>\n";
- &print_prompt($query);
- &do_work($query);
- &print_tail;
- print $query->end_html;
-
- sub print_prompt {
- my($query) = @_;
-
- print $query->startform;
- print "<EM>What's your name?</EM><BR>";
- print $query->textfield('name');
- print $query->checkbox('Not my real name');
-
- print "<P><EM>Where can you find English Sparrows?</EM><BR>";
- print $query->checkbox_group(
- -name=>'Sparrow locations',
- -values=>[England,France,Spain,Asia,Hoboken],
- -linebreak=>'yes',
- -defaults=>[England,Asia]);
-
- print "<P><EM>How far can they fly?</EM><BR>",
- $query->radio_group(
- -name=>'how far',
- -values=>['10 ft','1 mile','10 miles','real far'],
- -default=>'1 mile');
-
- print "<P><EM>What's your favorite color?</EM> ";
- print $query->popup_menu(-name=>'Color',
- -values=>['black','brown','red','yellow'],
- -default=>'red');
-
- print $query->hidden('Reference','Monty Python and the Holy Grail');
-
- print "<P><EM>What have you got there?</EM><BR>";
- print $query->scrolling_list(
- -name=>'possessions',
- -values=>['A Coconut','A Grail','An Icon',
- 'A Sword','A Ticket'],
- -size=>5,
- -multiple=>'true');
-
- print "<P><EM>Any parting comments?</EM><BR>";
- print $query->textarea(-name=>'Comments',
- -rows=>10,
- -columns=>50);
-
- print "<P>",$query->reset;
- print $query->submit('Action','Shout');
- print $query->submit('Action','Scream');
- print $query->endform;
- print "<HR>\n";
- }
-
- sub do_work {
- my($query) = @_;
- my(@values,$key);
-
- print "<H2>Here are the current settings in this form</H2>";
-
- foreach $key ($query->param) {
- print "<STRONG>$key</STRONG> -> ";
- @values = $query->param($key);
- print join(", ",@values),"<BR>\n";
- }
- }
-
- sub print_tail {
- print <<END;
- <HR>
- <ADDRESS>Lincoln D. Stein</ADDRESS><BR>
- <A HREF="/">Home Page</A>
- END
- }
-
-=head1 BUGS
-
-This module has grown large and monolithic. Furthermore it's doing many
-things, such as handling URLs, parsing CGI input, writing HTML, etc., that
-are also done in the LWP modules. It should be discarded in favor of
-the CGI::* modules, but somehow I continue to work on it.
-
-Note that the code is truly contorted in order to avoid spurious
-warnings when programs are run with the B<-w> switch.
-
-=head1 SEE ALSO
-
-L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>,
-L<CGI::Base>, L<CGI::Form>, L<CGI::Push>, L<CGI::Fast>,
-L<CGI::Pretty>
-
-=cut
-
OpenPOWER on IntegriCloud