X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI.pm;h=9f65f7d02b480357c3282439a13cf61ff3b40227;hb=cc83745da206d409d7227df077f422fd9ecbe680;hp=0c869d726208f3cd2e9119ead21e6c91d327ed92;hpb=38b7982183d856ea25d377fcd59aae2da555ff5b;p=p5sagit%2Fp5-mst-13.2.git
diff --git a/lib/CGI.pm b/lib/CGI.pm
index 0c869d7..9f65f7d 100644
--- a/lib/CGI.pm
+++ b/lib/CGI.pm
@@ -1,5 +1,6 @@
package CGI;
-require 5.001;
+require 5.004;
+use Carp 'croak';
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
@@ -8,42 +9,122 @@ require 5.001;
# documentation in manual or html file format (these utilities are part of the
# Perl 5 distribution).
-# Copyright 1995-1997 Lincoln D. Stein. All rights reserved.
+# Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
# It may be used and modified freely, but I do request that this copyright
# notice remain attached to the file. You may modify this module as you
# wish, but if you redistribute a modified version, please attach a note
# listing the modifications you have made.
# The most recent version and complete docs are available at:
-# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
-# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
+# http://stein.cshl.org/WWW/software/CGI/
-# Set this to 1 to enable copious autoloader debugging messages
-$AUTOLOAD_DEBUG=0;
+$CGI::revision = '$Id: CGI.pm,v 1.130 2003/08/01 14:39:17 lstein Exp $ + patches by merlyn';
+$CGI::VERSION='3.00';
-# Set this to 1 to enable NPH scripts
-# or:
-# 1) use CGI qw(:nph)
-# 2) $CGI::nph(1)
-# 3) print header(-nph=>1)
-$NPH=0;
+# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
+# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
+# $CGITempFile::TMPDIRECTORY = '/usr/tmp';
+use CGI::Util qw(rearrange make_attributes unescape escape expires);
-$CGI::revision = '$Id: CGI.pm,v 2.32 1997/3/19 10:10 lstein Exp $';
-$CGI::VERSION='2.3202';
+#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
+# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
-# OVERRIDE THE OS HERE IF CGI.pm GUESSES WRONG
-# $OS = 'UNIX';
-# $OS = 'MACINTOSH';
-# $OS = 'WINDOWS';
-# $OS = 'VMS';
-# $OS = 'OS2';
+use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
+ 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
-# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
-# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
-# $TempFile::TMPDIRECTORY = '/usr/tmp';
+{
+ local $^W = 0;
+ $TAINTED = substr("$0$^X",0,0);
+}
+
+my @SAVED_SYMBOLS;
+
+$MOD_PERL = 0; # no mod_perl by default
+
+# >>>>> 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 = [ '-//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)
+ # 3) print header(-nph=>1)
+ $NPH = 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);
+ $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;
+
+ # Change this to 1 to disable uploads entirely:
+ $DISABLE_UPLOADS = 0;
+
+ # Automatically determined -- don't change
+ $EBCDIC = 0;
+
+ # Change this to 1 to suppress redundant HTTP headers
+ $HEADERS_ONCE = 0;
+
+ # separate the name=value pairs by semicolons rather than ampersands
+ $USE_PARAM_SEMICOLONS = 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;
+ undef @QUERY_PARAM;
+ undef %EXPORT;
+ undef $QUERY_CHARSET;
+ undef %QUERY_FIELDNAMES;
+
+ # prevent complaints by mod_perl
+ 1;
+}
# ------------------ START OF THE LIBRARY ------------
+# make mod_perlhappy
+initialize_globals();
+
# FIGURE OUT THE OS WE'RE RUNNING UNDER
# Some systems support the $^O variable. If not
# available then require() the Config library
@@ -53,51 +134,80 @@ unless ($OS) {
$OS = $Config::Config{'osname'};
}
}
-if ($OS=~/Win/i) {
- $OS = 'WINDOWS';
-} elsif ($OS=~/vms/i) {
- $OS = 'VMS';
-} elsif ($OS=~/Mac/i) {
+if ($OS =~ /^MSWin/i) {
+ $OS = 'WINDOWS';
+} elsif ($OS =~ /^VMS/i) {
+ $OS = 'VMS';
+} elsif ($OS =~ /^dos/i) {
+ $OS = 'DOS';
+} 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|VMS|OS2)/;
+$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;
+
# This is where to look for autoloaded routines.
$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
# The path separator is a slash, backslash or semicolon, depending
# on the paltform.
$SL = {
- UNIX=>'/',
- OS2=>'\\',
- WINDOWS=>'\\',
- MACINTOSH=>':',
- VMS=>'\\'
+ UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/',
+ WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
}->{$OS};
+# This no longer seems to be necessary
# Turn on NPH scripts by default when running under IIS server!
-$NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
+# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
+$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
# Turn on special checking for Doug MacEachern's modperl
-if (defined($MOD_PERL = $ENV{'GATEWAY_INTERFACE'}) &&
- $MOD_PERL =~ /^CGI-Perl/)
-{
- $NPH++;
- $| = 1;
- $SEQNO = 1;
+if (exists $ENV{MOD_PERL}) {
+ eval "require 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 (defined $mod_perl::VERSION) {
+ if ($mod_perl::VERSION >= 1.99) {
+ $MOD_PERL = 2;
+ require Apache::RequestRec;
+ require Apache::RequestUtil;
+ require APR::Pool;
+ } else {
+ $MOD_PERL = 1;
+ require Apache;
+ }
+ }
}
-# This is really "\r\n", but the meaning of \n is different
-# in MacPerl, so we resort to octal here.
-$CRLF = "\015\012";
+# Turn on special checking for ActiveState's PerlEx
+$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
+
+# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
+# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
+# and sometimes CR). The most popular VMS web server
+# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
+# use ASCII, so \015\012 means something different. I find this all
+# really annoying.
+$EBCDIC = "\t" ne "\011";
+if ($OS eq 'VMS') {
+ $CRLF = "\n";
+} elsif ($EBCDIC) {
+ $CRLF= "\r\n";
+} else {
+ $CRLF = "\015\012";
+}
if ($needs_binmode) {
$CGI::DefaultClass->binmode(main::STDOUT);
@@ -105,43 +215,47 @@ if ($needs_binmode) {
$CGI::DefaultClass->binmode(main::STDERR);
}
-# Cute feature, but it broke when the overload mechanism changed...
-# %OVERLOAD = ('""'=>'as_string');
-
%EXPORT_TAGS = (
- ':html2'=>[h1..h6,qw/p br hr ol ul li dl dt dd menu code var strong em
- tt 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/],
- ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont/],
- ':netscape'=>[qw/blink frameset frame script font 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 isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
- ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump
- raw_cookie request_method query_string accept user_agent remote_host
- remote_addr referer server_name server_software server_port server_protocol
- virtual_host remote_ident auth_type http
- remote_user user_name header redirect import_names put/],
- ':ssl' => [qw/https/],
- ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
- ':html' => [qw/:html2 :html3 :netscape/],
- ':standard' => [qw/:html2 :form :cgi/],
- ':all' => [qw/:html2 :html3 :netscape :form :cgi/]
- );
+ ':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 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 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
+ 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
+ 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/],
+ ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
+ ':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/]
+ );
# to import symbols into caller
sub import {
my $self = shift;
+
+ # This causes modules to clash.
+ undef %EXPORT_OK;
+ undef %EXPORT;
+
+ $self->_setup_symbols(@_);
my ($callpack, $callfile, $callline) = caller;
- foreach (@_) {
- $NPH++, next if $_ eq ':nph';
- foreach (&expand_tags($_)) {
- tr/a-zA-Z0-9_//cd; # don't allow weird function names
- $EXPORT{$_}++;
- }
- }
+
# To allow overriding, search through the packages
# Till we find one in which the correct subroutine is defined.
my @packages = ($self,@{"$self\:\:ISA"});
@@ -158,8 +272,14 @@ sub import {
}
}
+sub compile {
+ my $pack = shift;
+ $pack->_setup_symbols('-compile',@_);
+}
+
sub expand_tags {
my($tag) = @_;
+ return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
my(@r);
return ($tag) unless $EXPORT_TAGS{$tag};
foreach (@{$EXPORT_TAGS{$tag}}) {
@@ -173,19 +293,46 @@ sub expand_tags {
# for an existing query string, and initialize itself, if so.
####
sub new {
- my($class,$initializer) = @_;
- my $self = {};
- bless $self,ref $class || $class || $DefaultClass;
- $CGI::DefaultClass->_reset_globals() if $MOD_PERL;
- $initializer = to_filehandle($initializer) if $initializer;
- $self->init($initializer);
- return $self;
+ my($class,@initializer) = @_;
+ my $self = {};
+ bless $self,ref $class || $class || $DefaultClass;
+ if (ref($initializer[0])
+ && (UNIVERSAL::isa($initializer[0],'Apache')
+ ||
+ UNIVERSAL::isa($initializer[0],'Apache::RequestRec')
+ )) {
+ $self->r(shift @initializer);
+ }
+ if ($MOD_PERL) {
+ $self->r(Apache->request) unless $self->r;
+ my $r = $self->r;
+ if ($MOD_PERL == 1) {
+ $r->register_cleanup(\&CGI::_reset_globals);
+ }
+ else {
+ # XXX: once we have the new API
+ # will do a real PerlOptions -SetupEnv check
+ $r->subprocess_env unless exists $ENV{REQUEST_METHOD};
+ $r->pool->cleanup_register(\&CGI::_reset_globals);
+ }
+ undef $NPH;
+ }
+ $self->_reset_globals if $PERLEX;
+ $self->init(@initializer);
+ return $self;
}
# We provide a DESTROY method so that the autoloader
# doesn't bother trying to find it.
sub DESTROY { }
+sub r {
+ my $self = shift;
+ my $r = $self->{'.r'};
+ $self->{'.r'} = shift if @_;
+ $r;
+}
+
#### Method: param
# Returns the value(s)of a named parameter.
# If invoked in a list context, returns the
@@ -205,10 +352,10 @@ sub param {
# 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) {
@@ -224,98 +371,32 @@ sub param {
$name = $p[0];
}
- return () unless defined($name) && $self->{$name};
+ return unless defined($name) && $self->{$name};
return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
}
-#### Method: delete
-# Deletes the named parameter entirely.
-####
-sub delete {
- my($self,$name) = self_or_default(@_);
- delete $self->{$name};
- delete $self->{'.fieldnames'}->{$name};
- @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
- return wantarray ? () : undef;
-}
-
sub self_or_default {
- return @_ if defined($_[0]) && !ref($_[0]) && ($_[0] eq 'CGI');
+ return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
unless (defined($_[0]) &&
- ref($_[0]) &&
- (ref($_[0]) eq 'CGI' ||
- eval "\$_[0]->isaCGI()")) { # optimize for the common case
- $CGI::DefaultClass->_reset_globals()
- if defined($Q) && $MOD_PERL && $CGI::DefaultClass->_new_request();
+ (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
+ ) {
$Q = $CGI::DefaultClass->new unless defined($Q);
unshift(@_,$Q);
}
- return @_;
-}
-
-sub _new_request {
- return undef unless (defined(Apache->seqno()) or eval { require Apache });
- if (Apache->seqno() != $SEQNO) {
- $SEQNO = Apache->seqno();
- return 1;
- } else {
- return undef;
- }
-}
-
-sub _reset_globals {
- undef $Q;
- undef @QUERY_PARAM;
+ return wantarray ? @_ : $Q;
}
sub self_or_CGI {
local $^W=0; # prevent a warning
if (defined($_[0]) &&
(substr(ref($_[0]),0,3) eq 'CGI'
- || eval "\$_[0]->isaCGI()")) {
+ || UNIVERSAL::isa($_[0],'CGI'))) {
return @_;
} else {
return ($DefaultClass,@_);
}
}
-sub isaCGI {
- return 1;
-}
-
-#### Method: import_names
-# Import all parameters into the given namespace.
-# Assumes namespace 'Q' if not specified
-####
-sub import_names {
- my($self,$namespace) = self_or_default(@_);
- $namespace = 'Q' unless defined($namespace);
- die "Can't import names into 'main'\n"
- if $namespace eq 'main';
- my($param,@value,$var);
- foreach $param ($self->param) {
- # protect against silly names
- ($var = $param)=~tr/a-zA-Z0-9_/_/c;
- $var = "${namespace}::$var";
- @value = $self->param($param);
- @{$var} = @value;
- ${$var} = $value[0];
- }
-}
-
-#### 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;
-}
-
########################################
# THESE METHODS ARE MORE OR LESS PRIVATE
# GO TO THE __DATA__ SECTION TO SEE MORE
@@ -330,28 +411,68 @@ sub use_named_parameters {
# parameter list with the single parameter 'keywords'.
sub init {
- my($self,$initializer) = @_;
- my($query_string,@lines);
- my($meth) = '';
+ 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 (defined(@QUERY_PARAM) && !defined($initializer)) {
-
foreach (@QUERY_PARAM) {
$self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
}
+ $self->charset($QUERY_CHARSET);
+ $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
return;
}
$meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
+ $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
+
+ $fh = to_filehandle($initializer) if $initializer;
+
+ # set charset to the safe ISO-8859-1
+ $self->charset('ISO-8859-1');
- # If initializer is defined, then read parameters
- # from it.
METHOD: {
- if (defined($initializer)) {
+ # avoid unreasonably large postings
+ if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
+ # quietly read and discard the post
+ my $buffer;
+ my $max = $content_length;
+ while ($max > 0 && (my $bytes = read(STDIN,$buffer,$max < 10000 ? $max : 10000))) {
+ $max -= $bytes;
+ }
+ $self->cgi_error("413 Request entity too large");
+ last METHOD;
+ }
+
+ # Process multipart postings, but only if the initializer is
+ # not defined.
+ if ($meth eq 'POST'
+ && defined($ENV{'CONTENT_TYPE'})
+ && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
+ && !defined($initializer)
+ ) {
+ my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
+ $self->read_multipart($boundary,$content_length);
+ last METHOD;
+ }
+
+ # If initializer is defined, then read parameters
+ # from it.
+ if (defined($initializer)) {
+ if (UNIVERSAL::isa($initializer,'CGI')) {
+ $query_string = $initializer->query_string;
+ last METHOD;
+ }
if (ref($initializer) && ref($initializer) eq 'HASH') {
foreach (keys %$initializer) {
$self->param('-name'=>$_,'-value'=>$initializer->{$_});
@@ -359,9 +480,8 @@ sub init {
last METHOD;
}
- $initializer = $$initializer if ref($initializer);
- if (defined(fileno($initializer))) {
- while (<$initializer>) {
+ if (defined($fh) && ($fh ne '')) {
+ while (<$fh>) {
chomp;
last if /^=/;
push(@lines,$_);
@@ -374,50 +494,59 @@ sub init {
}
last METHOD;
}
+
+ # last chance -- treat it as a string
+ $initializer = $$initializer if ref($initializer) eq 'SCALAR';
$query_string = $initializer;
+
last METHOD;
}
- # If method is GET or HEAD, fetch the query from
- # the environment.
- if ($meth=~/^(GET|HEAD)$/) {
- $query_string = $ENV{'QUERY_STRING'};
- last METHOD;
- }
-
- # If the method is POST, fetch the query from standard
- # input.
- if ($meth eq 'POST') {
-
- if (defined($ENV{'CONTENT_TYPE'})
- &&
- $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|) {
- my($boundary) = $ENV{'CONTENT_TYPE'}=~/boundary=(\S+)/;
- $self->read_multipart($boundary,$ENV{'CONTENT_LENGTH'});
+ # If method is GET or HEAD, fetch the query from
+ # the environment.
+ if ($meth=~/^(GET|HEAD)$/) {
+ if ($MOD_PERL) {
+ $query_string = $self->r->args;
} else {
-
- $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0)
- if $ENV{'CONTENT_LENGTH'} > 0;
-
+ $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)
+ if $content_length > 0;
# Some people want to have their cake and eat it too!
# Uncomment this line to have the contents of the query string
# APPENDED to the POST data.
- # $query_string .= ($query_string ? '&' : '') . $ENV{'QUERY_STRING'} if $ENV{'QUERY_STRING'};
+ # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
last METHOD;
}
-
- # If neither is set, assume we're being debugged offline.
+
+ # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
# Check the command line and then the standard input for data.
# We use the shellwords package in order to behave the way that
# UN*X programmers expect.
- $query_string = &read_from_cmdline;
+ $query_string = read_from_cmdline() if $DEBUG;
}
-
+
+# 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 ($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');
@@ -440,40 +569,25 @@ sub init {
# 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:
-
# Turn a string into a filehandle
sub to_filehandle {
- my $string = shift;
- if ($string && !ref($string)) {
- my($package) = caller(1);
- my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string";
- return $tmp if defined(fileno($tmp));
+ my $thingy = shift;
+ return undef unless $thingy;
+ return $thingy if UNIVERSAL::isa($thingy,'GLOB');
+ return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
+ if (!ref($thingy)) {
+ my $caller = 1;
+ while (my $package = caller($caller++)) {
+ my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
+ return $tmp if defined(fileno($tmp));
+ }
}
- return $string;
-}
-
-# Create a new multipart buffer
-sub new_MultipartBuffer {
- my($self,$boundary,$length,$filehandle) = @_;
- return MultipartBuffer->new($self,$boundary,$length,$filehandle);
-}
-
-# Read data from a file handle
-sub read_from_client {
- my($self, $fh, $buff, $len, $offset) = @_;
- local $^W=0; # prevent a warning
- return read($fh, $$buff, $len, $offset);
-}
-
-# put a filehandle into binary mode (DOS)
-sub binmode {
- binmode($_[1]);
+ return undef;
}
# send output to the browser
@@ -488,19 +602,11 @@ sub print {
CORE::print(@_);
}
-# unescape URL-encoded data
-sub unescape {
- my($todecode) = @_;
- $todecode =~ tr/+/ /; # pluses become spaces
- $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
- return $todecode;
-}
-
-# URL-encode data
-sub escape {
- my($toencode) = @_;
- $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
- return $toencode;
+# get/set last cgi_error
+sub cgi_error {
+ my ($self,$err) = self_or_default(@_);
+ $self->{'.cgi_error'} = $err if defined $err;
+ return $self->{'.cgi_error'};
}
sub save_request {
@@ -510,26 +616,24 @@ sub save_request {
# 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->{$_};
}
-}
-
-sub parse_keywordlist {
- my($self,$tosplit) = @_;
- $tosplit = &unescape($tosplit); # unescape the keywords
- $tosplit=~tr/+/ /; # pluses to spaces
- my(@keywords) = split(/\s+/,$tosplit);
- return @keywords;
+ $QUERY_CHARSET = $self->charset;
+ %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
}
sub parse_params {
my($self,$tosplit) = @_;
- my(@pairs) = split('&',$tosplit);
+ my(@pairs) = split(/[&;]/,$tosplit);
my($param,$value);
foreach (@pairs) {
- ($param,$value) = split('=');
- $param = &unescape($param);
- $value = &unescape($value);
+ ($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);
push (@{$self->{$param}},$value);
}
@@ -537,6 +641,7 @@ sub parse_params {
sub add_parameter {
my($self,$param)=@_;
+ return unless defined $param;
push (@{$self->{'.parameters'}},$param)
unless defined($self->{$param});
}
@@ -548,90 +653,151 @@ sub all_parameters {
return @{$self->{'.parameters'}};
}
-
-
-#### Method as_string
-#
-# synonym for "dump"
-####
-sub as_string {
- &dump(@_);
+# put a filehandle into binary mode (DOS)
+sub binmode {
+ CORE::binmode($_[1]);
+}
+
+sub _make_tag_func {
+ my ($self,$tagname) = @_;
+ my $func = qq(
+ 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 "<\L$1\E\$attr>";} !;
+ } elsif ($tagname=~/end_(\w+)/i) {
+ $func .= qq! return "<\L/$1\E>"; } !;
+ } else {
+ $func .= qq#
+ 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";
+ }#;
+ }
+return $func;
}
sub AUTOLOAD {
print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
+ my $func = &_compile;
+ goto &$func;
+}
+
+sub _compile {
my($func) = $AUTOLOAD;
- my($pack,$func_name) = $func=~/(.+)::([^:]+)$/;
- $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
- unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
-
- my($sub) = \%{"$pack\:\:SUBS"};
- unless (%$sub) {
- my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
- eval "package $pack; $$auto";
- die $@ if $@;
- }
- my($code) = $sub->{$func_name};
-
- $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
- if (!$code) {
- if ($EXPORT{':any'} ||
- $EXPORT{$func_name} ||
- (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
- && $EXPORT_OK{$func_name}) {
- $code = $sub->{'HTML_FUNC'};
- $code=~s/func_name/$func_name/mg;
- }
- }
- die "Undefined subroutine $AUTOLOAD\n" unless $code;
- eval "package $pack; $code";
- if ($@) {
- $@ =~ s/ at .*\n//;
- die $@;
- }
- goto &{"$pack\:\:$func_name"};
+ my($pack,$func_name);
+ {
+ local($1,$2); # this fixes an obscure variable suicide problem.
+ $func=~/(.+)::([^:]+)$/;
+ ($pack,$func_name) = ($1,$2);
+ $pack=~s/::SUPER$//; # fix another obscure problem
+ $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
+ unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
+
+ my($sub) = \%{"$pack\:\:SUBS"};
+ unless (%$sub) {
+ my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
+ eval "package $pack; $$auto";
+ croak("$AUTOLOAD: $@") if $@;
+ $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
+ }
+ my($code) = $sub->{$func_name};
+
+ $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
+ if (!$code) {
+ (my $base = $func_name) =~ s/^(start_|end_)//i;
+ if ($EXPORT{':any'} ||
+ $EXPORT{'-any'} ||
+ $EXPORT{$base} ||
+ (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
+ && $EXPORT_OK{$base}) {
+ $code = $CGI::DefaultClass->_make_tag_func($func_name);
+ }
+ }
+ croak("Undefined subroutine $AUTOLOAD\n") unless $code;
+ eval "package $pack; $code";
+ if ($@) {
+ $@ =~ s/ at .*\n//;
+ croak("$AUTOLOAD: $@");
+ }
+ }
+ CORE::delete($sub->{$func_name}); #free storage
+ return "$pack\:\:$func_name";
}
-# 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;
-
- return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-')
- || $self->use_named_parameters;
+sub _selected {
+ my $self = shift;
+ my $value = shift;
+ return '' unless $value;
+ return $XHTML ? qq( selected="selected") : qq( selected);
+}
- my $i;
- for ($i=0;$i<@param;$i+=2) {
- $param[$i]=~s/^\-//; # get rid of initial - if present
- $param[$i]=~tr/a-z/A-Z/; # parameters are upper case
- }
-
- my(%param) = @param; # convert into associative array
- my(@return_array);
-
- my($key)='';
- foreach $key (@$order) {
- my($value);
- # this is an awful hack to fix spurious warnings when the
- # -w switch is set.
- if (ref($key) && ref($key) eq 'ARRAY') {
- foreach (@$key) {
- last if defined($value);
- $value = $param{$_};
- delete $param{$_};
- }
- } else {
- $value = $param{$key};
- delete $param{$key};
+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$/;
+ $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$/) {
+ my($pkg) = caller(1);
+ *{"${pkg}::AUTOLOAD"} = sub {
+ my($routine) = $AUTOLOAD;
+ $routine =~ s/^.*::/CGI::/;
+ &$routine;
+ };
+ next;
+ }
+
+ foreach (&expand_tags($_)) {
+ tr/a-zA-Z0-9_//cd; # don't allow weird function names
+ $EXPORT{$_}++;
}
- push(@return_array,$value);
}
- push (@return_array,$self->make_attributes(\%param)) if %param;
- return (@return_array);
+ _compile_all(keys %EXPORT) if $compile;
+ @SAVED_SYMBOLS = @_;
+}
+
+sub charset {
+ my ($self,$charset) = self_or_default(@_);
+ $self->{'.charset'} = $charset if defined $charset;
+ $self->{'.charset'};
}
###############################################################################
@@ -650,32 +816,75 @@ END_OF_FUNC
sub MULTIPART { 'multipart/form-data'; }
END_OF_FUNC
-'HTML_FUNC' => <<'END_OF_FUNC',
-sub func_name {
+'SERVER_PUSH' => <<'END_OF_FUNC',
+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);
+}
+END_OF_FUNC
- # handle various cases in which we're called
- # most of this bizarre stuff is to avoid -w errors
- shift if $_[0] &&
- (!ref($_[0]) && $_[0] eq $CGI::DefaultClass) ||
- (ref($_[0]) &&
- (substr(ref($_[0]),0,3) eq 'CGI' ||
- eval "\$_[0]->isaCGI()"));
+'read_from_client' => <<'END_OF_FUNC',
+# Read data from a file handle
+sub read_from_client {
+ my($self, $fh, $buff, $len, $offset) = @_;
+ local $^W=0; # prevent a warning
+ return undef unless defined($fh);
+ return read($fh, $$buff, $len, $offset);
+}
+END_OF_FUNC
- my($attr) = '';
- if (ref($_[0]) && ref($_[0]) eq 'HASH') {
- my(@attr) = CGI::make_attributes('',shift);
- $attr = " @attr" if @attr;
+'delete' => <<'END_OF_FUNC',
+#### Method: delete
+# Deletes the named parameter entirely.
+####
+sub delete {
+ 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}++;
}
- my($tag,$untag) = ("\U","\U\E");
- return $tag unless @_;
- if (ref($_[0]) eq 'ARRAY') {
- my(@r);
- foreach (@{$_[0]}) {
- push(@r,"$tag$_$untag");
+ @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
+ return wantarray ? () : undef;
+}
+END_OF_FUNC
+
+#### Method: import_names
+# Import all parameters into the given namespace.
+# Assumes namespace 'Q' if not specified
+####
+'import_names' => <<'END_OF_FUNC',
+sub import_names {
+ my($self,$namespace,$delete) = self_or_default(@_);
+ $namespace = 'Q' unless defined($namespace);
+ die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
+ if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
+ # can anyone find an easier way to do this?
+ foreach (keys %{"${namespace}::"}) {
+ local *symbol = "${namespace}::${_}";
+ undef $symbol;
+ undef @symbol;
+ undef %symbol;
}
- return "@r";
- } else {
- return "$tag@_$untag";
+ }
+ my($param,@value,$var);
+ foreach $param ($self->param) {
+ # protect against silly names
+ ($var = $param)=~tr/a-zA-Z0-9_/_/c;
+ $var =~ s/^(?=\d)/_/;
+ local *symbol = "${namespace}::$var";
+ @value = $self->param($param);
+ @symbol = @value;
+ $symbol = $value[0];
}
}
END_OF_FUNC
@@ -690,13 +899,25 @@ sub keywords {
my($self,@values) = self_or_default(@_);
# If values is provided, then we set it.
$self->{'keywords'}=[@values] if @values;
- my(@result) = @{$self->{'keywords'}};
+ my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
@result;
}
END_OF_FUNC
# These are some tie() interfaces for compatibility
# with Steve Brenner's cgi-lib.pl routines
+'Vars' => <<'END_OF_FUNC',
+sub Vars {
+ my $q = shift;
+ my %in;
+ tie(%in,CGI,$q);
+ return %in if wantarray;
+ return \%in;
+}
+END_OF_FUNC
+
+# These are some tie() interfaces for compatibility
+# with Steve Brenner's cgi-lib.pl routines
'ReadParse' => <<'END_OF_FUNC',
sub ReadParse {
local(*in);
@@ -707,6 +928,7 @@ sub ReadParse {
*in=*{"${pkg}::in"};
}
tie(%in,CGI);
+ return scalar(keys %in);
}
END_OF_FUNC
@@ -752,14 +974,23 @@ sub MethPost {
END_OF_FUNC
'TIEHASH' => <<'END_OF_FUNC',
-sub TIEHASH {
- return new CGI;
+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
@@ -809,7 +1040,7 @@ END_OF_FUNC
'append' => <<'EOF',
sub append {
my($self,@p) = @_;
- my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
+ my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
if (@values) {
$self->add_parameter($name);
@@ -825,7 +1056,22 @@ EOF
'delete_all' => <<'EOF',
sub delete_all {
my($self) = self_or_default(@_);
- undef %{$self};
+ my @param = $self->param();
+ $self->delete(@param);
+}
+EOF
+
+'Delete' => <<'EOF',
+sub Delete {
+ my($self,@p) = self_or_default(@_);
+ $self->delete(@p);
+}
+EOF
+
+'Delete_all' => <<'EOF',
+sub Delete_all {
+ my($self,@p) = self_or_default(@_);
+ $self->delete_all(@p);
}
EOF
@@ -835,7 +1081,9 @@ 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
@@ -849,47 +1097,73 @@ sub version {
}
END_OF_FUNC
-'make_attributes' => <<'END_OF_FUNC',
-sub make_attributes {
- my($self,$attr) = @_;
- return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
- my(@att);
- foreach (keys %{$attr}) {
- my($key) = $_;
- $key=~s/^\-//; # get rid of initial - if present
- $key=~tr/a-z/A-Z/; # parameters are upper case
- push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/);
+#### Method: url_param
+# Return a parameter in the QUERY_STRING, regardless of
+# whether this was a POST or a GET
+####
+'url_param' => <<'END_OF_FUNC',
+sub url_param {
+ my ($self,@p) = self_or_default(@_);
+ my $name = shift(@p);
+ return undef unless exists($ENV{QUERY_STRING});
+ unless (exists($self->{'.url_param'})) {
+ $self->{'.url_param'}={}; # empty hash
+ if ($ENV{QUERY_STRING} =~ /=/) {
+ my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
+ my($param,$value);
+ foreach (@pairs) {
+ ($param,$value) = split('=',$_,2);
+ $param = unescape($param);
+ $value = unescape($value);
+ push(@{$self->{'.url_param'}->{$param}},$value);
+ }
+ } else {
+ $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
+ }
}
- return @att;
+ return keys %{$self->{'.url_param'}} unless defined($name);
+ return () unless $self->{'.url_param'}->{$name};
+ return wantarray ? @{$self->{'.url_param'}->{$name}}
+ : $self->{'.url_param'}->{$name}->[0];
}
END_OF_FUNC
-#### Method: dump
+#### 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 '
' unless $self->param;
- push(@result,"");
+ return '' unless $self->param;
+ push(@result,"");
foreach $param ($self->param) {
my($name)=$self->escapeHTML($param);
- push(@result,"- $param");
- push(@result,"
");
+ push(@result,"- $param
");
+ push(@result,"");
foreach $value ($self->param($param)) {
$value = $self->escapeHTML($value);
- push(@result,"- $value");
+ $value =~ s/\n/
\n/g;
+ push(@result," - $value
");
}
- push(@result,"
");
+ push(@result,"
");
}
- push(@result,"
\n");
+ push(@result,"
");
return join("\n",@result);
}
END_OF_FUNC
+#### Method as_string
+#
+# synonym for "dump"
+####
+'as_string' => <<'END_OF_FUNC',
+sub as_string {
+ &Dump(@_);
+}
+END_OF_FUNC
#### Method: save
# Write values out to a filehandle in such a way that they can
@@ -898,67 +1172,195 @@ END_OF_FUNC
'save' => <<'END_OF_FUNC',
sub save {
my($self,$filehandle) = self_or_default(@_);
- my($param);
- my($package) = caller;
-# Check that this still works!
-# $filehandle = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
$filehandle = to_filehandle($filehandle);
+ my($param);
+ local($,) = ''; # set print field separator back to a sane value
+ local($\) = ''; # set output line separator to a sane value
foreach $param ($self->param) {
- my($escaped_param) = &escape($param);
+ my($escaped_param) = escape($param);
my($value);
foreach $value ($self->param($param)) {
- print $filehandle "$escaped_param=",escape($value),"\n";
+ 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: header
-# Return a Content-Type: style header
-#
+#### Method: save_parameters
+# An alias for save() that is a better name for exportation.
+# Only intended to be used with the function (non-OO) interface.
####
-'header' => <<'END_OF_FUNC',
-sub header {
+'save_parameters' => <<'END_OF_FUNC',
+sub save_parameters {
+ my $fh = shift;
+ return save(to_filehandle($fh));
+}
+END_OF_FUNC
+
+#### Method: restore_parameters
+# A way to restore CGI parameters from an initializer.
+# Only intended to be used with the function (non-OO) interface.
+####
+'restore_parameters' => <<'END_OF_FUNC',
+sub restore_parameters {
+ $Q = $CGI::DefaultClass->new(@_);
+}
+END_OF_FUNC
+
+#### Method: multipart_init
+# Return a Content-Type: style header for server-push
+# This has to be NPH on most web servers, and it is advisable to set $| = 1
+#
+# Many thanks to Ed Jordan for this
+# 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) = rearrange([BOUNDARY],@p);
+ $boundary = $boundary || '------- =_aaaaaaaaaa0';
+ $self->{'separator'} = "$CRLF--$boundary$CRLF";
+ $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
+ $type = SERVER_PUSH($boundary);
+ return $self->header(
+ -nph => 1,
+ -type => $type,
+ (map { split "=", $_, 2 } @other),
+ ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
+}
+END_OF_FUNC
+
+
+#### Method: multipart_start
+# Return a Content-Type: style header for server-push, start of section
+#
+# Many thanks to Ed Jordan for this
+# 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) = rearrange([TYPE],@p);
+ $type = $type || 'text/html';
+ 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 MIME boundary separator for server-push, end of section
+#
+# Many thanks to Ed Jordan for this
+# contribution
+####
+'multipart_end' => <<'END_OF_FUNC',
+sub multipart_end {
+ my($self,@p) = self_or_default(@_);
+ return $self->{'separator'};
+}
+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
+#
+####
+'header' => <<'END_OF_FUNC',
+sub header {
my($self,@p) = self_or_default(@_);
my(@header);
- my($type,$status,$cookie,$target,$expires,$nph,@other) =
- $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
+ return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
+
+ 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;
+ }
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
foreach (@other) {
- next unless my($header,$value) = /([^\s=]+)=(.+)/;
- substr($header,1,1000)=~tr/A-Z/a-z/;
- ($value)=$value=~/^"(.*)"$/;
- $_ = "$header: $value";
+ # 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 = $type || 'text/html';
+ $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,'HTTP/1.0 ' . ($status || '200 OK')) if $nph || $NPH;
push(@header,"Status: $status") if $status;
- push(@header,"Window-target: $target") if $target;
+ 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) ? @{$cookie} : $cookie;
+ my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
foreach (@cookie) {
- push(@header,"Set-cookie: $_");
+ my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
+ push(@header,"Set-Cookie: $cs") if $cs ne '';
}
}
# if the user indicates an expiration time, then we need
# both an Expires and a Date header (so that the browser is
# uses OUR clock)
- push(@header,"Expires: " . &expires($expires)) if $expires;
- push(@header,"Date: " . &expires(0)) if $expires;
+ push(@header,"Expires: " . expires($expires,'http'))
+ if $expires;
+ push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
push(@header,"Pragma: no-cache") if $self->cache();
- push(@header,@other);
- push(@header,"Content-type: $type");
-
- my $header = join($CRLF,@header);
- return $header . "${CRLF}${CRLF}";
+ 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) {
+ $self->r->send_cgi_header($header);
+ return '';
+ }
+ return $header;
}
END_OF_FUNC
@@ -986,26 +1388,19 @@ END_OF_FUNC
'redirect' => <<'END_OF_FUNC',
sub redirect {
my($self,@p) = self_or_default(@_);
- my($url,$target,$cookie,$nph,@other) =
- $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p);
- $url = $url || $self->self_url;
+ my($url,$target,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,['COOKIE','COOKIES'],NPH],@p);
+ $url ||= $self->self_url;
my(@o);
- foreach (@other) { push(@o,split("=")); }
- if ($MOD_PERL or exists $self->{'.req'}) {
- my $r = $self->{'.req'} || Apache->request;
- $r->header_out(Location => $url);
- $r->err_header_out(Location => $url);
- $r->status(302);
- return;
- }
- push(@o,
- '-Status'=>'302 Found',
- '-Location'=>$url,
- '-URI'=>$url,
- '-nph'=>($nph||$NPH));
- push(@o,'-Target'=>$target) if $target;
- push(@o,'-Cookie'=>$cookie) if $cookie;
- return $self->header(@o);
+ foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
+ unshift(@o,
+ '-Status' => '302 Moved',
+ '-Location'=> $url,
+ '-nph' => $nph);
+ unshift(@o,'-Target'=>$target) if $target;
+ unshift(@o,'-Type'=>'');
+ my @unescaped;
+ unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
+ return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
}
END_OF_FUNC
@@ -1021,56 +1416,188 @@ END_OF_FUNC
# $xbase -> (optional) alternative base at some remote location (-xbase)
# $target -> (optional) target window to load all links into (-target)
# $script -> (option) Javascript code (-script)
+# $no_script -> (option) Javascript
END
;
my($other) = @other ? " @other" : '';
- push(@result,"");
+ push(@result,"");
return join("\n",@result);
}
END_OF_FUNC
+### Method: _style
+# internal method for generating a CSS style section
+####
+'_style' => <<'END_OF_FUNC',
+sub _style {
+ my ($self,$style) = @_;
+ my (@result);
+ my $type = 'text/css';
+
+ my $cdata_start = $XHTML ? "\n\n" : " -->\n";
+
+ if (ref($style)) {
+ my($src,$code,$verbatim,$stype,$foo,@other) =
+ rearrange([SRC,CODE,VERBATIM,TYPE],
+ '-foo'=>'bar', # trick to allow dash to be omitted
+ ref($style) eq 'ARRAY' ? @$style : %$style);
+ $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()
+ : qq()) if $src;
+ }
+ }
+ else
+ { # Otherwise, push the single -src, if it exists.
+ push(@result,$XHTML ? qq()
+ : qq()
+ ) if $src;
+ }
+ if ($verbatim) {
+ push(@result, "");
+ }
+ push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code;
+ } else {
+ my $src = $style;
+ push(@result,$XHTML ? qq()
+ : qq());
+ }
+ @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, $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, $type) = ('',$script,'JavaScript', 'text/javascript');
+ }
+
+ 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";
+ } else {
+ $cdata_start = "\n\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,script({@satts},$code || ''));
+ }
+ @result;
+}
+END_OF_FUNC
#### Method: end_html
# End an HTML document.
-# Trivial method for completeness. Just returns ""
+# Trivial method for completeness. Just returns ""
####
'end_html' => <<'END_OF_FUNC',
sub end_html {
- return "";
+ return "";
}
END_OF_FUNC
@@ -1084,14 +1611,14 @@ END_OF_FUNC
# Parameters:
# $action -> optional URL of script to run
# Returns:
-# A string containing a tag
+# A string containing a 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 "";
+ return $XHTML ? "" : "";
}
END_OF_FUNC
@@ -1107,15 +1634,20 @@ sub startform {
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';
+ $method = lc($method) || 'post';
$enctype = $enctype || &URL_ENCODED;
- $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
- 'ACTION="'.$self->script_name.'"' : '';
+ unless (defined $action) {
+ $action = $self->escapeHTML($self->url(-absolute=>1,-path=>1));
+ if (length($ENV{QUERY_STRING})>0) {
+ $action .= "?".$self->escapeHTML($ENV{QUERY_STRING},1);
+ }
+ }
+ $action = qq(action="$action");
my($other) = @other ? " @other" : '';
$self->{'.parametersToAdd'}={};
- return qq/");
+ if ( $NOSTICKY ) {
+ return wantarray ? ("") : "\n";
+ } else {
+ return wantarray ? ("",$self->get_fields,"
","") :
+ "".$self->get_fields ."
\n";
+ }
}
END_OF_FUNC
@@ -1167,6 +1708,28 @@ sub end_form {
END_OF_FUNC
+'_textfield' => <<'END_OF_FUNC',
+sub _textfield {
+ my($self,$tag,@p) = self_or_default(@_);
+ my($name,$default,$size,$maxlength,$override,@other) =
+ rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
+
+ my $current = $override ? $default :
+ (defined($self->param($name)) ? $self->param($name) : $default);
+
+ $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($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 $XHTML ? qq()
+ : qq();
+}
+END_OF_FUNC
+
#### Method: textfield
# Parameters:
# $name -> Name of the text field
@@ -1175,23 +1738,12 @@ END_OF_FUNC
# $size -> Optional width of field in characaters.
# $maxlength -> Optional maximum number of characters.
# Returns:
-# A string containing a field
+# A string containing a field
#
'textfield' => <<'END_OF_FUNC',
sub textfield {
my($self,@p) = self_or_default(@_);
- my($name,$default,$size,$maxlength,$override,@other) =
- $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
-
- my $current = $override ? $default :
- (defined($self->param($name)) ? $self->param($name) : $default);
-
- $current = defined($current) ? $self->escapeHTML($current) : '';
- $name = defined($name) ? $self->escapeHTML($name) : '';
- my($s) = defined($size) ? qq/ SIZE=$size/ : '';
- my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
- my($other) = @other ? " @other" : '';
- return qq//;
+ $self->_textfield('text',@p);
}
END_OF_FUNC
@@ -1202,24 +1754,12 @@ END_OF_FUNC
# $size -> Optional width of field in characaters.
# $maxlength -> Optional maximum number of characters.
# Returns:
-# A string containing a field
+# A string containing a field
#
'filefield' => <<'END_OF_FUNC',
sub filefield {
my($self,@p) = self_or_default(@_);
-
- my($name,$default,$size,$maxlength,$override,@other) =
- $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
-
- $current = $override ? $default :
- (defined($self->param($name)) ? $self->param($name) : $default);
-
- $name = defined($name) ? $self->escapeHTML($name) : '';
- my($s) = defined($size) ? qq/ SIZE=$size/ : '';
- my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
- $current = defined($current) ? $self->escapeHTML($current) : '';
- $other = ' ' . join(" ",@other);
- return qq//;
+ $self->_textfield('file',@p);
}
END_OF_FUNC
@@ -1233,28 +1773,15 @@ END_OF_FUNC
# $size -> Optional width of field in characters.
# $maxlength -> Optional maximum characters that can be entered.
# Returns:
-# A string containing a field
+# A string containing a field
#
'password_field' => <<'END_OF_FUNC',
sub password_field {
my ($self,@p) = self_or_default(@_);
-
- my($name,$default,$size,$maxlength,$override,@other) =
- $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
-
- my($current) = $override ? $default :
- (defined($self->param($name)) ? $self->param($name) : $default);
-
- $name = defined($name) ? $self->escapeHTML($name) : '';
- $current = defined($current) ? $self->escapeHTML($current) : '';
- my($s) = defined($size) ? qq/ SIZE=$size/ : '';
- my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
- my($other) = @other ? " @other" : '';
- return qq//;
+ $self->_textfield('password',@p);
}
END_OF_FUNC
-
#### Method: textarea
# Parameters:
# $name -> Name of the text field
@@ -1263,24 +1790,24 @@ END_OF_FUNC
# $rows -> Optional number of rows in text area
# $columns -> Optional number of columns in text area
# Returns:
-# A string containing a tag
+# A string containing a 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);
+ rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
my($current)= $override ? $default :
(defined($self->param($name)) ? $self->param($name) : $default);
$name = defined($name) ? $self->escapeHTML($name) : '';
$current = defined($current) ? $self->escapeHTML($current) : '';
- my($r) = $rows ? " ROWS=$rows" : '';
- my($c) = $cols ? " COLS=$cols" : '';
+ my($r) = $rows ? qq/ rows="$rows"/ : '';
+ my($c) = $cols ? qq/ cols="$cols"/ : '';
my($other) = @other ? " @other" : '';
- return qq{};
+ return qq{};
}
END_OF_FUNC
@@ -1293,27 +1820,28 @@ END_OF_FUNC
# $onclick -> (optional) Text of the JavaScript to run when the button is
# clicked.
# Returns:
-# A string containing a tag
+# A string containing a tag
####
'button' => <<'END_OF_FUNC',
sub button {
my($self,@p) = self_or_default(@_);
- my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
+ my($label,$value,$script,@other) = rearrange([NAME,[VALUE,LABEL],
[ONCLICK,SCRIPT]],@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//;
+ return $XHTML ? qq()
+ : qq();
}
END_OF_FUNC
@@ -1325,24 +1853,25 @@ 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 tag
+# A string containing a 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,@other) = rearrange([NAME,[VALUE,LABEL]],@p);
$label=$self->escapeHTML($label);
- $value=$self->escapeHTML($value);
+ $value=$self->escapeHTML($value,1);
- my($name) = ' NAME=".submit"';
- $name = qq/ NAME="$label"/ if $label;
- $value = $value || $label;
- my($val) = '';
- $val = qq/ VALUE="$value"/ if defined($value);
+ my($name) = ' name=".submit"' unless $NOSTICKY;
+ $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//;
+ return $XHTML ? qq()
+ : qq();
}
END_OF_FUNC
@@ -1352,16 +1881,22 @@ END_OF_FUNC
# Parameters:
# $name -> (optional) Name for the button.
# Returns:
-# A string containing a tag
+# A string containing a tag
####
'reset' => <<'END_OF_FUNC',
sub reset {
my($self,@p) = self_or_default(@_);
- my($label,@other) = $self->rearrange([NAME],@p);
+ my($label,$value,@other) = rearrange(['NAME',['VALUE','LABEL']],@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//;
+ return $XHTML ? qq()
+ : qq();
}
END_OF_FUNC
@@ -1371,7 +1906,7 @@ END_OF_FUNC
# Parameters:
# $name -> (optional) Name for the button.
# Returns:
-# A string containing a tag
+# A string containing a 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
@@ -1381,17 +1916,28 @@ END_OF_FUNC
sub defaults {
my($self,@p) = self_or_default(@_);
- my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
+ my($label,@other) = rearrange([[NAME,VALUE]],@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//;
+ return $XHTML ? qq()
+ : qq//;
}
END_OF_FUNC
+#### Method: comment
+# Create an HTML
+# Parameters: a string
+'comment' => <<'END_OF_FUNC',
+sub comment {
+ my($self,@p) = self_or_CGI(@_);
+ return "";
+}
+END_OF_FUNC
+
#### Method: checkbox
# Create a checkbox that is not logically linked to any others.
# The field value is "on" when the button is checked.
@@ -1402,31 +1948,31 @@ 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 field
+# A string containing a 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);
+ rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
- if (!$override && defined($self->param($name))) {
- $value = $self->param($name) unless defined $value;
- $checked = $self->param($name) eq $value ? ' CHECKED' : '';
+ $value = defined $value ? $value : 'on';
+
+ if (!$override && ($self->{'.fieldnames'}->{$name} ||
+ defined $self->param($name))) {
+ $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
} else {
- $checked = $checked ? ' CHECKED' : '';
- $value = defined $value ? $value : 'on';
+ $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" : '';
$self->register_parameter($name);
- return <$the_label
-END
+ return $XHTML ? qq{$the_label}
+ : qq{$the_label};
}
END_OF_FUNC
@@ -1450,16 +1996,16 @@ 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 fields
+# An ARRAY containing a series of fields
####
'checkbox_group' => <<'END_OF_FUNC',
sub checkbox_group {
my($self,@p) = self_or_default(@_);
- my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
+ my($name,$values,$defaults,$linebreak,$labels,$attributes,$rows,$columns,
$rowheaders,$colheaders,$override,$nolabels,@other) =
- $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
- LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
+ rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
+ LINEBREAK,LABELS,ATTRIBUTES,ROWS,[COLUMNS,COLS],
ROWHEADERS,COLHEADERS,
[OVERRIDE,FORCE],NOLABELS],@p);
@@ -1467,70 +2013,124 @@ sub checkbox_group {
my(%checked) = $self->previous_or_default($name,$defaults,$override);
- $break = $linebreak ? "
" : '';
+ if ($linebreak) {
+ $break = $XHTML ? "
" : "
";
+ }
+ else {
+ $break = '';
+ }
$name=$self->escapeHTML($name);
# Create the elements
- my(@elements);
- my(@values) = $values ? @$values : $self->param($name);
+ my(@elements,@values);
+
+ @values = $self->_set_values_and_labels($values,\$labels,$name);
+
my($other) = @other ? " @other" : '';
foreach (@values) {
- $checked = $checked{$_} ? ' CHECKED' : '';
+ $checked = $self->_checked($checked{$_});
$label = '';
unless (defined($nolabels) && $nolabels) {
$label = $_;
- $label = $labels->{$_} if defined($labels) && $labels->{$_};
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label = $self->escapeHTML($label);
}
- $_ = $self->escapeHTML($_);
- push(@elements,qq/${label} ${break}/);
+ my $attribs = $self->_set_attributes($_, $attributes);
+ $_ = $self->escapeHTML($_,1);
+ push(@elements,$XHTML ? qq(${label}${break})
+ : qq/${label}${break}/);
}
$self->register_parameter($name);
- return wantarray ? @elements : join('',@elements) unless $columns;
+ return wantarray ? @elements : join(' ',@elements)
+ unless defined($columns) || defined($rows);
+ $rows = 1 if $rows && $rows < 1;
+ $cols = 1 if $cols && $cols < 1;
return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
}
END_OF_FUNC
-
# Escape HTML -- used internally
'escapeHTML' => <<'END_OF_FUNC',
sub escapeHTML {
- my($self,$toencode) = @_;
- return undef unless defined($toencode);
- return $toencode if $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;
+ $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 ($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;
+ /^amp$/i ? "&" :
+ /^quot$/i ? '"' :
+ /^gt$/i ? ">" :
+ /^lt$/i ? "<" :
+ /^#(\d+)$/ && $latin ? chr($1) :
+ /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
+ $_
+ }gex;
+ return $string;
+}
+END_OF_FUNC
# Internal procedure - don't use
'_tableize' => <<'END_OF_FUNC',
sub _tableize {
my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
+ $rowheaders = [] unless defined $rowheaders;
+ $colheaders = [] unless defined $colheaders;
my($result);
- $rows = int(0.99 + @elements/$columns) unless $rows;
+ if (defined($columns)) {
+ $rows = int(0.99 + @elements/$columns) unless defined($rows);
+ }
+ if (defined($rows)) {
+ $columns = int(0.99 + @elements/$rows) unless defined($columns);
+ }
+
# rearrange into a pretty table
- $result = "";
+ $result = "";
my($row,$column);
unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
- $result .= "" if @{$colheaders};
+ $result .= "
" if @{$colheaders};
foreach (@{$colheaders}) {
- $result .= "$_ | ";
+ $result .= "$_ | ";
}
for ($row=0;$row<$rows;$row++) {
- $result .= "
";
- $result .= "$rowheaders->[$row] | " if @$rowheaders;
+ $result .= "
";
+ $result .= "$rowheaders->[$row] | " if @$rowheaders;
for ($column=0;$column<$columns;$column++) {
- $result .= "" . $elements[$column*$rows + $row] . " | ";
+ $result .= "" . $elements[$column*$rows + $row] . " | "
+ if defined($elements[$column*$rows + $row]);
}
- $result .= "
";
+ $result .= "";
}
- $result .= "
";
+ $result .= "
";
return $result;
}
END_OF_FUNC
@@ -1551,15 +2151,15 @@ 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 fields
+# An ARRAY containing a series of fields
####
'radio_group' => <<'END_OF_FUNC',
sub radio_group {
my($self,@p) = self_or_default(@_);
- my($name,$values,$default,$linebreak,$labels,
+ my($name,$values,$default,$linebreak,$labels,$attributes,
$rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
- $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
+ rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,ATTRIBUTES,
ROWS,[COLUMNS,COLS],
ROWHEADERS,COLHEADERS,
[OVERRIDE,FORCE],NOLABELS],@p);
@@ -1570,27 +2170,37 @@ sub radio_group {
} else {
$checked = $default;
}
+ my(@elements,@values);
+ @values = $self->_set_values_and_labels($values,\$labels,$name);
+
# If no check array is specified, check the first by default
- $checked = $values->[0] unless $checked;
+ $checked = $values[0] unless defined($checked) && $checked ne '';
$name=$self->escapeHTML($name);
- my(@elements);
- my(@values) = $values ? @$values : $self->param($name);
my($other) = @other ? " @other" : '';
foreach (@values) {
- my($checkit) = $checked eq $_ ? ' CHECKED' : '';
- my($break) = $linebreak ? '
' : '';
+ my($checkit) = $checked eq $_ ? qq/ checked="checked"/ : '';
+ my($break);
+ if ($linebreak) {
+ $break = $XHTML ? "
" : "
";
+ }
+ else {
+ $break = '';
+ }
my($label)='';
unless (defined($nolabels) && $nolabels) {
$label = $_;
- $label = $labels->{$_} if defined($labels) && $labels->{$_};
- $label = $self->escapeHTML($label);
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ $label = $self->escapeHTML($label,1);
}
+ my $attribs = $self->_set_attributes($_, $attributes);
$_=$self->escapeHTML($_);
- push(@elements,qq/${label} ${break}/);
+ push(@elements,$XHTML ? qq(${label}${break})
+ : qq/${label}${break}/);
}
$self->register_parameter($name);
- return wantarray ? @elements : join('',@elements) unless $columns;
+ return wantarray ? @elements : join(' ',@elements)
+ unless defined($columns) || defined($rows);
return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
}
END_OF_FUNC
@@ -1614,8 +2224,9 @@ END_OF_FUNC
sub popup_menu {
my($self,@p) = self_or_default(@_);
- my($name,$values,$default,$labels,$override,@other) =
- $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
+ my($name,$values,$default,$labels,$attributes,$override,@other) =
+ rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
+ ATTRIBUTES,[OVERRIDE,FORCE]],@p);
my($result,$selected);
if (!$override && defined($self->param($name))) {
@@ -1626,18 +2237,90 @@ sub popup_menu {
$name=$self->escapeHTML($name);
my($other) = @other ? " @other" : '';
- my(@values) = $values ? @$values : $self->param($name);
- $result = qq/";
+ 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