summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJarkko Hietaniemi <jhi@iki.fi>2000-08-10 23:03:34 +0000
committerJarkko Hietaniemi <jhi@iki.fi>2000-08-10 23:03:34 +0000
commit6b4ac6611c98278a0d6cf49b8f443a5cf6468a7a (patch)
treeafa01341286ca20a733a8d98d2eedd5bb1ad9f74
parentde34a54bfab4821fac0ced381d11269fbacc498b (diff)
downloadperl-6b4ac6611c98278a0d6cf49b8f443a5cf6468a7a.tar.gz
Update to CGI 2.70, from Lincoln Stein.
p4raw-id: //depot/perl@6580
-rw-r--r--lib/CGI.pm360
-rw-r--r--lib/CGI/Carp.pm79
-rw-r--r--lib/CGI/Cookie.pm44
-rw-r--r--lib/CGI/Pretty.pm4
-rw-r--r--lib/CGI/Push.pm4
-rw-r--r--lib/CGI/Util.pm34
-rwxr-xr-xt/lib/cgi-form.t52
-rwxr-xr-xt/lib/cgi-function.t18
-rwxr-xr-xt/lib/cgi-html.t82
-rwxr-xr-xt/lib/cgi-pretty.t23
-rwxr-xr-xt/lib/cgi-request.t8
11 files changed, 400 insertions, 308 deletions
diff --git a/lib/CGI.pm b/lib/CGI.pm
index 8b7568af8a..e017853369 100644
--- a/lib/CGI.pm
+++ b/lib/CGI.pm
@@ -17,18 +17,24 @@ 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.39 2000/07/28 03:00:03 lstein Exp $';
+$CGI::VERSION='2.70';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
# $TempFile::TMPDIRECTORY = '/usr/tmp';
use CGI::Util qw(rearrange make_attributes unescape escape expires);
+use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
+ 'DTD/xhtml1-transitional.dtd'];
+
# >>>>> 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');
@@ -569,13 +575,13 @@ sub _make_tag_func {
}
);
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 \@_;
+ my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
my \@result = map { "\$tag\$_\$untag" }
(ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
return "\@result";
@@ -644,6 +650,8 @@ 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$/;
$EXPORT{$_}++, next if /^[:-]any$/;
@@ -717,7 +725,8 @@ END_OF_FUNC
# Deletes the named parameter entirely.
####
sub delete {
- my($self,$name) = self_or_default(@_);
+ my($self,@p) = self_or_default(@_);
+ my($name) = rearrange([NAME],@p);
CORE::delete $self->{$name};
CORE::delete $self->{'.fieldnames'}->{$name};
@{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
@@ -851,7 +860,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
@@ -1135,10 +1145,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,@other) =
rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
'STATUS',['COOKIE','COOKIES'],'TARGET',
- 'EXPIRES','NPH','CHARSET'],@p);
+ 'EXPIRES','NPH','CHARSET',
+ 'ATTACHMENT'],@p);
$nph ||= $NPH;
if (defined $charset) {
@@ -1151,11 +1162,11 @@ sub header {
# need to fix it up a little.
foreach (@other) {
next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
- ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e;
+ ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.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/;
# Maybe future compatibility. Maybe not.
my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
@@ -1178,6 +1189,7 @@ sub header {
if $expires;
push(@header,"Date: " . expires(0,'http')) if $expires || $cookie;
push(@header,"Pragma: no-cache") if $self->cache();
+ push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
push(@header,@other);
push(@header,"Content-Type: $type") if $type ne '';
@@ -1216,7 +1228,7 @@ 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;
+ $url ||= $self->self_url;
my(@o);
foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
unshift(@o,
@@ -1253,39 +1265,45 @@ 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,$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,@other) =
+ rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD,LANG],@p);
# strangely enough, the title needs to be escaped as HTML
# while the author needs to be escaped as a URL
$title = $self->escapeHTML($title || 'Untitled Document');
$author = $self->escape($author);
+ $lang ||= 'en-US';
my(@result);
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;
}
if (ref($dtd) && ref($dtd) eq 'ARRAY') {
- push(@result,qq(<!DOCTYPE HTML PUBLIC "$dtd->[0]"\n\t"$dtd->[1]">));
+ push(@result,qq(<!DOCTYPE HTML\n\tPUBLIC "$dtd->[0]"\n\t"$dtd->[1]">));
} else {
- push(@result,qq(<!DOCTYPE HTML PUBLIC "$dtd">));
+ push(@result,qq(<!DOCTYPE HTML\n\tPUBLIC "$dtd">));
}
- push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
- push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if defined $author;
+ push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml" lang="$lang"><head><title>$title</title>)
+ : qq(<html lang="$lang"><head><title>$title</title>));
+ if (defined $author) {
+ push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
+ : "<link rev=made href=\"mailto:$author\">");
+ }
if ($base || $xbase || $target) {
my $href = $xbase || $self->url('-path'=>1);
- my $t = $target ? qq/ TARGET="$target"/ : '';
- push(@result,qq/<BASE HREF="$href"$t>/);
+ my $t = $target ? qq/ target="$target"/ : '';
+ push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
}
if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
- foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
+ foreach (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
+ : qq(<meta name="$_" content="$meta->{$_}">)); }
}
push(@result,ref($head) ? @$head : $head) if $head;
@@ -1296,13 +1314,13 @@ sub start_html {
# handle -noscript parameter
push(@result,<<END) if $noscript;
-<NOSCRIPT>
+<noscript>
$noscript
-</NOSCRIPT>
+</noscript>
END
;
my($other) = @other ? " @other" : '';
- push(@result,"</HEAD><BODY$other>");
+ push(@result,"</head><body$other>");
return join("\n",@result);
}
END_OF_FUNC
@@ -1316,21 +1334,33 @@ sub _style {
my (@result);
my $type = 'text/css';
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/<LINK REL="stylesheet" TYPE="$type" HREF="$src">/) if $src;
- push(@result,style({'type'=>$type},"<!--\n$code\n-->")) if $code;
+ 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;
+ #### Here is new code for checking for array reference in -src tag (6/20/00 -- JJN) #####
+ #### This should be passed in like this --> -src=>{['style1.css','style2.css','style3.css']}
+ 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,qq/<link rel="stylesheet" type="$type" href="$src">/) if $src;
+ }
+ }
+ else
+ { # Otherwise, push the single -src, if it exists.
+ push(@result,qq/<link rel="stylesheet" type="$type" href="$src">/) if $src;
+ }
+ #### End new code ####
+ push(@result,style({'type'=>$type},"<!--\n$code\n-->")) if $code;
} else {
- push(@result,style({'type'=>$type},"<!--\n$style\n-->"));
+ push(@result,style({'type'=>$type},"<!--\n$style\n-->"));
}
@result;
}
END_OF_FUNC
-
'_script' => <<'END_OF_FUNC',
sub _script {
my ($self,$script) = @_;
@@ -1377,7 +1407,7 @@ END_OF_FUNC
####
'end_html' => <<'END_OF_FUNC',
sub end_html {
- return "</BODY></HTML>";
+ return "</body></html>";
}
END_OF_FUNC
@@ -1396,9 +1426,9 @@ 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 "<ISINDEX $action$other>";
+ return $XHTML ? "<isindex $action$other />" : "<isindex $action$other>";
}
END_OF_FUNC
@@ -1416,13 +1446,12 @@ sub startform {
my($method,$action,$enctype,@other) =
rearrange([METHOD,ACTION,ENCTYPE],@p);
- $method = $method || 'POST';
+ $method = uc($method) || 'POST';
$enctype = $enctype || &URL_ENCODED;
- $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
- 'ACTION="'.$self->script_name.'"' : '';
+ $action = $action ? qq(action="$action") : qq 'action="' . $self->script_name . '"';
my($other) = @other ? " @other" : '';
$self->{'.parametersToAdd'}={};
- return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
+ return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
}
END_OF_FUNC
@@ -1465,10 +1494,10 @@ END_OF_FUNC
sub endform {
my($self,@p) = self_or_default(@_);
if ( $NOSTICKY ) {
- return wantarray ? ("</FORM>") : "\n</FORM>";
+ return wantarray ? ("</form>") : "\n</form>";
} else {
- return wantarray ? ($self->get_fields,"</FORM>") :
- $self->get_fields ."\n</FORM>";
+ return wantarray ? ($self->get_fields,"</form>") :
+ $self->get_fields ."\n</form>";
}
}
END_OF_FUNC
@@ -1494,13 +1523,14 @@ sub _textfield {
$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($s) = defined($size) ? qq/ size=$size/ : '';
+ my($m) = defined($maxlength) ? qq/ maxlength=$maxlength/ : '';
my($other) = @other ? " @other" : '';
# this entered at cristy's request to fix problems with file upload fields
# and WebTV -- not sure it won't break stuff
- my($value) = $current ne '' ? qq(VALUE="$current") : '';
- return qq/<INPUT TYPE="$tag" NAME="$name" $value$s$m$other>/;
+ my($value) = $current ne '' ? qq(value="$current") : '';
+ return $XHTML ? qq(<input type="$tag" name="$name" $value$s$m$other />)
+ : qq/<input type="$tag" name="$name" $value$s$m$other>/;
}
END_OF_FUNC
@@ -1578,10 +1608,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 ? " rows=$rows" : '';
+ my($c) = $cols ? " cols=$cols" : '';
my($other) = @other ? " @other" : '';
- return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
+ return qq{<textarea name="$name"$r$c$other>$current</textarea>};
}
END_OF_FUNC
@@ -1611,10 +1641,11 @@ sub button {
$name = qq/ NAME="$label"/ if $label;
$value = $value || $label;
my($val) = '';
- $val = qq/ VALUE="$value"/ if $value;
- $script = qq/ ONCLICK="$script"/ if $script;
+ $val = qq/ value="$value"/ if $value;
+ $script = qq/ onclick="$script"/ if $script;
my($other) = @other ? " @other" : '';
- return qq/<INPUT TYPE="button"$name$val$script$other>/;
+ return $XHTML ? qq(<input type="button"$name$val$script$other />)
+ : qq/<input type="button"$name$val$script$other>/;
}
END_OF_FUNC
@@ -1637,13 +1668,14 @@ sub submit {
$label=$self->escapeHTML($label);
$value=$self->escapeHTML($value);
- 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);
+ $val = qq/ value="$value"/ if defined($value);
my($other) = @other ? " @other" : '';
- return qq/<INPUT TYPE="submit"$name$val$other>/;
+ return $XHTML ? qq(<input type="submit"$name$val$other />)
+ : qq/<input type="submit"$name$val$other>/;
}
END_OF_FUNC
@@ -1660,9 +1692,10 @@ sub reset {
my($self,@p) = self_or_default(@_);
my($label,@other) = rearrange([NAME],@p);
$label=$self->escapeHTML($label);
- my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
+ my($value) = defined($label) ? qq/ value="$label"/ : '';
my($other) = @other ? " @other" : '';
- return qq/<INPUT TYPE="reset"$value$other>/;
+ return $XHTML ? qq(<input type="reset"$value$other />)
+ : qq/<input type="reset"$value$other>/;
}
END_OF_FUNC
@@ -1686,9 +1719,10 @@ sub defaults {
$label=$self->escapeHTML($label);
$label = $label || "Defaults";
- my($value) = qq/ VALUE="$label"/;
+ my($value) = qq/ value="$label"/;
my($other) = @other ? " @other" : '';
- return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
+ return $XHTML ? qq(<input type="submit" value".defaults"$value$other />)
+ : qq/<input type="submit" NAME=".defaults"$value$other>/;
}
END_OF_FUNC
@@ -1726,9 +1760,9 @@ 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)) ? ' checked="yes"' : '';
} else {
- $checked = $checked ? ' CHECKED' : '';
+ $checked = $checked ? qq/ checked="yes"/ : '';
}
my($the_label) = defined $label ? $label : $name;
$name = $self->escapeHTML($name);
@@ -1736,7 +1770,8 @@ sub checkbox {
$the_label = $self->escapeHTML($the_label);
my($other) = @other ? " @other" : '';
$self->register_parameter($name);
- return qq{<INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label};
+ return $XHTML ? qq{<input type="checkbox" name="$name" value="$value"$checked$other />$the_label}
+ : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
}
END_OF_FUNC
@@ -1777,7 +1812,12 @@ sub checkbox_group {
my(%checked) = $self->previous_or_default($name,$defaults,$override);
- $break = $linebreak ? "<BR>" : '';
+ if ($linebreak) {
+ $break = $XHTML ? "<br />" : "<br>";
+ }
+ else {
+ $break = '';
+ }
$name=$self->escapeHTML($name);
# Create the elements
@@ -1787,7 +1827,7 @@ sub checkbox_group {
my($other) = @other ? " @other" : '';
foreach (@values) {
- $checked = $checked{$_} ? ' CHECKED' : '';
+ $checked = $checked{$_} ? qq/ checked="yes"/ : '';
$label = '';
unless (defined($nolabels) && $nolabels) {
$label = $_;
@@ -1795,7 +1835,8 @@ sub checkbox_group {
$label = $self->escapeHTML($label);
}
$_ = $self->escapeHTML($_);
- push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label}${break}/);
+ push(@elements,$XHTML ? qq(<input type="checkbox" name="$name" value="$_"$checked$other />${label}${break})
+ : qq/<input type="checkbox" name="$name" value="$_"$checked$other>${label}${break}/);
}
$self->register_parameter($name);
return wantarray ? @elements : join(' ',@elements)
@@ -1807,32 +1848,28 @@ 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 '<') { '&lt;' }
- elsif ($1 eq '>') { '&gt;' }
- elsif ($1 eq '&') { '&amp;' }
- elsif ($1 eq '"') { '&quot;' }
- elsif ($1 eq "\x8b") { '&#139;' }
- elsif ($1 eq "\x9b") { '&#155;' }
- else { $1 }
- }gsex;
- } else {
- $toencode =~ s/(.)/'&#'.ord($1).';'/gsex;
- }
- return $toencode;
+ my ($self,$toencode) = CGI::self_or_default(@_);
+ return undef unless defined($toencode);
+ return $toencode if ref($self) && $self->{'dontescape'};
+ $toencode =~ s{&}{&amp;}gso;
+ $toencode =~ s{<}{&lt;}gso;
+ $toencode =~ s{>}{&gt;}gso;
+ $toencode =~ s{"}{&quot;}gso;
+ if (uc $self->{'.charset'} eq 'ISO-8859-1' or
+ uc $self->{'.charset'} eq 'WINDOWS-1252') { # bug
+ $toencode =~ s{\x8b}{&#139;}gso;
+ $toencode =~ s{\x9b}{&#155;}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 = $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i;
# thanks to Randal Schwartz for the correct solution to this one
$string=~ s[&(.*?);]{
local $_ = $1;
@@ -1840,8 +1877,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 +1889,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 +1901,23 @@ sub _tableize {
}
# rearrange into a pretty table
- $result = "<TABLE>";
+ $result = "<table>";
my($row,$column);
unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
- $result .= "<TR>" if @{$colheaders};
+ $result .= "<tr>" if @{$colheaders};
foreach (@{$colheaders}) {
- $result .= "<TH>$_</TH>";
+ $result .= "<th>$_</th>";
}
for ($row=0;$row<$rows;$row++) {
- $result .= "<TR>";
- $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
+ $result .= "<tr>";
+ $result .= "<th>$rowheaders->[$row]</th>" if @$rowheaders;
for ($column=0;$column<$columns;$column++) {
- $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>"
+ $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
if defined($elements[$column*$rows + $row]);
}
- $result .= "</TR>";
+ $result .= "</tr>";
}
- $result .= "</TABLE>";
+ $result .= "</table>";
return $result;
}
END_OF_FUNC
@@ -1927,8 +1966,14 @@ sub radio_group {
my($other) = @other ? " @other" : '';
foreach (@values) {
- my($checkit) = $checked eq $_ ? ' CHECKED' : '';
- my($break) = $linebreak ? '<BR>' : '';
+ my($checkit) = $checked eq $_ ? qq/ checked="yes"/ : '';
+ my($break);
+ if ($linebreak) {
+ $break = $XHTML ? "<br />" : "<br>";
+ }
+ else {
+ $break = '';
+ }
my($label)='';
unless (defined($nolabels) && $nolabels) {
$label = $_;
@@ -1936,7 +1981,8 @@ sub radio_group {
$label = $self->escapeHTML($label);
}
$_=$self->escapeHTML($_);
- push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label}${break}/);
+ push(@elements,$XHTML ? qq(<input type="radio" name="$name" value="$_"$checkit$other />${label}${break})
+ : qq/<input type="radio" name="$name" value="$_"$checkit$other>${label}${break}/);
}
$self->register_parameter($name);
return wantarray ? @elements : join(' ',@elements)
@@ -1979,17 +2025,17 @@ sub popup_menu {
my(@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
- $result = qq/<SELECT NAME="$name"$other>\n/;
+ $result = qq/<select name="$name"$other>\n/;
foreach (@values) {
- my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
+ my($selectit) = defined($selected) ? ($selected eq $_ ? qq/selected="yes"/ : '' ) : '';
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
my($value) = $self->escapeHTML($_);
$label=$self->escapeHTML($label);
- $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
+ $result .= "<option $selectit value=\"$value\">$label</option>\n";
}
- $result .= "</SELECT>\n";
+ $result .= "</select>\n";
return $result;
}
END_OF_FUNC
@@ -2028,21 +2074,21 @@ 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="yes"/ : '';
+ my($has_size) = $size ? qq/ size="$size"/: '';
my($other) = @other ? " @other" : '';
$name=$self->escapeHTML($name);
- $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
+ $result = qq/<select name="$name"$has_size$is_multiple$other>\n/;
foreach (@values) {
- my($selectit) = $selected{$_} ? 'SELECTED' : '';
+ my($selectit) = $selected{$_} ? qq/selected="yes"/ : '';
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label=$self->escapeHTML($label);
my($value)=$self->escapeHTML($_);
- $result .= "<OPTION $selectit VALUE=\"$value\">$label</OPTION>\n";
+ $result .= "<option $selectit value=\"$value\">$label</option>\n";
}
- $result .= "</SELECT>\n";
+ $result .= "</select>\n";
$self->register_parameter($name);
return $result;
}
@@ -2085,7 +2131,8 @@ sub hidden {
$name=$self->escapeHTML($name);
foreach (@value) {
$_ = defined($_) ? $self->escapeHTML($_) : '';
- push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
+ push(@result,$XHTMl ? qq(<input type="hidden" name="$name" value="$_" />)
+ : qq/<input type="hidden" name="$name" value="$_">/);
}
return wantarray ? @result : join('',@result);
}
@@ -2107,10 +2154,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/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/;
+ return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
+ : qq/<input type="image" name="$name" src="$src"$align$other>/;
}
END_OF_FUNC
@@ -2239,7 +2287,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
@@ -2762,7 +2810,7 @@ sub read_multipart {
my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
# Bug: Netscape doesn't escape quotation marks in file names!!!
- my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/;
+ my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\"]*)"?/;
# add this parameter to our list
$self->add_parameter($param);
@@ -2920,12 +2968,12 @@ END_OF_FUNC
sub new {
my($pack,$name,$file,$delete) = @_;
require Fcntl unless defined &Fcntl::O_RDWR;
- my $fv = ('Fh::' . ++$FH . quotemeta($name));
- warn unless *{$fv};
- my $ref = \*{$fv};
+ my $fv = ++$FH . quotemeta($name);
+ warn unless *{"Fh::$fv"};
+ my $ref = \*{"Fh::$fv"};
sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
unlink($file) if $delete;
- CORE::delete $Fh::{$FH};
+ CORE::delete $Fh::{$fv};
return bless $ref,$pack;
}
END_OF_FUNC
@@ -3678,13 +3726,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 a list context, it returns the
+CGI parameter list. Called in an array context, it returns the
parameter list as an ordinary hash. This allows you to read the
contents of the parameter list, but not to change it.
When using this, the thing you must watch out for are multivalued CGI
parameters. Because a hash cannot distinguish between scalar and
-list context, multivalued parameters will be returned as a packed
+array context, multivalued parameters will be returned as a packed
string, separated by the "\0" (null) character. You must split this
packed string in order to get at the individual values. This is the
convention introduced long ago by Steve Brenner in his cgi-lib.pl
@@ -3942,6 +3990,13 @@ 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_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 <kabrianis@hellug.gr> for this
+feature.
+
=item -nph
This makes CGI.pm produce a header appropriate for an NPH (no
@@ -4114,6 +4169,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 +4218,12 @@ 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".
+
=head2 GENERATING A REDIRECTION HEADER
print $query->redirect('http://somewhere.else/in/movie/land');
@@ -4172,9 +4234,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<not> print out a header as
-well. As of version 2.0, we produce both the unofficial Location:
-header and the official URI: header. This should satisfy most servers
-and browsers.
+well.
One hint I can offer is that relative links may not work correctly
when you generate a redirection to another document on your site.
@@ -4210,10 +4270,11 @@ page's appearance and behavior.
This method returns a canned HTML header and the opening <BODY> tag.
All parameters are optional. In the named parameter form, recognized
-parameters are -title, -author, -base, -xbase and -target (see below
-for the explanation). Any additional parameters you provide, such as
-the Netscape unofficial BGCOLOR attribute, are added to the <BODY>
-tag. Additional parameters must be proceeded by a hyphen.
+parameters are -title, -author, -base, -xbase, -dtd, -lang and -target
+(see below for the explanation). Any additional parameters you
+provide, such as the Netscape unofficial BGCOLOR attribute, are added
+to the <BODY> tag. Additional parameters must be proceeded by a
+hyphen.
The argument B<-xbase> allows you to provide an HREF for the <BASE> tag
different from the current location, as in
@@ -4239,22 +4300,25 @@ into a series of header <META> tags that look something like this:
<META NAME="keywords" CONTENT="pharaoh secret mummy">
<META NAME="description" CONTENT="copyright 1996 King Tut">
-There is no direct support for the HTTP-EQUIV type of <META> tag.
-This is because you can modify the HTTP header directly with the
-B<header()> method. For example, if you want to send the Refresh:
-header, do it in the header() method:
+To create an HTTP-EQUIV type of <META> tag, use B<-head>, described
+below.
- print $q->header(-Refresh=>'10; URL=http://www.capricorn.com');
+The B<-style> argument is used to incorporate cascading stylesheets
+into your code. See the section on CASCADING STYLESHEETS for more
+information.
-The B<-style> tag is used to incorporate cascading stylesheets into
-your code. See the section on CASCADING STYLESHEETS for more information.
+The B<-lang> argument is used to incorporate a language attribute into
+the <HTML> tag. The default if not specified is "en-US" for US
+English. For example:
+
+ print $q->header(-lang=>'fr-CA');
You can place other arbitrary HTML elements to the <HEAD> section with the
B<-head> tag. For example, to place the rarely-used <LINK> element in the
head section, use this:
print start_html(-head=>Link({-rel=>'next',
- -href=>'http://www.capricorn.com/s2.html'}));
+ -href=>'http://www.capricorn.com/s2.html'}));
To incorporate multiple HTML elements into the <HEAD> section, just pass an
array reference:
@@ -4267,6 +4331,12 @@ array reference:
]
);
+And here's how to create an HTTP-EQUIV <META> tag:
+
+ print header(-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
@@ -4579,7 +4649,7 @@ element of the list. For example, here's one way to make an ordered
list:
print ul(
- li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']);
+ li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy'])
);
This example will result in HTML output that looks like this:
@@ -4793,7 +4863,7 @@ This is the older type of encoding used by all browsers prior to
Netscape 2.0. It is compatible with many CGI scripts and is
suitable for short fields containing text data. For your
convenience, CGI.pm stores the name of this encoding
-type in B<$CGI::URL_ENCODED>.
+type in B<&CGI::URL_ENCODED>.
=item B<multipart/form-data>
@@ -4947,7 +5017,7 @@ recognized. See textfield().
filefield() will return a file upload field for Netscape 2.0 browsers.
In order to take full advantage of this I<you must use the new
multipart encoding scheme> for the form. You can do this either
-by calling B<start_form()> with an encoding type of B<$CGI::MULTIPART>,
+by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>,
or by calling the new method B<start_multipart_form()> instead of
vanilla B<start_form()>.
@@ -5854,6 +5924,9 @@ http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
);
print end_html;
+Pass an array reference to B<-style> in order to incorporate multiple
+stylesheets into your document.
+
=head1 DEBUGGING
If you are running the script from the command line or in the perl
@@ -5962,9 +6035,8 @@ like $query->user_agent(netscape);
=item B<path_info()>
Returns additional path information from the script URL.
-E.G. fetching /cgi-bin/your_script/additional/stuff will
-result in $query->path_info() returning
-"additional/stuff".
+E.G. fetching /cgi-bin/your_script/additional/stuff will result in
+$query->path_info() returning "/additional/stuff".
NOTE: The Microsoft Internet Information Server
is broken with respect to additional path information. If
diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm
index 0a5c1218ee..5aea1985ec 100644
--- a/lib/CGI/Carp.pm
+++ b/lib/CGI/Carp.pm
@@ -142,6 +142,33 @@ of the error message that caused the script to die. Example:
In order to correctly intercept compile-time errors, you should call
set_message() from within a BEGIN{} block.
+=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS
+
+It is now also possible to make non-fatal errors appear as HTML
+comments embedded in the output of your program. To enable this
+feature, export the new "warningsToBrowser" subroutine. Since sending
+warnings to the browser before the HTTP headers have been sent would
+cause an error, any warnings are stored in an internal buffer until
+you call the warningsToBrowser() subroutine with a true argument:
+
+ use CGI::Carp qw(fatalsToBrowser warningsToBrowser);
+ use CGI qw(:standard);
+ print header();
+ warningsToBrowser(1);
+
+You may also give a false argument to warningsToBrowser() to prevent
+warnings from being sent to the browser while you are printing some
+content where HTML comments are not allowed:
+
+ warningsToBrowser(0); # disable warnings
+ print "<SCRIPT type=javascript><!--\n";
+ print_some_javascript_code();
+ print "//--></SCRIPT>\n";
+ warningsToBrowser(1); # re-enable warnings
+
+Note: In this respect warningsToBrowser() differs fundamentally from
+fatalsToBrowser(), which you should never call yourself!
+
=head1 CHANGE LOG
1.05 carpout() added and minor corrections by Marc Hedlund
@@ -166,7 +193,11 @@ set_message() from within a BEGIN{} block.
1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning.
1.13 Added cluck() to make the module orthogonal with Carp.
- More mod_perl related fixes.
+ More mod_perl related fixes.
+
+1.20 Patch from Ilmari Karonen (perl@itz.pp.sci.fi): Added
+ warningsToBrowser(). Replaced <CODE> tags with <PRE> in
+ fatalsToBrowser() output.
=head1 AUTHORS
@@ -190,18 +221,11 @@ use Carp;
@ISA = qw(Exporter);
@EXPORT = qw(confess croak carp);
-@EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message cluck);
-
-BEGIN {
- $] >= 5.005
- ? eval q#sub ineval { defined $^S ? $^S : _longmess() =~ /eval [\{\']/m }#
- : eval q#sub ineval { _longmess() =~ /eval [\{\']/m }#;
- $@ and die;
-}
+@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message cluck);
$main::SIG{__WARN__}=\&CGI::Carp::warn;
$main::SIG{__DIE__}=\&CGI::Carp::die;
-$CGI::Carp::VERSION = '1.16';
+$CGI::Carp::VERSION = '1.20';
$CGI::Carp::CUSTOM_MSG = undef;
# fancy import routine detects and handles 'errorWrap' specially.
@@ -210,6 +234,7 @@ sub import {
my(%routines);
grep($routines{$_}++,@_,@EXPORT);
$WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
+ $WARN++ if $routines{'warningsToBrowser'};
my($oldlevel) = $Exporter::ExportLevel;
$Exporter::ExportLevel = 1;
Exporter::import($pkg,keys %routines);
@@ -223,7 +248,7 @@ sub realdie { CORE::die(@_); }
sub id {
my $level = shift;
my($pack,$file,$line,$sub) = caller($level);
- my($id) = $file=~m|([^/]+)\z|;
+ my($id) = $file=~m|([^/]+)$|;
return ($file,$line,$id);
}
@@ -235,7 +260,7 @@ sub stamp {
$id = $file;
($pack,$file) = caller($frame++);
} until !$file;
- ($id) = $id=~m|([^/]+)\z|;
+ ($id) = $id=~m|([^/]+)$|;
return "[$time] $id: ";
}
@@ -243,23 +268,40 @@ sub warn {
my $message = shift;
my($file,$line,$id) = id(1);
$message .= " at $file line $line.\n" unless $message=~/\n$/;
+ _warn($message) if $WARN;
my $stamp = stamp;
$message=~s/^/$stamp/gm;
realwarn $message;
}
+sub _warn {
+ my $msg = shift;
+ if ($EMIT_WARNINGS) {
+ # We need to mangle the message a bit to make it a valid HTML
+ # comment. This is done by substituting similar-looking ISO
+ # 8859-1 characters for <, > and -. This is a hack.
+ $msg =~ tr/<>-/\253\273\255/;
+ chomp $msg;
+ print STDOUT "<!-- warning: $msg -->\n";
+ } else {
+ push @WARNINGS, $msg;
+ }
+}
+
+sub ineval { _longmess() =~ /eval [\{\']/m }
+
# The mod_perl package Apache::Registry loads CGI programs by calling
# eval. These evals don't count when looking at the stack backtrace.
sub _longmess {
my $message = Carp::longmess();
my $mod_perl = exists $ENV{MOD_PERL};
$message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl;
- return( $message );
+ return $message;
}
sub die {
realdie @_ if ineval;
- my $message = shift;
+ my ($message) = @_;
my $time = scalar(localtime);
my($file,$line,$id) = id(1);
$message .= " at $file line $line." unless $message=~/\n$/;
@@ -299,6 +341,11 @@ sub carpout {
( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
}
+sub warningsToBrowser {
+ $EMIT_WARNINGS = @_ ? shift : 1;
+ _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS;
+}
+
# headers
sub fatalsToBrowser {
my($msg) = @_;
@@ -318,6 +365,8 @@ END
print STDOUT "Content-type: text/html\n\n"
unless $mod_perl;
+ warningsToBrowser(1); # emit warnings before dying
+
if ($CUSTOM_MSG) {
if (ref($CUSTOM_MSG) eq 'CODE') {
&$CUSTOM_MSG($msg); # nicer to perl 5.003 users
@@ -329,7 +378,7 @@ END
my $mess = <<END;
<H1>Software error:</H1>
-<CODE>$msg</CODE>
+<PRE>$msg</PRE>
<P>
$outer_message
END
diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm
index 575ae79458..8c5ac1efc6 100644
--- a/lib/CGI/Cookie.pm
+++ b/lib/CGI/Cookie.pm
@@ -40,17 +40,18 @@ sub raw_fetch {
my %results;
my($key,$value);
- my(@pairs) = split("; ",$raw_cookie);
+ my(@pairs) = split("; ?",$raw_cookie);
foreach (@pairs) {
- if (/^([^=]+)=(.*)/) {
- $key = $1;
- $value = $2;
- }
- else {
- $key = $_;
- $value = '';
- }
- $results{$key} = $value;
+ s/\s*(.*?)\s*/$1/;
+ if (/^([^=]+)=(.*)/) {
+ $key = $1;
+ $value = $2;
+ }
+ else {
+ $key = $_;
+ $value = '';
+ }
+ $results{$key} = $value;
}
return \%results unless wantarray;
return %results;
@@ -60,17 +61,18 @@ sub parse {
my ($self,$raw_cookie) = @_;
my %results;
- my(@pairs) = split("; ",$raw_cookie);
+ my(@pairs) = split("; ?",$raw_cookie);
foreach (@pairs) {
- my($key,$value) = split("=");
- my(@values) = map unescape($_),split('&',$value);
- $key = unescape($key);
- # Some foreign cookies are not in name=value format, so ignore
- # them.
- next if !defined($value);
- # A bug in Netscape can cause several cookies with same name to
- # appear. The FIRST one in HTTP_COOKIE is the most recent version.
- $results{$key} ||= $self->new(-name=>$key,-value=>\@values);
+ s/\s*(.*?)\s*/$1/;
+ my($key,$value) = split("=");
+ my(@values) = map unescape($_),split('&',$value);
+ $key = unescape($key);
+ # Some foreign cookies are not in name=value format, so ignore
+ # them.
+ next if !defined($value);
+ # A bug in Netscape can cause several cookies with same name to
+ # appear. The FIRST one in HTTP_COOKIE is the most recent version.
+ $results{$key} ||= $self->new(-name=>$key,-value=>\@values);
}
return \%results unless wantarray;
return %results;
@@ -382,7 +384,7 @@ Get or set the cookie's value. Example:
$value = $c->value;
@new_value = $c->value(['a','b','c','d']);
-B<value()> is context sensitive. In a list context it will return
+B<value()> is context sensitive. In an array context it will return
the current value of the cookie as an array. In a scalar context it
will return the B<first> value of a multivalued cookie.
diff --git a/lib/CGI/Pretty.pm b/lib/CGI/Pretty.pm
index 20173f9acf..d348807d68 100644
--- a/lib/CGI/Pretty.pm
+++ b/lib/CGI/Pretty.pm
@@ -72,7 +72,7 @@ sub _make_tag_func {
\$attr = " \@attr" if \@attr;
}
- my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U</$tagname>\E");
+ my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
return \$tag unless \@_;
my \@result;
@@ -128,7 +128,7 @@ sub initialize_globals {
$CGI::Pretty::LINEBREAK = "\n";
# These tags are not prettify'd.
- @CGI::Pretty::AS_IS = qw( A PRE CODE SCRIPT TEXTAREA );
+ @CGI::Pretty::AS_IS = qw( a pre code script textarea );
1;
}
diff --git a/lib/CGI/Push.pm b/lib/CGI/Push.pm
index 6b8e012a15..83002f2336 100644
--- a/lib/CGI/Push.pm
+++ b/lib/CGI/Push.pm
@@ -16,7 +16,7 @@ package CGI::Push;
# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::Push::VERSION='1.02';
+$CGI::Push::VERSION='1.03';
use CGI;
use CGI::Util 'rearrange';
@ISA = ('CGI');
@@ -60,7 +60,7 @@ sub do_push {
while (1) {
last unless (@contents = &$callback($self,++$COUNTER)) && defined($contents[0]);
print "Content-type: ${type}$CGI::CRLF$CGI::CRLF"
- unless $type eq 'dynamic';
+ unless $type =~ /^dynamic|heterogeneous$/i;
print @contents,"$CGI::CRLF";
print "${boundary}$CGI::CRLF";
do_sleep($self->push_delay()) if $self->push_delay();
diff --git a/lib/CGI/Util.pm b/lib/CGI/Util.pm
index cb6dd8a9e2..ac7376d41a 100644
--- a/lib/CGI/Util.pm
+++ b/lib/CGI/Util.pm
@@ -1,13 +1,5 @@
package CGI::Util;
-=pod
-
-=head1 NAME
-
-CGI::Util - various utilities
-
-=cut
-
use strict;
use vars '$VERSION','@EXPORT_OK','@ISA','$EBCDIC','@A2E';
require Exporter;
@@ -56,14 +48,14 @@ sub rearrange {
my ($i,%pos);
$i = 0;
foreach (@$order) {
- foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; }
+ foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
$i++;
}
my (@result,%leftover);
$#result = $#$order; # preextend
while (@param) {
- my $key = uc(shift(@param));
+ my $key = lc(shift(@param));
$key =~ s/^\-//;
if (exists $pos{$key}) {
$result[$pos{$key}] = shift(@param);
@@ -72,7 +64,7 @@ sub rearrange {
}
}
- push (@result,make_attributes(\%leftover)) if %leftover;
+ push (@result,make_attributes(\%leftover,1)) if %leftover;
@result;
}
@@ -84,7 +76,7 @@ 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, use dashes
+ $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
}
@@ -92,16 +84,14 @@ sub make_attributes {
}
sub simple_escape {
- return unless defined (my $toencode = shift);
- $toencode =~ s{(.)}{
- if ($1 eq '<') { '&lt;' }
- elsif ($1 eq '>') { '&gt;' }
- elsif ($1 eq '&') { '&amp;' }
- elsif ($1 eq '"') { '&quot;' }
- elsif ($1 eq "\x8b") { '&#139;' }
- elsif ($1 eq "\x9b") { '&#155;' }
- else { $1 }
- }gsex;
+ return unless defined(my $toencode = shift);
+ $toencode =~ s{&}{&amp;}gso;
+ $toencode =~ s{<}{&lt;}gso;
+ $toencode =~ s{>}{&gt;}gso;
+ $toencode =~ s{\"}{&quot;}gso;
+# Doesn't work. Can't work. forget it.
+# $toencode =~ s{\x8b}{&#139;}gso;
+# $toencode =~ s{\x9b}{&#155;}gso;
$toencode;
}
diff --git a/t/lib/cgi-form.t b/t/lib/cgi-form.t
index e3cba5fc20..1be3894582 100755
--- a/t/lib/cgi-form.t
+++ b/t/lib/cgi-form.t
@@ -1,12 +1,8 @@
-#!./perl
+#!/usr/local/bin/perl -w
# Test ability to retrieve HTTP request info
######################### We start with some black magic to print on failure.
-
-BEGIN {
- chdir 't' if -d 't';
- unshift @INC, '../lib' if -d '../lib';
-}
+use lib '../blib/lib','../blib/arch';
BEGIN {$| = 1; print "1..17\n"; }
END {print "not ok 1\n" unless $loaded;}
@@ -34,48 +30,48 @@ $ENV{SERVER_PORT} = 8080;
$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
test(2,start_form(-action=>'foobar',-method=>GET) eq
- qq(<FORM METHOD="GET" ACTION="foobar" ENCTYPE="application/x-www-form-urlencoded">\n),
+ qq(<form method="GET" action="foobar" enctype="application/x-www-form-urlencoded">\n),
"start_form()");
-test(3,submit() eq qq(<INPUT TYPE="submit" NAME=".submit">),"submit()");
-test(4,submit(-name=>'foo',-value=>'bar') eq qq(<INPUT TYPE="submit" NAME="foo" VALUE="bar">),"submit(-name,-value)");
-test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(<INPUT TYPE="submit" NAME="foo" VALUE="bar">),"submit({-name,-value})");
-test(6,textfield(-name=>'weather') eq qq(<INPUT TYPE="text" NAME="weather" VALUE="dull">),"textfield({-name})");
-test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="text" NAME="weather" VALUE="dull">),"textfield({-name,-value})");
-test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<INPUT TYPE="text" NAME="weather" VALUE="nice">),
+test(3,submit() eq qq(<input type="submit" name=".submit" />),"submit()");
+test(4,submit(-name=>'foo',-value=>'bar') eq qq(<input type="submit" name="foo" value="bar" />),"submit(-name,-value)");
+test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(<input type="submit" name="foo" value="bar" />),"submit({-name,-value})");
+test(6,textfield(-name=>'weather') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name})");
+test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name,-value})");
+test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<input type="text" name="weather" value="nice" />),
"textfield({-name,-value,-override})");
-test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">weather),
+test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<input type="checkbox" name="weather" value="nice" />weather),
"checkbox()");
test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq
- qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">forecast),
+ qq(<input type="checkbox" name="weather" value="nice" />forecast),
"checkbox()");
test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq
- qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice" CHECKED>forecast),
+ qq(<input type="checkbox" name="weather" value="nice" checked="yes" />forecast),
"checkbox()");
test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq
- qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="dull" CHECKED>forecast),
+ qq(<input type="checkbox" name="weather" value="dull" checked="yes" />forecast),
"checkbox()");
test(13,radio_group(-name=>'game') eq
- qq(<INPUT TYPE="radio" NAME="game" VALUE="chess" CHECKED>chess <INPUT TYPE="radio" NAME="game" VALUE="checkers">checkers),
+ qq(<input type="radio" name="game" value="chess" checked="yes" />chess <input type="radio" name="game" value="checkers" />checkers),
'radio_group()');
test(14,radio_group(-name=>'game',-labels=>{'chess'=>'ping pong'}) eq
- qq(<INPUT TYPE="radio" NAME="game" VALUE="chess" CHECKED>ping pong <INPUT TYPE="radio" NAME="game" VALUE="checkers">checkers),
+ qq(<input type="radio" name="game" value="chess" checked="yes" />ping pong <input type="radio" name="game" value="checkers" />checkers),
'radio_group()');
test(15, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/]) eq
- qq(<INPUT TYPE="checkbox" NAME="game" VALUE="checkers" CHECKED>checkers <INPUT TYPE="checkbox" NAME="game" VALUE="chess" CHECKED>chess <INPUT TYPE="checkbox" NAME="game" VALUE="cribbage">cribbage),
+ qq(<input type="checkbox" name="game" value="checkers" checked="yes" />checkers <input type="checkbox" name="game" value="chess" checked="yes" />chess <input type="checkbox" name="game" value="cribbage" />cribbage),
'checkbox_group()');
-test(16, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/],-Defaults=>['cribbage'],-override=>1) eq
- qq(<INPUT TYPE="checkbox" NAME="game" VALUE="checkers">checkers <INPUT TYPE="checkbox" NAME="game" VALUE="chess">chess <INPUT TYPE="checkbox" NAME="game" VALUE="cribbage" CHECKED>cribbage),
+test(16, checkbox_group(-name=>'game',-values=>[qw/checkers chess cribbage/],-defaults=>['cribbage'],-override=>1) eq
+ qq(<input type="checkbox" name="game" value="checkers" />checkers <input type="checkbox" name="game" value="chess" />chess <input type="checkbox" name="game" value="cribbage" checked="yes" />cribbage),
'checkbox_group()');
-test(17, popup_menu(-name=>'game',-Values=>[qw/checkers chess cribbage/],-Default=>'cribbage',-override=>1) eq <<END,'checkbox_group()');
-<SELECT NAME="game">
-<OPTION VALUE="checkers">checkers
-<OPTION VALUE="chess">chess
-<OPTION SELECTED VALUE="cribbage">cribbage
-</SELECT>
+test(17, popup_menu(-name=>'game',-values=>[qw/checkers chess cribbage/],-default=>'cribbage',-override=>1) eq <<END,'checkbox_group()');
+<select name="game">
+<option value="checkers">checkers</option>
+<option value="chess">chess</option>
+<option selected="yes" value="cribbage">cribbage</option>
+</select>
END
diff --git a/t/lib/cgi-function.t b/t/lib/cgi-function.t
index 934e27cdc9..87ce5d4438 100755
--- a/t/lib/cgi-function.t
+++ b/t/lib/cgi-function.t
@@ -1,12 +1,8 @@
-#!./perl
+#!/usr/local/bin/perl -w
# Test ability to retrieve HTTP request info
######################### We start with some black magic to print on failure.
-
-BEGIN {
- chdir 't' if -d 't';
- unshift @INC, '../lib' if -d '../lib';
-}
+use lib '../blib/lib','../blib/arch';
BEGIN {$| = 1; print "1..27\n"; }
END {print "not ok 1\n" unless $loaded;}
@@ -80,12 +76,12 @@ if ($Config{d_fork}) {
}
# at this point, we're in a new (child) process
test(23,param('weather') eq 'nice',"CGI::param() from POST");
- test(24,url_param('big_balls') eq 'basketball',"CGI::url_param()");
+ test(24,(url_param('big_balls') eq 'basketball'),"CGI::url_param()");
} else {
print "ok 23 # Skip\n";
print "ok 24 # Skip\n";
}
-
-test(25,redirect('http://somewhere.else') eq "Status: 302 Moved${CRLF}Location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1");
-test(26,redirect(-Location=>'http://somewhere.else',-Type=>'text/html') eq "Status: 302 Moved${CRLF}Location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");
-test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Moved${CRLF}Location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");
+test(25,redirect('http://somewhere.else') eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1");
+my $h = redirect(-Location=>'http://somewhere.else',-Type=>'text/html');
+test(26,$h eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");
+test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Moved${CRLF}location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");
diff --git a/t/lib/cgi-html.t b/t/lib/cgi-html.t
index 1e20a315fa..1ce02e402c 100755
--- a/t/lib/cgi-html.t
+++ b/t/lib/cgi-html.t
@@ -1,13 +1,8 @@
-#!./perl
+#!/usr/local/bin/perl -w
# Test ability to retrieve HTTP request info
######################### We start with some black magic to print on failure.
-
-BEGIN {
- chdir 't' if -d 't';
- unshift @INC, '../lib' if -d '../lib';
- require Config; import Config;
-}
+use lib '../blib/lib','../blib/arch';
BEGIN {$| = 1; print "1..24\n"; }
END {print "not ok 1\n" unless $loaded;}
@@ -17,9 +12,6 @@ print "ok 1\n";
######################### End of black magic.
-my $Is_EBCDIC = $Config{'ebcdic'} eq 'define';
-my $crlf = $CGI::CRLF;
-
# util
sub test {
local($^W) = 0;
@@ -28,53 +20,55 @@ sub test {
}
# all the automatic tags
-test(2,h1() eq '<H1>',"single tag");
-test(3,h1('fred') eq '<H1>fred</H1>',"open/close tag");
-test(4,h1('fred','agnes','maura') eq '<H1>fred agnes maura</H1>',"open/close tag multiple");
-test(5,h1({-align=>'CENTER'},'fred') eq '<H1 ALIGN="CENTER">fred</H1>',"open/close tag with attribute");
-test(6,h1({-align=>undef},'fred') eq '<H1 ALIGN>fred</H1>',"open/close tag with orphan attribute");
+test(2,h1() eq '<h1 />',"single tag");
+test(3,h1('fred') eq '<h1>fred</h1>',"open/close tag");
+test(4,h1('fred','agnes','maura') eq '<h1>fred agnes maura</h1>',"open/close tag multiple");
+test(5,h1({-align=>'CENTER'},'fred') eq '<h1 align="CENTER">fred</h1>',"open/close tag with attribute");
+test(6,h1({-align=>undef},'fred') eq '<h1 align>fred</h1>',"open/close tag with orphan attribute");
test(7,h1({-align=>'CENTER'},['fred','agnes']) eq
- '<H1 ALIGN="CENTER">fred</H1> <H1 ALIGN="CENTER">agnes</H1>',
+ '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>',
"distributive tag with attribute");
{
local($") = '-';
- test(8,h1('fred','agnes','maura') eq '<H1>fred-agnes-maura</H1>',"open/close tag \$\" interpolation");
+ test(8,h1('fred','agnes','maura') eq '<h1>fred-agnes-maura</h1>',"open/close tag \$\" interpolation");
}
-
-test(9,header() eq "Content-Type: text/html; charset=ISO-8859-1$crlf$crlf","header()");
-test(10,header(-type=>'image/gif') eq "Content-Type: image/gif; charset=ISO-8859-1$crlf$crlf","header()");
-test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${crlf}Content-Type: image/gif; charset=ISO-8859-1$crlf$crlf","header()");
-test(12,header(-nph=>1) eq "HTTP/1.0 200 OK${crlf}Content-Type: text/html; charset=ISO-8859-1$crlf$crlf","header()");
+test(9,header() eq "Content-Type: text/html; charset=ISO-8859-1\015\012\015\012","header()");
+test(10,header(-type=>'image/gif') eq "Content-Type: image/gif\015\012\015\012","header()");
+test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks\015\012Content-Type: image/gif\015\012\015\012","header()");
+test(12,header(-nph=>1) eq "HTTP/1.0 200 OK\015\012Content-Type: text/html; charset=ISO-8859-1\015\012\015\012","header()");
test(13,start_html() ."\n" eq <<END,"start_html()");
-<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
- "http://www.w3.org/TR/html4/loose.dtd">
-<HTML><HEAD><TITLE>Untitled Document</TITLE>
-</HEAD><BODY>
+<!DOCTYPE HTML
+ PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
+ "DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title>
+</head><body>
END
;
test(14,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR") ."\n" eq <<END,"start_html()");
-<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 3.2//FR">
-<HTML><HEAD><TITLE>Untitled Document</TITLE>
-</HEAD><BODY>
+<!DOCTYPE HTML
+ PUBLIC "-//IETF//DTD HTML 3.2//FR">
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title>
+</head><body>
END
;
test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()");
-<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
- "http://www.w3.org/TR/html4/loose.dtd">
-<HTML><HEAD><TITLE>The world of foo</TITLE>
-</HEAD><BODY>
+<!DOCTYPE HTML
+ PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
+ "DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>The world of foo</title>
+</head><body>
END
;
-test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq
- 'fred=chocolate&chip; path=/',"cookie()");
-test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${crlf}Date:.*${crlf}Content-Type: text/html$crlf$crlf!s,
- "header(-cookie)");
-test(18,start_h3 eq '<H3>');
-test(19,end_h3 eq '</H3>');
-test(20,start_table({-border=>undef}) eq '<TABLE BORDER>');
-test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<H1>this is &lt;not&gt; &#139;right&#155;</H1>');
+test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq 'fred=chocolate&chip; path=/',"cookie()");
+my $h = header(-Cookie=>$cookie);
+test(17,$h =~ m!^Set-Cookie: fred=chocolate&chip\; path=/\015\012Date:.*\015\012Content-Type: text/html; charset=ISO-8859-1\015\012\015\012!s,
+ "header(-cookie)");
+test(18,start_h3 eq '<h3>');
+test(19,end_h3 eq '</h3>');
+test(20,start_table({-border=>undef}) eq '<table border>');
+test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is &lt;not&gt; &#139;right&#155;</h1>');
charset('utf-8');
-test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<H1>&#116;&#104;&#105;&#115;&#32;&#105;&#115;&#32;&#60;&#110;&#111;&#116;&#62;&#32;&#139;&#114;&#105;&#103;&#104;&#116;&#155;</H1>');
-test(23,i(p('hello there')) eq '<I><P>hello there</P></I>');
+test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is &lt;not&gt; ‹right›</h1>');
+test(23,i(p('hello there')) eq '<i><p>hello there</p></i>');
my $q = new CGI;
-test(24,$q->h1('hi') eq '<H1>hi</H1>');
+test(24,$q->h1('hi') eq '<h1>hi</h1>');
diff --git a/t/lib/cgi-pretty.t b/t/lib/cgi-pretty.t
index e217a7dbd4..807897f66d 100755
--- a/t/lib/cgi-pretty.t
+++ b/t/lib/cgi-pretty.t
@@ -1,11 +1,8 @@
-#!./perl
+#!/usr/local/bin/perl -w
# Test ability to retrieve HTTP request info
######################### We start with some black magic to print on failure.
-BEGIN {
- chdir 't' if -d 't';
- unshift @INC, '../lib' if -d '../lib';
-}
+use lib '../blib/lib','../blib/arch';
BEGIN {$| = 1; print "1..5\n"; }
END {print "not ok 1\n" unless $loaded;}
@@ -23,17 +20,17 @@ sub test {
}
# all the automatic tags
-test(2,h1() eq '<H1>',"single tag");
-test(3,ol(li('fred'),li('ethel')) eq "<OL>\n\t<LI>\n\t\tfred\n\t</LI>\n\t <LI>\n\t\tethel\n\t</LI>\n</OL>\n","basic indentation");
+test(2,h1() eq '<h1>',"single tag");
+test(3,ol(li('fred'),li('ethel')) eq "<ol>\n\t<li>\n\t\tfred\n\t</li>\n\t <li>\n\t\tethel\n\t</li>\n</ol>\n","basic indentation");
test(4,p('hi',pre('there'),'frog') eq
-'<P>
- hi <PRE>there</PRE>
+'<p>
+ hi <pre>there</pre>
frog
-</P>
+</p>
',"<pre> tags");
test(5,p('hi',a({-href=>'frog'},'there'),'frog') eq
-'<P>
- hi <A HREF="frog">there</A>
+'<p>
+ hi <a href="frog">there</a>
frog
-</P>
+</p>
',"as-is");
diff --git a/t/lib/cgi-request.t b/t/lib/cgi-request.t
index 390c08cccd..96775a9279 100755
--- a/t/lib/cgi-request.t
+++ b/t/lib/cgi-request.t
@@ -1,12 +1,8 @@
-#!./perl
+#!/usr/local/bin/perl -w
# Test ability to retrieve HTTP request info
######################### We start with some black magic to print on failure.
-
-BEGIN {
- chdir 't' if -d 't';
- unshift @INC, '../lib' if -d '../lib';
-}
+use lib '../blib/lib','../blib/arch';
BEGIN {$| = 1; print "1..33\n"; }
END {print "not ok 1\n" unless $loaded;}