X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI.pm;h=c0cb5fd518a75113f1dae6241becdbf216b0dcac;hb=9bea678f36dc293400ada67aa122ef456a9dcf74;hp=e53c9576777643e6eb4875adf7d292f2ac59b700;hpb=7d37aa8ee0fac2db54fce8cbb5b1e5e3c1188e88;p=p5sagit%2Fp5-mst-13.2.git
diff --git a/lib/CGI.pm b/lib/CGI.pm
index e53c957..c0cb5fd 100644
--- a/lib/CGI.pm
+++ b/lib/CGI.pm
@@ -1,5 +1,5 @@
package CGI;
-require 5.001;
+require 5.004;
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
@@ -8,49 +8,80 @@ 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/
-
-# Set this to 1 to enable copious autoloader debugging messages
-$AUTOLOAD_DEBUG=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 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;
-
-$CGI::revision = '$Id: CGI.pm,v 2.36 1997/5/10 8:22 lstein Exp $';
-$CGI::VERSION='2.36';
-
-# OVERRIDE THE OS HERE IF CGI.pm GUESSES WRONG
-# $OS = 'UNIX';
-# $OS = 'MACINTOSH';
-# $OS = 'WINDOWS';
-# $OS = 'VMS';
-# $OS = 'OS2';
+# http://stein.cshl.org/WWW/software/CGI/
+
+$CGI::revision = '$Id: CGI.pm,v 1.18 1999/06/09 14:52:45 lstein Exp $';
+$CGI::VERSION='2.53';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
# $TempFile::TMPDIRECTORY = '/usr/tmp';
+# >>>>> Here are some globals that you might want to adjust <<<<<<
+sub initialize_globals {
+ # Set this to 1 to enable copious autoloader debugging messages
+ $AUTOLOAD_DEBUG = 0;
+
+ # Change this to the preferred DTD to print in start_html()
+ # or use default_dtd('text of DTD to use');
+ $DEFAULT_DTD = '-//IETF//DTD HTML//EN';
+
+ # Set this to 1 to enable NPH scripts
+ # or:
+ # 1) use CGI qw(-nph)
+ # 2) $CGI::nph(1)
+ # 3) print header(-nph=>1)
+ $NPH = 0;
+
+ # Set this to 1 to disable debugging from the
+ # command line
+ $NO_DEBUG = 0;
+
+ # Set this to 1 to make the temporary files created
+ # during file uploads safe from prying eyes
+ # or do...
+ # 1) use CGI qw(:private_tempfiles)
+ # 2) $CGI::private_tempfiles(1);
+ $PRIVATE_TEMPFILES = 0;
+
+ # Set this to a positive value to limit the size of a POSTing
+ # to a certain number of bytes:
+ $POST_MAX = -1;
+
+ # Change this to 1 to disable uploads entirely:
+ $DISABLE_UPLOADS = 0;
+
+ # Automatically determined -- don't change
+ $EBCDIC = 0;
+
+ # Change this to 1 to suppress redundant HTTP headers
+ $HEADERS_ONCE = 0;
+
+ # separate the name=value pairs by semicolons rather than ampersands
+ $USE_PARAM_SEMICOLONS = 0;
+
+ # Other globals that you shouldn't worry about.
+ undef $Q;
+ $BEEN_THERE = 0;
+ undef @QUERY_PARAM;
+ undef %EXPORT;
+
+ # prevent complaints by mod_perl
+ 1;
+}
+
# ------------------ START OF THE LIBRARY ------------
+# make mod_perlhappy
+initialize_globals();
+
# FIGURE OUT THE OS WE'RE RUNNING UNDER
# Some systems support the $^O variable. If not
# available then require() the Config library
@@ -61,10 +92,12 @@ unless ($OS) {
}
}
if ($OS=~/Win/i) {
- $OS = 'WINDOWS';
+ $OS = 'WINDOWS';
} elsif ($OS=~/vms/i) {
- $OS = 'VMS';
-} elsif ($OS=~/Mac/i) {
+ $OS = 'VMS';
+} elsif ($OS=~/dos/i) {
+ $OS = 'DOS';
+} elsif ($OS=~/^MacOS$/i) {
$OS = 'MACINTOSH';
} elsif ($OS=~/os2/i) {
$OS = 'OS2';
@@ -73,81 +106,117 @@ if ($OS=~/Win/i) {
}
# Some OS logic. Binary mode enabled on DOS, NT and VMS
-$needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/;
+$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/;
# This is the default class for the CGI object to use when all else fails.
$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
+
# This is where to look for autoloaded routines.
$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
# The path separator is a slash, backslash or semicolon, depending
# on the paltform.
$SL = {
- UNIX=>'/',
- OS2=>'\\',
- WINDOWS=>'\\',
- MACINTOSH=>':',
- VMS=>'\\'
+ UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
}->{$OS};
+# This no longer seems to be necessary
# Turn on NPH scripts by default when running under IIS server!
-$NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
+# $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($ENV{'GATEWAY_INTERFACE'}) && ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)) {
- $NPH++;
+if (exists $ENV{'GATEWAY_INTERFACE'}
+ &&
+ ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
+{
$| = 1;
- $SEQNO = 1;
+ require Apache;
+}
+# Turn on special checking for ActiveState's PerlEx
+$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
+
+# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
+# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
+# and sometimes CR). The most popular VMS web server
+# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
+# use ASCII, so \015\012 means something different. I find this all
+# really annoying.
+$EBCDIC = "\t" ne "\011";
+if ($OS eq 'VMS') {
+ $CRLF = "\n";
+} elsif ($EBCDIC) {
+ $CRLF= "\r\n";
+} else {
+ $CRLF = "\015\012";
+}
+
+if ($EBCDIC) {
+@A2E = (
+ 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
+ 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
+240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
+124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
+215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
+121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
+151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7,
+ 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27,
+ 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255,
+ 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
+144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
+100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
+172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
+ 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
+140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
+ );
}
-# This is really "\r\n", but the meaning of \n is different
-# in MacPerl, so we resort to octal here.
-$CRLF = "\015\012";
-
if ($needs_binmode) {
$CGI::DefaultClass->binmode(main::STDOUT);
$CGI::DefaultClass->binmode(main::STDIN);
$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 style span/],
- ':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 use_named_parameters
- 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/],
+ ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param
+ embed basefont style span layer ilayer font frameset frame script small big/],
+ ':netscape'=>[qw/blink fontsize center/],
+ ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
+ submit reset defaults radio_group popup_menu button autoEscape
+ scrolling_list image_button start_form end_form startform endform
+ start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
+ ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump
+ raw_cookie request_method query_string Accept user_agent remote_host content_type
+ remote_addr referer server_name server_software server_port server_protocol
+ virtual_host remote_ident auth_type http use_named_parameters
+ save_parameters restore_parameters param_fetch
+ remote_user user_name header redirect import_names put
+ Delete Delete_all url_param cgi_error/],
+ ':ssl' => [qw/https/],
+ ':imagemap' => [qw/Area Map/],
+ ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
+ ':html' => [qw/:html2 :html3 :netscape/],
+ ':standard' => [qw/:html2 :html3 :form :cgi/],
+ ':push' => [qw/multipart_init multipart_start multipart_end/],
+ ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/]
+ );
# to import symbols into caller
sub import {
my $self = shift;
+
+# This causes modules to clash.
+# undef %EXPORT_OK;
+# undef %EXPORT;
+
+ $self->_setup_symbols(@_);
my ($callpack, $callfile, $callline) = caller;
- foreach (@_) {
- $NPH++, next if $_ eq ':nph';
- $PRIVATE_TEMPFILES++, next if $_ eq ':private_tempfiles';
- 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"});
@@ -164,8 +233,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}}) {
@@ -182,8 +257,11 @@ 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;
+ if ($MOD_PERL) {
+ Apache->request->register_cleanup(\&CGI::_reset_globals);
+ undef $NPH;
+ }
+ $self->_reset_globals if $PERLEX;
$self->init($initializer);
return $self;
}
@@ -230,98 +308,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;
-}
-
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
@@ -337,14 +349,13 @@ sub use_named_parameters {
sub init {
my($self,$initializer) = @_;
- my($query_string,@lines);
- my($meth) = '';
+ my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
+ local($/) = "\n";
# if we get called more than once, we want to initialize
# ourselves from the original query (which may be gone
# if it was read from STDIN originally.)
- if (defined(@QUERY_PARAM) && !defined($initializer)) {
-
+ if (@QUERY_PARAM && !defined($initializer)) {
foreach (@QUERY_PARAM) {
$self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
}
@@ -352,12 +363,37 @@ sub init {
}
$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;
- # 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)) {
+ $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->{$_});
@@ -365,9 +401,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,$_);
@@ -380,49 +415,45 @@ 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 = Apache->request->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'};
}
+ 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() unless $NO_DEBUG;
}
-
+
# 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 ne '') {
if ($query_string =~ /=/) {
$self->parse_params($query_string);
} else {
@@ -447,39 +478,23 @@ sub init {
$self->delete('.submit');
$self->delete('.cgifields');
$self->save_request unless $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
@@ -494,18 +509,34 @@ sub print {
CORE::print(@_);
}
+# get/set last cgi_error
+sub cgi_error {
+ my ($self,$err) = self_or_default(@_);
+ $self->{'.cgi_error'} = $err if defined $err;
+ return $self->{'.cgi_error'};
+}
+
# unescape URL-encoded data
sub unescape {
- my($todecode) = @_;
- $todecode =~ tr/+/ /; # pluses become spaces
- $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
- return $todecode;
+ shift() if ref($_[0]) || $_[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 {
- my($toencode) = @_;
- $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
+ shift() if ref($_[0]) || $_[0] eq $DefaultClass;
+ my $toencode = shift;
+ return undef unless defined($toencode);
+ $toencode=~s/ /+/g;
+ $toencode=~s/([^a-zA-Z0-9_.+-])/uc sprintf("%%%02x",ord($1))/eg;
return $toencode;
}
@@ -520,22 +551,14 @@ sub save_request {
}
}
-sub parse_keywordlist {
- my($self,$tosplit) = @_;
- $tosplit = &unescape($tosplit); # unescape the keywords
- $tosplit=~tr/+/ /; # pluses to spaces
- my(@keywords) = split(/\s+/,$tosplit);
- return @keywords;
-}
-
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);
+ $param = unescape($param);
+ $value = unescape($value);
$self->add_parameter($param);
push (@{$self->{$param}},$value);
}
@@ -554,46 +577,46 @@ 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 {
+ shift if \$_[0] &&
+# (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) ||
+ (ref(\$_[0]) &&
+ (substr(ref(\$_[0]),0,3) eq 'CGI' ||
+ UNIVERSAL::isa(\$_[0],'CGI')));
+
+ my(\$attr) = '';
+ if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') {
+ my(\@attr) = make_attributes( '',shift() );
+ \$attr = " \@attr" if \@attr;
+ }
+ );
+ if ($tagname=~/start_(\w+)/i) {
+ $func .= qq! return "<\U$1\E\$attr>";} !;
+ } elsif ($tagname=~/end_(\w+)/i) {
+ $func .= qq! return "<\U/$1\E>"; } !;
+ } else {
+ $func .= qq#
+ my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U$tagname>\E");
+ return \$tag unless \@_;
+ my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
+ return "\@result";
+ }#;
+ }
+return $func;
}
sub AUTOLOAD {
print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
- my($func) = $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 $func = &_compile;
+ goto &$func;
}
# PRIVATE SUBROUTINE
@@ -604,38 +627,112 @@ sub AUTOLOAD {
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;
- 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
+ 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;
}
-
- 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{$_};
- }
+
+ # 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 {
- $value = $param{$key};
- delete $param{$key};
+ $leftover{$key} = shift(@param);
+ }
+ }
+
+ push (@result,$self->make_attributes(\%leftover)) if %leftover;
+ @result;
+}
+
+sub _compile {
+ my($func) = $AUTOLOAD;
+ my($pack,$func_name);
+ {
+ local($1,$2); # this fixes an obscure variable suicide problem.
+ $func=~/(.+)::([^:]+)$/;
+ ($pack,$func_name) = ($1,$2);
+ $pack=~s/::SUPER$//; # fix another obscure problem
+ $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
+ unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
+
+ my($sub) = \%{"$pack\:\:SUBS"};
+ unless (%$sub) {
+ my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
+ eval "package $pack; $$auto";
+ die $@ if $@;
+ $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
+ }
+ my($code) = $sub->{$func_name};
+
+ $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
+ if (!$code) {
+ (my $base = $func_name) =~ s/^(start_|end_)//i;
+ if ($EXPORT{':any'} ||
+ $EXPORT{'-any'} ||
+ $EXPORT{$base} ||
+ (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
+ && $EXPORT_OK{$base}) {
+ $code = $CGI::DefaultClass->_make_tag_func($func_name);
+ }
+ }
+ die "Undefined subroutine $AUTOLOAD\n" unless $code;
+ eval "package $pack; $code";
+ if ($@) {
+ $@ =~ s/ at .*\n//;
+ die $@;
+ }
+ }
+ CORE::delete($sub->{$func_name}); #free storage
+ return "$pack\:\:$func_name";
+}
+
+sub _reset_globals { initialize_globals(); }
+
+sub _setup_symbols {
+ my $self = shift;
+ my $compile = 0;
+ foreach (@_) {
+ $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
+ $NPH++, next if /^[:-]nph$/;
+ $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/;
+ $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
+ $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
+ $EXPORT{$_}++, next if /^[:-]any$/;
+ $compile++, next if /^[:-]compile$/;
+
+ # This is probably extremely evil code -- to be deleted some day.
+ if (/^[-]autoload$/) {
+ my($pkg) = caller(1);
+ *{"${pkg}::AUTOLOAD"} = sub {
+ my($routine) = $AUTOLOAD;
+ $routine =~ s/^.*::/CGI::/;
+ &$routine;
+ };
+ next;
+ }
+
+ foreach (&expand_tags($_)) {
+ tr/a-zA-Z0-9_//cd; # don't allow weird function names
+ $EXPORT{$_}++;
}
- push(@return_array,$value);
}
- push (@return_array,$self->make_attributes(\%param)) if %param;
- return (@return_array);
+ _compile_all(keys %EXPORT) if $compile;
}
###############################################################################
@@ -654,32 +751,83 @@ 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
+
+'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);
- # 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()"));
+ # stupidity to avoid annoying warnings
+ return $self->{'.named'}=$use_named;
+}
+END_OF_FUNC
- my($attr) = '';
- if (ref($_[0]) && ref($_[0]) eq 'HASH') {
- my(@attr) = CGI::make_attributes('',shift);
- $attr = " @attr" if @attr;
- }
- my($tag,$untag) = ("\U","\U\E");
- return $tag unless @_;
- if (ref($_[0]) eq 'ARRAY') {
- my(@r);
- foreach (@{$_[0]}) {
- push(@r,"$tag$_$untag");
+'new_MultipartBuffer' => <<'END_OF_FUNC',
+# Create a new multipart buffer
+sub new_MultipartBuffer {
+ my($self,$boundary,$length,$filehandle) = @_;
+ return MultipartBuffer->new($self,$boundary,$length,$filehandle);
+}
+END_OF_FUNC
+
+'read_from_client' => <<'END_OF_FUNC',
+# Read data from a file handle
+sub read_from_client {
+ my($self, $fh, $buff, $len, $offset) = @_;
+ local $^W=0; # prevent a warning
+ return undef unless defined($fh);
+ return read($fh, $$buff, $len, $offset);
+}
+END_OF_FUNC
+
+'delete' => <<'END_OF_FUNC',
+#### Method: delete
+# Deletes the named parameter entirely.
+####
+sub delete {
+ my($self,$name) = self_or_default(@_);
+ CORE::delete $self->{$name};
+ CORE::delete $self->{'.fieldnames'}->{$name};
+ @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
+ return wantarray ? () : undef;
+}
+END_OF_FUNC
+
+#### Method: import_names
+# Import all parameters into the given namespace.
+# Assumes namespace 'Q' if not specified
+####
+'import_names' => <<'END_OF_FUNC',
+sub import_names {
+ my($self,$namespace,$delete) = self_or_default(@_);
+ $namespace = 'Q' unless defined($namespace);
+ die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
+ if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
+ # can anyone find an easier way to do this?
+ foreach (keys %{"${namespace}::"}) {
+ local *symbol = "${namespace}::${_}";
+ undef $symbol;
+ undef @symbol;
+ undef %symbol;
}
- 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
@@ -694,13 +842,24 @@ 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 %in;
+ tie(%in,CGI);
+ 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);
@@ -711,6 +870,7 @@ sub ReadParse {
*in=*{"${pkg}::in"};
}
tie(%in,CGI);
+ return scalar(keys %in);
}
END_OF_FUNC
@@ -757,7 +917,7 @@ END_OF_FUNC
'TIEHASH' => <<'END_OF_FUNC',
sub TIEHASH {
- return new CGI;
+ return $Q || new CGI;
}
END_OF_FUNC
@@ -833,11 +993,25 @@ sub delete_all {
}
EOF
-#### Method: autoescape
-# If you want to turn off the autoescaping features,
-# call this method with undef as the argument
-'autoEscape' => <<'END_OF_FUNC',
-sub autoEscape {
+'Delete' => <<'EOF',
+sub Delete {
+ my($self,@p) = self_or_default(@_);
+ $self->delete(@p);
+}
+EOF
+
+'Delete_all' => <<'EOF',
+sub Delete_all {
+ my($self,@p) = self_or_default(@_);
+ $self->delete_all(@p);
+}
+EOF
+
+#### Method: autoescape
+# If you want to turn off the autoescaping features,
+# call this method with undef as the argument
+'autoEscape' => <<'END_OF_FUNC',
+sub autoEscape {
my($self,$escape) = self_or_default(@_);
$self->{'dontescape'}=!$escape;
}
@@ -861,13 +1035,44 @@ sub make_attributes {
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/);
+ $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
+ push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/);
}
return @att;
}
END_OF_FUNC
+#### Method: url_param
+# Return a parameter in the QUERY_STRING, regardless of
+# whether this was a POST or a GET
+####
+'url_param' => <<'END_OF_FUNC',
+sub url_param {
+ my ($self,@p) = self_or_default(@_);
+ my $name = shift(@p);
+ return undef unless exists($ENV{QUERY_STRING});
+ unless (exists($self->{'.url_param'})) {
+ $self->{'.url_param'}={}; # empty hash
+ if ($ENV{QUERY_STRING} =~ /=/) {
+ my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
+ my($param,$value);
+ foreach (@pairs) {
+ ($param,$value) = split('=',$_,2);
+ $param = unescape($param);
+ $value = unescape($value);
+ push(@{$self->{'.url_param'}->{$param}},$value);
+ }
+ } else {
+ $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
+ }
+ }
+ return keys %{$self->{'.url_param'}} unless defined($name);
+ return () unless $self->{'.url_param'}->{$name};
+ return wantarray ? @{$self->{'.url_param'}->{$name}}
+ : $self->{'.url_param'}->{$name}->[0];
+}
+END_OF_FUNC
+
#### Method: dump
# Returns a string in which all the known parameter/value
# pairs are represented as nested lists, mainly for the purposes
@@ -885,6 +1090,7 @@ sub dump {
push(@result,"
");
foreach $value ($self->param($param)) {
$value = $self->escapeHTML($value);
+ $value =~ s/\n/
\n/g;
push(@result,"- $value");
}
push(@result,"
");
@@ -894,6 +1100,15 @@ sub dump {
}
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
@@ -902,16 +1117,15 @@ 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";
}
}
print $filehandle "=\n"; # end of record
@@ -919,6 +1133,83 @@ sub save {
END_OF_FUNC
+#### Method: save_parameters
+# An alias for save() that is a better name for exportation.
+# Only intended to be used with the function (non-OO) interface.
+####
+'save_parameters' => <<'END_OF_FUNC',
+sub save_parameters {
+ my $fh = shift;
+ return save(to_filehandle($fh));
+}
+END_OF_FUNC
+
+#### Method: restore_parameters
+# A way to restore CGI parameters from an initializer.
+# Only intended to be used with the function (non-OO) interface.
+####
+'restore_parameters' => <<'END_OF_FUNC',
+sub restore_parameters {
+ $Q = $CGI::DefaultClass->new(@_);
+}
+END_OF_FUNC
+
+#### Method: multipart_init
+# Return a Content-Type: style header for server-push
+# This has to be NPH, and it is advisable to set $| = 1
+#
+# Many thanks to Ed Jordan for this
+# contribution
+####
+'multipart_init' => <<'END_OF_FUNC',
+sub multipart_init {
+ my($self,@p) = self_or_default(@_);
+ my($boundary,@other) = $self->rearrange([BOUNDARY],@p);
+ $boundary = $boundary || '------- =_aaaaaaaaaa0';
+ $self->{'separator'} = "\n--$boundary\n";
+ $type = SERVER_PUSH($boundary);
+ return $self->header(
+ -nph => 1,
+ -type => $type,
+ (map { split "=", $_, 2 } @other),
+ ) . $self->multipart_end;
+}
+END_OF_FUNC
+
+
+#### Method: multipart_start
+# Return a Content-Type: style header for server-push, start of section
+#
+# Many thanks to Ed Jordan for this
+# contribution
+####
+'multipart_start' => <<'END_OF_FUNC',
+sub multipart_start {
+ my($self,@p) = self_or_default(@_);
+ my($type,@other) = $self->rearrange([TYPE],@p);
+ $type = $type || 'text/html';
+ return $self->header(
+ -type => $type,
+ (map { split "=", $_, 2 } @other),
+ );
+}
+END_OF_FUNC
+
+
+#### Method: multipart_end
+# Return a Content-Type: style header for server-push, end of section
+#
+# Many thanks to Ed Jordan for this
+# contribution
+####
+'multipart_end' => <<'END_OF_FUNC',
+sub multipart_end {
+ my($self,@p) = self_or_default(@_);
+ return $self->{'separator'};
+}
+END_OF_FUNC
+
+
#### Method: header
# Return a Content-Type: style header
#
@@ -928,42 +1219,53 @@ sub header {
my($self,@p) = self_or_default(@_);
my(@header);
+ return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
+
my($type,$status,$cookie,$target,$expires,$nph,@other) =
- $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
+ $self->rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
+ STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
+ $nph ||= $NPH;
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
foreach (@other) {
- next unless my($header,$value) = /([^\s=]+)=(.+)/;
- substr($header,1,1000)=~tr/A-Z/a-z/;
- ($value)=$value=~/^"(.*)"$/;
- $_ = "$header: $value";
+ next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
+ ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e;
}
- $type = $type || 'text/html';
+ $type ||= 'text/html' unless defined($type);
+
+ # Maybe future compatibility. Maybe not.
+ my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
+ push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
- push(@header,'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;
# 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: " . &date(&expire_calc($expires),'http'))
+ push(@header,"Expires: " . expires($expires,'http'))
if $expires;
- push(@header,"Date: " . &date(&expire_calc(0),'http')) if $expires || $cookie;
+ push(@header,"Date: " . expires(0,'http')) if $expires || $cookie;
push(@header,"Pragma: no-cache") if $self->cache();
push(@header,@other);
- push(@header,"Content-type: $type");
+ push(@header,"Content-Type: $type") if $type ne '';
- my $header = join($CRLF,@header);
- return $header . "${CRLF}${CRLF}";
+ my $header = join($CRLF,@header)."${CRLF}${CRLF}";
+ if ($MOD_PERL and not $nph) {
+ my $r = Apache->request;
+ $r->send_cgi_header($header);
+ return '';
+ }
+ return $header;
}
END_OF_FUNC
@@ -991,24 +1293,17 @@ 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);
+ my($url,$target,$cookie,$nph,@other) = $self->rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p);
$url = $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',
+ foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
+ unshift(@o,
+ '-Status'=>'302 Moved',
'-Location'=>$url,
- '-URI'=>$url,
- '-nph'=>($nph||$NPH));
- push(@o,'-Target'=>$target) if $target;
- push(@o,'-Cookie'=>$cookie) if $cookie;
+ '-nph'=>$nph);
+ unshift(@o,'-Target'=>$target) if $target;
+ unshift(@o,'-Cookie'=>$cookie) if $cookie;
+ unshift(@o,'-Type'=>'');
return $self->header(@o);
}
END_OF_FUNC
@@ -1036,20 +1331,21 @@ END_OF_FUNC
'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,@other) =
- $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE],@p);
+ my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,@other) =
+ $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD],@p);
# strangely enough, the title needs to be escaped as HTML
# while the author needs to be escaped as a URL
$title = $self->escapeHTML($title || 'Untitled Document');
- $author = $self->escapeHTML($author);
+ $author = $self->escape($author);
my(@result);
- push(@result,'');
+ $dtd = $DEFAULT_DTD unless $dtd && $dtd =~ m|^-//|;
+ push(@result,qq()) if $dtd;
push(@result,"$title");
- push(@result,"") if $author;
+ push(@result,"") if defined $author;
if ($base || $xbase || $target) {
- my $href = $xbase || $self->url();
+ my $href = $xbase || $self->url('-path'=>1);
my $t = $target ? qq/ TARGET="$target"/ : '';
push(@result,qq//);
}
@@ -1060,29 +1356,60 @@ sub start_html {
push(@result,ref($head) ? @$head : $head) if $head;
- # handle various types of -style parameters
- if ($style) {
- if (ref($style)) {
- my($src,$code,@other) =
- $self->rearrange([SRC,CODE],
- '-foo'=>'bar', # a trick to allow the '-' to be omitted
- ref($style) eq 'ARRAY' ? @$style : %$style);
- push(@result,qq//) if $src;
- push(@result,style($code)) if $code;
- } else {
- push(@result,style($style))
- }
+ # handle the infrequently-used -style and -script parameters
+ push(@result,$self->_style($style)) if defined $style;
+ push(@result,$self->_script($script)) if defined $script;
+
+ # handle -noscript parameter
+ push(@result,<
+$noscript
+
+END
+ ;
+ my($other) = @other ? " @other" : '';
+ 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';
+ 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//) if $src;
+ push(@result,style({'type'=>$type},"")) if $code;
+ } else {
+ push(@result,style({'type'=>$type},""));
}
+ @result;
+}
+END_OF_FUNC
+
- # handle -script parameter
- if ($script) {
+'_script' => <<'END_OF_FUNC',
+sub _script {
+ my ($self,$script) = @_;
+ my (@result);
+ my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
+ foreach $script (@scripts) {
my($src,$code,$language);
if (ref($script)) { # script is a hash
($src,$code,$language) =
$self->rearrange([SRC,CODE,LANGUAGE],
'-foo'=>'bar', # a trick to allow the '-' to be omitted
- ref($style) eq 'ARRAY' ? @$script : %$script);
-
+ ref($script) eq 'ARRAY' ? @$script : %$script);
+
} else {
($src,$code,$language) = ('',$script,'JavaScript');
}
@@ -1093,23 +1420,12 @@ sub start_html {
if $code && $language=~/javascript/i;
$code = ""
if $code && $language=~/perl/i;
- push(@result,script({@satts},$code));
+ push(@result,script({@satts},$code || ''));
}
-
- # handle -noscript parameter
- push(@result,<
-$noscript
-
-END
- ;
- my($other) = @other ? " @other" : '';
- push(@result,"");
- return join("\n",@result);
+ @result;
}
END_OF_FUNC
-
#### Method: end_html
# End an HTML document.
# Trivial method for completeness. Just returns ""
@@ -1174,6 +1490,11 @@ sub start_form {
}
END_OF_FUNC
+'end_multipart_form' => <<'END_OF_FUNC',
+sub end_multipart_form {
+ &endform;
+}
+END_OF_FUNC
#### Method: start_multipart_form
# synonym for startform
@@ -1213,6 +1534,27 @@ 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) =
+ $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
+
+ my $current = $override ? $default :
+ (defined($self->param($name)) ? $self->param($name) : $default);
+
+ $current = defined($current) ? $self->escapeHTML($current) : '';
+ $name = defined($name) ? $self->escapeHTML($name) : '';
+ my($s) = defined($size) ? qq/ SIZE=$size/ : '';
+ my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
+ my($other) = @other ? " @other" : '';
+ # this entered at cristy's request to fix problems with file upload fields
+ # and WebTV -- not sure it won't break stuff
+ my($value) = $current ne '' ? qq(VALUE="$current") : '';
+ return qq//;
+}
+END_OF_FUNC
+
#### Method: textfield
# Parameters:
# $name -> Name of the text field
@@ -1226,18 +1568,7 @@ END_OF_FUNC
'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
@@ -1253,19 +1584,7 @@ END_OF_FUNC
'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
@@ -1284,23 +1603,10 @@ END_OF_FUNC
'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
@@ -1383,8 +1689,8 @@ sub submit {
$value=$self->escapeHTML($value);
my($name) = ' NAME=".submit"';
- $name = qq/ NAME="$label"/ if $label;
- $value = $value || $label;
+ $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" : '';
@@ -1438,6 +1744,16 @@ sub defaults {
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.
@@ -1457,12 +1773,13 @@ sub checkbox {
my($name,$checked,$value,$label,$override,@other) =
$self->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)) ? ' CHECKED' : '';
} else {
$checked = $checked ? ' CHECKED' : '';
- $value = defined $value ? $value : 'on';
}
my($the_label) = defined $label ? $label : $name;
$name = $self->escapeHTML($name);
@@ -1470,9 +1787,7 @@ sub checkbox {
$the_label = $self->escapeHTML($the_label);
my($other) = @other ? " @other" : '';
$self->register_parameter($name);
- return <$the_label
-END
+ return qq{$the_label};
}
END_OF_FUNC
@@ -1517,33 +1832,36 @@ sub checkbox_group {
$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' : '';
$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}/);
+ push(@elements,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
-
# Escape HTML -- used internally
'escapeHTML' => <<'END_OF_FUNC',
sub escapeHTML {
- my($self,$toencode) = @_;
+ my ($self,$toencode) = self_or_default(@_);
return undef unless defined($toencode);
- return $toencode if $self->{'dontescape'};
+ return $toencode if ref($self) && $self->{'dontescape'};
+
$toencode=~s/&/&/g;
$toencode=~s/\"/"/g;
$toencode=~s/>/>/g;
@@ -1552,6 +1870,25 @@ sub escapeHTML {
}
END_OF_FUNC
+# unescape HTML -- used internally
+'unescapeHTML' => <<'END_OF_FUNC',
+sub unescapeHTML {
+ my $string = ref($_[0]) ? $_[1] : $_[0];
+ return undef unless defined($string);
+ # thanks to Randal Schwartz for the correct solution to this one
+ $string=~ s[&(.*?);]{
+ local $_ = $1;
+ /^amp$/i ? "&" :
+ /^quot$/i ? '"' :
+ /^gt$/i ? ">" :
+ /^lt$/i ? "<" :
+ /^#(\d+)$/ ? chr($1) :
+ /^#x([0-9a-f]+)$/i ? chr(hex($1)) :
+ $_
+ }gex;
+ return $string;
+}
+END_OF_FUNC
# Internal procedure - don't use
'_tableize' => <<'END_OF_FUNC',
@@ -1559,12 +1896,18 @@ sub _tableize {
my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
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 = "";
my($row,$column);
unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
- $result .= "" if @{$colheaders};
+ $result .= "
" if @$colheaders;
foreach (@{$colheaders}) {
$result .= "$_ | ";
}
@@ -1572,7 +1915,8 @@ sub _tableize {
$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 .= "
";
}
@@ -1616,12 +1960,13 @@ 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' : '';
@@ -1629,14 +1974,15 @@ sub radio_group {
my($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}/);
+ push(@elements,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
@@ -1672,12 +2018,14 @@ sub popup_menu {
$name=$self->escapeHTML($name);
my($other) = @other ? " @other" : '';
- my(@values) = $values ? @$values : $self->param($name);
+ my(@values);
+ @values = $self->_set_values_and_labels($values,\$labels,$name);
+
$result = qq/