");
}
@@ -1157,7 +1253,8 @@ sub multipart_start {
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
foreach (@other) {
- next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
+ # 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);
@@ -1205,11 +1302,11 @@ sub header {
return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
- my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,@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',
- 'ATTACHMENT'],@p);
+ 'ATTACHMENT','P3P'],@p);
$nph ||= $NPH;
if (defined $charset) {
@@ -1221,13 +1318,13 @@ 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) . ': '.$self->unescapeHTML($value)/e;
- $header = ucfirst($header);
+ # Don't use \s because of perl bug 21951
+ next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
+ ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
}
$type ||= 'text/html' unless defined($type);
- $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/;
+ $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';
@@ -1236,6 +1333,10 @@ sub header {
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;
@@ -1254,12 +1355,10 @@ sub header {
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;
}
@@ -1289,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);
+ 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
@@ -1331,13 +1431,13 @@ sub start_html {
$target,$meta,$head,$style,$dtd,$lang,$encoding,@other) =
rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD,LANG,ENCODING],@p);
- $encoding = 'utf-8' unless defined $encoding;
+ $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);
- $lang ||= 'en-US';
+ $lang = 'en-US' unless defined $lang;
my(@result,$xml_dtd);
if ($dtd) {
if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
@@ -1354,12 +1454,13 @@ sub start_html {
push @result,qq() if $xml_dtd;
if (ref($dtd) && ref($dtd) eq 'ARRAY') {
- push(@result,qq([0]"\n\tSYSTEM "$dtd->[1]">));
+ push(@result,qq([0]"\n\t "$dtd->[1]">));
} else {
push(@result,qq());
}
- push(@result,$XHTML ? qq($title)
- : qq($title));
+ push(@result,$XHTML ? qq($title)
+ : ($lang ? qq() : "")
+ . "$title");
if (defined $author) {
push(@result,$XHTML ? ""
: "");
@@ -1408,28 +1509,35 @@ sub _style {
my $cdata_end = $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
+ 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;
+ $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)
+ { # If it is, push a LINK tag for each one
+ foreach $src (@$src)
{
- push(@result,$XHTML ? qq()
- : qq(/)) if $src;
+ push(@result,$XHTML ? qq()
+ : qq()) if $src;
}
}
else
{ # Otherwise, push the single -src, if it exists.
- push(@result,$XHTML ? qq()
- : qq()
+ push(@result,$XHTML ? qq()
+ : qq()
) if $src;
}
- push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code;
+ if ($verbatim) {
+ push(@result, "");
+ }
+ push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code;
} else {
- push(@result,style({'type'=>$type},"$cdata_start\n$style\n$cdata_end"));
+ my $src = $style;
+ push(@result,$XHTML ? qq()
+ : qq());
}
@result;
}
@@ -1463,17 +1571,21 @@ sub _script {
$comment = '#' if $type=~/perl|tcl/i;
$comment = "'" if $type=~/vbscript/i;
- my $cdata_start = "\n\n";
-
- my(@satts);
- push(@satts,'src'=>$src) if $src;
- push(@satts,'language'=>$language);
- push(@satts,'type'=>$type);
- $code = "$cdata_start$code$cdata_end" if defined $code;
- push(@result,script({@satts},$code || ''));
+ 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;
}
@@ -1499,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 $XHTML ? "" : "";
+ return $XHTML ? "" : "";
}
END_OF_FUNC
@@ -1527,8 +1639,10 @@ sub startform {
$method = lc($method) || 'post';
$enctype = $enctype || &URL_ENCODED;
unless (defined $action) {
- $action = $self->url(-absolute=>1,-path=>1);
- $action .= "?$ENV{QUERY_STRING}" if $ENV{QUERY_STRING};
+ $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" : '';
@@ -1578,8 +1692,8 @@ sub endform {
if ( $NOSTICKY ) {
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
@@ -1598,7 +1712,7 @@ 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);
@@ -1612,7 +1726,7 @@ sub _textfield {
# and WebTV -- not sure it won't break stuff
my($value) = $current ne '' ? qq(value="$current") : '';
return $XHTML ? qq()
- : qq//;
+ : qq();
}
END_OF_FUNC
@@ -1624,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 {
@@ -1640,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 {
@@ -1659,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 {
@@ -1706,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 {
@@ -1727,7 +1841,7 @@ sub button {
$script = qq/ onclick="$script"/ if $script;
my($other) = @other ? " @other" : '';
return $XHTML ? qq()
- : qq//;
+ : qq();
}
END_OF_FUNC
@@ -1739,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 {
@@ -1753,11 +1867,11 @@ sub submit {
my($name) = ' name=".submit"' unless $NOSTICKY;
$name = qq/ name="$label"/ if defined($label);
$value = defined($value) ? $value : $label;
- my($val) = '';
+ my $val = '';
$val = qq/ value="$value"/ if defined($value);
my($other) = @other ? " @other" : '';
return $XHTML ? qq()
- : qq//;
+ : qq();
}
END_OF_FUNC
@@ -1767,17 +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 $XHTML ? qq()
- : qq//;
+ return $XHTML ? qq()
+ : qq();
}
END_OF_FUNC
@@ -1787,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
@@ -1829,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 {
@@ -1877,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);
@@ -1916,13 +2035,16 @@ sub checkbox_group {
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label = $self->escapeHTML($label);
}
+ my $attribs = $self->_set_attributes($_, $attributes);
$_ = $self->escapeHTML($_,1);
- push(@elements,$XHTML ? qq(${label}${break})
- : qq/${label}${break}/);
+ 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
@@ -1934,7 +2056,7 @@ sub escapeHTML {
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->{'dontescape'};
+ return $toencode if ref($self) && !$self->{'escape'};
$toencode =~ s{&}{&}gso;
$toencode =~ s{<}{<}gso;
$toencode =~ s{>}{>}gso;
@@ -1943,8 +2065,8 @@ sub escapeHTML {
uc $self->{'.charset'} eq 'WINDOWS-1252';
if ($latin) { # bug in some browsers
$toencode =~ s{'}{'}gso;
- $toencode =~ s{\x8b}{}gso;
- $toencode =~ s{\x9b}{}gso;
+ $toencode =~ s{\x8b}{‹}gso;
+ $toencode =~ s{\x9b}{›}gso;
if (defined $newlinestoo && $newlinestoo) {
$toencode =~ s{\012}{
}gso;
$toencode =~ s{\015}{
}gso;
@@ -2029,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);
@@ -2057,7 +2179,7 @@ sub radio_group {
my($other) = @other ? " @other" : '';
foreach (@values) {
- my($checkit) = $checked eq $_ ? qq/ checked="1"/ : '';
+ my($checkit) = $checked eq $_ ? qq/ checked="checked"/ : '';
my($break);
if ($linebreak) {
$break = $XHTML ? " " : " ";
@@ -2071,9 +2193,10 @@ sub radio_group {
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label = $self->escapeHTML($label,1);
}
+ my $attribs = $self->_set_attributes($_, $attributes);
$_=$self->escapeHTML($_);
- push(@elements,$XHTML ? qq(${label}${break})
- : qq/${label}${break}/);
+ push(@elements,$XHTML ? qq(${label}${break})
+ : qq/${label}${break}/);
}
$self->register_parameter($name);
return wantarray ? @elements : join(' ',@elements)
@@ -2101,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))) {
@@ -2118,12 +2242,22 @@ sub popup_menu {
$result = qq/";
@@ -2132,6 +2266,66 @@ sub popup_menu {
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