X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI.pm;h=9f65f7d02b480357c3282439a13cf61ff3b40227;hb=cc83745da206d409d7227df077f422fd9ecbe680;hp=63805544f8f2f787b56adace78fa69af975923f1;hpb=ee8c7f5465f003860e2347a2946abacac39bd9b9;p=p5sagit%2Fp5-mst-13.2.git
diff --git a/lib/CGI.pm b/lib/CGI.pm
index 6380554..9f65f7d 100644
--- a/lib/CGI.pm
+++ b/lib/CGI.pm
@@ -1,5 +1,6 @@
package CGI;
require 5.004;
+use Carp 'croak';
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
@@ -17,19 +18,37 @@ require 5.004;
# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.30 2000/03/28 21:31:40 lstein Exp $';
-$CGI::VERSION='2.66';
+$CGI::revision = '$Id: CGI.pm,v 1.130 2003/08/01 14:39:17 lstein Exp $ + patches by merlyn';
+$CGI::VERSION='3.00';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
-# $TempFile::TMPDIRECTORY = '/usr/tmp';
+# $CGITempFile::TMPDIRECTORY = '/usr/tmp';
use CGI::Util qw(rearrange make_attributes unescape escape expires);
+#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
+# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
+
+use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
+ 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
+
+{
+ local $^W = 0;
+ $TAINTED = substr("$0$^X",0,0);
+}
+
+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',
@@ -59,6 +78,16 @@ sub initialize_globals {
# 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;
@@ -75,11 +104,17 @@ sub initialize_globals {
# 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;
@@ -99,24 +134,26 @@ unless ($OS) {
$OS = $Config::Config{'osname'};
}
}
-if ($OS=~/Win/i) {
+if ($OS =~ /^MSWin/i) {
$OS = 'WINDOWS';
-} elsif ($OS=~/vms/i) {
+} elsif ($OS =~ /^VMS/i) {
$OS = 'VMS';
-} elsif ($OS=~/bsdos/i) {
- $OS = 'UNIX';
-} elsif ($OS=~/dos/i) {
+} elsif ($OS =~ /^dos/i) {
$OS = 'DOS';
-} elsif ($OS=~/^MacOS$/i) {
+} elsif ($OS =~ /^MacOS/i) {
$OS = 'MACINTOSH';
-} elsif ($OS=~/os2/i) {
+} elsif ($OS =~ /^os2/i) {
$OS = 'OS2';
+} elsif ($OS =~ /^epoc/i) {
+ $OS = 'EPOC';
+} elsif ($OS =~ /^cygwin/i) {
+ $OS = 'CYGWIN';
} else {
$OS = 'UNIX';
}
# Some OS logic. Binary mode enabled on DOS, NT and VMS
-$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/;
+$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN)/;
# This is the default class for the CGI object to use when all else fails.
$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
@@ -127,7 +164,8 @@ $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
# The path separator is a slash, backslash or semicolon, depending
# on the paltform.
$SL = {
- UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
+ UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/',
+ WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
}->{$OS};
# This no longer seems to be necessary
@@ -136,13 +174,23 @@ $SL = {
$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
# Turn on special checking for Doug MacEachern's modperl
-if (exists $ENV{'GATEWAY_INTERFACE'}
- &&
- ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
-{
- $| = 1;
- require Apache;
+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;
+ }
+ }
}
+
# Turn on special checking for ActiveState's PerlEx
$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
@@ -173,7 +221,10 @@ if ($needs_binmode) {
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/],
+ 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
@@ -187,21 +238,20 @@ if ($needs_binmode) {
remote_user user_name header redirect import_names put
Delete Delete_all url_param cgi_error/],
':ssl' => [qw/https/],
- ':imagemap' => [qw/Area Map/],
':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
- ':html' => [qw/:html2 :html3 :netscape/],
- ':standard' => [qw/:html2 :html3 :form :cgi/],
- ':push' => [qw/multipart_init multipart_start multipart_end/],
- ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/]
+ ':html' => [qw/:html2 :html3 :html4 :netscape/],
+ ':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
+ ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
+ ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/]
);
# to import symbols into caller
sub import {
my $self = shift;
-# This causes modules to clash.
-# undef %EXPORT_OK;
-# undef %EXPORT;
+ # This causes modules to clash.
+ undef %EXPORT_OK;
+ undef %EXPORT;
$self->_setup_symbols(@_);
my ($callpack, $callfile, $callline) = caller;
@@ -243,22 +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;
- if ($MOD_PERL && defined Apache->request) {
- Apache->request->register_cleanup(\&CGI::_reset_globals);
- undef $NPH;
+ my($class,@initializer) = @_;
+ my $self = {};
+ bless $self,ref $class || $class || $DefaultClass;
+ if (ref($initializer[0])
+ && (UNIVERSAL::isa($initializer[0],'Apache')
+ ||
+ UNIVERSAL::isa($initializer[0],'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);
}
- $self->_reset_globals if $PERLEX;
- $self->init($initializer);
- return $self;
+ 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
@@ -337,17 +411,24 @@ sub self_or_CGI {
# parameter list with the single parameter 'keywords'.
sub init {
- my($self,$initializer) = @_;
- my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
- local($/) = "\n";
+ my $self = shift;
+ my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
+
+ my $initializer = shift; # for backward compatibility
+ local($/) = "\n";
+
+ # set autoescaping on by default
+ $self->{'escape'} = 1;
# if we get called more than once, we want to initialize
# ourselves from the original query (which may be gone
# if it was read from STDIN originally.)
- if (@QUERY_PARAM && !defined($initializer)) {
+ if (defined(@QUERY_PARAM) && !defined($initializer)) {
foreach (@QUERY_PARAM) {
$self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
}
+ $self->charset($QUERY_CHARSET);
+ $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
return;
}
@@ -356,10 +437,19 @@ sub init {
$fh = to_filehandle($initializer) if $initializer;
+ # set charset to the safe ISO-8859-1
+ $self->charset('ISO-8859-1');
+
METHOD: {
# avoid unreasonably large postings
if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
+ # 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;
}
@@ -416,7 +506,7 @@ sub init {
# the environment.
if ($meth=~/^(GET|HEAD)$/) {
if ($MOD_PERL) {
- $query_string = Apache->request->args;
+ $query_string = $self->r->args;
} else {
$query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
$query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
@@ -441,9 +531,21 @@ sub init {
$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 (defined $query_string && $query_string) {
+ if (defined $query_string && length $query_string) {
if ($query_string =~ /[&=;]/) {
$self->parse_params($query_string);
} else {
@@ -468,9 +570,7 @@ sub init {
$self->delete('.submit');
$self->delete('.cgifields');
- # set charset to the safe ISO-8859-1
- $self->charset('ISO-8859-1');
- $self->save_request unless $initializer;
+ $self->save_request unless defined $initializer;
}
# FUNCTIONS TO OVERRIDE:
@@ -519,6 +619,8 @@ sub save_request {
next unless defined $_;
$QUERY_PARAM{$_}=$self->{$_};
}
+ $QUERY_CHARSET = $self->charset;
+ %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
}
sub parse_params {
@@ -527,6 +629,8 @@ sub parse_params {
my($param,$value);
foreach (@pairs) {
($param,$value) = split('=',$_,2);
+ next unless defined $param;
+ next if $NO_UNDEF_PARAMS and not defined $value;
$value = '' unless defined $value;
$param = unescape($param);
$value = unescape($value);
@@ -558,26 +662,25 @@ sub _make_tag_func {
my ($self,$tagname) = @_;
my $func = qq(
sub $tagname {
- shift if \$_[0] &&
- (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()||undef,1);
- \$attr = " \@attr" if \@attr;
- }
+ my (\$q,\$a,\@rest) = self_or_default(\@_);
+ my(\$attr) = '';
+ if (ref(\$a) && ref(\$a) eq 'HASH') {
+ my(\@attr) = make_attributes(\$a,\$q->{'escape'});
+ \$attr = " \@attr" if \@attr;
+ } else {
+ unshift \@rest,\$a if defined \$a;
+ }
);
if ($tagname=~/start_(\w+)/i) {
- $func .= qq! return "<\U$1\E\$attr>";} !;
+ $func .= qq! return "<\L$1\E\$attr>";} !;
} elsif ($tagname=~/end_(\w+)/i) {
- $func .= qq! return "<\U/$1\E>"; } !;
+ $func .= qq! return "<\L/$1\E>"; } !;
} else {
$func .= qq#
- my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U$tagname>\E");
- return \$tag unless \@_;
+ 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(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
+ (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
return "\@result";
}#;
}
@@ -605,7 +708,7 @@ sub _compile {
unless (%$sub) {
my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
eval "package $pack; $$auto";
- die $@ if $@;
+ croak("$AUTOLOAD: $@") if $@;
$$auto = ''; # Free the unneeded storage (but don't undef it!!!)
}
my($code) = $sub->{$func_name};
@@ -621,22 +724,40 @@ sub _compile {
$code = $CGI::DefaultClass->_make_tag_func($func_name);
}
}
- die "Undefined subroutine $AUTOLOAD\n" unless $code;
+ croak("Undefined subroutine $AUTOLOAD\n") unless $code;
eval "package $pack; $code";
if ($@) {
$@ =~ s/ at .*\n//;
- die $@;
+ croak("$AUTOLOAD: $@");
}
}
CORE::delete($sub->{$func_name}); #free storage
return "$pack\:\:$func_name";
}
+sub _selected {
+ my $self = shift;
+ my $value = shift;
+ return '' unless $value;
+ return $XHTML ? qq( selected="selected") : qq( selected);
+}
+
+sub _checked {
+ my $self = shift;
+ my $value = shift;
+ return '' unless $value;
+ return $XHTML ? qq( checked="checked") : qq( checked);
+}
+
sub _reset_globals { initialize_globals(); }
sub _setup_symbols {
my $self = shift;
my $compile = 0;
+
+ # to avoid reexporting unwanted variables
+ undef %EXPORT;
+
foreach (@_) {
$HEADERS_ONCE++, next if /^[:-]unique_headers$/;
$NPH++, next if /^[:-]nph$/;
@@ -644,10 +765,14 @@ sub _setup_symbols {
$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$/) {
@@ -666,6 +791,7 @@ sub _setup_symbols {
}
}
_compile_all(keys %EXPORT) if $compile;
+ @SAVED_SYMBOLS = @_;
}
sub charset {
@@ -691,7 +817,7 @@ sub MULTIPART { 'multipart/form-data'; }
END_OF_FUNC
'SERVER_PUSH' => <<'END_OF_FUNC',
-sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; }
+sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
END_OF_FUNC
'new_MultipartBuffer' => <<'END_OF_FUNC',
@@ -717,10 +843,17 @@ END_OF_FUNC
# Deletes the named parameter entirely.
####
sub delete {
- my($self,$name) = self_or_default(@_);
- CORE::delete $self->{$name};
- CORE::delete $self->{'.fieldnames'}->{$name};
- @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
+ my($self,@p) = self_or_default(@_);
+ my(@names) = rearrange([NAME],@p);
+ my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
+ my %to_delete;
+ foreach my $name (@to_delete)
+ {
+ CORE::delete $self->{$name};
+ CORE::delete $self->{'.fieldnames'}->{$name};
+ $to_delete{$name}++;
+ }
+ @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
return wantarray ? () : undef;
}
END_OF_FUNC
@@ -841,9 +974,13 @@ sub MethPost {
END_OF_FUNC
'TIEHASH' => <<'END_OF_FUNC',
-sub TIEHASH {
- return $_[1] if defined $_[1];
- return $Q ||= new shift;
+sub TIEHASH {
+ my $class = shift;
+ my $arg = $_[0];
+ if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
+ return $arg;
+ }
+ return $Q ||= $class->new(@_);
}
END_OF_FUNC
@@ -851,7 +988,8 @@ END_OF_FUNC
sub STORE {
my $self = shift;
my $tag = shift;
- my @vals = split("\0",shift);
+ my $vals = shift;
+ my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
$self->param(-name=>$tag,-value=>\@vals);
}
END_OF_FUNC
@@ -918,7 +1056,8 @@ EOF
'delete_all' => <<'EOF',
sub delete_all {
my($self) = self_or_default(@_);
- undef %{$self};
+ my @param = $self->param();
+ $self->delete(@param);
}
EOF
@@ -942,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
@@ -996,20 +1137,20 @@ 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);
- $value =~ s/\n/ \n/g;
- 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
@@ -1042,6 +1183,9 @@ sub save {
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
@@ -1070,23 +1214,24 @@ END_OF_FUNC
#### Method: multipart_init
# Return a Content-Type: style header for server-push
-# This has to be NPH, and it is advisable to set $| = 1
+# This has to be NPH on most web servers, and it is advisable to set $| = 1
#
# Many thanks to Ed Jordan for this
-# contribution
+# contribution, updated by Andrew Benham (adsb@bigfoot.com)
####
'multipart_init' => <<'END_OF_FUNC',
sub multipart_init {
my($self,@p) = self_or_default(@_);
my($boundary,@other) = rearrange([BOUNDARY],@p);
$boundary = $boundary || '------- =_aaaaaaaaaa0';
- $self->{'separator'} = "\n--$boundary\n";
+ $self->{'separator'} = "$CRLF--$boundary$CRLF";
+ $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
$type = SERVER_PUSH($boundary);
return $self->header(
-nph => 1,
-type => $type,
(map { split "=", $_, 2 } @other),
- ) . $self->multipart_end;
+ ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
}
END_OF_FUNC
@@ -1095,23 +1240,32 @@ END_OF_FUNC
# Return a Content-Type: style header for server-push, start of section
#
# Many thanks to Ed Jordan for this
-# contribution
+# contribution, updated by Andrew Benham (adsb@bigfoot.com)
####
'multipart_start' => <<'END_OF_FUNC',
sub multipart_start {
+ my(@header);
my($self,@p) = self_or_default(@_);
my($type,@other) = rearrange([TYPE],@p);
$type = $type || 'text/html';
- return $self->header(
- -type => $type,
- (map { split "=", $_, 2 } @other),
- );
+ push(@header,"Content-Type: $type");
+
+ # rearrange() was designed for the HTML portion, so we
+ # need to fix it up a little.
+ foreach (@other) {
+ # Don't use \s because of perl bug 21951
+ next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
+ ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
+ }
+ push(@header,@other);
+ my $header = join($CRLF,@header)."${CRLF}${CRLF}";
+ return $header;
}
END_OF_FUNC
#### Method: multipart_end
-# Return a Content-Type: style header for server-push, end of section
+# Return a MIME boundary separator for server-push, end of section
#
# Many thanks to Ed Jordan for this
# contribution
@@ -1124,6 +1278,19 @@ sub multipart_end {
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
#
@@ -1135,10 +1302,11 @@ sub header {
return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
- my($type,$status,$cookie,$target,$expires,$nph,$charset,@other) =
+ my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
'STATUS',['COOKIE','COOKIES'],'TARGET',
- 'EXPIRES','NPH','CHARSET'],@p);
+ 'EXPIRES','NPH','CHARSET',
+ 'ATTACHMENT','P3P'],@p);
$nph ||= $NPH;
if (defined $charset) {
@@ -1150,19 +1318,25 @@ sub header {
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
foreach (@other) {
- next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
- ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e;
+ # Don't use \s because of perl bug 21951
+ next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
+ ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
}
$type ||= 'text/html' unless defined($type);
- $type .= "; charset=$charset" if $type ne '' and $type !~ /\bcharset\b/;
+ $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/ and $charset ne '';
# Maybe future compatibility. Maybe not.
my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
+ push(@header,"Server: " . &server_software()) if $nph;
push(@header,"Status: $status") if $status;
push(@header,"Window-Target: $target") if $target;
+ if ($p3p) {
+ $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
+ push(@header,qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p"));
+ }
# push all the cookies -- there may be several
if ($cookie) {
my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
@@ -1176,16 +1350,15 @@ sub header {
# uses OUR clock)
push(@header,"Expires: " . expires($expires,'http'))
if $expires;
- push(@header,"Date: " . expires(0,'http')) if $expires || $cookie;
+ push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
push(@header,"Pragma: no-cache") if $self->cache();
- push(@header,@other);
+ push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
+ push(@header,map {ucfirst $_} @other);
push(@header,"Content-Type: $type") if $type ne '';
-
my $header = join($CRLF,@header)."${CRLF}${CRLF}";
if ($MOD_PERL and not $nph) {
- my $r = Apache->request;
- $r->send_cgi_header($header);
- return '';
+ $self->r->send_cgi_header($header);
+ return '';
}
return $header;
}
@@ -1215,18 +1388,19 @@ END_OF_FUNC
'redirect' => <<'END_OF_FUNC',
sub redirect {
my($self,@p) = self_or_default(@_);
- my($url,$target,$cookie,$nph,@other) = rearrange([[LOCATION,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) { tr/\"//d; push(@o,split("=",$_,2)); }
unshift(@o,
- '-Status'=>'302 Moved',
- '-Location'=>$url,
- '-nph'=>$nph);
+ '-Status' => '302 Moved',
+ '-Location'=> $url,
+ '-nph' => $nph);
unshift(@o,'-Target'=>$target) if $target;
- unshift(@o,'-Cookie'=>$cookie) if $cookie;
unshift(@o,'-Type'=>'');
- return $self->header(@o);
+ my @unescaped;
+ unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
+ return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
}
END_OF_FUNC
@@ -1244,48 +1418,63 @@ END_OF_FUNC
# $script -> (option) Javascript code (-script)
# $no_script -> (option) Javascript tag (-noscript)
# $meta -> (optional) Meta information tags
-# $head -> (optional) any other elements you'd like to incorporate into the tag
+# $head -> (optional) any other elements you'd like to incorporate into the tag
# (a scalar or array ref)
# $style -> (optional) reference to an external style sheet
# @other -> (optional) any other named parameters you'd like to incorporate into
-# the tag.
+# the tag.
####
'start_html' => <<'END_OF_FUNC',
sub start_html {
my($self,@p) = &self_or_default(@_);
- my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,@other) =
- rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD],@p);
+ my($title,$author,$base,$xbase,$script,$noscript,
+ $target,$meta,$head,$style,$dtd,$lang,$encoding,@other) =
+ rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD,LANG,ENCODING],@p);
+
+ $encoding = 'iso-8859-1' unless defined $encoding;
# strangely enough, the title needs to be escaped as HTML
# while the author needs to be escaped as a URL
$title = $self->escapeHTML($title || 'Untitled Document');
$author = $self->escape($author);
- my(@result);
+ $lang = 'en-US' unless defined $lang;
+ my(@result,$xml_dtd);
if ($dtd) {
- if (ref $dtd && $ref eq 'ARRAY') {
+ if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
$dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
} else {
$dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
}
} else {
- $dtd = $DEFAULT_DTD;
+ $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
}
+
+ $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
+ $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
+ push @result,qq() if $xml_dtd;
+
if (ref($dtd) && ref($dtd) eq 'ARRAY') {
- push(@result,qq([1]">));
+ push(@result,qq([0]"\n\t "$dtd->[1]">));
} else {
- push(@result,qq());
+ push(@result,qq());
}
- push(@result,"$title ");
- push(@result," ") if defined $author;
+ push(@result,$XHTML ? qq($title )
+ : ($lang ? qq() : "")
+ . "$title ");
+ if (defined $author) {
+ push(@result,$XHTML ? " "
+ : " ");
+ }
if ($base || $xbase || $target) {
my $href = $xbase || $self->url('-path'=>1);
- my $t = $target ? qq/ TARGET="$target"/ : '';
- push(@result,qq/ /);
+ my $t = $target ? qq/ target="$target"/ : '';
+ push(@result,$XHTML ? qq( ) : qq( ));
}
if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
- foreach (keys %$meta) { push(@result,qq( )); }
+ foreach (keys %$meta) { push(@result,$XHTML ? qq( )
+ : qq( )); }
}
push(@result,ref($head) ? @$head : $head) if $head;
@@ -1296,13 +1485,13 @@ sub start_html {
# handle -noscript parameter
push(@result,<
+
$noscript
-
+
END
;
my($other) = @other ? " @other" : '';
- push(@result,"");
+ push(@result,"");
return join("\n",@result);
}
END_OF_FUNC
@@ -1315,26 +1504,50 @@ sub _style {
my ($self,$style) = @_;
my (@result);
my $type = 'text/css';
+
+ my $cdata_start = $XHTML ? "\n\n" : " -->\n";
+
if (ref($style)) {
- my($src,$code,$stype,@other) =
- 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;
+ 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 {
- push(@result,style({'type'=>$type},""));
+ 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);
@@ -1353,19 +1566,26 @@ sub _script {
} else {
($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript');
}
- my(@satts);
- push(@satts,'src'=>$src) if $src;
- push(@satts,'language'=>$language);
- push(@satts,'type'=>$type);
- $code = ""
- if $code && $type=~/javascript/i;
- $code = ""
- if $code && $type=~/perl/i;
- $code = ""
- if $code && $type=~/tcl/i;
- $code = ""
- if $code && $type=~/vbscript/i;
- push(@result,script({@satts},$code || ''));
+
+ my $comment = '//'; # javascript by default
+ $comment = '#' if $type=~/perl|tcl/i;
+ $comment = "'" if $type=~/vbscript/i;
+
+ my ($cdata_start,$cdata_end);
+ if ($XHTML) {
+ $cdata_start = "$comment";
+ } 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;
}
@@ -1373,11 +1593,11 @@ 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
@@ -1391,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) = rearrange([ACTION],@p);
- $action = qq/ACTION="$action"/ if $action;
+ $action = qq/ action="$action"/ if $action;
my($other) = @other ? " @other" : '';
- return " ";
+ return $XHTML ? " " : " ";
}
END_OF_FUNC
@@ -1416,13 +1636,18 @@ sub startform {
my($method,$action,$enctype,@other) =
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/") : "\n";
+ return wantarray ? ("") : "\n";
} else {
- return wantarray ? ($self->get_fields,"") :
- $self->get_fields ."\n";
+ return wantarray ? ("",$self->get_fields,"
","") :
+ "".$self->get_fields ."
\n";
}
}
END_OF_FUNC
@@ -1487,20 +1712,21 @@ END_OF_FUNC
sub _textfield {
my($self,$tag,@p) = self_or_default(@_);
my($name,$default,$size,$maxlength,$override,@other) =
- rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
+ 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) : '';
+ $current = defined($current) ? $self->escapeHTML($current,1) : '';
$name = defined($name) ? $self->escapeHTML($name) : '';
- my($s) = defined($size) ? qq/ SIZE=$size/ : '';
- my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
+ my($s) = defined($size) ? qq/ size="$size"/ : '';
+ my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
my($other) = @other ? " @other" : '';
# this entered at cristy's request to fix problems with file upload fields
# and WebTV -- not sure it won't break stuff
- my($value) = $current ne '' ? qq(VALUE="$current") : '';
- return qq/ /;
+ my($value) = $current ne '' ? qq(value="$current") : '';
+ return $XHTML ? qq( )
+ : qq( );
}
END_OF_FUNC
@@ -1512,7 +1738,7 @@ 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 {
@@ -1528,7 +1754,7 @@ 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 {
@@ -1547,7 +1773,7 @@ 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 {
@@ -1564,7 +1790,7 @@ 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 {
@@ -1578,10 +1804,10 @@ sub textarea {
$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
@@ -1594,7 +1820,7 @@ 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 {
@@ -1604,17 +1830,18 @@ sub button {
[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
@@ -1626,7 +1853,7 @@ 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 {
@@ -1635,15 +1862,16 @@ sub submit {
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"' unless $NOSTICKY;
- $name = qq/ NAME="$label"/ if defined($label);
+ 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 $val = '';
+ $val = qq/ value="$value"/ if defined($value);
my($other) = @other ? " @other" : '';
- return qq/ /;
+ return $XHTML ? qq( )
+ : qq( );
}
END_OF_FUNC
@@ -1653,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) = 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
@@ -1672,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
@@ -1684,11 +1918,12 @@ sub defaults {
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
@@ -1713,7 +1948,7 @@ 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 {
@@ -1726,17 +1961,18 @@ sub checkbox {
if (!$override && ($self->{'.fieldnames'}->{$name} ||
defined $self->param($name))) {
- $checked = grep($_ eq $value,$self->param($name)) ? ' CHECKED' : '';
+ $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
} else {
- $checked = $checked ? ' CHECKED' : '';
+ $checked = $self->_checked($checked);
}
my($the_label) = defined $label ? $label : $name;
$name = $self->escapeHTML($name);
- $value = $self->escapeHTML($value);
+ $value = $self->escapeHTML($value,1);
$the_label = $self->escapeHTML($the_label);
my($other) = @other ? " @other" : '';
$self->register_parameter($name);
- return qq{ $the_label};
+ return $XHTML ? qq{ $the_label}
+ : qq{ $the_label};
}
END_OF_FUNC
@@ -1760,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) =
rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
- LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
+ LINEBREAK,LABELS,ATTRIBUTES,ROWS,[COLUMNS,COLS],
ROWHEADERS,COLHEADERS,
[OVERRIDE,FORCE],NOLABELS],@p);
@@ -1777,7 +2013,12 @@ 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
@@ -1787,19 +2028,23 @@ sub checkbox_group {
my($other) = @other ? " @other" : '';
foreach (@values) {
- $checked = $checked{$_} ? ' CHECKED' : '';
+ $checked = $self->_checked($checked{$_});
$label = '';
unless (defined($nolabels) && $nolabels) {
$label = $_;
$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 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
@@ -1807,32 +2052,37 @@ END_OF_FUNC
# Escape HTML -- used internally
'escapeHTML' => <<'END_OF_FUNC',
sub escapeHTML {
- my ($self,$toencode) = self_or_default(@_);
- return undef unless defined($toencode);
- return $toencode if ref($self) && $self->{'dontescape'};
- if (uc $self->{'.charset'} eq 'ISO-8859-1') {
- # fix non-compliant bug in IE and Netscape
- $toencode =~ s{(.)}{
- if ($1 eq '<') { '<' }
- elsif ($1 eq '>') { '>' }
- elsif ($1 eq '&') { '&' }
- elsif ($1 eq '"') { '"' }
- elsif ($1 eq "\x8b") { '' }
- elsif ($1 eq "\x9b") { '' }
- else { $1 }
- }gsex;
- } else {
- $toencode =~ s/(.)/''.ord($1).';'/gsex;
- }
- 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 $string = ref($_[0]) ? $_[1] : $_[0];
+ 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;
@@ -1840,8 +2090,8 @@ sub unescapeHTML {
/^quot$/i ? '"' :
/^gt$/i ? ">" :
/^lt$/i ? "<" :
- /^#(\d+)$/ ? chr($1) :
- /^#x([0-9a-f]+)$/i ? chr(hex($1)) :
+ /^#(\d+)$/ && $latin ? chr($1) :
+ /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
$_
}gex;
return $string;
@@ -1852,6 +2102,8 @@ END_OF_FUNC
'_tableize' => <<'END_OF_FUNC',
sub _tableize {
my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
+ $rowheaders = [] unless defined $rowheaders;
+ $colheaders = [] unless defined $colheaders;
my($result);
if (defined($columns)) {
@@ -1862,23 +2114,23 @@ sub _tableize {
}
# 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
@@ -1899,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) =
- rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
+ rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,ATTRIBUTES,
ROWS,[COLUMNS,COLS],
ROWHEADERS,COLHEADERS,
[OVERRIDE,FORCE],NOLABELS],@p);
@@ -1927,16 +2179,24 @@ sub radio_group {
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) && defined($labels->{$_});
- $label = $self->escapeHTML($label);
+ $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)
@@ -1964,8 +2224,9 @@ END_OF_FUNC
sub popup_menu {
my($self,@p) = self_or_default(@_);
- my($name,$values,$default,$labels,$override,@other) =
- 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))) {
@@ -1979,17 +2240,87 @@ sub popup_menu {
my(@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
- $result = qq/\n/;
+ $result = qq/\n/;
foreach (@values) {
- my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
+ if (/_set_attributes($_, $attributes);
+ my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : '';
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
my($value) = $self->escapeHTML($_);
- $label=$self->escapeHTML($label);
- $result .= "$label\n";
+ $label=$self->escapeHTML($label,1);
+ $result .= " $label \n";
+ }
}
- $result .= " \n";
+ $result .= " ";
+ 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 element, but the label
+# attribute allows authors to more easily use optgroup without sacrificing
+# compatibility with browsers that do not support option groups.
+# $novals -> (optional)
+# A true value indicates to suppress the val attribute in the option elements
+# Returns:
+# A string containing the definition of an option group.
+####
+'optgroup' => <<'END_OF_FUNC',
+sub optgroup {
+ my($self,@p) = self_or_default(@_);
+ my($name,$values,$attributes,$labeled,$noval,$labels,@other)
+ = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p);
+
+ my($result,@values);
+ @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
+ my($other) = @other ? " @other" : '';
+
+ $name=$self->escapeHTML($name);
+ $result = qq/ \n/;
+ foreach (@values) {
+ if (/_set_attributes($_, $attributes);
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ $label=$self->escapeHTML($label);
+ my($value)=$self->escapeHTML($_,1);
+ $result .= $labeled ? $novals ? "$label \n"
+ : "$label \n"
+ : $novals ? "$label \n"
+ : "$label \n";
+ }
+ }
+ $result .= " ";
return $result;
}
END_OF_FUNC
@@ -2018,9 +2349,9 @@ END_OF_FUNC
'scrolling_list' => <<'END_OF_FUNC',
sub scrolling_list {
my($self,@p) = self_or_default(@_);
- my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
+ my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,@other)
= rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
- SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
+ SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE]],@p);
my($result,@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
@@ -2028,21 +2359,22 @@ sub scrolling_list {
$size = $size || scalar(@values);
my(%selected) = $self->previous_or_default($name,$defaults,$override);
- my($is_multiple) = $multiple ? ' MULTIPLE' : '';
- my($has_size) = $size ? " SIZE=$size" : '';
+ my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
+ my($has_size) = $size ? qq/ size="$size"/: '';
my($other) = @other ? " @other" : '';
$name=$self->escapeHTML($name);
- $result = qq/\n/;
+ $result = qq/\n/;
foreach (@values) {
- my($selectit) = $selected{$_} ? 'SELECTED' : '';
+ my($selectit) = $self->_selected($selected{$_});
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label=$self->escapeHTML($label);
- my($value)=$self->escapeHTML($_);
- $result .= "$label \n";
+ my($value)=$self->escapeHTML($_,1);
+ my $attribs = $self->_set_attributes($_, $attributes);
+ $result .= "$label \n";
}
- $result .= " \n";
+ $result .= " ";
$self->register_parameter($name);
return $result;
}
@@ -2056,7 +2388,7 @@ END_OF_FUNC
# or
# $default->[initial values of field]
# Returns:
-# A string containing a
+# A string containing a
####
'hidden' => <<'END_OF_FUNC',
sub hidden {
@@ -2084,8 +2416,9 @@ sub hidden {
$name=$self->escapeHTML($name);
foreach (@value) {
- $_ = defined($_) ? $self->escapeHTML($_) : '';
- push(@result,qq/ /);
+ $_ = defined($_) ? $self->escapeHTML($_,1) : '';
+ push @result,$XHTML ? qq( )
+ : qq( );
}
return wantarray ? @result : join('',@result);
}
@@ -2098,7 +2431,7 @@ END_OF_FUNC
# $src -> URL of the image source
# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
# Returns:
-# A string containing a
+# A string containing a
####
'image_button' => <<'END_OF_FUNC',
sub image_button {
@@ -2107,10 +2440,11 @@ sub image_button {
my($name,$src,$alignment,@other) =
rearrange([NAME,SRC,ALIGN],@p);
- my($align) = $alignment ? " ALIGN=\U$alignment" : '';
+ my($align) = $alignment ? " align=\U\"$alignment\"" : '';
my($other) = @other ? " @other" : '';
$name=$self->escapeHTML($name);
- return qq/ /;
+ return $XHTML ? qq( )
+ : qq/ /;
}
END_OF_FUNC
@@ -2145,25 +2479,24 @@ END_OF_FUNC
'url' => <<'END_OF_FUNC',
sub url {
my($self,@p) = self_or_default(@_);
- my ($relative,$absolute,$full,$path_info,$query) =
- rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING']],@p);
+ my ($relative,$absolute,$full,$path_info,$query,$base) =
+ rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE'],@p);
my $url;
- $full++ if !($relative || $absolute);
+ $full++ if $base || !($relative || $absolute);
my $path = $self->path_info;
- my $script_name;
+ my $script_name = $self->script_name;
+
+ # for compatibility with Apache's MultiViews
if (exists($ENV{REQUEST_URI})) {
my $index;
- $script_name = $ENV{REQUEST_URI};
- # strip query string
- substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0;
+ $script_name = unescape($ENV{REQUEST_URI});
+ $script_name =~ s/\?.+$//; # strip query string
# and path
if (exists($ENV{PATH_INFO})) {
- my $decoded_path = unescape($ENV{PATH_INFO});
- substr($script_name,$index) = '' if ($index = rindex($script_name,$decoded_path)) >= 0;
+ my $encoded_path = quotemeta($ENV{PATH_INFO});
+ $script_name =~ s/$encoded_path$//i;
}
- } else {
- $script_name = $self->script_name;
}
if ($full) {
@@ -2179,16 +2512,18 @@ sub url {
unless (lc($protocol) eq 'http' && $port == 80)
|| (lc($protocol) eq 'https' && $port == 443);
}
+ return $url if $base;
$url .= $script_name;
} elsif ($relative) {
($url) = $script_name =~ m!([^/]+)$!;
} elsif ($absolute) {
$url = $script_name;
}
+
$url .= $path if $path_info and defined $path;
$url .= "?" . $self->query_string if $query and $self->query_string;
$url = '' unless defined $url;
- $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/uc sprintf("%%%02x",ord($1))/eg;
+ $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
return $url;
}
@@ -2229,7 +2564,7 @@ sub cookie {
}
# If we get here, we're creating a new cookie
- return undef unless $name; # this is an error
+ return undef unless defined($name) && $name ne ''; # this is an error
my @param;
push(@param,'-name'=>$name);
@@ -2239,7 +2574,7 @@ sub cookie {
push(@param,'-expires'=>$expires) if $expires;
push(@param,'-secure'=>$secure) if $secure;
- return CGI::Cookie->new(@param);
+ return new CGI::Cookie(@param);
}
END_OF_FUNC
@@ -2338,6 +2673,9 @@ sub query_string {
push(@pairs,"$eparam=$value");
}
}
+ foreach (keys %{$self->{'.fieldnames'}}) {
+ push(@pairs,".cgifields=".escape("$_"));
+ }
return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
}
END_OF_FUNC
@@ -2657,6 +2995,17 @@ sub private_tempfiles {
return $CGI::PRIVATE_TEMPFILES;
}
END_OF_FUNC
+#### Method: close_upload_files
+# Set or return the close_upload_files global flag
+####
+'close_upload_files' => <<'END_OF_FUNC',
+sub close_upload_files {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::CLOSE_UPLOAD_FILES = $param if defined($param);
+ return $CGI::CLOSE_UPLOAD_FILES;
+}
+END_OF_FUNC
+
#### Method: default_dtd
# Set or return the default_dtd global
@@ -2760,17 +3109,23 @@ sub read_multipart {
}
my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
+ $param .= $TAINTED;
# Bug: Netscape doesn't escape quotation marks in file names!!!
- my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/;
+ my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\"]*)"?/;
+ # Test for Opera's multiple upload feature
+ my($multipart) = ( defined( $header{'Content-Type'} ) &&
+ $header{'Content-Type'} =~ /multipart\/mixed/ ) ?
+ 1 : 0;
# add this parameter to our list
$self->add_parameter($param);
# If no filename specified, then just read the data and assign it
# to our parameter list.
- if ( !defined($filename) || $filename eq '' ) {
+ if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
my($value) = $buffer->readBody;
+ $value .= $TAINTED;
push(@{$self->{$param}},$value);
next;
}
@@ -2787,17 +3142,32 @@ sub read_multipart {
last UPLOADS;
}
+ # set the filename to some recognizable value
+ if ( ( !defined($filename) || $filename eq '' ) && $multipart ) {
+ $filename = "multipart/mixed";
+ }
+
# choose a relatively unpredictable tmpfile sequence number
my $seqno = unpack("%16C*",join('',localtime,values %ENV));
for (my $cnt=10;$cnt>0;$cnt--) {
- next unless $tmpfile = new TempFile($seqno);
+ next unless $tmpfile = new CGITempFile($seqno);
$tmp = $tmpfile->as_string;
last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
$seqno += int rand(100);
}
- die "CGI open of tmpfile: $!\n" unless $filehandle;
+ die "CGI open of tmpfile: $!\n" unless defined $filehandle;
$CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
+ # if this is an multipart/mixed attachment, save the header
+ # together with the body for lateron parsing with an external
+ # MIME parser module
+ if ( $multipart ) {
+ foreach ( keys %header ) {
+ print $filehandle "$_: $header{$_}${CRLF}";
+ }
+ print $filehandle "${CRLF}";
+ }
+
my ($data);
local($\) = '';
while (defined($data = $buffer->read)) {
@@ -2806,6 +3176,12 @@ sub read_multipart {
# back up to beginning of file
seek($filehandle,0,0);
+
+ ## Close the filehandle if requested this allows a multipart MIME
+ ## upload to contain many files, and we won't die due to too many
+ ## open file handles. The user can access the files using the hash
+ ## below.
+ close $filehandle if $CLOSE_UPLOAD_FILES;
$CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
# Save some information about the uploaded file where we can get
@@ -2823,10 +3199,9 @@ END_OF_FUNC
'upload' =><<'END_OF_FUNC',
sub upload {
my($self,$param_name) = self_or_default(@_);
- my $param = $self->param($param_name);
- return unless $param;
- return unless ref($param) && fileno($param);
- return $param;
+ my @param = grep(ref && fileno($_), $self->param($param_name));
+ return unless @param;
+ return wantarray ? @param : $param[0];
}
END_OF_FUNC
@@ -2858,6 +3233,22 @@ sub _set_values_and_labels {
}
END_OF_FUNC
+# internal routine, don't use
+'_set_attributes' => <<'END_OF_FUNC',
+sub _set_attributes {
+ my $self = shift;
+ my($element, $attributes) = @_;
+ return '' unless defined($attributes->{$element});
+ $attribs = ' ';
+ foreach my $attrib (keys %{$attributes->{$element}}) {
+ $attrib =~ s/^-//;
+ $attribs .= "@{[lc($attrib)]}=\"$attributes->{$element}{$attrib}\" ";
+ }
+ $attribs =~ s/ $//;
+ return $attribs;
+}
+END_OF_FUNC
+
'_compile_all' => <<'END_OF_FUNC',
sub _compile_all {
foreach (@_) {
@@ -2895,8 +3286,8 @@ sub asString {
my $self = shift;
# get rid of package name
(my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
- $i =~ s/\\(.)/$1/g;
- return $i;
+ $i =~ s/%(..)/ chr(hex($1)) /eg;
+ return $i.$CGI::TAINTED;
# BEGIN DEAD CODE
# This was an extremely clever patch that allowed "use strict refs".
# Unfortunately it relied on another bug that caused leaky file descriptors.
@@ -2919,13 +3310,16 @@ END_OF_FUNC
'new' => <<'END_OF_FUNC',
sub new {
my($pack,$name,$file,$delete) = @_;
+ _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
require Fcntl unless defined &Fcntl::O_RDWR;
- my $fv = ('Fh::' . ++$FH . quotemeta($name));
- warn unless *{$fv};
- my $ref = \*{$fv};
- sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
- unlink($file) if $delete;
- CORE::delete $Fh::{$FH};
+ (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
+ my $fv = ++$FH . $safename;
+ my $ref = \*{"Fh::$fv"};
+ $file =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
+ my $safe = $1;
+ sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
+ unlink($safe) if $delete;
+ CORE::delete $Fh::{$fv};
return bless $ref,$pack;
}
END_OF_FUNC
@@ -2993,7 +3387,7 @@ sub new {
# BUG: IE 3.01 on the Macintosh uses just the boundary -- not
# the two extra hyphens. We do a special case here on the user-agent!!!!
- $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac');
+ $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport');
} else { # otherwise we find it ourselves
my($old);
@@ -3050,15 +3444,15 @@ sub readHeader {
substr($self->{BUFFER},0,$end+4) = '';
my %return;
-
# See RFC 2045 Appendix A and RFC 822 sections 3.4.8
# (Folding Long Header Fields), 3.4.3 (Comments)
# and 3.4.5 (Quoted-Strings).
my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
$header=~s/$CRLF\s+/ /og; # merge continuation lines
+
while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
- my ($field_name,$field_value) = ($1,$2); # avoid taintedness
+ my ($field_name,$field_value) = ($1,$2);
$field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
$return{$field_name}=$field_value;
}
@@ -3099,8 +3493,7 @@ sub read {
die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
# If the boundary begins the data, then skip past it
- # and return undef. The +2 here is a fiendish plot to
- # remove the CR/LF pair at the end of the boundary.
+ # and return undef.
if ($start == 0) {
# clear us out completely if we've hit the last boundary.
@@ -3111,13 +3504,14 @@ sub read {
}
# just remove the boundary.
- substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
+ substr($self->{BUFFER},0,length($self->{BOUNDARY}))='';
+ $self->{BUFFER} =~ s/^\012\015?//;
return undef;
}
- my $bytesToReturn;
+ my $bytesToReturn;
if ($start > 0) { # read up to the boundary
- $bytesToReturn = $start > $bytes ? $bytes : $start;
+ $bytesToReturn = $start-2 > $bytes ? $bytes : $start;
} else { # read the requested number of bytes
# leave enough bytes in the buffer to allow us to read
# the boundary. Thanks to Kevin Hendrick for finding
@@ -3129,7 +3523,8 @@ sub read {
substr($self->{BUFFER},0,$bytesToReturn)='';
# If we hit the boundary, remove the CRLF from the end.
- return ($start > 0) ? substr($returnval,0,-2) : $returnval;
+ return ($bytesToReturn==$start)
+ ? substr($returnval,0,-2) : $returnval;
}
END_OF_FUNC
@@ -3186,17 +3581,20 @@ END_OF_AUTOLOAD
####################################################################################
################################## TEMPORARY FILES #################################
####################################################################################
-package TempFile;
-
-$SL = $CGI::SL;
-$MAC = $CGI::OS eq 'MACINTOSH';
-my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
-unless ($TMPDIRECTORY) {
+package CGITempFile;
+
+sub find_tempdir {
+ undef $TMPDIRECTORY;
+ $SL = $CGI::SL;
+ $MAC = $CGI::OS eq 'MACINTOSH';
+ my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
+ unless ($TMPDIRECTORY) {
@TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
"C:${SL}temp","${SL}tmp","${SL}temp",
"${vol}${SL}Temporary Items",
- "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH");
- unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'};
+ "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
+ "C:${SL}system${SL}temp");
+ unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'};
# this feature was supposed to provide per-user tmpfiles, but
# it is problematic.
@@ -3208,16 +3606,26 @@ unless ($TMPDIRECTORY) {
# unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
foreach (@TEMP) {
- do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
+ do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
}
+ }
+ $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
}
-$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
+find_tempdir();
+
$MAXTRIES = 5000;
# cute feature, but overload implementation broke it
# %OVERLOAD = ('""'=>'as_string');
-*TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
+*CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD;
+
+sub DESTROY {
+ my($self) = @_;
+ $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
+ my $safe = $1; # untaint operation
+ unlink $safe; # get rid of the file
+}
###############################################################################
################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
@@ -3230,23 +3638,18 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
sub new {
my($package,$sequence) = @_;
my $filename;
+ find_tempdir() unless -w $TMPDIRECTORY;
for (my $i = 0; $i < $MAXTRIES; $i++) {
last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
}
- # untaint the darn thing
- return unless $filename =~ m!^([a-zA-Z0-9_ '":/.\$\\]+)$!;
- $filename = $1;
+ # check that it is a more-or-less valid filename
+ return unless $filename =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$!;
+ # this used to untaint, now it doesn't
+ # $filename = $1;
return bless \$filename;
}
END_OF_FUNC
-'DESTROY' => <<'END_OF_FUNC',
-sub DESTROY {
- my($self) = @_;
- unlink $$self; # get rid of the file
-}
-END_OF_FUNC
-
'as_string' => <<'END_OF_FUNC'
sub as_string {
my($self) = @_;
@@ -3425,12 +3828,12 @@ this:
Code Generated HTML
---- --------------
- h1()
- h1('some','contents'); some contents
- h1({-align=>left});
- h1({-align=>left},'contents'); contents
+ h1()
+ h1('some','contents'); some contents
+ h1({-align=>left});
+ h1({-align=>left},'contents'); contents
-HTML tags are described in more detail later.
+HTML tags are described in more detail later.
Many newcomers to CGI.pm are puzzled by the difference between the
calling conventions for the HTML shortcuts, which require curly braces
@@ -3451,12 +3854,18 @@ have several choices:
=over 4
-=item 1. Use another name for the argument, if one is available. For
-example, -value is an alias for -values.
+=item 1.
+
+Use another name for the argument, if one is available.
+For example, -value is an alias for -values.
-=item 2. Change the capitalization, e.g. -Values
+=item 2.
-=item 3. Put quotes around the argument name, e.g. '-values'
+Change the capitalization, e.g. -Values
+
+=item 3.
+
+Put quotes around the argument name, e.g. '-values'
=back
@@ -3588,6 +3997,11 @@ If a value is not given in the query string, as in the queries
"name1=&name2=" or "name1&name2", it will be returned as an empty
string. This feature is new in 2.63.
+
+If the parameter does not exist at all, then param() will return undef
+in a scalar context, and the empty list in a list context.
+
+
=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
$query->param('foo','an','array','of','values');
@@ -3626,17 +4040,22 @@ If no namespace is given, this method will assume 'Q'.
WARNING: don't import anything into 'main'; this is a major security
risk!!!!
-In older versions, this method was called B. As of version 2.20,
+NOTE 1: Variable names are transformed as necessary into legal Perl
+variable names. All non-legal characters are transformed into
+underscores. If you need to keep the original names, you should use
+the param() method instead to access CGI variables by name.
+
+NOTE 2: In older versions, this method was called B. As of version 2.20,
this name has been removed completely to avoid conflict with the built-in
Perl module B operator.
=head2 DELETING A PARAMETER COMPLETELY:
- $query->delete('foo');
+ $query->delete('foo','bar','baz');
-This completely clears a parameter. It sometimes useful for
-resetting parameters that you don't want passed down between
-script invocations.
+This completely clears a list of parameters. It sometimes useful for
+resetting parameters that you don't want passed down between script
+invocations.
If you are using the function call interface, use "Delete()" instead
to avoid conflicts with Perl's built-in delete operator.
@@ -3678,13 +4097,13 @@ the keys are the names of the CGI parameters, and the values are the
parameters' values. The Vars() method does this. Called in a scalar
context, it returns the parameter list as a tied hash reference.
Changing a key changes the value of the parameter in the underlying
-CGI parameter list. Called in an array context, it returns the
+CGI parameter list. Called in a list context, it returns the
parameter list as an ordinary hash. This allows you to read the
contents of the parameter list, but not to change it.
When using this, the thing you must watch out for are multivalued CGI
parameters. Because a hash cannot distinguish between scalar and
-array context, multivalued parameters will be returned as a packed
+list context, multivalued parameters will be returned as a packed
string, separated by the "\0" (null) character. You must split this
packed string in order to get at the individual values. This is the
convention introduced long ago by Steve Brenner in his cgi-lib.pl
@@ -3811,9 +4230,14 @@ Import all methods that generate HTML 2.0 standard elements.
=item B<:html3>
-Import all methods that generate HTML 3.0 proposed elements (such as
+Import all methods that generate HTML 3.0 elements (such as
, and ).
+=item B<:html4>
+
+Import all methods that generate HTML 4 elements (such as
+, and ).
+
=item B<:netscape>
Import all methods that generate Netscape-specific HTML extensions.
@@ -3825,7 +4249,7 @@ Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
=item B<:standard>
-Import "standard" features, 'html2', 'html3', 'form' and 'cgi'.
+Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'.
=item B<:all>
@@ -3838,7 +4262,7 @@ If you import a function name that is not part of CGI.pm, the module
will treat it as a new HTML tag and generate the appropriate
subroutine. You can then use it like any other HTML tag. This is to
provide for the rapidly-evolving HTML "standard." For example, say
-Microsoft comes out with a new tag called (which causes the
+Microsoft comes out with a new tag called (which causes the
user's desktop to be flooded with a rotating gradient fill until his
machine reboots). You don't need to wait for a new version of CGI.pm
to start using it immediately:
@@ -3932,7 +4356,14 @@ or even
Note that using the -compile pragma in this way will always have
the effect of importing the compiled functions into the current
namespace. If you want to compile without importing use the
-compile() method instead (see below).
+compile() method instead:
+
+ use CGI();
+ CGI->compile();
+
+This is particularly useful in a mod_perl environment, in which you
+might want to precompile all CGI routines in a startup script, and
+then import the functions individually in each mod_perl script.
=item -nosticky
@@ -3942,6 +4373,17 @@ have the hidden fields appear in the querystring in a GET method.
For example, a search script generated this way will have
a very nice url with search parameters for bookmarking.
+=item -no_undef_params
+
+This keeps CGI.pm from including undef params in the parameter list.
+
+=item -no_xhtml
+
+By default, CGI.pm versions 2.69 and higher emit XHTML
+(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this
+feature. Thanks to Michalis Kabrianis for this
+feature.
+
=item -nph
This makes CGI.pm produce a header appropriate for an NPH (no
@@ -4041,7 +4483,7 @@ For example:
produces
- Level 1 Header
+ Level 1 Header
There will be some times when you want to produce the start and end
tags yourself. In this case, you can use the form start_I
@@ -4065,13 +4507,13 @@ the standard ones:
=over 4
-=item 1. start_table() (generates a tag)
+=item 1. start_table() (generates a tag)
-=item 2. end_table() (generates a
tag)
+=item 2. end_table() (generates a
tag)
-=item 3. start_ul() (generates a tag)
+=item 3. start_ul() (generates a tag)
-=item 4. end_ul() (generates a tag)
+=item 4. end_ul() (generates a tag)
=back
@@ -4114,6 +4556,7 @@ pages.
-expires=>'+3d',
-cookie=>$cookie,
-charset=>'utf-7',
+ -attachment=>'foo.gif',
-Cost=>'$2.00');
header() returns the Content-type: header. You can provide your own
@@ -4162,6 +4605,23 @@ The B<-charset> parameter can be used to control the character set
sent to the browser. If not provided, defaults to ISO-8859-1. As a
side effect, this sets the charset() method as well.
+The B<-attachment> parameter can be used to turn the page into an
+attachment. Instead of displaying the page, some browsers will prompt
+the user to save it to disk. The value of the argument is the
+suggested name for the saved file. In order for this to work, you may
+have to set the B<-type> to "application/octet-stream".
+
+The B<-p3p> parameter will add a P3P tag to the outgoing header. The
+parameter can be an arrayref or a space-delimited string of P3P tags.
+For example:
+
+ print header(-p3p=>[qw(CAO DSP LAW CURa)]);
+ print header(-p3p=>'CAO DSP LAW CURa');
+
+In either case, the outgoing header will be formatted as:
+
+ P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"
+
=head2 GENERATING A REDIRECTION HEADER
print $query->redirect('http://somewhere.else/in/movie/land');
@@ -4172,9 +4632,7 @@ time of day or the identity of the user.
The redirect() function redirects the browser to a different URL. If
you use redirection like this, you should B print out a header as
-well. As of version 2.0, we produce both the unofficial Location:
-header and the official URI: header. This should satisfy most servers
-and browsers.
+well.
One hint I can offer is that relative links may not work correctly
when you generate a redirection to another document on your site.
@@ -4189,7 +4647,7 @@ You can also use named arguments:
The B<-nph> parameter, if set to a true value, will issue the correct
headers to work with a NPH (no-parse-header) script. This is important
-to use with certain servers, such as Microsoft Internet Explorer, which
+to use with certain servers, such as Microsoft IIS, which
expect all their scripts to be NPH.
=head2 CREATING THE HTML DOCUMENT HEADER
@@ -4208,14 +4666,15 @@ out an HTML document. The start_html() routine creates the top of the
page, along with a lot of optional information that controls the
page's appearance and behavior.
-This method returns a canned HTML header and the opening tag.
+This method returns a canned HTML header and the opening tag.
All parameters are optional. In the named parameter form, recognized
-parameters are -title, -author, -base, -xbase and -target (see below
-for the explanation). Any additional parameters you provide, such as
-the Netscape unofficial BGCOLOR attribute, are added to the
-tag. Additional parameters must be proceeded by a hyphen.
+parameters are -title, -author, -base, -xbase, -dtd, -lang and -target
+(see below for the explanation). Any additional parameters you
+provide, such as the Netscape unofficial BGCOLOR attribute, are added
+to the tag. Additional parameters must be proceeded by a
+hyphen.
-The argument B<-xbase> allows you to provide an HREF for the tag
+The argument B<-xbase> allows you to provide an HREF for the tag
different from the current location, as in
-xbase=>"http://home.mcom.com/"
@@ -4234,29 +4693,38 @@ All relative links will be interpreted relative to this tag.
You add arbitrary meta information to the header with the B<-meta>
argument. This argument expects a reference to an associative array
containing name/value pairs of meta information. These will be turned
-into a series of header tags that look something like this:
+into a series of header tags that look something like this:
+
+
+
+
+To create an HTTP-EQUIV type of tag, use B<-head>, described
+below.
+
+The B<-style> argument is used to incorporate cascading stylesheets
+into your code. See the section on CASCADING STYLESHEETS for more
+information.
-
-
+The B<-lang> argument is used to incorporate a language attribute into
+the tag. The default if not specified is "en-US" for US
+English. For example:
-There is no direct support for the HTTP-EQUIV type of tag.
-This is because you can modify the HTTP header directly with the
-B method. For example, if you want to send the Refresh:
-header, do it in the header() method:
+ print $q->start_html(-lang=>'fr-CA');
- print $q->header(-Refresh=>'10; URL=http://www.capricorn.com');
+To leave off the lang attribute, as you must do if you want to generate
+legal HTML 3.2 or earlier, pass the empty string (-lang=>'').
-The B<-style> tag is used to incorporate cascading stylesheets into
-your code. See the section on CASCADING STYLESHEETS for more information.
+The B<-encoding> argument can be used to specify the character set for
+XHTML. It defaults to iso-8859-1 if not specified.
-You can place other arbitrary HTML elements to the section with the
-B<-head> tag. For example, to place the rarely-used element in the
+You can place other arbitrary HTML elements to the section with the
+B<-head> tag. For example, to place the rarely-used element in the
head section, use this:
print start_html(-head=>Link({-rel=>'next',
- -href=>'http://www.capricorn.com/s2.html'}));
+ -href=>'http://www.capricorn.com/s2.html'}));
-To incorporate multiple HTML elements into the section, just pass an
+To incorporate multiple HTML elements into the section, just pass an
array reference:
print start_html(-head=>[
@@ -4267,11 +4735,17 @@ array reference:
]
);
+And here's how to create an HTTP-EQUIV tag:
+
+ print start_html(-head=>meta({-http_equiv => 'Content-Type',
+ -content => 'text/html'}))
+
+
JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
to add Netscape JavaScript calls to your pages. B<-script> should
point to a block of text containing JavaScript function definitions.
-This block will be placed within a