package CGI;
require 5.004;
+use Carp 'croak';
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
# 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';
+$CGI::revision = '$Id: CGI.pm,v 1.185 2005/08/03 21:14:55 lstein Exp $';
+$CGI::VERSION='3.11_01';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
-# $TempFile::TMPDIRECTORY = '/usr/tmp';
+# $CGITempFile::TMPDIRECTORY = '/usr/tmp';
+use CGI::Util qw(rearrange make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
+
+#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
+# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
+
+use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
+ 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
+
+{
+ local $^W = 0;
+ $TAINTED = substr("$0$^X",0,0);
+}
+
+$MOD_PERL = 0; # no mod_perl by default
+@SAVED_SYMBOLS = ();
# >>>>> 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;
+ # Set this to 1 to generate XTML-compatible output
+ $XHTML = 1;
+
# 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';
+ $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
+ 'http://www.w3.org/TR/html4/loose.dtd' ] ;
+
+ # Set this to 1 to enable NOSTICKY scripts
+ # or:
+ # 1) use CGI qw(-nosticky)
+ # 2) $CGI::nosticky(1)
+ $NOSTICKY = 0;
# Set this to 1 to enable NPH scripts
# or:
# 1) use CGI qw(-nph)
- # 2) $CGI::nph(1)
+ # 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 enable debugging from @ARGV
+ # Set to 2 to enable debugging from STDIN
+ $DEBUG = 1;
# 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);
+ # 2) CGI::private_tempfiles(1);
$PRIVATE_TEMPFILES = 0;
+ # Set this to 1 to cause files uploaded in multipart documents
+ # to be closed, instead of caching the file handle
+ # or:
+ # 1) use CGI qw(:close_upload_files)
+ # 2) $CGI::close_upload_files(1);
+ # Uploads with many files run out of file handles.
+ # Also, for performance, since the file is already on disk,
+ # it can just be renamed, instead of read and written.
+ $CLOSE_UPLOAD_FILES = 0;
+
# Set this to a positive value to limit the size of a POSTing
# to a certain number of bytes:
$POST_MAX = -1;
$HEADERS_ONCE = 0;
# separate the name=value pairs by semicolons rather than ampersands
- $USE_PARAM_SEMICOLONS = 0;
+ $USE_PARAM_SEMICOLONS = 1;
+
+ # Do not include undefined params parsed from query string
+ # use CGI qw(-no_undef_params);
+ $NO_UNDEF_PARAMS = 0;
# Other globals that you shouldn't worry about.
undef $Q;
$BEEN_THERE = 0;
+ $DTD_PUBLIC_IDENTIFIER = "";
undef @QUERY_PARAM;
undef %EXPORT;
+ undef $QUERY_CHARSET;
+ undef %QUERY_FIELDNAMES;
# prevent complaints by mod_perl
1;
# ------------------ START OF THE LIBRARY ------------
+*end_form = \&endform;
+
# make mod_perlhappy
initialize_globals();
$OS = $Config::Config{'osname'};
}
}
-if ($OS=~/Win/i) {
+if ($OS =~ /^MSWin/i) {
$OS = 'WINDOWS';
-} elsif ($OS=~/vms/i) {
+} elsif ($OS =~ /^VMS/i) {
$OS = 'VMS';
-} elsif ($OS=~/bsdos/i) {
- $OS = 'UNIX';
-} elsif ($OS=~/dos/i) {
+} elsif ($OS =~ /^dos/i) {
$OS = 'DOS';
-} elsif ($OS=~/^MacOS$/i) {
+} elsif ($OS =~ /^MacOS/i) {
$OS = 'MACINTOSH';
-} elsif ($OS=~/os2/i) {
+} elsif ($OS =~ /^os2/i) {
$OS = 'OS2';
+} elsif ($OS =~ /^epoc/i) {
+ $OS = 'EPOC';
+} elsif ($OS =~ /^cygwin/i) {
+ $OS = 'CYGWIN';
} else {
$OS = 'UNIX';
}
# Some OS logic. Binary mode enabled on DOS, NT and VMS
-$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/;
+$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN)/;
# This is the default class for the CGI object to use when all else fails.
$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
# The path separator is a slash, backslash or semicolon, depending
# on the paltform.
$SL = {
- UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
+ UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/',
+ WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
}->{$OS};
# This no longer seems to be necessary
$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;
+if (exists $ENV{MOD_PERL}) {
+ # mod_perl handlers may run system() on scripts using CGI.pm;
+ # Make sure so we don't get fooled by inherited $ENV{MOD_PERL}
+ if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
+ $MOD_PERL = 2;
+ require Apache2::Response;
+ require Apache2::RequestRec;
+ require Apache2::RequestUtil;
+ require Apache2::RequestIO;
+ require APR::Pool;
+ } else {
+ $MOD_PERL = 1;
require Apache;
+ }
}
+
# Turn on special checking for ActiveState's PerlEx
$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
$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);
+ $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/],
+ input Select option comment charset escapeHTML/],
':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/],
+ embed basefont style span layer ilayer font frameset frame script small big Area Map/],
+ ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
+ ins label legend noframes noscript object optgroup Q
+ thead tbody tfoot/],
':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
+ ':cgi'=>[qw/param upload path_info path_translated request_uri 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
+ remote_addr referer server_name server_software server_port server_protocol virtual_port
+ virtual_host remote_ident auth_type http append
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/]
+ ':html' => [qw/:html2 :html3 :html4 :netscape/],
+ ':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
+ ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
+ ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/]
);
+# Custom 'can' method for both autoloaded and non-autoloaded subroutines.
+# Author: Cees Hek <cees@sitesuite.com.au>
+
+sub can {
+ my($class, $method) = @_;
+
+ # See if UNIVERSAL::can finds it.
+
+ if (my $func = $class -> SUPER::can($method) ){
+ return $func;
+ }
+
+ # Try to compile the function.
+
+ eval {
+ # _compile looks at $AUTOLOAD for the function name.
+
+ local $AUTOLOAD = join "::", $class, $method;
+ &_compile;
+ };
+
+ # Now that the function is loaded (if it exists)
+ # just use UNIVERSAL::can again to do the work.
+
+ return $class -> SUPER::can($method);
+}
+
# to import symbols into caller
sub import {
my $self = shift;
-# This causes modules to clash.
-# undef %EXPORT_OK;
-# undef %EXPORT;
+ # This causes modules to clash.
+ undef %EXPORT_OK;
+ undef %EXPORT;
$self->_setup_symbols(@_);
my ($callpack, $callfile, $callline) = caller;
# 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;
+ my($class,@initializer) = @_;
+ my $self = {};
+
+ bless $self,ref $class || $class || $DefaultClass;
+ if (ref($initializer[0])
+ && (UNIVERSAL::isa($initializer[0],'Apache')
+ ||
+ UNIVERSAL::isa($initializer[0],'Apache2::RequestRec')
+ )) {
+ $self->r(shift @initializer);
+ }
+ if (ref($initializer[0])
+ && (UNIVERSAL::isa($initializer[0],'CODE'))) {
+ $self->upload_hook(shift @initializer, shift @initializer);
+ }
+ if ($MOD_PERL) {
+ if ($MOD_PERL == 1) {
+ $self->r(Apache->request) unless $self->r;
+ my $r = $self->r;
+ $r->register_cleanup(\&CGI::_reset_globals);
+ }
+ else {
+ # XXX: once we have the new API
+ # will do a real PerlOptions -SetupEnv check
+ $self->r(Apache2::RequestUtil->request) unless $self->r;
+ my $r = $self->r;
+ $r->subprocess_env unless exists $ENV{REQUEST_METHOD};
+ $r->pool->cleanup_register(\&CGI::_reset_globals);
}
- $self->_reset_globals if $PERLEX;
- $self->init($initializer);
- return $self;
+ undef $NPH;
+ }
+ $self->_reset_globals if $PERLEX;
+ $self->init(@initializer);
+ return $self;
+}
+
+# We provide a DESTROY method so that we can ensure that
+# temporary files are closed (via Fh->DESTROY) before they
+# are unlinked (via CGITempFile->DESTROY) because it is not
+# possible to unlink an open file on Win32. We explicitly
+# call DESTROY on each, rather than just undefing them and
+# letting Perl DESTROY them by garbage collection, in case the
+# user is still holding any reference to them as well.
+sub DESTROY {
+ my $self = shift;
+ foreach my $href (values %{$self->{'.tmpfiles'}}) {
+ $href->{hndl}->DESTROY if defined $href->{hndl};
+ $href->{name}->DESTROY if defined $href->{name};
+ }
+}
+
+sub r {
+ my $self = shift;
+ my $r = $self->{'.r'};
+ $self->{'.r'} = shift if @_;
+ $r;
}
-# We provide a DESTROY method so that the autoloader
-# doesn't bother trying to find it.
-sub DESTROY { }
+sub upload_hook {
+ my ($self,$hook,$data) = self_or_default(@_);
+ $self->{'.upload_hook'} = $hook;
+ $self->{'.upload_data'} = $data;
+}
#### Method: param
# Returns the value(s)of a named parameter.
# 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);
+ ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
my(@values);
- if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
+ if (substr($p[0],0,1) eq '-') {
@values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
} else {
foreach ($value,@other) {
$Q = $CGI::DefaultClass->new unless defined($Q);
unshift(@_,$Q);
}
- return @_;
+ return wantarray ? @_ : $Q;
}
sub self_or_CGI {
# parameter list with the single parameter 'keywords'.
sub init {
- my($self,$initializer) = @_;
- my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
- local($/) = "\n";
+ my $self = shift;
+ my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
+
+ my $initializer = shift; # for backward compatibility
+ local($/) = "\n";
+
+ # set autoescaping on by default
+ $self->{'escape'} = 1;
# 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)) {
+ if (defined(@QUERY_PARAM) && !defined($initializer)) {
foreach (@QUERY_PARAM) {
$self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
}
+ $self->charset($QUERY_CHARSET);
+ $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
return;
}
$fh = to_filehandle($initializer) if $initializer;
+ # set charset to the safe ISO-8859-1
+ $self->charset('ISO-8859-1');
+
METHOD: {
# avoid unreasonably large postings
if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
- $self->cgi_error("413 Request entity too large");
- last METHOD;
- }
+ # quietly read and discard the post
+ my $buffer;
+ my $max = $content_length;
+ while ($max > 0 &&
+ (my $bytes = $MOD_PERL
+ ? $self->r->read($buffer,$max < 10000 ? $max : 10000)
+ : read(STDIN,$buffer,$max < 10000 ? $max : 10000)
+ )) {
+ $self->cgi_error("413 Request entity too large");
+ last METHOD;
+ }
+ }
# Process multipart postings, but only if the initializer is
# not defined.
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;
# the environment.
if ($meth=~/^(GET|HEAD)$/) {
if ($MOD_PERL) {
- $query_string = Apache->request->args;
+ $query_string = $self->r->args;
} else {
$query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
}
last METHOD;
}
if ($meth eq 'POST') {
- $self->read_from_client(\*STDIN,\$query_string,$content_length,0)
+ $self->read_from_client(\$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
# 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;
+ if ($DEBUG)
+ {
+ my $cmdline_ret = read_from_cmdline();
+ $query_string = $cmdline_ret->{'query_string'};
+ if (defined($cmdline_ret->{'subpath'}))
+ {
+ $self->path_info($cmdline_ret->{'subpath'});
+ }
+ }
}
+# YL: Begin Change for XML handler 10/19/2001
+ if ($meth eq 'POST'
+ && defined($ENV{'CONTENT_TYPE'})
+ && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
+ && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
+ my($param) = 'POSTDATA' ;
+ $self->add_parameter($param) ;
+ push (@{$self->{$param}},$query_string);
+ undef $query_string ;
+ }
+# YL: End Change for XML handler 10/19/2001
+
# 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 =~ /=/) {
+ if (defined $query_string && length $query_string) {
+ if ($query_string =~ /[&=;]/) {
$self->parse_params($query_string);
} else {
$self->add_parameter('keywords');
# Special case. Erase everything if there is a field named
# .defaults.
if ($self->param('.defaults')) {
- undef %{$self};
+ $self->delete_all();
}
# Associative array containing our defined fieldnames
# Clear out our default submission button flag if present
$self->delete('.submit');
$self->delete('.cgifields');
- $self->save_request unless $initializer;
+
+ $self->save_request unless defined $initializer;
}
# FUNCTIONS TO OVERRIDE:
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
# us to have several of these objects.
@QUERY_PARAM = $self->param; # save list of parameters
foreach (@QUERY_PARAM) {
- $QUERY_PARAM{$_}=$self->{$_};
+ next unless defined $_;
+ $QUERY_PARAM{$_}=$self->{$_};
}
+ $QUERY_CHARSET = $self->charset;
+ %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
}
sub parse_params {
my($param,$value);
foreach (@pairs) {
($param,$value) = split('=',$_,2);
+ next unless defined $param;
+ next if $NO_UNDEF_PARAMS and not defined $value;
+ $value = '' unless defined $value;
$param = unescape($param);
$value = unescape($value);
$self->add_parameter($param);
sub add_parameter {
my($self,$param)=@_;
+ return unless defined $param;
push (@{$self->{'.parameters'}},$param)
unless defined($self->{$param});
}
# put a filehandle into binary mode (DOS)
sub binmode {
+ return unless defined($_[1]) && defined fileno($_[1]);
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;
- }
+ sub $tagname {
+ my (\$q,\$a,\@rest) = self_or_default(\@_);
+ my(\$attr) = '';
+ if (ref(\$a) && ref(\$a) eq 'HASH') {
+ my(\@attr) = make_attributes(\$a,\$q->{'escape'});
+ \$attr = " \@attr" if \@attr;
+ } else {
+ unshift \@rest,\$a if defined \$a;
+ }
);
if ($tagname=~/start_(\w+)/i) {
- $func .= qq! return "<\U$1\E\$attr>";} !;
+ $func .= qq! return "<\L$1\E\$attr>";} !;
} elsif ($tagname=~/end_(\w+)/i) {
- $func .= qq! return "<\U/$1\E>"; } !;
+ $func .= qq! return "<\L/$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 \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest;
+ my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
+ my \@result = map { "\$tag\$_\$untag" }
+ (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
return "\@result";
}#;
}
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);
my($sub) = \%{"$pack\:\:SUBS"};
unless (%$sub) {
my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
+ local ($@,$!);
eval "package $pack; $$auto";
- die $@ if $@;
+ croak("$AUTOLOAD: $@") if $@;
$$auto = ''; # Free the unneeded storage (but don't undef it!!!)
}
my($code) = $sub->{$func_name};
$code = $CGI::DefaultClass->_make_tag_func($func_name);
}
}
- die "Undefined subroutine $AUTOLOAD\n" unless $code;
+ croak("Undefined subroutine $AUTOLOAD\n") unless $code;
+ local ($@,$!);
eval "package $pack; $code";
if ($@) {
$@ =~ s/ at .*\n//;
- die $@;
+ croak("$AUTOLOAD: $@");
}
}
CORE::delete($sub->{$func_name}); #free storage
return "$pack\:\:$func_name";
}
+sub _selected {
+ my $self = shift;
+ my $value = shift;
+ return '' unless $value;
+ return $XHTML ? qq( selected="selected") : qq( selected);
+}
+
+sub _checked {
+ my $self = shift;
+ my $value = shift;
+ return '' unless $value;
+ return $XHTML ? qq( checked="checked") : qq( checked);
+}
+
sub _reset_globals { initialize_globals(); }
sub _setup_symbols {
my $self = shift;
my $compile = 0;
+
+ # to avoid reexporting unwanted variables
+ undef %EXPORT;
+
foreach (@_) {
$HEADERS_ONCE++, next if /^[:-]unique_headers$/;
$NPH++, next if /^[:-]nph$/;
- $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/;
+ $NOSTICKY++, next if /^[:-]nosticky$/;
+ $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
+ $DEBUG=2, next if /^[:-][Dd]ebug$/;
$USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
+ $XHTML++, next if /^[:-]xhtml$/;
+ $XHTML=0, next if /^[:-]no_?xhtml$/;
+ $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
$PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
+ $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
$EXPORT{$_}++, next if /^[:-]any$/;
$compile++, next if /^[:-]compile$/;
+ $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
# This is probably extremely evil code -- to be deleted some day.
if (/^[-]autoload$/) {
}
}
_compile_all(keys %EXPORT) if $compile;
+ @SAVED_SYMBOLS = @_;
+}
+
+sub charset {
+ my ($self,$charset) = self_or_default(@_);
+ $self->{'.charset'} = $charset if defined $charset;
+ $self->{'.charset'};
+}
+
+sub element_id {
+ my ($self,$new_value) = self_or_default(@_);
+ $self->{'.elid'} = $new_value if defined $new_value;
+ sprintf('%010d',$self->{'.elid'}++);
+}
+
+sub element_tab {
+ my ($self,$new_value) = self_or_default(@_);
+ $self->{'.etab'} ||= 1;
+ $self->{'.etab'} = $new_value if defined $new_value;
+ $self->{'.etab'}++;
}
###############################################################################
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;
-}
+sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
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);
+ my($self,$boundary,$length) = @_;
+ return MultipartBuffer->new($self,$boundary,$length);
}
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) = @_;
+ my($self, $buff, $len, $offset) = @_;
local $^W=0; # prevent a warning
- return undef unless defined($fh);
- return read($fh, $$buff, $len, $offset);
+ return $MOD_PERL
+ ? $self->r->read($$buff, $len, $offset)
+ : read(\*STDIN, $$buff, $len, $offset);
}
END_OF_FUNC
# 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;
+ my($self,@p) = self_or_default(@_);
+ my(@names) = rearrange([NAME],@p);
+ my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
+ my %to_delete;
+ foreach my $name (@to_delete)
+ {
+ CORE::delete $self->{$name};
+ CORE::delete $self->{'.fieldnames'}->{$name};
+ $to_delete{$name}++;
+ }
+ @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
+ return;
}
END_OF_FUNC
END_OF_FUNC
'TIEHASH' => <<'END_OF_FUNC',
-sub TIEHASH {
- return $_[1] if defined $_[1];
- return $Q || new shift;
+sub TIEHASH {
+ my $class = shift;
+ my $arg = $_[0];
+ if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
+ return $arg;
+ }
+ return $Q ||= $class->new(@_);
}
END_OF_FUNC
'STORE' => <<'END_OF_FUNC',
sub STORE {
- $_[0]->param($_[1],split("\0",$_[2]));
+ my $self = shift;
+ my $tag = shift;
+ my $vals = shift;
+ my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
+ $self->param(-name=>$tag,-value=>\@vals);
}
END_OF_FUNC
####
'append' => <<'EOF',
sub append {
- my($self,@p) = @_;
- my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
+ my($self,@p) = self_or_default(@_);
+ my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
if (@values) {
$self->add_parameter($name);
'delete_all' => <<'EOF',
sub delete_all {
my($self) = self_or_default(@_);
- undef %{$self};
+ my @param = $self->param();
+ $self->delete(@param);
}
EOF
'autoEscape' => <<'END_OF_FUNC',
sub autoEscape {
my($self,$escape) = self_or_default(@_);
- $self->{'dontescape'}=!$escape;
+ my $d = $self->{'escape'};
+ $self->{'escape'} = $escape;
+ $d;
}
END_OF_FUNC
}
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
}
END_OF_FUNC
-#### Method: dump
+#### 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 {
+'Dump' => <<'END_OF_FUNC',
+sub Dump {
my($self) = self_or_default(@_);
my($param,$value,@result);
- return '<UL></UL>' unless $self->param;
- push(@result,"<UL>");
+ 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>");
+ push(@result,"<li><strong>$param</strong></li>");
+ push(@result,"<ul>");
foreach $value ($self->param($param)) {
$value = $self->escapeHTML($value);
- $value =~ s/\n/<BR>\n/g;
- push(@result,"<LI>$value");
+ $value =~ s/\n/<br \/>\n/g;
+ push(@result,"<li>$value</li>");
}
- push(@result,"</UL>");
+ push(@result,"</ul>");
}
- push(@result,"</UL>\n");
+ push(@result,"</ul>");
return join("\n",@result);
}
END_OF_FUNC
####
'as_string' => <<'END_OF_FUNC',
sub as_string {
- &dump(@_);
+ &Dump(@_);
}
END_OF_FUNC
print $filehandle "$escaped_param=",escape("$value"),"\n";
}
}
+ foreach (keys %{$self->{'.fieldnames'}}) {
+ print $filehandle ".cgifields=",escape("$_"),"\n";
+ }
print $filehandle "=\n"; # end of record
}
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
+# This has to be NPH on most web servers, and it is advisable to set $| = 1
#
# Many thanks to Ed Jordan <ed@fidalgo.net> for this
-# contribution
+# contribution, updated by Andrew Benham (adsb@bigfoot.com)
####
'multipart_init' => <<'END_OF_FUNC',
sub multipart_init {
my($self,@p) = self_or_default(@_);
- my($boundary,@other) = $self->rearrange([BOUNDARY],@p);
+ my($boundary,@other) = rearrange([BOUNDARY],@p);
$boundary = $boundary || '------- =_aaaaaaaaaa0';
- $self->{'separator'} = "\n--$boundary\n";
+ $self->{'separator'} = "$CRLF--$boundary$CRLF";
+ $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
$type = SERVER_PUSH($boundary);
return $self->header(
- -nph => 1,
+ -nph => 0,
-type => $type,
(map { split "=", $_, 2 } @other),
- ) . $self->multipart_end;
+ ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
}
END_OF_FUNC
# Return a Content-Type: style header for server-push, start of section
#
# Many thanks to Ed Jordan <ed@fidalgo.net> for this
-# contribution
+# contribution, updated by Andrew Benham (adsb@bigfoot.com)
####
'multipart_start' => <<'END_OF_FUNC',
sub multipart_start {
+ my(@header);
my($self,@p) = self_or_default(@_);
- my($type,@other) = $self->rearrange([TYPE],@p);
+ my($type,@other) = rearrange([TYPE],@p);
$type = $type || 'text/html';
- return $self->header(
- -type => $type,
- (map { split "=", $_, 2 } @other),
- );
+ push(@header,"Content-Type: $type");
+
+ # rearrange() was designed for the HTML portion, so we
+ # need to fix it up a little.
+ foreach (@other) {
+ # Don't use \s because of perl bug 21951
+ next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
+ ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
+ }
+ push(@header,@other);
+ my $header = join($CRLF,@header)."${CRLF}${CRLF}";
+ return $header;
}
END_OF_FUNC
#### Method: multipart_end
-# Return a Content-Type: style header for server-push, end of section
+# Return a MIME boundary separator for server-push, end of section
#
# Many thanks to Ed Jordan <ed@fidalgo.net> for this
# contribution
END_OF_FUNC
+#### Method: multipart_final
+# Return a MIME boundary separator for server-push, end of all sections
+#
+# Contributed by Andrew Benham (adsb@bigfoot.com)
+####
+'multipart_final' => <<'END_OF_FUNC',
+sub multipart_final {
+ my($self,@p) = self_or_default(@_);
+ return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
+}
+END_OF_FUNC
+
+
#### Method: header
# Return a Content-Type: style header
#
my($self,@p) = self_or_default(@_);
my(@header);
- return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
+ return "" 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);
+ my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
+ rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
+ 'STATUS',['COOKIE','COOKIES'],'TARGET',
+ 'EXPIRES','NPH','CHARSET',
+ 'ATTACHMENT','P3P'],@p);
+
+ $nph ||= $NPH;
+ if (defined $charset) {
+ $self->charset($charset);
+ } else {
+ $charset = $self->charset;
+ }
- $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;
+ # Don't use \s because of perl bug 21951
+ next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
+ ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
}
$type ||= 'text/html' unless defined($type);
+ $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/ and $charset ne '';
# Maybe future compatibility. Maybe not.
my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
+ push(@header,"Server: " . &server_software()) if $nph;
push(@header,"Status: $status") if $status;
push(@header,"Window-Target: $target") if $target;
+ if ($p3p) {
+ $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
+ push(@header,qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p"));
+ }
# push all the cookies -- there may be several
if ($cookie) {
my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
# uses OUR clock)
push(@header,"Expires: " . expires($expires,'http'))
if $expires;
- push(@header,"Date: " . expires(0,'http')) if $expires || $cookie;
+ push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
push(@header,"Pragma: no-cache") if $self->cache();
- push(@header,@other);
+ push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
+ push(@header,map {ucfirst $_} @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 '';
+ $self->r->send_cgi_header($header);
+ return '';
}
return $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($url,$target,$status,$cookie,$nph,@other) =
+ rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p);
+ $status = '302 Moved' unless defined $status;
+ $url ||= $self->self_url;
my(@o);
foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
unshift(@o,
- '-Status'=>'302 Moved',
- '-Location'=>$url,
- '-nph'=>$nph);
+ '-Status' => $status,
+ '-Location'=> $url,
+ '-nph' => $nph);
unshift(@o,'-Target'=>$target) if $target;
- unshift(@o,'-Cookie'=>$cookie) if $cookie;
unshift(@o,'-Type'=>'');
- return $self->header(@o);
+ my @unescaped;
+ unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
+ return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
}
END_OF_FUNC
# $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
+# $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.
+# 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);
+ my($title,$author,$base,$xbase,$script,$noscript,
+ $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) =
+ rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,
+ META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p);
+
+ $self->element_id(0);
+ $self->element_tab(0);
+
+ $encoding = 'iso-8859-1' unless defined $encoding;
+
+ # Need to sort out the DTD before it's okay to call escapeHTML().
+ my(@result,$xml_dtd);
+ if ($dtd) {
+ if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
+ $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
+ } else {
+ $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
+ }
+ } else {
+ $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
+ }
+
+ $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
+ $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
+ push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml;
- # strangely enough, the title needs to be escaped as HTML
- # while the author needs to be escaped as a URL
+ if (ref($dtd) && ref($dtd) eq 'ARRAY') {
+ push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
+ $DTD_PUBLIC_IDENTIFIER = $dtd->[0];
+ } else {
+ push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
+ $DTD_PUBLIC_IDENTIFIER = $dtd;
+ }
+
+ # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
+ # call escapeHTML(). 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 ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2)/i) {
+ $lang = "" unless defined $lang;
+ $XHTML = 0;
+ }
+ else {
+ $lang = 'en-US' unless defined $lang;
+ }
+
+ my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : '';
+ my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />)
+ if $XHTML && $encoding && !$declare_xml;
+
+ push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>)
+ : ($lang ? qq(<html lang="$lang">) : "<html>")
+ . "<head><title>$title</title>");
+ if (defined $author) {
+ push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
+ : "<link rev=\"made\" href=\"mailto:$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>/);
+ my $t = $target ? qq/ target="$target"/ : '';
+ push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
}
if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
- foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
+ foreach (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
+ : 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->_style($style)) if defined $style;
push(@result,$self->_script($script)) if defined $script;
+ push(@result,$meta_bits) if defined $meta_bits;
# handle -noscript parameter
push(@result,<<END) if $noscript;
-<NOSCRIPT>
+<noscript>
$noscript
-</NOSCRIPT>
+</noscript>
END
;
my($other) = @other ? " @other" : '';
- push(@result,"</HEAD><BODY$other>");
+ push(@result,"</head>\n<body$other>\n");
return join("\n",@result);
}
END_OF_FUNC
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-->"));
+
+ my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
+ my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
+
+ my @s = ref($style) eq 'ARRAY' ? @$style : $style;
+
+ for my $s (@s) {
+ if (ref($s)) {
+ my($src,$code,$verbatim,$stype,$foo,@other) =
+ rearrange([qw(SRC CODE VERBATIM TYPE FOO)],
+ ('-foo'=>'bar',
+ ref($s) eq 'ARRAY' ? @$s : %$s));
+ $type = $stype if $stype;
+ my $other = @other ? join ' ',@other : '';
+
+ if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
+ { # If it is, push a LINK tag for each one
+ foreach $src (@$src)
+ {
+ push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
+ : qq(<link rel="stylesheet" type="$type" href="$src"$other>)) if $src;
+ }
+ }
+ else
+ { # Otherwise, push the single -src, if it exists.
+ push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
+ : qq(<link rel="stylesheet" type="$type" href="$src"$other>)
+ ) if $src;
+ }
+ if ($verbatim) {
+ my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim;
+ push(@result, "<style type=\"text/css\">\n$_\n</style>") foreach @v;
+ }
+ my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code;
+ push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) foreach @c;
+
+ } else {
+ my $src = $s;
+ push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
+ : qq(<link rel="stylesheet" type="$type" href="$src"$other>));
+ }
}
@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],
+ ($src,$code,$language, $type) =
+ rearrange([SRC,CODE,LANGUAGE,TYPE],
'-foo'=>'bar', # a trick to allow the '-' to be omitted
ref($script) eq 'ARRAY' ? @$script : %$script);
-
+ # User may not have specified language
+ $language ||= 'JavaScript';
+ unless (defined $type) {
+ $type = lc $language;
+ # strip '1.2' from 'javascript1.2'
+ $type =~ s/^(\D+).*$/text\/$1/;
+ }
} else {
- ($src,$code,$language) = ('',$script,'JavaScript');
+ ($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/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 || ''));
+
+ my $comment = '//'; # javascript by default
+ $comment = '#' if $type=~/perl|tcl/i;
+ $comment = "'" if $type=~/vbscript/i;
+
+ my ($cdata_start,$cdata_end);
+ if ($XHTML) {
+ $cdata_start = "$comment<![CDATA[\n";
+ $cdata_end .= "\n$comment]]>";
+ } else {
+ $cdata_start = "\n<!-- Hide script\n";
+ $cdata_end = $comment;
+ $cdata_end .= " End script hiding -->\n";
+ }
+ my(@satts);
+ push(@satts,'src'=>$src) if $src;
+ push(@satts,'language'=>$language) unless defined $type;
+ push(@satts,'type'=>$type);
+ $code = $cdata_start . $code . $cdata_end if defined $code;
+ push(@result,$self->script({@satts},$code || ''));
}
@result;
}
#### Method: end_html
# End an HTML document.
-# Trivial method for completeness. Just returns "</BODY>"
+# Trivial method for completeness. Just returns "</body>"
####
'end_html' => <<'END_OF_FUNC',
sub end_html {
- return "</BODY></HTML>";
+ return "\n</body>\n</html>";
}
END_OF_FUNC
# Parameters:
# $action -> optional URL of script to run
# Returns:
-# A string containing a <ISINDEX> tag
+# 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($action,@other) = rearrange([ACTION],@p);
+ $action = qq/ action="$action"/ if $action;
my($other) = @other ? " @other" : '';
- return "<ISINDEX $action$other>";
+ return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>";
}
END_OF_FUNC
my($self,@p) = self_or_default(@_);
my($method,$action,$enctype,@other) =
- $self->rearrange([METHOD,ACTION,ENCTYPE],@p);
+ rearrange([METHOD,ACTION,ENCTYPE],@p);
- $method = $method || 'POST';
- $enctype = $enctype || &URL_ENCODED;
- $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
- 'ACTION="'.$self->script_name.'"' : '';
+ $method = $self->escapeHTML(lc($method) || 'post');
+ $enctype = $self->escapeHTML($enctype || &URL_ENCODED);
+ if (defined $action) {
+ $action = $self->escapeHTML($action);
+ }
+ else {
+ $action = $self->escapeHTML($self->url(-absolute=>1,-path=>1));
+ if (exists $ENV{QUERY_STRING} && length($ENV{QUERY_STRING})>0) {
+ $action .= "?".$self->escapeHTML($ENV{QUERY_STRING},1);
+ }
+ }
+ $action = qq(action="$action");
my($other) = @other ? " @other" : '';
$self->{'.parametersToAdd'}={};
- return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
+ return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
}
END_OF_FUNC
# synonym for startform
'start_form' => <<'END_OF_FUNC',
sub start_form {
- &startform;
+ $XHTML ? &start_multipart_form : &startform;
}
END_OF_FUNC
'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 '-')) {
+ if (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);
+ rearrange([METHOD,ACTION],@p);
return $self->startform($method,$action,&MULTIPART,@other);
}
}
'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;
+ if ( $NOSTICKY ) {
+ return wantarray ? ("</form>") : "\n</form>";
+ } else {
+ return wantarray ? ("<div>",$self->get_fields,"</div>","</form>") :
+ "<div>".$self->get_fields ."</div>\n</form>";
+ }
}
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($name,$default,$size,$maxlength,$override,$tabindex,@other) =
+ rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p);
my $current = $override ? $default :
(defined($self->param($name)) ? $self->param($name) : $default);
- $current = defined($current) ? $self->escapeHTML($current) : '';
+ $current = defined($current) ? $self->escapeHTML($current,1) : '';
$name = defined($name) ? $self->escapeHTML($name) : '';
- my($s) = defined($size) ? qq/ SIZE=$size/ : '';
- my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
+ 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>/;
+ my($value) = $current ne '' ? qq(value="$current") : '';
+ $tabindex = $self->element_tab($tabindex);
+ return $XHTML ? qq(<input type="$tag" name="$name" tabindex="$tabindex" $value$s$m$other />)
+ : qq(<input type="$tag" name="$name" $value$s$m$other>);
}
END_OF_FUNC
# $size -> Optional width of field in characaters.
# $maxlength -> Optional maximum number of characters.
# Returns:
-# A string containing a <INPUT TYPE="text"> field
+# A string containing a <input type="text"> field
#
'textfield' => <<'END_OF_FUNC',
sub textfield {
# $size -> Optional width of field in characaters.
# $maxlength -> Optional maximum number of characters.
# Returns:
-# A string containing a <INPUT TYPE="text"> field
+# A string containing a <input type="file"> field
#
'filefield' => <<'END_OF_FUNC',
sub filefield {
# $size -> Optional width of field in characters.
# $maxlength -> Optional maximum characters that can be entered.
# Returns:
-# A string containing a <INPUT TYPE="password"> field
+# A string containing a <input type="password"> field
#
'password_field' => <<'END_OF_FUNC',
sub password_field {
# $rows -> Optional number of rows in text area
# $columns -> Optional number of columns in text area
# Returns:
-# A string containing a <TEXTAREA></TEXTAREA> tag
+# 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($name,$default,$rows,$cols,$override,$tabindex,@other) =
+ rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@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($r) = $rows ? qq/ rows="$rows"/ : '';
+ my($c) = $cols ? qq/ cols="$cols"/ : '';
my($other) = @other ? " @other" : '';
- return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
+ $tabindex = $self->element_tab($tabindex);
+ return qq{<textarea name="$name" tabindex="$tabindex"$r$c$other>$current</textarea>};
}
END_OF_FUNC
# $onclick -> (optional) Text of the JavaScript to run when the button is
# clicked.
# Returns:
-# A string containing a <INPUT TYPE="button"> tag
+# 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);
+ my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],
+ [ONCLICK,SCRIPT],TABINDEX],@p);
$label=$self->escapeHTML($label);
- $value=$self->escapeHTML($value);
+ $value=$self->escapeHTML($value,1);
$script=$self->escapeHTML($script);
my($name) = '';
- $name = qq/ NAME="$label"/ if $label;
+ $name = qq/ name="$label"/ if $label;
$value = $value || $label;
my($val) = '';
- $val = qq/ VALUE="$value"/ if $value;
- $script = qq/ ONCLICK="$script"/ if $script;
+ $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>/;
+ $tabindex = $self->element_tab($tabindex);
+ return $XHTML ? qq(<input type="button" tabindex="$tabindex"$name$val$script$other />)
+ : qq(<input type="button"$name$val$script$other>);
}
END_OF_FUNC
# $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
+# 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);
+ my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p);
$label=$self->escapeHTML($label);
- $value=$self->escapeHTML($value);
+ $value=$self->escapeHTML($value,1);
- my($name) = ' NAME=".submit"';
- $name = qq/ NAME="$label"/ if defined($label);
+ my $name = $NOSTICKY ? '' : ' name=".submit"';
+ $name = qq/ name="$label"/ if defined($label);
$value = defined($value) ? $value : $label;
- my($val) = '';
- $val = qq/ VALUE="$value"/ if defined($value);
+ my $val = '';
+ $val = qq/ value="$value"/ if defined($value);
+ $tabindex = $self->element_tab($tabindex);
my($other) = @other ? " @other" : '';
- return qq/<INPUT TYPE="submit"$name$val$other>/;
+ return $XHTML ? qq(<input type="submit" tabindex="$tabindex"$name$val$other />)
+ : qq(<input type="submit"$name$val$other>);
}
END_OF_FUNC
# Parameters:
# $name -> (optional) Name for the button.
# Returns:
-# A string containing a <INPUT TYPE="reset"> tag
+# 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);
+ my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p);
$label=$self->escapeHTML($label);
- my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
+ $value=$self->escapeHTML($value,1);
+ my ($name) = ' name=".reset"';
+ $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="reset"$value$other>/;
+ $tabindex = $self->element_tab($tabindex);
+ return $XHTML ? qq(<input type="reset" tabindex="$tabindex"$name$val$other />)
+ : qq(<input type="reset"$name$val$other>);
}
END_OF_FUNC
# Parameters:
# $name -> (optional) Name for the button.
# Returns:
-# A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
+# 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
sub defaults {
my($self,@p) = self_or_default(@_);
- my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
+ my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p);
- $label=$self->escapeHTML($label);
+ $label=$self->escapeHTML($label,1);
$label = $label || "Defaults";
- my($value) = qq/ VALUE="$label"/;
+ my($value) = qq/ value="$label"/;
my($other) = @other ? " @other" : '';
- return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
+ $tabindex = $self->element_tab($tabindex);
+ return $XHTML ? qq(<input type="submit" name=".defaults" tabindex="$tabindex"$value$other />)
+ : qq/<input type="submit" NAME=".defaults"$value$other>/;
}
END_OF_FUNC
# $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
+# 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);
-
+ my($name,$checked,$value,$label,$override,$tabindex,@other) =
+ rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE],TABINDEX],@p);
+
$value = defined $value ? $value : 'on';
if (!$override && ($self->{'.fieldnames'}->{$name} ||
defined $self->param($name))) {
- $checked = grep($_ eq $value,$self->param($name)) ? ' CHECKED' : '';
+ $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
} else {
- $checked = $checked ? ' CHECKED' : '';
+ $checked = $self->_checked($checked);
}
my($the_label) = defined $label ? $label : $name;
$name = $self->escapeHTML($name);
- $value = $self->escapeHTML($value);
+ $value = $self->escapeHTML($value,1);
$the_label = $self->escapeHTML($the_label);
my($other) = @other ? " @other" : '';
+ $tabindex = $self->element_tab($tabindex);
$self->register_parameter($name);
- return qq{<INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label};
+ return $XHTML ? CGI::label(qq{<input type="checkbox" name="$name" value="$value" tabindex="$tabindex"$checked$other />$the_label})
+ : 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/&/&/g;
- $toencode=~s/\"/"/g;
- $toencode=~s/>/>/g;
- $toencode=~s/</</g;
- return $toencode;
+ # hack to work around earlier hacks
+ push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
+ my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
+ return undef unless defined($toencode);
+ return $toencode if ref($self) && !$self->{'escape'};
+ $toencode =~ s{&}{&}gso;
+ $toencode =~ s{<}{<}gso;
+ $toencode =~ s{>}{>}gso;
+ if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
+ # $quot; was accidentally omitted from the HTML 3.2 DTD -- see
+ # <http://validator.w3.org/docs/errors.html#bad-entity> /
+ # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
+ $toencode =~ s{"}{"}gso;
+ }
+ else {
+ $toencode =~ s{"}{"}gso;
+ }
+ my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' ||
+ uc $self->{'.charset'} eq 'WINDOWS-1252';
+ if ($latin) { # bug in some browsers
+ $toencode =~ s{'}{'}gso;
+ $toencode =~ s{\x8b}{‹}gso;
+ $toencode =~ s{\x9b}{›}gso;
+ if (defined $newlinestoo && $newlinestoo) {
+ $toencode =~ s{\012}{ }gso;
+ $toencode =~ s{\015}{ }gso;
+ }
+ }
+ return $toencode;
}
END_OF_FUNC
# unescape HTML -- used internally
'unescapeHTML' => <<'END_OF_FUNC',
sub unescapeHTML {
- my $string = ref($_[0]) ? $_[1] : $_[0];
+ # hack to work around earlier hacks
+ push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
+ my ($self,$string) = CGI::self_or_default(@_);
return undef unless defined($string);
+ my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
+ : 1;
# thanks to Randal Schwartz for the correct solution to this one
$string=~ s[&(.*?);]{
local $_ = $1;
/^quot$/i ? '"' :
/^gt$/i ? ">" :
/^lt$/i ? "<" :
- /^#(\d+)$/ ? chr($1) :
- /^#x([0-9a-f]+)$/i ? chr(hex($1)) :
+ /^#(\d+)$/ && $latin ? chr($1) :
+ /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
$_
}gex;
return $string;
'_tableize' => <<'END_OF_FUNC',
sub _tableize {
my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
+ my @rowheaders = $rowheaders ? @$rowheaders : ();
+ my @colheaders = $colheaders ? @$colheaders : ();
my($result);
if (defined($columns)) {
if (defined($rows)) {
$columns = int(0.99 + @elements/$rows) unless defined($columns);
}
-
+
# rearrange into a pretty table
- $result = "<TABLE>";
+ $result = "<table>";
my($row,$column);
- unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
- $result .= "<TR>" if @$colheaders;
- foreach (@{$colheaders}) {
- $result .= "<TH>$_</TH>";
+ 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;
+ $result .= "<tr>";
+ $result .= "<th>$rowheaders[$row]</th>" if @rowheaders;
for ($column=0;$column<$columns;$column++) {
- $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>"
+ $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
if defined($elements[$column*$rows + $row]);
}
- $result .= "</TR>";
+ $result .= "</tr>";
}
- $result .= "</TABLE>";
+ $result .= "</table>";
return $result;
}
END_OF_FUNC
# 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
+# An ARRAY containing a series of <input type="radio"> fields
####
'radio_group' => <<'END_OF_FUNC',
sub radio_group {
my($self,@p) = self_or_default(@_);
+ $self->_box_group('radio',@p);
+}
+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(@_);
+ $self->_box_group('checkbox',@p);
+}
+END_OF_FUNC
- 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);
+'_box_group' => <<'END_OF_FUNC',
+sub _box_group {
+ my $self = shift;
+ my $box_type = shift;
+
+ my($name,$values,$defaults,$linebreak,$labels,$attributes,
+ $rows,$columns,$rowheaders,$colheaders,
+ $override,$nolabels,$tabindex,@other) =
+ rearrange([ NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,ATTRIBUTES,
+ ROWS,[COLUMNS,COLS],ROWHEADERS,COLHEADERS,
+ [OVERRIDE,FORCE],NOLABELS,TABINDEX
+ ],@_);
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);
+ my %checked = $self->previous_or_default($name,$defaults,$override);
# If no check array is specified, check the first by default
- $checked = $values[0] unless defined($checked) && $checked ne '';
+ $checked{$values[0]}++ if $box_type eq 'radio' && !%checked;
+
$name=$self->escapeHTML($name);
- my($other) = @other ? " @other" : '';
+ my %tabs = ();
+ if ($tabindex) {
+ if (!ref $tabindex) {
+ $self->element_tab($tabindex);
+ } elsif (ref $tabindex eq 'ARRAY') {
+ %tabs = map {$_=>$self->element_tab} @$tabindex;
+ } elsif (ref $tabindex eq 'HASH') {
+ %tabs = %$tabindex;
+ }
+ }
+ %tabs = map {$_=>$self->element_tab} @values unless %tabs;
+
+ my $other = @other ? " @other" : '';
+ my $radio_checked;
foreach (@values) {
- my($checkit) = $checked eq $_ ? ' CHECKED' : '';
- my($break) = $linebreak ? '<BR>' : '';
+ my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
+ : $checked{$_});
+ my($break);
+ if ($linebreak) {
+ $break = $XHTML ? "<br />" : "<br>";
+ }
+ else {
+ $break = '';
+ }
my($label)='';
unless (defined($nolabels) && $nolabels) {
$label = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- $label = $self->escapeHTML($label);
+ $label = $self->escapeHTML($label,1);
}
+ my $attribs = $self->_set_attributes($_, $attributes);
+ my $tab = qq( tabindex="$tabs{$_}") if exists $tabs{$_};
$_=$self->escapeHTML($_);
- push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label}${break}/);
+ if ($XHTML) {
+ push @elements,
+ CGI::label(
+ qq(<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs />$label)).${break};
+ } else {
+ push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs>${label}${break}/);
+ }
}
$self->register_parameter($name);
- return wantarray ? @elements : join(' ',@elements)
+ return wantarray ? @elements : "@elements"
unless defined($columns) || defined($rows);
return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
}
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($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) =
+ rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
+ ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
my($result,$selected);
if (!$override && defined($self->param($name))) {
my(@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
-
- $result = qq/<SELECT NAME="$name"$other>\n/;
+ $tabindex = $self->element_tab($tabindex);
+ $result = qq/<select name="$name" tabindex="$tabindex"$other>\n/;
foreach (@values) {
- my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
+ if (/<optgroup/) {
+ foreach (split(/\n/)) {
+ my $selectit = $XHTML ? 'selected="selected"' : 'selected';
+ s/(value="$selected")/$selectit $1/ if defined $selected;
+ $result .= "$_\n";
+ }
+ }
+ else {
+ my $attribs = $self->_set_attributes($_, $attributes);
+ my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : '';
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
my($value) = $self->escapeHTML($_);
- $label=$self->escapeHTML($label);
- $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
+ $label=$self->escapeHTML($label,1);
+ $result .= "<option$selectit$attribs value=\"$value\">$label</option>\n";
+ }
}
- $result .= "</SELECT>\n";
+ $result .= "</select>";
+ return $result;
+}
+END_OF_FUNC
+
+
+#### Method: optgroup
+# Create a optgroup.
+# Parameters:
+# $name -> Label for the group
+# $values -> A pointer to a regular array containing the
+# values for each option line in the group.
+# $labels -> (optional)
+# A pointer to an associative array of labels to print next to each item
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# $labeled -> (optional)
+# A true value indicates the value should be used as the label attribute
+# in the option elements.
+# The label attribute specifies the option label presented to the user.
+# This defaults to the content of the <option> element, but the label
+# attribute allows authors to more easily use optgroup without sacrificing
+# compatibility with browsers that do not support option groups.
+# $novals -> (optional)
+# A true value indicates to suppress the val attribute in the option elements
+# Returns:
+# A string containing the definition of an option group.
+####
+'optgroup' => <<'END_OF_FUNC',
+sub optgroup {
+ my($self,@p) = self_or_default(@_);
+ my($name,$values,$attributes,$labeled,$noval,$labels,@other)
+ = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p);
+
+ my($result,@values);
+ @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
+ my($other) = @other ? " @other" : '';
+
+ $name=$self->escapeHTML($name);
+ $result = qq/<optgroup label="$name"$other>\n/;
+ foreach (@values) {
+ if (/<optgroup/) {
+ foreach (split(/\n/)) {
+ my $selectit = $XHTML ? 'selected="selected"' : 'selected';
+ s/(value="$selected")/$selectit $1/ if defined $selected;
+ $result .= "$_\n";
+ }
+ }
+ else {
+ my $attribs = $self->_set_attributes($_, $attributes);
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ $label=$self->escapeHTML($label);
+ my($value)=$self->escapeHTML($_,1);
+ $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
+ : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
+ : $novals ? "<option$attribs>$label</option>\n"
+ : "<option$attribs value=\"$value\">$label</option>\n";
+ }
+ }
+ $result .= "</optgroup>";
return $result;
}
END_OF_FUNC
'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($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other)
+ = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
+ SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@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($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
+ my($has_size) = $size ? qq/ size="$size"/: '';
my($other) = @other ? " @other" : '';
$name=$self->escapeHTML($name);
- $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
+ $tabindex = $self->element_tab($tabindex);
+ $result = qq/<select name="$name" tabindex="$tabindex"$has_size$is_multiple$other>\n/;
foreach (@values) {
- my($selectit) = $selected{$_} ? 'SELECTED' : '';
+ my($selectit) = $self->_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";
+ my($value)=$self->escapeHTML($_,1);
+ my $attribs = $self->_set_attributes($_, $attributes);
+ $result .= "<option$selectit$attribs value=\"$value\">$label</option>\n";
}
- $result .= "</SELECT>\n";
+ $result .= "</select>";
$self->register_parameter($name);
return $result;
}
# or
# $default->[initial values of field]
# Returns:
-# A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
+# A string containing a <input type="hidden" name="name" value="value">
####
'hidden' => <<'END_OF_FUNC',
sub hidden {
# 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);
+ 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 ) {
+ if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
@value = ref($default) ? @{$default} : $default;
$do_override = $override;
} else {
$name=$self->escapeHTML($name);
foreach (@value) {
- $_ = defined($_) ? $self->escapeHTML($_) : '';
- push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
+ $_ = defined($_) ? $self->escapeHTML($_,1) : '';
+ push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
+ : qq(<input type="hidden" name="$name" value="$_" @other>);
}
return wantarray ? @result : join('',@result);
}
# $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">
+# 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);
+ rearrange([NAME,SRC,ALIGN],@p);
- my($align) = $alignment ? " ALIGN=\U$alignment" : '';
+ 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>/;
+ return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
+ : qq/<input type="image" name="$name" src="$src"$align$other>/;
}
END_OF_FUNC
'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 ($relative,$absolute,$full,$path_info,$query,$base) =
+ rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE'],@p);
my $url;
- $full++ if !($relative || $absolute);
+ $full++ if $base || !($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;
- }
+ my $script_name = $self->script_name;
if ($full) {
my $protocol = $self->protocol();
$url = "$protocol://";
- my $vh = http('host');
+ my $vh = http('x_forwarded_host') || http('host');
if ($vh) {
$url .= $vh;
} else {
$url .= server_name();
my $port = $self->server_port;
$url .= ":" . $port
- unless (lc($protocol) eq 'http' && $port == 80)
+ unless (lc($protocol) eq 'http' && $port == 80)
|| (lc($protocol) eq 'https' && $port == 443);
}
+ return $url if $base;
$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;
+ $url = '' unless defined $url;
+ $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
return $url;
}
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);
+ rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
require CGI::Cookie;
}
# If we get here, we're creating a new cookie
- return undef unless $name; # this is an error
+ return undef unless defined($name) && $name ne ''; # this is an error
my @param;
push(@param,'-name'=>$name);
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);
+ return new CGI::Cookie(@param);
}
END_OF_FUNC
'param_fetch' => <<'END_OF_FUNC',
sub param_fetch {
my($self,@p) = self_or_default(@_);
- my($name) = $self->rearrange([NAME],@p);
+ my($name) = rearrange([NAME],@p);
unless (exists($self->{$name})) {
$self->add_parameter($name);
$self->{$name} = [];
$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'} : '';
-
+ my (undef,$path_info) = $self->_name_and_path_from_env;
+ $self->{'.path_info'} = $path_info || '';
# hack to fix broken path info in IIS
$self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
}
END_OF_FUNC
+# WE USE THIS TO COMPENSATE FOR A BUG IN APACHE 2 PRESENT AT LEAST UP THROUGH 2.0.54
+'_name_and_path_from_env' => <<'END_OF_FUNC',
+sub _name_and_path_from_env {
+ my $self = shift;
+ my $raw_script_name = $ENV{SCRIPT_NAME} || '';
+ my $raw_path_info = $ENV{PATH_INFO} || '';
+ my $uri = $ENV{REQUEST_URI} || '';
+
+ my @uri_double_slashes = $uri =~ m^(/{2,}?)^g;
+ my @path_double_slashes = "$raw_script_name $raw_path_info" =~ m^(/{2,}?)^g;
+
+ my $apache_bug = @uri_double_slashes != @path_double_slashes;
+ return ($raw_script_name,$raw_path_info) unless $apache_bug;
+
+ my $path_info_search = $raw_path_info;
+ # these characters will not (necessarily) be escaped
+ $path_info_search =~ s/([^a-zA-Z0-9$()':_.,+*\/;?=&-])/uc sprintf("%%%02x",ord($1))/eg;
+ $path_info_search = quotemeta($path_info_search);
+ $path_info_search =~ s!/!/+!g;
+ if ($uri =~ m/^(.+)($path_info_search)/) {
+ return ($1,$2);
+ } else {
+ return ($raw_script_name,$raw_path_info);
+ }
+}
+END_OF_FUNC
+
#### Method: request_method
# Returns 'POST', 'GET', 'PUT' or 'HEAD'
END_OF_FUNC
+#### Method: request_uri
+# Return the literal request URI
+####
+'request_uri' => <<'END_OF_FUNC',
+sub request_uri {
+ return $ENV{'REQUEST_URI'};
+}
+END_OF_FUNC
+
+
#### Method: query_string
# Synthesize a query string from our current
# parameters
push(@pairs,"$eparam=$value");
}
}
+ foreach (keys %{$self->{'.fieldnames'}}) {
+ push(@pairs,".cgifields=".escape("$_"));
+ }
return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
}
END_OF_FUNC
######
'virtual_host' => <<'END_OF_FUNC',
sub virtual_host {
- my $vh = http('host') || server_name();
+ my $vh = http('x_forwarded_host') || http('host') || server_name();
$vh =~ s/:\d+$//; # get rid of port number
return $vh;
}
####
'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;
+ my ($self,@p) = self_or_default(@_);
+ if (@p) {
+ $self->{'.script_name'} = shift;
+ } elsif (!exists $self->{'.script_name'}) {
+ my ($script_name,$path_info) = $self->_name_and_path_from_env();
+ $self->{'.script_name'} = $script_name;
+ }
+ return $self->{'.script_name'};
}
END_OF_FUNC
}
END_OF_FUNC
+#### Method: virtual_port
+# Return the server port, taking virtual hosts into account
+####
+'virtual_port' => <<'END_OF_FUNC',
+sub virtual_port {
+ my($self) = self_or_default(@_);
+ my $vh = $self->http('x_forwarded_host') || $self->http('host');
+ if ($vh) {
+ return ($vh =~ /:(\d+)$/)[0] || '80';
+ } else {
+ return $self->server_port();
+ }
+}
+END_OF_FUNC
+
#### Method: server_port
# Return the tcp/ip port the server is running on
####
}
END_OF_FUNC
+#### Method: nosticky
+# Set or return the NOSTICKY global flag
+####
+'nosticky' => <<'END_OF_FUNC',
+sub nosticky {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::NOSTICKY = $param if defined($param);
+ return $CGI::NOSTICKY;
+}
+END_OF_FUNC
+
#### Method: nph
# Set or return the NPH global flag
####
return $CGI::PRIVATE_TEMPFILES;
}
END_OF_FUNC
+#### Method: close_upload_files
+# Set or return the close_upload_files global flag
+####
+'close_upload_files' => <<'END_OF_FUNC',
+sub close_upload_files {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::CLOSE_UPLOAD_FILES = $param if defined($param);
+ return $CGI::CLOSE_UPLOAD_FILES;
+}
+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);
+ my ($self,$param,$param2) = self_or_CGI(@_);
+ if (defined $param2 && defined $param) {
+ $CGI::DEFAULT_DTD = [ $param, $param2 ];
+ } elsif (defined $param) {
+ $CGI::DEFAULT_DTD = $param;
+ }
return $CGI::DEFAULT_DTD;
}
END_OF_FUNC
sub read_from_cmdline {
my($input,@words);
my($query_string);
- if (@ARGV) {
+ my($subpath);
+ if ($DEBUG && @ARGV) {
@words = @ARGV;
- } else {
+ } elsif ($DEBUG > 1) {
require "shellwords.pl";
- print STDERR "(offline mode: enter name=value pairs on standard input)\n";
+ print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n";
chomp(@lines = <STDIN>); # remove newlines
$input = join(" ",@lines);
@words = &shellwords($input);
} else {
$query_string = join('+',@words);
}
- return $query_string;
+ if ($query_string =~ /^(.*?)\?(.*)$/)
+ {
+ $query_string = $2;
+ $subpath = $1;
+ }
+ return { 'query_string' => $query_string, 'subpath' => $subpath };
}
END_OF_FUNC
#####
'read_multipart' => <<'END_OF_FUNC',
sub read_multipart {
- my($self,$boundary,$length,$filehandle) = @_;
- my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle);
+ my($self,$boundary,$length) = @_;
+ my($buffer) = $self->new_MultipartBuffer($boundary,$length);
return unless $buffer;
my(%header,$body);
my $filenumber = 0;
return;
}
- my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
+ my($param)= $header{'Content-Disposition'}=~/ name="([^;]*)"/;
+ $param .= $TAINTED;
# Bug: Netscape doesn't escape quotation marks in file names!!!
- my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/;
+ my($filename) = $header{'Content-Disposition'}=~/ filename="([^;]*)"/;
+ # Test for Opera's multiple upload feature
+ my($multipart) = ( defined( $header{'Content-Type'} ) &&
+ $header{'Content-Type'} =~ /multipart\/mixed/ ) ?
+ 1 : 0;
# 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 '' ) {
+ if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
my($value) = $buffer->readBody;
+ $value .= $TAINTED;
push(@{$self->{$param}},$value);
next;
}
last UPLOADS;
}
+ # set the filename to some recognizable value
+ if ( ( !defined($filename) || $filename eq '' ) && $multipart ) {
+ $filename = "multipart/mixed";
+ }
+
# choose a relatively unpredictable tmpfile sequence number
- my $seqno = unpack("%16C*",join('',localtime,values %ENV));
+ my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
for (my $cnt=10;$cnt>0;$cnt--) {
- next unless $tmpfile = new TempFile($seqno);
+ next unless $tmpfile = new CGITempFile($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;
+ die "CGI open of tmpfile: $!\n" unless defined $filehandle;
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
+ && defined fileno($filehandle);
+
+ # if this is an multipart/mixed attachment, save the header
+ # together with the body for later parsing with an external
+ # MIME parser module
+ if ( $multipart ) {
+ foreach ( keys %header ) {
+ print $filehandle "$_: $header{$_}${CRLF}";
+ }
+ print $filehandle "${CRLF}";
+ }
my ($data);
local($\) = '';
- while (defined($data = $buffer->read)) {
+ my $totalbytes;
+ while (defined($data = $buffer->read)) {
+ if (defined $self->{'.upload_hook'})
+ {
+ $totalbytes += length($data);
+ &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
+ }
print $filehandle $data;
- }
+ }
# back up to beginning of file
seek($filehandle,0,0);
+
+ ## Close the filehandle if requested this allows a multipart MIME
+ ## upload to contain many files, and we won't die due to too many
+ ## open file handles. The user can access the files using the hash
+ ## below.
+ close $filehandle if $CLOSE_UPLOAD_FILES;
$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)}= {
+ hndl => $filehandle,
name => $tmpfile,
info => {%header},
};
'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;
+ my @param = grep(ref && fileno($_), $self->param($param_name));
+ return unless @param;
+ return wantarray ? @param : $param[0];
}
END_OF_FUNC
}
END_OF_FUNC
+# internal routine, don't use
+'_set_attributes' => <<'END_OF_FUNC',
+sub _set_attributes {
+ my $self = shift;
+ my($element, $attributes) = @_;
+ return '' unless defined($attributes->{$element});
+ $attribs = ' ';
+ foreach my $attrib (keys %{$attributes->{$element}}) {
+ (my $clean_attrib = $attrib) =~ s/^-//;
+ $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" ";
+ }
+ $attribs =~ s/ $//;
+ return $attribs;
+}
+END_OF_FUNC
+
'_compile_all' => <<'END_OF_FUNC',
sub _compile_all {
foreach (@_) {
*Fh::AUTOLOAD = \&CGI::AUTOLOAD;
+sub DESTROY {
+ my $self = shift;
+ close $self;
+}
+
$AUTOLOADED_ROUTINES = ''; # prevent -w error
$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
%SUBS = (
my $self = shift;
# get rid of package name
(my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
- $i =~ s/\\(.)/$1/g;
- return $i;
+ $i =~ s/%(..)/ chr(hex($1)) /eg;
+ return $i.$CGI::TAINTED;
# 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.
'new' => <<'END_OF_FUNC',
sub new {
my($pack,$name,$file,$delete) = @_;
+ _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
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};
+ (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
+ my $fv = ++$FH . $safename;
+ my $ref = \*{"Fh::$fv"};
+ $file =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
+ my $safe = $1;
+ sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
+ unlink($safe) if $delete;
+ CORE::delete $Fh::{$fv};
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;
+use constant DEBUG => 0;
+
# how many bytes to read at a time. We use
# a 4K buffer by default.
$INITIAL_FILLUNIT = 1024 * 4;
'new' => <<'END_OF_FUNC',
sub new {
- my($package,$interface,$boundary,$length,$filehandle) = @_;
+ my($package,$interface,$boundary,$length) = @_;
$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; # just do it always
- $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
# Netscape seems to be a little bit unreliable
# about providing boundary strings.
+ my $boundary_read = 0;
if ($boundary) {
# Under the MIME spec, the boundary consists of the
# 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');
+ $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport');
} 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
+ $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl
$length -= length($boundary);
chomp($boundary); # remove the CRLF
$/ = $old; # restore old line separator
+ $boundary_read++;
}
my $self = {LENGTH=>$length,
+ CHUNKED=>!defined $length,
BOUNDARY=>$boundary,
- IN=>$IN,
INTERFACE=>$interface,
BUFFER=>'',
};
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;
+ unless ($boundary_read) {
+ while ($self->read(0)) { }
+ }
+ die "Malformed multipart POST: data truncated\n" if $self->eof;
return $retval;
}
my($ok) = 0;
my($bad) = 0;
- if ($CGI::OS eq 'VMS') { # tssk, tssk: inconsistency alert!
- local($CRLF) = "\015\012";
- }
+ local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC;
do {
$self->fillBuffer($FILLUNIT);
} until $ok || $bad;
return () if $bad;
+ #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines!
+
my($header) = substr($self->{BUFFER},0,$end+2);
substr($self->{BUFFER},0,$end+4) = '';
my %return;
-
+ if ($CGI::EBCDIC) {
+ warn "untranslated header=$header\n" if DEBUG;
+ $header = CGI::Util::ascii2ebcdic($header);
+ warn "translated header=$header\n" if DEBUG;
+ }
+
# 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
+ my ($field_name,$field_value) = ($1,$2);
$field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
$return{$field_name}=$field_value;
}
my($self) = @_;
my($data);
my($returnval)='';
+
+ #EBCDIC NOTE: want to translate returnval into EBCDIC HERE
+
while (defined($data = $self->read)) {
$returnval .= $data;
}
+
+ if ($CGI::EBCDIC) {
+ warn "untranslated body=$returnval\n" if DEBUG;
+ $returnval = CGI::Util::ascii2ebcdic($returnval);
+ warn "translated body=$returnval\n" if DEBUG;
+ }
return $returnval;
}
END_OF_FUNC
my($self,$bytes) = @_;
# default number of bytes to read
- $bytes = $bytes || $FILLUNIT;
+ $bytes = $bytes || $FILLUNIT;
# Fill up our internal buffer in such a way that the boundary
# is never split between reads.
$self->fillBuffer($bytes);
+ my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY};
+ my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--';
+
# Find the boundary in the buffer (it may not be there).
- my $start = index($self->{BUFFER},$self->{BOUNDARY});
+ my $start = index($self->{BUFFER},$boundary_start);
+
+ warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG;
+
# protect against malformed multipart POST operations
- die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
+ die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0);
+
+ #EBCDIC NOTE: want to translate boundary search into ASCII here.
# 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.
+ # and return undef.
if ($start == 0) {
# clear us out completely if we've hit the last boundary.
- if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
+ if (index($self->{BUFFER},$boundary_end)==0) {
$self->{BUFFER}='';
$self->{LENGTH}=0;
return undef;
}
# just remove the boundary.
- substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
+ substr($self->{BUFFER},0,length($boundary_start))='';
+ $self->{BUFFER} =~ s/^\012\015?//;
return undef;
}
- my $bytesToReturn;
+ my $bytesToReturn;
if ($start > 0) { # read up to the boundary
- $bytesToReturn = $start > $bytes ? $bytes : $start;
+ $bytesToReturn = $start-2 > $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);
+ $bytesToReturn = $bytes - (length($boundary_start)+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;
+ return ($bytesToReturn==$start)
+ ? substr($returnval,0,-2) : $returnval;
}
END_OF_FUNC
'fillBuffer' => <<'END_OF_FUNC',
sub fillBuffer {
my($self,$bytes) = @_;
- return unless $self->{LENGTH};
+ return unless $self->{CHUNKED} || $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;
+ $bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $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},
+ # Try to read some data. We may hang here if the browser is screwed up.
+ my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER},
$bytesToRead,
$bufferLength);
+ warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG;
$self->{BUFFER} = '' unless defined $self->{BUFFER};
# An apparent bug in the Apache server causes the read()
# 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) {
+ 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;
+ $self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead;
}
END_OF_FUNC
####################################################################################
################################## TEMPORARY FILES #################################
####################################################################################
-package TempFile;
-
-$SL = $CGI::SL;
-$MAC = $CGI::OS eq 'MACINTOSH';
-my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
-unless ($TMPDIRECTORY) {
+package CGITempFile;
+
+sub find_tempdir {
+ undef $TMPDIRECTORY;
+ $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}WWW_ROOT");
- unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'};
+ "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
+ "C:${SL}system${SL}temp");
+ unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'};
- #
+ # this feature was supposed to provide per-user tmpfiles, but
+ # it is problematic.
# 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';
+ # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
foreach (@TEMP) {
- do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
+ do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
}
+ }
+ $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
}
-$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
+find_tempdir();
+
$MAXTRIES = 5000;
# cute feature, but overload implementation broke it
# %OVERLOAD = ('""'=>'as_string');
-*TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
+*CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD;
+
+sub DESTROY {
+ my($self) = @_;
+ $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
+ my $safe = $1; # untaint operation
+ unlink $safe; # get rid of the file
+}
###############################################################################
################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
sub new {
my($package,$sequence) = @_;
my $filename;
+ find_tempdir() unless -w $TMPDIRECTORY;
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;
+ # check that it is a more-or-less valid filename
+ return unless $filename =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$!;
+ # this used to untaint, now it doesn't
+ # $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) = @_;
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')),
+ my $name = param('name');
+ my $keywords = join ', ',param('words');
+ my $color = param('color');
+ print "Your name is",em(escapeHTML($name)),p,
+ "The keywords are: ",em(escapeHTML($keywords)),p,
+ "Your favorite color is ",em(escapeHTML($color)),
hr;
}
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
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']);
+ $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.
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>
+ 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.
+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
=over 4
-=item 1. Use another name for the argument, if one is available. For
-example, -value is an alias for -values.
+=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 2. Change the capitalization, e.g. -Values
+=item 3.
-=item 3. Put quotes around the argument name, e.g. '-values'
+Put quotes around the argument name, e.g. '-values'
=back
@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'.
+(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 and contains a string without ampersands
+(e.g. "value1+value2+value3") , there will be a single parameter named
+"keywords" containing the "+"-delimited 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.
selections in a scrolling list), you can ask to receive an array. Otherwise
the method will return a single value.
+If a value is not given in the query string, as in the queries
+"name1=&name2=" or "name1&name2", it will be returned as an empty
+string. This feature is new in 2.63.
+
+
+If the parameter does not exist at all, then param() will return undef
+in a scalar context, and the empty list in a list context.
+
+
=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
$query->param('foo','an','array','of','values');
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,
+NOTE 1: Variable names are transformed as necessary into legal Perl
+variable names. All non-legal characters are transformed into
+underscores. If you need to keep the original names, you should use
+the param() method instead to access CGI variables by name.
+
+NOTE 2: 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');
+ $query->delete('foo','bar','baz');
-This completely clears a parameter. It sometimes useful for
-resetting parameters that you don't want passed down between
-script invocations.
+This completely clears a list of parameters. 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.
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
+CGI parameter list. Called in a list 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
+list 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
=head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
- $query->save(FILEHANDLE)
+ $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
foreach (0..$records) {
my $q = new CGI;
$q->param(-name=>'counter',-value=>$_);
- $q->save(OUT);
+ $q->save(\*OUT);
}
close OUT;
# reopen for reading
open (IN,"test.out") || die;
while (!eof(IN)) {
- my $q = new CGI(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.
=item B<:html3>
-Import all methods that generate HTML 3.0 proposed elements (such as
+Import all methods that generate HTML 3.0 elements (such as
<table>, <super> and <sub>).
+=item B<:html4>
+
+Import all methods that generate HTML 4 elements (such as
+<abbrev>, <acronym> and <thead>).
+
=item B<:netscape>
Import all methods that generate Netscape-specific HTML extensions.
=item B<:standard>
-Import "standard" features, 'html2', 'html3', 'form' and 'cgi'.
+Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'.
=item B<:all>
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
+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:
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):
+standard set of functions and enables debugging mode (pragma
+-debug):
- use CGI qw/:standard -no_debug/;
+ use CGI qw/:standard -debug/;
The current list of pragmas is as follows:
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);
+ 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:
+
+ use CGI();
+ CGI->compile();
+
+This is particularly useful in a mod_perl environment, in which you
+might want to precompile all CGI routines in a startup script, and
+then import the functions individually in each mod_perl script.
+
+=item -nosticky
+
+By default the CGI module implements a state-preserving behavior
+called "sticky" fields. The way this works is that if you are
+regenerating a form, the methods that generate the form field values
+will interrogate param() to see if similarly-named parameters are
+present in the query string. If they find a like-named parameter, they
+will use it to set their default values.
+
+Sometimes this isn't what you want. The B<-nosticky> pragma prevents
+this behavior. You can also selectively change the sticky behavior in
+each element that you generate.
+
+=item -no_undef_params
-or even
+This keeps CGI.pm from including undef params in the parameter list.
- use CGI qw(-compile :all);
+=item -no_xhtml
-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).
+By default, CGI.pm versions 2.69 and higher emit XHTML
+(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this
+feature. Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this
+feature.
+
+If start_html()'s -dtd parameter specifies an HTML 2.0 or 3.2 DTD,
+XHTML will automatically be disabled without needing to use this
+pragma.
=item -nph
emitted by self_url() and query_string() unless the -newstyle_urls
pragma is specified.
+This became the default in version 2.64.
+
+=item -oldstyle_urls
+
+Separate the name=value pairs in CGI parameter query strings with
+ampersands rather than semicolons. This is no longer the default.
+
=item -autoload
This overrides the autoloader so that any function in your program
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:
+don't want it to read CGI parameters from the command line or STDIN,
+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:
+=item -debug
+
+This turns on full debugging. In addition to reading CGI arguments
+from the command-line processing, CGI.pm will pause and try to read
+arguments from STDIN, producing the message "(offline mode: enter
+name=value pairs on standard input)" features.
- use CGI qw(-no_debug :standard);
- restore_parameters(join('&',@ARGV));
-
See the section on debugging for more details.
=item -private_tempfiles
produces
- <H1>Level 1 Header</H1>
+ <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>
=over 4
-=item 1. start_table() (generates a <TABLE> tag)
+=item 1. start_table() (generates a <table> tag)
-=item 2. end_table() (generates a </TABLE> tag)
+=item 2. end_table() (generates a </table> tag)
-=item 3. start_ul() (generates a <UL> tag)
+=item 3. start_ul() (generates a <ul> tag)
-=item 4. end_ul() (generates a </UL> tag)
+=item 4. end_ul() (generates a </ul> tag)
=back
manipulated for special purposes, such as server push and pay per view
pages.
- print $query->header;
+ print header;
-or-
- print $query->header('image/gif');
+ print header('image/gif');
-or-
- print $query->header('text/html','204 No response');
+ print header('text/html','204 No response');
-or-
- print $query->header(-type=>'image/gif',
+ print header(-type=>'image/gif',
-nph=>1,
-status=>'402 Payment required',
-expires=>'+3d',
-cookie=>$cookie,
+ -charset=>'utf-7',
+ -attachment=>'foo.gif',
-Cost=>'$2.00');
header() returns the Content-type: header. You can provide your own
header fields, allowing you to specify any HTTP header you desire.
Internal underscores will be turned into hyphens:
- print $query->header(-Content_length=>3002);
+ print 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
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.
+to use with certain servers that expect all their scripts to be NPH.
+
+The B<-charset> parameter can be used to control the character set
+sent to the browser. If not provided, defaults to ISO-8859-1. As a
+side effect, this sets the charset() method as well.
+
+The B<-attachment> parameter can be used to turn the page into an
+attachment. Instead of displaying the page, some browsers will prompt
+the user to save it to disk. The value of the argument is the
+suggested name for the saved file. In order for this to work, you may
+have to set the B<-type> to "application/octet-stream".
+
+The B<-p3p> parameter will add a P3P tag to the outgoing header. The
+parameter can be an arrayref or a space-delimited string of P3P tags.
+For example:
+
+ print header(-p3p=>[qw(CAO DSP LAW CURa)]);
+ print header(-p3p=>'CAO DSP LAW CURa');
+
+In either case, the outgoing header will be formatted as:
+
+ P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"
=head2 GENERATING A REDIRECTION HEADER
- print $query->redirect('http://somewhere.else/in/movie/land');
+ print 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
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.
+well.
-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 should always use full URLs (including the http: or ftp: part) in
+redirection requests. Relative URLs will not work correctly.
You can also use named arguments:
- print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
- -nph=>1);
+ print redirect(-uri=>'http://somewhere.else/in/movie/land',
+ -nph=>1,
+ -status=>301);
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
+to use with certain servers, such as Microsoft IIS, which
expect all their scripts to be NPH.
+The B<-status> parameter will set the status of the redirect. HTTP
+defines three different possible redirection status codes:
+
+ 301 Moved Permanently
+ 302 Found
+ 303 See Other
+
+The default if not specified is 302, which means "moved temporarily."
+You may change the status to another status code if you wish. Be
+advised that changing the status to anything other than 301, 302 or
+303 will probably break redirection.
+
=head2 CREATING THE HTML DOCUMENT HEADER
- print $query->start_html(-title=>'Secrets of the Pyramids',
+ print start_html(-title=>'Secrets of the Pyramids',
-author=>'fred@capricorn.org',
-base=>'true',
-target=>'_blank',
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.
+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.
+parameters are -title, -author, -base, -xbase, -dtd, -lang 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
+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.
+for all the links and fill-out forms on the page. B<This is a
+non-standard HTTP feature which only works with Netscape browsers!>
+See the Netscape documentation on frames for details of how to
+manipulate this.
-target=>"answer_window"
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:
+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">
+ <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:
+To create an HTTP-EQUIV type of <meta> tag, use B<-head>, described
+below.
- print $q->header(-Refresh=>'10; URL=http://www.capricorn.com');
+The B<-style> argument is used to incorporate cascading stylesheets
+into your code. See the section on CASCADING STYLESHEETS for more
+information.
-The B<-style> tag is used to incorporate cascading stylesheets into
-your code. See the section on CASCADING STYLESHEETS for more information.
+The B<-lang> argument is used to incorporate a language attribute into
+the <html> tag. For example:
-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
+ print $q->start_html(-lang=>'fr-CA');
+
+The default if not specified is "en-US" for US English, unless the
+-dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the
+lang attribute is left off. You can force the lang attribute to left
+off in other cases by passing an empty string (-lang=>'').
+
+The B<-encoding> argument can be used to specify the character set for
+XHTML. It defaults to iso-8859-1 if not specified.
+
+The B<-declare_xml> argument, when used in conjunction with XHTML,
+will put a <?xml> declaration at the top of the HTML header. The sole
+purpose of this declaration is to declare the character set
+encoding. In the absence of -declare_xml, the output HTML will contain
+a <meta> tag that specifies the encoding, allowing the HTML to pass
+most validators. The default for -declare_xml is false.
+
+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'}));
+ -href=>'http://www.capricorn.com/s2.html'}));
-To incorporate multiple HTML elements into the <HEAD> section, just pass an
+To incorporate multiple HTML elements into the <head> section, just pass an
array reference:
print start_html(-head=>[
]
);
+And here's how to create an HTTP-EQUIV <meta> tag:
+
+ print start_html(-head=>meta({-http_equiv => 'Content-Type',
+ -content => 'text/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
+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
B<-script> field:
$query = new CGI;
- print $query->header;
+ print header;
$JSCRIPT=<<END;
// Ask a silly question
function riddle_me_this() {
alert("Wrong! Guess again.");
}
END
- print $query->start_html(-title=>'The Riddle of the Sphinx',
+ print 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,
+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
);
-A final feature allows you to incorporate multiple <SCRIPT> sections into the
+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:
}
]
);
- </pre>
If this looks a bit extreme, take my advice and stick with straight CGI scripting.
=item 2.
-The author's e-mail address (will create a <LINK REV="MADE"> tag if present
+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
+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
+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
+ print end_html
-This ends an HTML document by printing the </BODY></HTML> tags.
+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>";
+ $myself = self_url;
+ print q(<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
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>";
+ $myself = 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;
+ $the_string = 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);
+ $full_url = url();
+ $full_url = url(-full=>1); #alternative syntax
+ $relative_url = url(-relative=>1);
+ $absolute_url = url(-absolute=>1);
+ $url_with_path = url(-path_info=>1);
+ $url_with_path_and_query = url(-path_info=>1,-query=>1);
+ $netloc = url(-base => 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
B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
as a synonym.
+=item B<-base>
+
+Generate just the protocol and net location, as in http://www.foo.com:8000
+
=back
=head2 MIXING POST AND URL PARAMETERS
- $color = $query->url_param('color');
+ $color = 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
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"),
<blockquote>
Many years ago on the island of
- <a HREF="http://crete.org/">Crete</a> there lived
+ <a href="http://crete.org/">Crete</a> there lived
a minotaur named <strong>Fred.</strong>
</blockquote>
<hr>
The HTML methods will accept zero, one or multiple arguments. If you
provide no arguments, you get a single tag:
- print hr; # <HR>
+ 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>"
+ 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>
-
+ <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">
+ <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
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:
-
+<img alt="">. The difference is shown in these two pieces of code:
+
CODE RESULT
- img({alt=>undef}) <IMG ALT>
- img({alt=>''}) <IMT ALT="">
+ img({alt=>undef}) <img alt>
+ img({alt=>''}) <img alt="">
=head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
list:
print ul(
- li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']);
+ 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>
+ <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:
It will ordinarily return the string that you probably expect, namely:
- <BLOCKQUOTE><EM>Hi</EM> mom!</BLOCKQUOTE>
+ <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
start_multipart_form() and all the fill-out form tags are special.
See their respective sections.
+=head2 AUTOESCAPING HTML
+
+By default, all HTML that is emitted by the form-generating functions
+is passed through a function called escapeHTML():
+
+=over 4
+
+=item $escaped_string = escapeHTML("unescaped string");
+
+Escape HTML formatting characters in a string.
+
+=back
+
+Provided that you have specified a character set of ISO-8859-1 (the
+default), the standard HTML escaping rules will be used. The "<"
+character becomes "<", ">" becomes ">", "&" becomes "&", and
+the quote character becomes """. In addition, the hexadecimal
+0x8b and 0x9b characters, which some browsers incorrectly interpret
+as the left and right angle-bracket characters, are replaced by their
+numeric character entities ("‹" and "›"). If you manually change
+the charset, either by calling the charset() method explicitly or by
+passing a -charset argument to header(), then B<all> characters will
+be replaced by their numeric entities, since CGI.pm has no lookup
+table for all the possible encodings.
+
+The automatic escaping does not apply to other shortcuts, such as
+h1(). You should call escapeHTML() yourself on untrusted data in
+order to protect your pages against nasty tricks that people may enter
+into guestbooks, etc.. To change the character set, use charset().
+To turn autoescaping off completely, use autoEscape(0):
+
+=over 4
+
+=item $charset = charset([$charset]);
+
+Get or set the current character set.
+
+=item $flag = autoEscape([$flag]);
+
+Get or set the value of the autoescape flag.
+
+=back
+
=head2 PRETTY-PRINTING HTML
By default, all the HTML produced by these functions comes out as one
(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',
+ print textfield(-name=>'field_name',
-default=>'starting value',
-override=>1,
-size=>50,
autoEscape() method with a false value immediately after creating the CGI object:
$query = new CGI;
- $query->autoEscape(undef);
-
+ autoEscape(undef);
+
+I<A Lurking Trap!> Some of the form-element generating methods return
+multiple tags. In a scalar context, the tags will be concatenated
+together with spaces, or whatever is the current value of the $"
+global. In a list context, the methods will return a list of
+elements, allowing you to modify them if you wish. Usually you will
+not notice this behavior, but beware of this:
+
+ printf("%s\n",end_form())
+
+end_form() produces several tags, and only the first of them will be
+printed because the format only expects one value.
+
+<p>
+
=head2 CREATING AN ISINDEX TAG
- print $query->isindex(-action=>$action);
+ print isindex(-action=>$action);
-or-
- print $query->isindex($action);
+ print isindex($action);
-Prints out an <ISINDEX> tag. Not very exciting. The parameter
+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);
+ print start_form(-method=>$method,
+ -action=>$action,
+ -enctype=>$encoding);
<... various form stuff ...>
- print $query->endform;
+ print endform;
-or-
- print $query->startform($method,$action,$encoding);
+ print start_form($method,$action,$encoding);
<... various form stuff ...>
- print $query->endform;
+ print endform;
-startform() will return a <FORM> tag with the optional method,
+start_form() 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.
+endform() returns the closing </form> tag.
-Startform()'s enctype argument tells the browser how to package the various
+Start_form()'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:
+B<Note:> This method was previously named startform(), and startform()
+is still recognized as an alias.
+
=over 4
=item B<application/x-www-form-urlencoded>
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>.
+type in B<&CGI::URL_ENCODED>.
=item B<multipart/form-data>
by CGI scripts unless they use CGI.pm or another library designed
to handle them.
+If XHTML is activated (the default), then forms will be automatically
+created using this type of encoding.
+
=back
-For compatibility, the startform() method uses the older form of
+For compatibility, the start_form() 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()>.
+B<start_form()>.
JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
for use with JavaScript. The -name parameter gives the
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>
+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 FORM ELEMENTS
+
+After starting a form, you will typically create one or more
+textfields, popup menus, radio groups and other form elements. Each
+of these elements takes a standard set of named arguments. Some
+elements also have optional arguments. The standard arguments are as
+follows:
+
+=over 4
+
+=item B<-name>
+
+The name of the field. After submission this name can be used to
+retrieve the field's value using the param() method.
+
+=item B<-value>, B<-values>
+
+The initial value of the field which will be returned to the script
+after form submission. Some form elements, such as text fields, take
+a single scalar -value argument. Others, such as popup menus, take a
+reference to an array of values. The two arguments are synonyms.
+
+=item B<-tabindex>
+
+A numeric value that sets the order in which the form element receives
+focus when the user presses the tab key. Elements with lower values
+receive focus first.
+
+=item B<-id>
+
+A string identifier that can be used to identify this element to
+JavaScript and DHTML.
+
+=item B<-override>
+
+A boolean, which, if true, forces the element to take on the value
+specified by B<-value>, overriding the sticky behavior described
+earlier for the B<-no_sticky> pragma.
+
+=item B<-onChange>, B<-onFocus>, B<-onBlur>, B<-onMouseOver>, B<-onMouseOut>, B<-onSelect>
+
+These are used to assign JavaScript event handlers. See the
+JavaScripting section for more details.
+
+=back
+
+Other common arguments are described in the next section. In addition
+to these, all attributes described in the HTML specifications are
+supported.
+
=head2 CREATING A TEXT FIELD
- print $query->textfield(-name=>'field_name',
- -default=>'starting value',
- -size=>50,
- -maxlength=>80);
+ print textfield(-name=>'field_name',
+ -value=>'starting value',
+ -size=>50,
+ -maxlength=>80);
-or-
- print $query->textfield('field_name','starting value',50,80);
+ print textfield('field_name','starting value',50,80);
-textfield() will return a text input field.
+textfield() will return a text input field.
=over 4
=item 1.
-The first parameter is the required name for the field (-name).
+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).
+contents (-value, formerly known as -default).
=item 3.
When the form is processed, the value of the text field can be
retrieved with:
- $value = $query->param('foo');
+ $value = 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.
+ param('foo',"I'm taking over this value!");
=head2 CREATING A BIG TEXT FIELD
- print $query->textarea(-name=>'foo',
+ print textarea(-name=>'foo',
-default=>'starting value',
-rows=>10,
-columns=>50);
-or
- print $query->textarea('foo','starting value',10,50);
+ print 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',
+ print password_field(-name=>'secret',
-value=>'starting value',
-size=>50,
-maxlength=>80);
-or-
- print $query->password_field('secret','starting value',50,80);
+ print 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',
+ print filefield(-name=>'uploaded_file',
-default=>'starting value',
-size=>50,
-maxlength=>80);
-or-
- print $query->filefield('uploaded_file','starting value',50,80);
+ print 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>,
+by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>,
or by calling the new method B<start_multipart_form()> instead of
-vanilla B<startform()>.
+vanilla B<start_form()>.
=over 4
When the form is processed, you can retrieve the entered filename
by calling param():
- $filename = $query->param('uploaded_file');
+ $filename = param('uploaded_file');
Different browsers will return slightly different things for the
name. Some browsers return the filename only. Others return the full
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');
+ $fh = upload('uploaded_file');
while (<$fh>) {
print;
}
+In an list context, upload() will return an array of filehandles.
+This makes it possible to create forms that use the same name for
+multiple upload fields.
+
This is the recommended idiom.
When a file is uploaded the browser usually sends along some
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'};
+ $filename = param('uploaded_file');
+ $type = uploadInfo($filename)->{'Content-Type'};
unless ($type eq 'text/html') {
die "HTML FILES ONLY!";
}
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);
+ $file = upload('uploaded_file');
+ if (!$file && cgi_error) {
+ print header(-status=>cgi_error);
exit 0;
}
You are free to create a custom HTML page to complain about the error,
if you wish.
+You can set up a callback that will be called whenever a file upload
+is being read during the form processing. This is much like the
+UPLOAD_HOOK facility available in Apache::Request, with the exception
+that the first argument to the callback is an Apache::Upload object,
+here it's the remote filename.
+
+ $q = CGI->new();
+ $q->upload_hook(\&hook,$data);
+
+ sub hook
+ {
+ my ($filename, $buffer, $bytes_read, $data) = @_;
+ print "Read $bytes_read bytes of $filename\n";
+ }
+
+If using the function-oriented interface, call the CGI::upload_hook()
+method before calling param() or any other CGI functions:
+
+ CGI::upload_hook(\&hook,$data);
+
+This method is not exported by default. You will have to import it
+explicitly if you wish to use it without the CGI:: prefix.
+
+If you are using CGI.pm on a Windows platform and find that binary
+files get slightly larger when uploaded but that text files remain the
+same, then you have forgotten to activate binary mode on the output
+filehandle. Be sure to call binmode() on any handle that you create
+to write the uploaded file to disk.
+
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',
+ print popup_menu('menu_name',
['eenie','meenie','minie'],
'meenie');
%labels = ('eenie'=>'your first choice',
'meenie'=>'your second choice',
'minie'=>'your third choice');
- print $query->popup_menu('menu_name',
+ %attributes = ('eenie'=>{'class'=>'class of first choice'});
+ print popup_menu('menu_name',
['eenie','meenie','minie'],
- 'meenie',\%labels);
+ 'meenie',\%labels,\%attributes);
-or (named parameter style)-
- print $query->popup_menu(-name=>'menu_name',
+ print popup_menu(-name=>'menu_name',
-values=>['eenie','meenie','minie'],
-default=>'meenie',
- -labels=>\%labels);
+ -labels=>\%labels,
+ -attributes=>\%attributes);
popup_menu() creates a menu.
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
+popup menu and 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).
+=item 5.
+
+The optional fifth parameter (-attributes) is provided to assign
+any of the common HTML attributes to an individual menu item. It's
+a pointer to an associative array relating menu values to another
+associative array with the attribute's name as the key and the
+attribute's value as the value.
+
=back
When the form is processed, the selected value of the popup menu can
be retrieved using:
- $popup_menu_value = $query->param('menu_name');
+ $popup_menu_value = param('menu_name');
+
+=head2 CREATING AN OPTION GROUP
+
+Named parameter style
+
+ print popup_menu(-name=>'menu_name',
+ -values=>[qw/eenie meenie minie/,
+ optgroup(-name=>'optgroup_name',
+ -values => ['moe','catch'],
+ -attributes=>{'catch'=>{'class'=>'red'}})],
+ -labels=>{'eenie'=>'one',
+ 'meenie'=>'two',
+ 'minie'=>'three'},
+ -default=>'meenie');
+
+ Old style
+ print popup_menu('menu_name',
+ ['eenie','meenie','minie',
+ optgroup('optgroup_name', ['moe', 'catch'],
+ {'catch'=>{'class'=>'red'}})],'meenie',
+ {'eenie'=>'one','meenie'=>'two','minie'=>'three'});
+
+optgroup() creates an option group within a popup menu.
+
+=over 4
+
+=item 1.
+
+The required first argument (B<-name>) is the label attribute of the
+optgroup and is B<not> inserted in the parameter list of the query.
+
+=item 2.
+
+The required second argument (B<-values>) is an array 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. If you pass a HASH reference,
+the keys will be used for the menu values, and the values will be
+used for the menu labels (see -labels below).
+
+=item 3.
+
+The optional third parameter (B<-labels>) allows you to pass a reference
+to an associative array containing user-visible labels for one or more
+of the menu items. You can use this when you want the user to see one
+menu string, but have the browser return your program a different one.
+If you don't specify this, the value string will be used instead
+("eenie", "meenie" and "minie" in this example). This is equivalent
+to using a hash reference for the -values parameter.
+
+=item 4.
+
+An optional fourth parameter (B<-labeled>) can be set to a true value
+and indicates that the values should be used as the label attribute
+for each option element within the optgroup.
+
+=item 5.
+
+An optional fifth parameter (-novals) can be set to a true value and
+indicates to suppress the val attribute in each option element within
+the optgroup.
+
+See the discussion on optgroup at W3C
+(http://www.w3.org/TR/REC-html40/interact/forms.html#edef-OPTGROUP)
+for details.
+
+=item 6.
+
+An optional sixth parameter (-attributes) is provided to assign
+any of the common HTML attributes to an individual menu item. It's
+a pointer to an associative array relating menu values to another
+associative array with the attribute's name as the key and the
+attribute's value as the value.
-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.
+=back
=head2 CREATING A SCROLLING LIST
- print $query->scrolling_list('list_name',
+ print scrolling_list('list_name',
['eenie','meenie','minie','moe'],
- ['eenie','moe'],5,'true');
+ ['eenie','moe'],5,'true',{'moe'=>{'class'=>'red'}});
-or-
- print $query->scrolling_list('list_name',
+ print scrolling_list('list_name',
['eenie','meenie','minie','moe'],
['eenie','moe'],5,'true',
- \%labels);
+ \%labels,%attributes);
-or-
- print $query->scrolling_list(-name=>'list_name',
+ print scrolling_list(-name=>'list_name',
-values=>['eenie','meenie','minie','moe'],
-default=>['eenie','moe'],
-size=>5,
-multiple=>'true',
- -labels=>\%labels);
+ -labels=>\%labels,
+ -attributes=>\%attributes);
scrolling_list() creates a scrolling list.
containing long user-visible labels for the list items (-labels).
If not provided, the values will be displayed.
+=item 6.
+
+The optional sixth parameter (-attributes) is provided to assign
+any of the common HTML attributes to an individual menu item. It's
+a pointer to an associative array relating menu values to another
+associative array with the attribute's name as the key and the
+attribute's value as the value.
+
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');
+ @selected = 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',
+ print checkbox_group(-name=>'group_name',
-values=>['eenie','meenie','minie','moe'],
-default=>['eenie','moe'],
-linebreak=>'true',
- -labels=>\%labels);
+ -labels=>\%labels,
+ -attributes=>\%attributes);
- print $query->checkbox_group('group_name',
+ print checkbox_group('group_name',
['eenie','meenie','minie','moe'],
- ['eenie','moe'],'true',\%labels);
+ ['eenie','moe'],'true',\%labels,
+ {'moe'=>{'class'=>'red'}});
HTML3-COMPATIBLE BROWSERS ONLY:
- print $query->checkbox_group(-name=>'group_name',
+ print 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.
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.
+=back
-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.
+The optional b<-labels> argument is a pointer to an associative array
+relating the checkbox values to the user-visible labels that will be
+printed next to them. If not provided, the values will be used as the
+default.
-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.
+Modern browsers 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.
-=back
+
+The optional B<-attributes> argument is provided to assign any of the
+common HTML attributes to an individual menu item. It's a pointer to
+an associative array relating menu values to another associative array
+with the attribute's name as the key and the attribute's value as the
+value.
+
+The optional B<-tabindex> argument can be used to control the order in which
+radio buttons receive focus when the user presses the tab button. If
+passed a scalar numeric value, the first element in the group will
+receive this tab index and subsequent elements will be incremented by
+one. If given a reference to an array of radio button values, then
+the indexes will be jiggered so that the order specified in the array
+will correspond to the tab order. You can also pass a reference to a
+hash in which the hash keys are the radio button values and the values
+are the tab indexes of each button. Examples:
+
+ -tabindex => 100 # this group starts at index 100 and counts up
+ -tabindex => ['moe','minie','eenie','meenie'] # tab in this order
+ -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
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');
+ @turned_on = 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);
+ @h = 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',
+ print checkbox(-name=>'checkbox_name',
+ -checked=>1,
-value=>'ON',
-label=>'CLICK ME');
-or-
- print $query->checkbox('checkbox_name','checked','ON','CLICK ME');
+ print checkbox('checkbox_name','checked','ON','CLICK ME');
checkbox() is used to create an isolated checkbox that isn't logically
related to any others.
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.
+ $turned_on = param('checkbox_name');
=head2 CREATING A RADIO BUTTON GROUP
- print $query->radio_group(-name=>'group_name',
+ print radio_group(-name=>'group_name',
-values=>['eenie','meenie','minie'],
-default=>'meenie',
-linebreak=>'true',
- -labels=>\%labels);
+ -labels=>\%labels,
+ -attributes=>\%attributes);
-or-
- print $query->radio_group('group_name',['eenie','meenie','minie'],
- 'meenie','true',\%labels);
+ print radio_group('group_name',['eenie','meenie','minie'],
+ 'meenie','true',\%labels,\%attributes);
HTML3-COMPATIBLE BROWSERS ONLY:
- print $query->radio_group(-name=>'group_name',
+ print radio_group(-name=>'group_name',
-values=>['eenie','meenie','minie','moe'],
-rows=2,-columns=>2);
used in the display. If not provided, the values themselves are
displayed.
-=item 6.
+=back
+
-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.
+All modern browsers 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
interpretation of the radio buttons -- they're still a single named
unit.
-=back
+The optional B<-tabindex> argument can be used to control the order in which
+radio buttons receive focus when the user presses the tab button. If
+passed a scalar numeric value, the first element in the group will
+receive this tab index and subsequent elements will be incremented by
+one. If given a reference to an array of radio button values, then
+the indexes will be jiggered so that the order specified in the array
+will correspond to the tab order. You can also pass a reference to a
+hash in which the hash keys are the radio button values and the values
+are the tab indexes of each button. Examples:
+
+ -tabindex => 100 # this group starts at index 100 and counts up
+ -tabindex => ['moe','minie','eenie','meenie'] # tab in this order
+ -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
+
+
+The optional B<-attributes> argument is provided to assign any of the
+common HTML attributes to an individual menu item. It's a pointer to
+an associative array relating menu values to another associative array
+with the attribute's name as the key and the attribute's value as the
+value.
When the form is processed, the selected radio button can
be retrieved using:
- $which_radio_button = $query->param('group_name');
+ $which_radio_button = 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);
+ @h = radio_group(-name=>'group_name',-values=>\@values);
&use_in_creative_way(@h);
=head2 CREATING A SUBMIT BUTTON
- print $query->submit(-name=>'button_name',
+ print submit(-name=>'button_name',
-value=>'value');
-or-
- print $query->submit('button_name','value');
+ print submit('button_name','value');
submit() will create the query submission button. Every form
should have one of these.
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.
+to distinguish between them.
=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.
+a value that will be passed to your script in the query string. The
+name will also be used as the user-visible label.
+
+=item 3.
+
+You can use -label as an alias for -value. I always get confused
+about which of -name and -value changes the user-visible label on the
+button.
=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.
+ $which_one = param('button_name');
=head2 CREATING A RESET BUTTON
- print $query->reset
+ print reset
reset() creates the "reset" button. Note that it restores the
form to its value from the last time the script was called,
=head2 CREATING A DEFAULT BUTTON
- print $query->defaults('button_label')
+ print 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
=head2 CREATING A HIDDEN FIELD
- print $query->hidden(-name=>'hidden_name',
+ print hidden(-name=>'hidden_name',
-default=>['value1','value2'...]);
-or-
- print $query->hidden('hidden_name','value1','value2'...);
+ print 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
Fetch the value of a hidden field this way:
- $hidden_value = $query->param('hidden_name');
+ $hidden_value = 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');
+ param('hidden_name','new','values','here');
=head2 CREATING A CLICKABLE IMAGE BUTTON
- print $query->image_button(-name=>'button_name',
+ print image_button(-name=>'button_name',
-src=>'/source/URL',
-align=>'MIDDLE');
-or-
- print $query->image_button('button_name','/source/URL','MIDDLE');
+ print 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:>
=back
Fetch the value of the button this way:
- $x = $query->param('button_name.x');
- $y = $query->param('button_name.y');
+ $x = param('button_name.x');
+ $y = param('button_name.y');
=head2 CREATING A JAVASCRIPT ACTION BUTTON
- print $query->button(-name=>'button_name',
+ print button(-name=>'button_name',
-value=>'user visible label',
-onClick=>"do_something()");
-or-
- print $query->button('button_name',"do_something()");
+ print 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
The interface to HTTP cookies is the B<cookie()> method:
- $cookie = $query->cookie(-name=>'sessionID',
+ $cookie = cookie(-name=>'sessionID',
-value=>'xyzzy',
-expires=>'+1h',
-path=>'/cgi-bin/database',
-domain=>'.capricorn.org',
-secure=>1);
- print $query->header(-cookie=>$cookie);
+ print header(-cookie=>$cookie);
B<cookie()> creates a new cookie. Its parameters include:
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',
+ $cookie=cookie(-name=>'family information',
-value=>\%childrens_ages);
=item B<-path>
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);
+ print header(-cookie=>$my_cookie);
To create multiple cookies, give header() an array reference:
- $cookie1 = $query->cookie(-name=>'riddle_name',
+ $cookie1 = cookie(-name=>'riddle_name',
-value=>"The Sphynx's Question");
- $cookie2 = $query->cookie(-name=>'answers',
+ $cookie2 = cookie(-name=>'answers',
-value=>\%answers);
- print $query->header(-cookie=>[$cookie1,$cookie2]);
+ print header(-cookie=>[$cookie1,$cookie2]);
-To retrieve a cookie, request it by name by calling cookie()
-method without the B<-value> parameter:
+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!
+ $riddle = cookie('riddle_name');
+ %answers = cookie('answers');
+
+Cookies created with a single scalar value, such as the "riddle_name"
+cookie, will be returned in that form. Cookies with array and hash
+values can also be retrieved.
The cookie and CGI namespaces are separate. If you have a parameter
named 'answers' and a cookie named 'answers', the values retrieved by
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')]);
+ $c=cookie(-name=>'answers',-value=>[param('answers')]);
# vice-versa
- $q->param(-name=>'answers',-value=>[$q->cookie('answers')]);
+ param(-name=>'answers',-value=>[cookie('answers')]);
See the B<cookie.cgi> example script for some ideas on how to use
cookies effectively.
=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>
+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
+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
=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');
+
+ print 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
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
+=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');
+ print start_form(-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
create pages in which the fill-out form and the response live in
side-by-side frames.
+=head1 SUPPORT FOR JAVASCRIPT
+
+Netscape versions 2.0 and higher incorporate an interpreted language
+called JavaScript. Internet Explorer, 3.0 and higher, supports a
+closely-related dialect called JScript. JavaScript isn't the same as
+Java, and certainly isn't at all the same as Perl, which is a great
+pity. JavaScript allows you to programmatically change the contents of
+fill-out forms, create new windows, and pop up dialog box from within
+Netscape itself. From the point of view of CGI scripting, JavaScript
+is quite useful for validating fill-out forms prior to submitting
+them.
+
+You'll need to know JavaScript in order to use it. There are many good
+sources in bookstores and on the web.
+
+The usual way to use JavaScript is to define a set of functions in a
+<SCRIPT> block inside the HTML header and then to register event
+handlers in the various elements of the page. Events include such
+things as the mouse passing over a form element, a button being
+clicked, the contents of a text field changing, or a form being
+submitted. When an event occurs that involves an element that has
+registered an event handler, its associated JavaScript code gets
+called.
+
+The elements that can register event handlers include the <BODY> of an
+HTML document, hypertext links, all the various elements of a fill-out
+form, and the form itself. There are a large number of events, and
+each applies only to the elements for which it is relevant. Here is a
+partial list:
+
+=over 4
+
+=item B<onLoad>
+
+The browser is loading the current document. Valid in:
+
+ + The HTML <BODY> section only.
+
+=item B<onUnload>
+
+The browser is closing the current page or frame. Valid for:
+
+ + The HTML <BODY> section only.
+
+=item B<onSubmit>
+
+The user has pressed the submit button of a form. This event happens
+just before the form is submitted, and your function can return a
+value of false in order to abort the submission. Valid for:
+
+ + Forms only.
+
+=item B<onClick>
+
+The mouse has clicked on an item in a fill-out form. Valid for:
+
+ + Buttons (including submit, reset, and image buttons)
+ + Checkboxes
+ + Radio buttons
+
+=item B<onChange>
+
+The user has changed the contents of a field. Valid for:
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+ + Popup Menus
+ + Scrolling lists
+
+=item B<onFocus>
+
+The user has selected a field to work with. Valid for:
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+ + Popup Menus
+ + Scrolling lists
+
+=item B<onBlur>
+
+The user has deselected a field (gone to work somewhere else). Valid
+for:
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+ + Popup Menus
+ + Scrolling lists
+
+=item B<onSelect>
+
+The user has changed the part of a text field that is selected. Valid
+for:
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+
+=item B<onMouseOver>
+
+The mouse has moved over an element.
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+ + Popup Menus
+ + Scrolling lists
+
+=item B<onMouseOut>
+
+The mouse has moved off an element.
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+ + Popup Menus
+ + Scrolling lists
+
+=back
+
+In order to register a JavaScript event handler with an HTML element,
+just use the event name as a parameter when you call the corresponding
+CGI method. For example, to have your validateAge() JavaScript code
+executed every time the textfield named "age" changes, generate the
+field like this:
+
+ print textfield(-name=>'age',-onChange=>"validateAge(this)");
+
+This example assumes that you've already declared the validateAge()
+function by incorporating it into a <SCRIPT> block. The CGI.pm
+start_html() method provides a convenient way to create this section.
+
+Similarly, you can create a form that checks itself over for
+consistency and alerts the user if some essential value is missing by
+creating it this way:
+ print startform(-onSubmit=>"validateMe(this)");
+
+See the javascript.cgi script for a demonstration of how this all
+works.
+
+
=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
+parameter may be a scalar, in which case it is treated as the source
+URL for the stylesheet, 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>
+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
);
print end_html;
+Pass an array reference to B<-code> or B<-src> in order to incorporate
+multiple stylesheets into your document.
+
+Should you wish to incorporate a verbatim stylesheet that includes
+arbitrary formatting in the header, you may pass a -verbatim tag to
+the -style hash, as follows:
+
+print start_html (-STYLE => {-verbatim => '@import
+url("/server-common/css/'.$cssFile.'");',
+ -src => '/server-common/css/core.css'});
+</blockquote></pre>
+
+
+This will generate an HTML header that contains this:
+
+ <link rel="stylesheet" type="text/css" href="/server-common/css/core.css">
+ <style type="text/css">
+ @import url("/server-common/css/main.css");
+ </style>
+
+Any additional arguments passed in the -style value will be
+incorporated into the <link> tag. For example:
+
+ start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'],
+ -media => 'all'});
+
+This will give:
+
+ <link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/>
+ <link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/>
+
+<p>
+
+To make more complicated <link> tags, use the Link() function
+and pass it to start_html() in the -head argument, as in:
+
+ @h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}),
+ Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'}));
+ print start_html({-head=>\@h})
+
=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:
+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
your_script.pl name1=value1&name2=value2
-or even as newline-delimited parameters on standard input.
+To turn off this feature, use the -no_debug pragma.
+
+To test the POST method, you may enable full debugging with the -debug
+pragma. This will allow you to feed newline-delimited name=value
+pairs to the script on standard input.
When debugging, you can use quotes and backslashes to escape
characters in the familiar shell manner, letting you place
your_script.pl "name1='I am a long value'" "name2=two\ words"
+Finally, you can set the path info for the script by prefixing the first
+name/value parameter with the path followed by a question mark (?):
+
+ your_script.pl /your/path/here?name1=value1&name2=value2
+
=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
-The dump() method produces a string consisting of all the query's
+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
-
+ print Dump
+
Produces something that looks like:
- <UL>
- <LI>name1
- <UL>
- <LI>value1
- <LI>value2
- </UL>
- <LI>name2
- <UL>
- <LI>value1
- </UL>
- </UL>
+ <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";
+ print "<h2>Current Values</h2> $query\n";
=head1 FETCHING ENVIRONMENT VARIABLES
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
+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.
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);
+like 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".
+E.G. fetching /cgi-bin/your_script/additional/stuff will result in
+path_info() returning "/additional/stuff".
NOTE: The Microsoft Internet Information Server
is broken with respect to additional path information. If
When using virtual hosts, returns the name of the host that
the browser attempted to contact
+=item B<server_port ()>
+
+Return the port that the server is listening on.
+
+=item B<virtual_port ()>
+
+Like server_port() except that it takes virtual hosts into account.
+Use this when running with virtual hosts.
+
=item B<server_software ()>
Returns the server software and version number.
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');
+ $requested_language = http('Accept-language');
+ $requested_language = http('Accept_language');
+ $requested_language = http('HTTP_ACCEPT_LANGUAGE');
=item B<https()>
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:
+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. However,
+note that if you have applied Service Pack 6, much of the
+functionality of NPH scripts, including the ability to redirect while
+setting a cookie, b<do not work at all> on IIS without a special patch
+from Microsoft. See
+http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP:
+Non-Parsed Headers Stripped From CGI Applications That Have nph-
+Prefix in Name.
=over 4
CGI->nph(1)
-=item By using B<-nph> parameters in the B<header()> and B<redirect()> statements:
+=item By using B<-nph> parameters
+
+in the B<header()> and B<redirect()> statements:
- print $q->header(-nph=>1);
+ print header(-nph=>1);
=back
=head1 Server Push
-CGI.pm provides three simple functions for producing multipart
+CGI.pm provides four 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.
#!/usr/local/bin/perl
use CGI qw/:push -nph/;
$| = 1;
- print multipart_init(-boundary=>'----------------here we go!');
- while (1) {
+ print multipart_init(-boundary=>'----here we go!');
+ foreach (0 .. 4) {
print multipart_start(-type=>'text/plain'),
- "The current time is ",scalar(localtime),"\n",
- multipart_end;
+ "The current time is ",scalar(localtime),"\n";
+ if ($_ < 4) {
+ print multipart_end;
+ } else {
+ print multipart_final;
+ }
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,
+It then enters a 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.
+a second, and begins again. On the final iteration, it ends the
+multipart section with B<multipart_final()> rather than with
+B<multipart_end()>.
=over 4
=item multipart_init()
-
+
multipart_init(-boundary=>$boundary);
Initialize the multipart system. The -boundary argument specifies
multipart_end()
End a part. You must remember to call multipart_end() once for each
-multipart_start().
+multipart_start(), except at the end of the last part of the multipart
+document when multipart_final() should be called instead of multipart_end().
+
+=item multipart_final()
+
+ multipart_final()
+
+End all parts. You should call multipart_final() rather than
+multipart_end() at the end of the last part of the multipart document.
=back
Users interested in server push applications should also have a look
at the CGI::Push module.
+Only Netscape Navigator supports server push. Internet Explorer
+browsers do not.
+
=head1 Avoiding Denial of Service Attacks
A potential problem with CGI.pm is that, by default, it attempts to
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
+ CGI::ReadParse();
print "The value of the antique is $in{antique}.\n";
CGI.pm's ReadParse() routine creates a tied variable named %in,
this way:
$q = $in{CGI};
- print $q->textfield(-name=>'wow',
+ print textfield(-name=>'wow',
-value=>'does this really work?');
This allows you to start using the more interesting features
#!/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;
-
+ use CGI ':standard';
+
+ print header;
+ print start_html("Example CGI.pm Form");
+ print "<h1> Example CGI.pm Form</h1>\n";
+ print_prompt();
+ do_work();
+ print_tail();
+ print 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(
+ print start_form;
+ print "<em>What's your name?</em><br>";
+ print textfield('name');
+ print checkbox('Not my real name');
+
+ print "<p><em>Where can you find English Sparrows?</em><br>";
+ print 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(
+
+ print "<p><em>How far can they fly?</em><br>",
+ 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',
+
+ print "<p><em>What's your favorite color?</em> ";
+ print 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(
+
+ print hidden('Reference','Monty Python and the Holy Grail');
+
+ print "<p><em>What have you got there?</em><br>";
+ print 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',
+
+ print "<p><em>Any parting comments?</em><br>";
+ print 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";
+
+ print "<p>",reset;
+ print submit('Action','Shout');
+ print submit('Action','Scream');
+ print endform;
+ print "<hr>\n";
}
-
+
sub do_work {
- my($query) = @_;
my(@values,$key);
- print "<H2>Here are the current settings in this form</H2>";
+ 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";
+ foreach $key (param) {
+ print "<strong>$key</strong> -> ";
+ @values = param($key);
+ print join(", ",@values),"<br>\n";
}
}
-
+
sub print_tail {
print <<END;
- <HR>
- <ADDRESS>Lincoln D. Stein</ADDRESS><BR>
- <A HREF="/">Home Page</A>
+ <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.
+Please report them.
=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>
+L<CGI::Carp>, L<CGI::Fast>, L<CGI::Pretty>
=cut
https://perl5.git.perl.org / perl5.git / blobdiff