Change 33587 by [EMAIL PROTECTED] on 2008/03/28 13:12:32
Integrate:
[ 32299]
Re-apply change #30562 (thanks to Abe Timmerman)
[ 33581]
Integrate:
[ 33552]
Upgrade to Module-Pluggable-3.8
[ 33571]
Actually use the computed @path so as to write the awkwardly named test
files to the right place when in core. Without this the open fails
(silently as intended) and the tests are skipped on all OS.
[ 33582]
Integrate:
[ 32683]
Subject: [perl #37607] CGI file upload file name parsing errors
From: [EMAIL PROTECTED] (Marko Asplund)
Date: Fri, 4 Nov 2005 13:40:05 +0200 (EET)
Message-ID: <[EMAIL PROTECTED]>
[ 32883]
Silence new warning grep in void context warning in various modules and
test files, also silence a warning that came from a previous 'dev' version
number bump.
[ 33094]
Subject: [PATCH] Fix uc/lc warnings in CGI.pm
From: "Jerry D. Hedden" <[EMAIL PROTECTED]>
Date: Mon, 28 Jan 2008 10:19:26 -0500
Message-ID: <[EMAIL PROTECTED]>
[ 33129]
Assorted POD nits from the Debian bug list.
[ 33143]
Subject: Re: [perl #50322] CGITempFile causes "Insecure dependency in
sprintf" in perl 5.10.0
From: "Steffen Mueller via RT" <[EMAIL PROTECTED]>
Date: Mon, 28 Jan 2008 05:16:19 -0800
Message-ID: <[EMAIL PROTECTED]>
Fixes [perl #50322]
[ 33564]
Upgrade to CGI.pm-3.34. There are still a few differences, so adding
a version bump.
[ 33568]
Upgrade to CGI-3.35.
[ 33585]
Integrate:
[ 32883]
Silence new warning grep in void context warning in various modules and
test files, also silence a warning that came from a previous 'dev' version
number bump.
[ 32884]
dev version numbers, xs and warnings dont play together nicely, so use
MM->parse_version() to smooth over the cracks....
[ 33583]
Subject: [PATCH] DB_File 1.817
From: "Paul Marquess" <[EMAIL PROTECTED]>
Date: Thu, 27 Mar 2008 11:12:22 -0000
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/maint-5.8/perl/ext/DB_File/Changes#11 integrate
... //depot/maint-5.8/perl/ext/DB_File/DB_File.pm#15 integrate
... //depot/maint-5.8/perl/ext/DB_File/DB_File.xs#14 integrate
... //depot/maint-5.8/perl/ext/DB_File/Makefile.PL#3 integrate
... //depot/maint-5.8/perl/ext/DB_File/dbinfo#4 integrate
... //depot/maint-5.8/perl/ext/DB_File/t/db-btree.t#6 integrate
... //depot/maint-5.8/perl/ext/DB_File/t/db-hash.t#9 integrate
... //depot/maint-5.8/perl/ext/DB_File/t/db-recno.t#9 integrate
... //depot/maint-5.8/perl/ext/DB_File/version.c#2 integrate
... //depot/maint-5.8/perl/ext/Module/Pluggable/Makefile.PL#2 integrate
... //depot/maint-5.8/perl/ext/Module/Pluggable/lib/Module/Pluggable.pm#2
integrate
... //depot/maint-5.8/perl/lib/CGI.pm#22 integrate
... //depot/maint-5.8/perl/lib/CGI/Changes#9 integrate
... //depot/maint-5.8/perl/lib/CGI/Util.pm#12 integrate
Differences ...
==== //depot/maint-5.8/perl/ext/DB_File/Changes#11 (text) ====
Index: perl/ext/DB_File/Changes
--- perl/ext/DB_File/Changes#10~32291~ 2007-11-12 12:55:44.000000000 -0800
+++ perl/ext/DB_File/Changes 2008-03-28 06:12:32.000000000 -0700
@@ -1,9 +1,26 @@
+1.817 27 March 2008
+
+ * Updated dbinfo
+
+ * Applied core patch 32299 - Re-apply change #30562
+
+ * Applied core patch 32208
+
+ * Applied core patch 32884 - use MM->parse_version() in Makefile.PL
+
+ * Applied core patch 32883 - Silence new warning grep in void context
warning
+
+ * Applied core patch 32704 to remove use of PL_na in typemap
+
+ * Applied core patch 30562 to fix a build issue on OSF
+
1.816 28 October 2007
* Clarified the warning about building with a different version of
Berkeley DB that is used at runtime.
+
* Also made the boot version check less strict.
[rt.cpan.org #30013]
==== //depot/maint-5.8/perl/ext/DB_File/DB_File.pm#15 (text) ====
Index: perl/ext/DB_File/DB_File.pm
--- perl/ext/DB_File/DB_File.pm#14~32291~ 2007-11-12 12:55:44.000000000
-0800
+++ perl/ext/DB_File/DB_File.pm 2008-03-28 06:12:32.000000000 -0700
@@ -2,9 +2,9 @@
#
# written by Paul Marquess ([EMAIL PROTECTED])
# last modified 28th October 2007
-# version 1.816
+# version 1.817
#
-# Copyright (c) 1995-2007 Paul Marquess. All rights reserved.
+# Copyright (c) 1995-2008 Paul Marquess. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
@@ -165,7 +165,8 @@
use Carp;
-$VERSION = "1.816" ;
+$VERSION = "1.817" ;
+$VERSION = eval $VERSION; # needed for dev releases
{
local $SIG{__WARN__} = sub {$splice_end_array = "@_";};
==== //depot/maint-5.8/perl/ext/DB_File/DB_File.xs#14 (text) ====
Index: perl/ext/DB_File/DB_File.xs
--- perl/ext/DB_File/DB_File.xs#13~32291~ 2007-11-12 12:55:44.000000000
-0800
+++ perl/ext/DB_File/DB_File.xs 2008-03-28 06:12:32.000000000 -0700
@@ -4,11 +4,11 @@
written by Paul Marquess <[EMAIL PROTECTED]>
last modified 4th February 2007
- version 1.815
+ version 1.817
All comments/suggestions/problems are welcome
- Copyright (c) 1995-2005 Paul Marquess. All rights reserved.
+ Copyright (c) 1995-2008 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
@@ -1192,7 +1192,7 @@
Flags |= DB_TRUNCATE ;
#endif
- status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo,
&RETVAL->dbp) ;
+ status = db_open(name, RETVAL->type, Flags, mode, NULL,
(DB_INFO*)openinfo, &RETVAL->dbp) ;
if (status == 0)
#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor)
;
==== //depot/maint-5.8/perl/ext/DB_File/Makefile.PL#3 (text) ====
Index: perl/ext/DB_File/Makefile.PL
--- perl/ext/DB_File/Makefile.PL#2~30746~ 2007-03-24 08:06:54.000000000
-0700
+++ perl/ext/DB_File/Makefile.PL 2008-03-28 06:12:32.000000000 -0700
@@ -22,6 +22,7 @@
XSPROTOARG => '-noprototypes',
DEFINE => $OS2 || "",
INC => ($^O eq "MacOS" ? "-i ::::db:include" : ""),
+ XS_VERSION => eval MM->parse_version('DB_File.pm'),
((ExtUtils::MakeMaker->VERSION() gt '6.30')
? ('LICENSE' => 'perl')
: ()
==== //depot/maint-5.8/perl/ext/DB_File/dbinfo#4 (text) ====
Index: perl/ext/DB_File/dbinfo
--- perl/ext/DB_File/dbinfo#3~21626~ 2003-11-02 12:27:25.000000000 -0800
+++ perl/ext/DB_File/dbinfo 2008-03-28 06:12:32.000000000 -0700
@@ -4,10 +4,10 @@
# a database file
#
# Author: Paul Marquess <[EMAIL PROTECTED]>
-# Version: 1.05
-# Date 1sh November 2003
+# Version: 1.06
+# Date 27th MArch 2008
#
-# Copyright (c) 1998-2003 Paul Marquess. All rights reserved.
+# Copyright (c) 1998-2008 Paul Marquess. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
@@ -18,9 +18,10 @@
my %Data =
(
- 0x053162 => {
+ 0x053162 => # DB_BTREEMAGIC
+ {
Type => "Btree",
- Versions =>
+ Versions => # DB_BTREEVERSION
{
1 => [0, "Unknown (older than 1.71)"],
2 => [0, "Unknown (older than 1.71)"],
@@ -33,9 +34,10 @@
9 => [1, "4.1.x or greater"],
}
},
- 0x061561 => {
+ 0x061561 => # DB_HASHMAGIC
+ {
Type => "Hash",
- Versions =>
+ Versions => # DB_HASHVERSION
{
1 => [0, "Unknown (older than 1.71)"],
2 => [0, "1.71 -> 1.85"],
@@ -45,11 +47,13 @@
6 => [0, "3.0.x"],
7 => [0, "3.1.x -> 4.0.x"],
8 => [1, "4.1.x or greater"],
+ 9 => [1, "4.6.x or greater"],
}
},
- 0x042253 => {
+ 0x042253 => # DB_QAMMAGIC
+ {
Type => "Queue",
- Versions =>
+ Versions => # DB_QAMVERSION
{
1 => [0, "3.0.x"],
2 => [0, "3.1.x"],
==== //depot/maint-5.8/perl/ext/DB_File/t/db-btree.t#6 (xtext) ====
Index: perl/ext/DB_File/t/db-btree.t
--- perl/ext/DB_File/t/db-btree.t#5~26616~ 2006-01-03 09:56:09.000000000
-0800
+++ perl/ext/DB_File/t/db-btree.t 2008-03-28 06:12:32.000000000 -0700
@@ -1472,7 +1472,7 @@
$h{"fred"} = "joe" ;
ok(173, $h{"fred"} eq "joe");
- eval { grep { $h{$_} } (1, 2, 3) };
+ eval { my @r= grep { $h{$_} } (1, 2, 3) };
ok (174, ! $@);
@@ -1488,7 +1488,7 @@
ok(176, $db->FIRSTKEY() eq "fred") ;
- eval { grep { $h{$_} } (1, 2, 3) };
+ eval { my @r= grep { $h{$_} } (1, 2, 3) };
ok (177, ! $@);
undef $db ;
==== //depot/maint-5.8/perl/ext/DB_File/t/db-hash.t#9 (xtext) ====
Index: perl/ext/DB_File/t/db-hash.t
--- perl/ext/DB_File/t/db-hash.t#8~26616~ 2006-01-03 09:56:09.000000000
-0800
+++ perl/ext/DB_File/t/db-hash.t 2008-03-28 06:12:32.000000000 -0700
@@ -970,7 +970,7 @@
$h{"fred"} = "joe" ;
ok(137, $h{"fred"} eq "joe");
- eval { grep { $h{$_} } (1, 2, 3) };
+ eval { my @r= grep { $h{$_} } (1, 2, 3) };
ok (138, ! $@);
@@ -986,7 +986,7 @@
ok(140, $db->FIRSTKEY() eq "fred") ;
- eval { grep { $h{$_} } (1, 2, 3) };
+ eval { my @r= grep { $h{$_} } (1, 2, 3) };
ok (141, ! $@);
undef $db ;
==== //depot/maint-5.8/perl/ext/DB_File/t/db-recno.t#9 (xtext) ====
Index: perl/ext/DB_File/t/db-recno.t
--- perl/ext/DB_File/t/db-recno.t#8~26616~ 2006-01-03 09:56:09.000000000
-0800
+++ perl/ext/DB_File/t/db-recno.t 2008-03-28 06:12:32.000000000 -0700
@@ -994,7 +994,7 @@
$h[0] = "joe" ;
ok(155, $h[0] eq "joe");
- eval { grep { $h[$_] } (1, 2, 3) };
+ eval { my @r= grep { $h[$_] } (1, 2, 3) };
ok (156, ! $@);
@@ -1008,7 +1008,7 @@
ok(157, $h[1] eq "joe");
- eval { grep { $h[$_] } (1, 2, 3) };
+ eval { my @r= grep { $h[$_] } (1, 2, 3) };
ok (158, ! $@);
undef $db ;
==== //depot/maint-5.8/perl/ext/DB_File/version.c#2 (text) ====
Index: perl/ext/DB_File/version.c
--- perl/ext/DB_File/version.c#1~17645~ 2002-07-19 12:29:57.000000000 -0700
+++ perl/ext/DB_File/version.c 2008-03-28 06:12:32.000000000 -0700
@@ -49,9 +49,10 @@
(void)db_version(&Major, &Minor, &Patch) ;
/* Check that the versions of db.h and libdb.a are the same */
- if (Major != DB_VERSION_MAJOR || Minor != DB_VERSION_MINOR
- || Patch != DB_VERSION_PATCH)
- croak("\nDB_File needs compatible versions of libdb & db.h\n\tyou have
db.h version %d.%d.%d and libdb version %d.%d.%d\n",
+ if (Major != DB_VERSION_MAJOR || Minor != DB_VERSION_MINOR )
+ /* || Patch != DB_VERSION_PATCH) */
+
+ croak("\nDB_File was build with libdb version %d.%d.%d,\nbut you are
attempting to run it with libdb version %d.%d.%d\n",
DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH,
Major, Minor, Patch) ;
==== //depot/maint-5.8/perl/ext/Module/Pluggable/Makefile.PL#2 (text) ====
Index: perl/ext/Module/Pluggable/Makefile.PL
--- perl/ext/Module/Pluggable/Makefile.PL#1~33527~ 2008-03-14
03:46:20.000000000 -0700
+++ perl/ext/Module/Pluggable/Makefile.PL 2008-03-28 06:12:32.000000000
-0700
@@ -14,9 +14,9 @@
my $core = grep { $_ eq 'PERL_CORE=1' } @ARGV;
my @path = $core ? (File::Spec->updir, File::Spec->updir, File::Spec->updir,
- "t", "Module_Pluggable") : ($FindBin::Bin,"t");
-my @files;
+ "t", "Module_Pluggable") : ($FindBin::Bin,"t");
+my @files;
if ($^O ne 'VMS' && $^O ne 'VOS') {
foreach my $test (keys %dodgy_files) {
my ($file) = (catfile(@path, "lib", $test)=~/^(.*)$/);
@@ -24,24 +24,25 @@
my $name = $dodgy_files{$test};
print $fh "package $name;\nsub new {}\n1;";
close($fh);
- push @files, $file;
+ push @files, $file;
}
}
}
+
WriteMakefile
(
- 'NAME' => 'Module::Pluggable',
+ 'NAME' => 'Module::Pluggable',
'VERSION_FROM' => 'lib/Module/Pluggable.pm',
- 'PREREQ_PM' => {
+ 'PREREQ_PM' => {
'File::Basename' => '0',
'File::Spec' => '3.00',
'Test::More' => '0.62'
},
- 'INSTALLDIRS' => 'site',
- 'EXE_FILES' => [],
- 'PL_FILES' => {},
- 'realclean' => {FILES=> join ' ', @files},
+ 'EXE_FILES' => [],
+ 'INSTALLDIRS' => ($] >= 5.008009) ? "perl" : "site",
+ 'PL_FILES' => {},
+ 'realclean' => {FILES=> join ' ', @files},
# In the core pods will be built by installman.
$core ? (MAN3PODS => {}) : (),
)
==== //depot/maint-5.8/perl/ext/Module/Pluggable/lib/Module/Pluggable.pm#2
(text) ====
Index: perl/ext/Module/Pluggable/lib/Module/Pluggable.pm
--- perl/ext/Module/Pluggable/lib/Module/Pluggable.pm#1~33527~ 2008-03-14
03:46:20.000000000 -0700
+++ perl/ext/Module/Pluggable/lib/Module/Pluggable.pm 2008-03-28
06:12:32.000000000 -0700
@@ -9,7 +9,7 @@
# Peter Gibbons: I wouldn't say I've been missing it, Bob!
-$VERSION = '3.7';
+$VERSION = '3.8';
sub import {
my $class = shift;
==== //depot/maint-5.8/perl/lib/CGI.pm#22 (text) ====
Index: perl/lib/CGI.pm
--- perl/lib/CGI.pm#21~33516~ 2008-03-13 12:37:42.000000000 -0700
+++ perl/lib/CGI.pm 2008-03-28 06:12:32.000000000 -0700
@@ -18,8 +18,8 @@
# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.240 2007/11/30 18:58:27 lstein Exp $';
-$CGI::VERSION='3.33';
+$CGI::revision = '$Id: CGI.pm,v 1.249 2008/03/25 15:17:55 lstein Exp $';
+$CGI::VERSION='3.35';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
@@ -1835,7 +1835,7 @@
my($method,$action,$enctype,@other) =
rearrange([METHOD,ACTION,ENCTYPE],@p);
- $method = $self->escapeHTML(lc($method) || 'post');
+ $method = $self->escapeHTML(lc($method || 'post'));
$enctype = $self->escapeHTML($enctype || &URL_ENCODED);
if (defined $action) {
$action = $self->escapeHTML($action);
@@ -2198,9 +2198,11 @@
else {
$toencode =~ s{"}{"}gso;
}
- my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' ||
- uc $self->{'.charset'} eq 'WINDOWS-1252';
- if ($latin) { # bug in some browsers
+ # Handle bug in some browsers with Latin charsets
+ if ($self->{'.charset'} &&
+ (uc($self->{'.charset'}) eq 'ISO-8859-1' ||
+ uc($self->{'.charset'}) eq 'WINDOWS-1252'))
+ {
$toencode =~ s{'}{'}gso;
$toencode =~ s{\x8b}{‹}gso;
$toencode =~ s{\x9b}{›}gso;
@@ -2567,6 +2569,7 @@
$size = $size || scalar(@values);
my(%selected) = $self->previous_or_default($name,$defaults,$override);
+
my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
my($has_size) = $size ? qq/ size="$size"/: '';
my($other) = @other ? " @other" : '';
@@ -2699,7 +2702,7 @@
my $request_uri = unescape($self->request_uri) || '';
my $query_str = $self->query_string;
- my $rewrite_in_use = $request_uri && $request_uri !~ /^$script_name/;
+ my $rewrite_in_use = $request_uri && $request_uri !~ /^\Q$script_name/;
undef $path if $rewrite_in_use && $rewrite; # path not valid when
rewriting active
my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
@@ -3292,10 +3295,10 @@
if (!$override && ($self->{'.fieldnames'}->{$name} ||
defined($self->param($name)) ) ) {
- grep($selected{$_}++,$self->param($name));
+ $selected{$_}++ for $self->param($name);
} elsif (defined($defaults) && ref($defaults) &&
(ref($defaults) eq 'ARRAY')) {
- grep($selected{$_}++,@{$defaults});
+ $selected{$_}++ for @{$defaults};
} else {
$selected{$defaults}++ if defined($defaults);
}
@@ -3379,8 +3382,12 @@
my($param)= $header{'Content-Disposition'}=~/ name="([^"]*)"/;
$param .= $TAINTED;
- # Bug: Netscape doesn't escape quotation marks in file names!!!
- my($filename) = $header{'Content-Disposition'}=~/ filename="([^"]*)"/;
+ # See RFC 1867, 2183, 2045
+ # NB: File content will be loaded into memory should
+ # content-disposition parsing fail.
+ my ($filename) = $header{'Content-Disposition'}
+ =~/
filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i;
+ $filename =~ s/^"([^"]*)"$/$1/;
# Test for Opera's multiple upload feature
my($multipart) = ( defined( $header{'Content-Type'} ) &&
$header{'Content-Type'} =~ /multipart\/mixed/ ) ?
@@ -4040,7 +4047,7 @@
my $filename;
find_tempdir() unless -w $TMPDIRECTORY;
for (my $i = 0; $i < $MAXTRIES; $i++) {
- last if ! -f ($filename =
sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
+ last if ! -f ($filename = sprintf("\%s${SL}CGItemp%d", $TMPDIRECTORY,
$sequence++));
}
# check that it is a more-or-less valid filename
return unless $filename =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\-]+)$!;
@@ -4117,6 +4124,8 @@
hr;
}
+ print end_html;
+
=head1 ABSTRACT
This perl library uses perl5 objects to make it easy to create Web
@@ -5410,7 +5419,7 @@
If Apache's mod_rewrite is turned on, then the script name and path
info probably won't match the request that the user sent. Set
-rewrite=>1 (default) to return URLs that match what the user sent
-(the original request URI). Set -rewrite->0 to return URLs that match
+(the original request URI). Set -rewrite=>0 to return URLs that match
the URL after mod_rewrite's rules have run. Because the additional
path information only makes sense in the context of the rewritten URL,
-rewrite is set to false when you request path info in the URL.
@@ -7686,10 +7695,8 @@
=head1 AUTHOR INFORMATION
-Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
+The GD.pm interface is copyright 1995-2007, Lincoln D. Stein. It is
+distributed under GPL and the Artistic License 2.0.
Address bug reports and comments to: [EMAIL PROTECTED] When sending
bug reports, please provide the version of CGI.pm, the version of
==== //depot/maint-5.8/perl/lib/CGI/Changes#9 (text) ====
Index: perl/lib/CGI/Changes
--- perl/lib/CGI/Changes#8~32319~ 2007-11-14 15:26:31.000000000 -0800
+++ perl/lib/CGI/Changes 2008-03-28 06:12:32.000000000 -0700
@@ -1,3 +1,27 @@
+ Version 3.35
+ 1. Resync with bleadperl, primarily fixing a bug in parsing semicolons in
uploaded filenames.
+
+ Version 3.34
+ 1. Handle Unicode %uXXXX escapes properly -- patch from [EMAIL PROTECTED]
+ 2. Fix url() method to not choke on path names that contain regex characters.
+
+ Version 3.33
+ 1. Remove uninit variable warning when calling url(-relative=>1)
+ 2. Fix uninit variable warnings for two lc calls
+ 3. Fixed failure of tempfile upload due to sprintf() taint failure in perl
5.10
+
+ Version 3.32
+ 1. Patch from Miguel Santinho to prevent sending premature headers under
mod_perl 2.0
+
+ Version 3.31
+ 1. Patch from Xavier Robin so that CGI::Carp issues a 500 Status code rather
than a 200 status code.
+ 2. Patch from Alexander Klink to select correct temporary directory in OSX
Leopard so that upload works.
+ 3. Possibly fixed "wrapped pack" error on 5.10 and higher.
+
+ Version 3.30
+ 1. Patch from Mike Barry to handle POSTDATA in the same way as PUT.
+ 2. Patch from Rafael Garcia-Suarez to correctly reencode unicode values as
byte values.
+
Version 3.29
1. The position of file handles is now reset to zero when CGI->new is called.
(Mark Stosberg)
==== //depot/maint-5.8/perl/lib/CGI/Util.pm#12 (text) ====
Index: perl/lib/CGI/Util.pm
--- perl/lib/CGI/Util.pm#11~33516~ 2008-03-13 12:37:42.000000000 -0700
+++ perl/lib/CGI/Util.pm 2008-03-28 06:12:32.000000000 -0700
@@ -7,7 +7,7 @@
@EXPORT_OK = qw(rearrange make_attributes unescape escape
expires ebcdic2ascii ascii2ebcdic);
-$VERSION = '1.5';
+$VERSION = '1.5_01';
$EBCDIC = "\t" ne "\011";
# (ord('^') == 95) for codepage 1047 as on os390, vmesa
@@ -141,8 +141,12 @@
sub utf8_chr {
my $c = shift(@_);
- return chr($c) if $] >= 5.006;
-
+ if ($] >= 5.006){
+ require utf8;
+ my $u = chr($c);
+ utf8::encode($u); # drop utf8 flag
+ return $u;
+ }
if ($c < 0x80) {
return sprintf("%c", $c);
} elsif ($c < 0x800) {
@@ -189,6 +193,17 @@
if ($EBCDIC) {
$todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
} else {
+ # handle surrogate pairs first -- dankogai
+ $todecode =~ s{
+ %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
+ %u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo
+ }{
+ utf8_chr(
+ 0x10000
+ + (hex($1) - 0xD800) * 0x400
+ + (hex($2) - 0xDC00)
+ )
+ }gex;
$todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
}
@@ -200,9 +215,12 @@
shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq
$CGI::DefaultClass));
my $toencode = shift;
return undef unless defined($toencode);
+ $toencode = eval { pack("C*", unpack("U0C*", $toencode))} || pack("C*",
unpack("C*", $toencode));
+
# force bytes while preserving backward compatibility -- dankogai
-# $toencode = eval { pack("C*", unpack("U0C*", $toencode))} || pack("C*",
unpack("C*", $toencode));
- $toencode = eval { pack("U*", unpack("U0C*", $toencode))} || pack("C*",
unpack("C*", $toencode));
+ # but commented out because it was breaking CGI::Compress -- lstein
+ # $toencode = eval { pack("U*", unpack("U0C*", $toencode))} || pack("C*",
unpack("C*", $toencode));
+
if ($EBCDIC) {
$toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
} else {
End of Patch.
