In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/a7a22abc1654ce1bee21c7bb8657a3b7c07ae25a?hp=9e0b0d62ba5a660ab4b6f498912cfaead79014a0>
- Log ----------------------------------------------------------------- commit a7a22abc1654ce1bee21c7bb8657a3b7c07ae25a Author: Karl Williamson <[email protected]> Date: Mon Mar 2 22:08:41 2015 -0700 DBM_Filter/t/utf8.t: Generalize for other EBCDIC code pages This worked for EBCDIC 1047, but not for other pages. This commit changes to use the tools created for the purpose to make it general. M lib/DBM_Filter/t/utf8.t commit 96c7b11637ff39945439a12d8537de89dba86bde Author: Karl Williamson <[email protected]> Date: Thu Jan 22 14:26:54 2015 -0700 dist/Net-Ping/t/450_service.t: Skip 2 tests on os390 These two tests are already skipped for hpux, and one for win32. I'm assuming the same issue here. M dist/Net-Ping/t/450_service.t commit 02b4438c0b5715a80520b510dc85b983b605ee2a Author: Karl Williamson <[email protected]> Date: Sun Nov 30 23:17:07 2014 -0700 Module::CoreList: Fix to work on EBCDIC platforms This creates a sort help that make a '?' always sort after the digits, which it naturally does on ASCII platforms, but not EBCDIC M dist/Module-CoreList/lib/Module/CoreList.pm M dist/Module-CoreList/lib/Module/CoreList/Utils.pm M dist/Module-CoreList/t/utils.t commit 94563b2d0982d4eb19e2dba1e0a4e975db43051d Author: Karl Williamson <[email protected]> Date: Wed Nov 26 14:35:31 2014 -0700 Devel::Peek:Peek.t: Fix to work on EBCDIC M ext/Devel-Peek/t/Peek.t commit fedc1b0e2d9cec34b7e3b1fa65dd0f7eb4f539fd Author: Karl Williamson <[email protected]> Date: Tue Apr 16 12:02:26 2013 -0600 dist/Safe/t/safeutf8.t: Generalize to non-ASCII platform M dist/Safe/t/safeutf8.t commit 571d5cf7467f1af9ff1e6d751f49ac47e4f88380 Author: Karl Williamson <[email protected]> Date: Mon May 20 21:59:48 2013 -0600 dist/Storable/t/code.t: Fixes to run under EBCDIC M dist/Storable/t/code.t commit 81d8a24707e5e29312efe194299c42f93cebed52 Author: Karl Williamson <[email protected]> Date: Mon Apr 1 22:28:43 2013 -0600 dist/Storable/t/utf8.t: Fix to run under EBCDIC M dist/Storable/t/utf8.t ----------------------------------------------------------------------- Summary of changes: dist/Module-CoreList/lib/Module/CoreList.pm | 14 +++++++-- dist/Module-CoreList/lib/Module/CoreList/Utils.pm | 14 +++++++-- dist/Module-CoreList/t/utils.t | 2 +- dist/Net-Ping/t/450_service.t | 4 +-- dist/Safe/t/safeutf8.t | 2 +- dist/Storable/t/code.t | 2 +- dist/Storable/t/utf8.t | 2 +- ext/Devel-Peek/t/Peek.t | 36 ++++++++++++++--------- lib/DBM_Filter/t/utf8.t | 26 ++++++---------- 9 files changed, 61 insertions(+), 41 deletions(-) diff --git a/dist/Module-CoreList/lib/Module/CoreList.pm b/dist/Module-CoreList/lib/Module/CoreList.pm index 0a53cc7..2628907 100644 --- a/dist/Module-CoreList/lib/Module/CoreList.pm +++ b/dist/Module-CoreList/lib/Module/CoreList.pm @@ -6,6 +6,16 @@ use Module::CoreList::TieHashDelta; use version; $VERSION = '5.20150320'; +sub _released_order { # Sort helper, to make '?' sort after everything else + (substr($released{$a}, 0, 1) eq "?") + ? ((substr($released{$b}, 0, 1) eq "?") + ? 0 + : 1) + : ((substr($released{$b}, 0, 1) eq "?") + ? -1 + : $released{$a} cmp $released{$b} ) +} + my $dumpinc = 0; sub import { my $self = shift; @@ -38,7 +48,7 @@ sub first_release_raw { sub first_release_by_date { my @perls = &first_release_raw; return unless @perls; - return (sort { $released{$a} cmp $released{$b} } @perls)[0]; + return (sort _released_order @perls)[0]; } sub first_release { @@ -96,7 +106,7 @@ sub removed_from { } sub removed_from_by_date { - my @perls = sort { $released{$a} cmp $released{$b} } &removed_raw; + my @perls = sort _released_order &removed_raw; return shift @perls; } diff --git a/dist/Module-CoreList/lib/Module/CoreList/Utils.pm b/dist/Module-CoreList/lib/Module/CoreList/Utils.pm index 10ebd87..6b608a0 100644 --- a/dist/Module-CoreList/lib/Module/CoreList/Utils.pm +++ b/dist/Module-CoreList/lib/Module/CoreList/Utils.pm @@ -15,6 +15,16 @@ sub utilities { return sort keys %{ $utilities{$perl} }; } +sub _released_order { # Sort helper, to make '?' sort after everything else + (substr($Module::CoreList::released{$a}, 0, 1) eq "?") + ? ((substr($Module::CoreList::released{$b}, 0, 1) eq "?") + ? 0 + : 1) + : ((substr($Module::CoreList::released{$b}, 0, 1) eq "?") + ? -1 + : $Module::CoreList::released{$a} cmp $Module::CoreList::released{$b} ) +} + sub first_release_raw { my $util = shift; $util = shift if eval { $util->isa(__PACKAGE__) }; @@ -32,7 +42,7 @@ sub first_release_raw { sub first_release_by_date { my @perls = &first_release_raw; return unless @perls; - return (sort { $Module::CoreList::released{$a} cmp $Module::CoreList::released{$b} } @perls)[0]; + return (sort _released_order @perls)[0]; } sub first_release { @@ -47,7 +57,7 @@ sub removed_from { } sub removed_from_by_date { - my @perls = sort { $Module::CoreList::released{$a} cmp $Module::CoreList::released{$b} } &removed_raw; + my @perls = sort _released_order &removed_raw; return shift @perls; } diff --git a/dist/Module-CoreList/t/utils.t b/dist/Module-CoreList/t/utils.t index 4822495..d42a158 100644 --- a/dist/Module-CoreList/t/utils.t +++ b/dist/Module-CoreList/t/utils.t @@ -11,7 +11,7 @@ is( Module::CoreList::Utils->first_release('corelist'), 5.008009, 'corelist with is( Module::CoreList::Utils->first_release_by_date('corelist'), 5.009002, 'corelist with v5.9.2'); is( Module::CoreList::Utils::first_release_by_date('corelist'), 5.009002, 'corelist with v5.9.2'); { - my @expected = qw(a2p c2ph cppstdin find2perl h2xs pstruct s2p); + my @expected = sort qw(a2p c2ph cppstdin find2perl h2xs pstruct s2p); { my @foo = Module::CoreList::Utils->utilities(5.001); is_deeply( \@foo, \@expected, '5.001 utils all present and correct' ); diff --git a/dist/Net-Ping/t/450_service.t b/dist/Net-Ping/t/450_service.t index c16b30d..fc8d758 100644 --- a/dist/Net-Ping/t/450_service.t +++ b/dist/Net-Ping/t/450_service.t @@ -79,7 +79,7 @@ $p->{port_num} = $port2; { local $TODO; - $TODO = "Believed not to work on $^O" if $^O eq 'hpux'; + $TODO = "Believed not to work on $^O" if $^O eq 'hpux' || $^O eq 'os390'; is($p->ping("127.0.0.1"), 1, 'second port is reachable'); } @@ -131,7 +131,7 @@ is($p->ping("127.0.0.1"), 1, "send SYN to second port") or diag ("ERRNO: $!"); { local $TODO; - $TODO = "Believed not to work on $^O" if $^O eq 'hpux' || $^O eq 'MSWin32'; + $TODO = "Believed not to work on $^O" if $^O eq 'hpux' || $^O eq 'MSWin32' || $^O eq 'os390'; is($p->ack(), '127.0.0.1', 'IP should be reachable'); } is($p->ack(), undef, 'No more sockets'); diff --git a/dist/Safe/t/safeutf8.t b/dist/Safe/t/safeutf8.t index 42b84ef..6521c9c 100644 --- a/dist/Safe/t/safeutf8.t +++ b/dist/Safe/t/safeutf8.t @@ -21,7 +21,7 @@ $safe->deny_only(); # Expression that triggers require utf8 and call to SWASHNEW. # Fails with "Undefined subroutine PLPerl::utf8::SWASHNEW called" # if SWASHNEW is not shared, else returns true if unicode logic is working. -my $trigger = q{ my $a = pack('U',0xC4); my $b = chr 0xE4; utf8::upgrade $b; $a =~ /$b/i }; +my $trigger = q{ my $a = pack('U',0xC4); my $b = chr utf8::unicode_to_native(0xE4); utf8::upgrade $b; $a =~ /$b/i }; ok $safe->reval( $trigger ), 'trigger expression should return true'; is $@, '', 'trigger expression should not die'; diff --git a/dist/Storable/t/code.t b/dist/Storable/t/code.t index c383142..7fc40ba 100644 --- a/dist/Storable/t/code.t +++ b/dist/Storable/t/code.t @@ -102,7 +102,7 @@ is($thawed->{"b"}->(), "JAPH"); $freezed = freeze $obj[2]; $thawed = thaw $freezed; -is($thawed->(), 42); +is($thawed->(), (ord "A") == 193 ? -118 : 42); ###################################################################### diff --git a/dist/Storable/t/utf8.t b/dist/Storable/t/utf8.t index fd20ef6..dfb43ea 100644 --- a/dist/Storable/t/utf8.t +++ b/dist/Storable/t/utf8.t @@ -33,7 +33,7 @@ $x = join '', map {chr $_} (0..1023); is($x, ${thaw freeze \$x}); # Char in the range 127-255 (probably) in utf8 -$x = chr (175) . chr (256); +$x = chr(utf8::unicode_to_native(175)) . chr (256); chop $x; is($x, ${thaw freeze \$x}); diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index f5127b6..e35930b 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -1043,8 +1043,16 @@ SKIP: { # a way to make a better place for it: use constant { - perl => 'rules', - beer => 'foamy', + + # The length of the rhs string must be such that if chr() is applied to it + # doesn't yield a character with a backslash mnemonic. For example, if it + # were 'rules' instead of 'rule', it would have 5 characters, and on + # EBCDIC, chr(5) is \t. The dumping code would translate all the 5's in + # MG_PTR into "\t", and this test code would be expecting \5's, so the + # tests would fail. No platform that Perl works on translates chr(4) into + # a mnemonic. + perl => 'rule', + beer => 'foam', }; unless ($Config{useithreads}) { @@ -1056,8 +1064,8 @@ unless ($Config{useithreads}) { REFCNT = 5 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005 - PV = $ADDR "rules"\\\0 - CUR = 5 + PV = $ADDR "rule"\\\0 + CUR = 4 LEN = \d+ COW_REFCNT = 0 '); @@ -1072,8 +1080,8 @@ unless ($Config{useithreads}) { 'SV = PVMG\\($ADDR\\) at $ADDR REFCNT = 5 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\) - PV = $ADDR "rules"\\\0 - CUR = 5 + PV = $ADDR "rule"\\\0 + CUR = 4 LEN = \d+ COW_REFCNT = 0 MAGIC = $ADDR @@ -1092,8 +1100,8 @@ unless ($Config{useithreads}) { 'SV = PVMG\\($ADDR\\) at $ADDR REFCNT = 5 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\) - PV = $ADDR "rules"\\\0 - CUR = 5 + PV = $ADDR "rule"\\\0 + CUR = 4 LEN = \d+ COW_REFCNT = 0 MAGIC = $ADDR @@ -1111,8 +1119,8 @@ unless ($Config{useithreads}) { REFCNT = 6 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005 - PV = $ADDR "foamy"\\\0 - CUR = 5 + PV = $ADDR "foam"\\\0 + CUR = 4 LEN = \d+ COW_REFCNT = 0 '); @@ -1123,8 +1131,8 @@ unless ($Config{useithreads}) { REFCNT = 6 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005 - PV = $ADDR "foamy"\\\0 - CUR = 5 + PV = $ADDR "foam"\\\0 + CUR = 4 LEN = \d+ COW_REFCNT = 0 '); @@ -1132,8 +1140,8 @@ unless ($Config{useithreads}) { my $want = 'SV = PVMG\\($ADDR\\) at $ADDR REFCNT = 6 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\) - PV = $ADDR "foamy"\\\0 - CUR = 5 + PV = $ADDR "foam"\\\0 + CUR = 4 LEN = \d+ COW_REFCNT = 0 MAGIC = $ADDR diff --git a/lib/DBM_Filter/t/utf8.t b/lib/DBM_Filter/t/utf8.t index 0bc38f8..fb290e9 100644 --- a/lib/DBM_Filter/t/utf8.t +++ b/lib/DBM_Filter/t/utf8.t @@ -6,6 +6,8 @@ use Carp; BEGIN { + require "../t/charset_tools.pl"; + eval { require Encode; }; if ($@) { @@ -79,23 +81,13 @@ my $db2 = tie(%h2, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ; ok $db2, "tied to $db_file"; -if (ord('A') == 193) { # EBCDIC. - VerifyData(\%h2, - { - 'alpha' => "\xB4\x58", - 'beta' => "\xB4\x59", - "\xB4\x62"=> "gamma", - "" => "", - }); -} else { - VerifyData(\%h2, - { - 'alpha' => "\xCE\xB1", - 'beta' => "\xCE\xB2", - "\xCE\xB3"=> "gamma", - "" => "", - }); -} +VerifyData(\%h2, + { + 'alpha' => byte_utf8a_to_utf8n("\xCE\xB1"), + 'beta' => byte_utf8a_to_utf8n("\xCE\xB2"), + byte_utf8a_to_utf8n("\xCE\xB3")=> "gamma", + "" => "", + }); undef $db2; { -- Perl5 Master Repository
