Change 33923 by [EMAIL PROTECTED] on 2008/05/25 20:30:46
Integrate:
[ 33628]
Integrate:
[ 33316]
Avoid utf8 warnings when printing diagnostics
[ 33433]
use strict; and use Test::More; to give decent failure diagnostics.
(And less code)
[ 33440]
Fix skip counts introduced in #33433
[ 33565]
Subject: Re: Change 33556: [PATCH] borg parent.pm
From: "Jerry D. Hedden" <[EMAIL PROTECTED]>
Date: Tue, 25 Mar 2008 11:51:00 -0400
Message-ID: <[EMAIL PROTECTED]>
[ 33823]
Integrate:
[ 33674]
Test::More::is_deeply may do overloading (at least for TODOs), and
overloading may require Scalar::Util, which it won't find if all
the paths in @INC are relative to somewhere other than where we are.
[ 33705]
Test dbmopen more thoroughly, including closing the coverage hole for
the code that automatically requires AnyDBM_File.pm in pp_dbmopen.
[ 33749]
Subject: [perl #53238] Patch to stop t/op/fork.t relying on rand
From: David Dick (via RT) <[EMAIL PROTECTED]>
Date: Wed, 23 Apr 2008 04:12:42 -0700
Message-ID: <[EMAIL PROTECTED]>
[ 33752]
Subject: [PATCH] another go; was RE: [perl #49302] [[:print:]] v
\p{Print}
From: "Robin Barker" <[EMAIL PROTECTED]>
Date: Fri, 25 Apr 2008 14:21:06 +0100
Message-ID: <[EMAIL PROTECTED]>
[ 33765]
Subject: [PATCH] extra tests for t/op/sprintf2.t (was Re: [perl #45383]
RE:
From: Bram <[EMAIL PROTECTED]>
Date: Tue, 29 Apr 2008 22:27:21 +0200
Message-ID: <[EMAIL PROTECTED]>
[ 33767]
A skip() function is missing, to get this test pass with miniperl
[ 33768]
Avoid garbage in test output when running make minitest.
This makes all minitests pass on my machine.
[ 33769]
Subject: Re: [PATCH] testing $/ with in memory files
From: Bram <[EMAIL PROTECTED]>
Date: Wed, 30 Apr 2008 11:55:30 +0200
Message-ID: <[EMAIL PROTECTED]>
[ 33774]
Subject: [perl #53560] Patch for linux LDAP groups
From: David Dick (via RT) <[EMAIL PROTECTED]>
Date: Wed, 30 Apr 2008 05:17:54 -0700
Message-ID: <[EMAIL PROTECTED]>
[ 33775]
Add a test for "lc(LATIN CAPITAL LETTER SHARP S)"
[ 33776]
Subject: [PATCH] t/op/pat.t
From: "Robin Barker" <[EMAIL PROTECTED]>
Date: Thu, 1 May 2008 19:12:28 +0100
Message-ID: <[EMAIL PROTECTED]>
[ 33888]
Integrate:
[ 33850]
Subject: [perl #53500] op/pwent.t should use the DirectoryService on OS
X
From: "Tom Wyant via RT" <[EMAIL PROTECTED]>
Date: Sun, 11 May 2008 14:40:04 -0700
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/maint-5.8/perl/MANIFEST#430 integrate
... //depot/maint-5.8/perl/ext/File/Glob/t/basic.t#6 integrate
... //depot/maint-5.8/perl/lib/Devel/SelfStubber.t#3 integrate
... //depot/maint-5.8/perl/pod/perlre.pod#25 integrate
... //depot/maint-5.8/perl/t/base/rs.t#3 integrate
... //depot/maint-5.8/perl/t/op/dbm.t#1 branch
... //depot/maint-5.8/perl/t/op/fork.t#6 integrate
... //depot/maint-5.8/perl/t/op/groups.t#5 integrate
... //depot/maint-5.8/perl/t/op/lc.t#15 integrate
... //depot/maint-5.8/perl/t/op/pat.t#52 integrate
... //depot/maint-5.8/perl/t/op/pwent.t#3 integrate
... //depot/maint-5.8/perl/t/op/sprintf2.t#8 integrate
... //depot/maint-5.8/perl/t/run/fresh_perl.t#16 integrate
Differences ...
==== //depot/maint-5.8/perl/MANIFEST#430 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#429~33819~ 2008-05-11 03:19:04.000000000 -0700
+++ perl/MANIFEST 2008-05-25 13:30:46.000000000 -0700
@@ -3042,6 +3042,7 @@
t/op/context.t See if context propagation works
t/op/cproto.t Check builtin prototypes
t/op/crypt.t See if crypt works
+t/op/dbm.t See if dbmopen/dbmclose work
t/op/defins.t See if auto-insert of defined() works
t/op/delete.t See if delete works
t/op/die_exit.t See if die and exit status interaction
works
==== //depot/maint-5.8/perl/ext/File/Glob/t/basic.t#6 (xtext) ====
Index: perl/ext/File/Glob/t/basic.t
--- perl/ext/File/Glob/t/basic.t#5~32318~ 2007-11-14 15:02:34.000000000
-0800
+++ perl/ext/File/Glob/t/basic.t 2008-05-25 13:30:46.000000000 -0700
@@ -13,103 +13,89 @@
print "1..0\n";
exit 0;
}
- print "1..13\n";
}
-END {
- print "not ok 1\n" unless $loaded;
-}
-use File::Glob ':glob';
+use strict;
+use Test::More tests => 14;
+BEGIN {use_ok('File::Glob', ':glob')};
use Cwd ();
-$loaded = 1;
-print "ok 1\n";
-
-sub array {
- return '(', join(", ", map {defined $_ ? "\"$_\"" : "undef"} @a), ")\n";
-}
# look for the contents of the current directory
$ENV{PATH} = "/bin";
-delete @ENV{BASH_ENV, CDPATH, ENV, IFS};
[EMAIL PROTECTED] = ();
+delete @ENV{qw(BASH_ENV CDPATH ENV IFS)};
+my @correct = ();
if (opendir(D, $^O eq "MacOS" ? ":" : ".")) {
@correct = grep { !/^\./ } sort readdir(D);
closedir D;
}
[EMAIL PROTECTED] = File::Glob::glob("*", 0);
+my @a = File::Glob::glob("*", 0);
@a = sort @a;
-if ("@a" ne "@correct" || GLOB_ERROR) {
- print "# |@a| ne |@correct|\nnot ";
+if (GLOB_ERROR) {
+ fail(GLOB_ERROR);
+} else {
+ is_deeply([EMAIL PROTECTED], [EMAIL PROTECTED]);
}
-print "ok 2\n";
# look up the user's home directory
# should return a list with one item, and not set ERROR
-if ($^O ne 'MSWin32' && $^O ne 'NetWare' && $^O ne 'VMS' && $^O ne 'os2'
- && $^O ne 'beos') {
- eval {
- ($name, $home) = (getpwuid($>))[0,7];
- 1;
- } and do {
- if (defined $home && defined $name && -d $home) {
- @a = bsd_glob("~$name", GLOB_TILDE);
- if ((scalar(@a) != 1 || $a[0] ne $home || GLOB_ERROR)) {
- print "not ";
- }
+SKIP: {
+ my ($name, $home);
+ skip $^O, 1 if $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS'
+ || $^O eq 'os2' || $^O eq 'beos';
+ skip "Can't find user for $>: $@", 1 unless eval {
+ ($name, $home) = (getpwuid($>))[0,7];
+ 1;
+ };
+ skip "$> has no home directory", 1
+ unless defined $home && defined $name && -d $home;
+
+ @a = bsd_glob("~$name", GLOB_TILDE);
+
+ if (GLOB_ERROR) {
+ fail(GLOB_ERROR);
+ } else {
+ is_deeply ([EMAIL PROTECTED], [$home]);
}
- };
}
-print "ok 3\n";
# check backslashing
# should return a list with one item, and not set ERROR
@a = bsd_glob('TEST', GLOB_QUOTE);
-if (scalar @a != 1 || $a[0] ne 'TEST' || GLOB_ERROR) {
- local $/ = "][";
- print "# [EMAIL PROTECTED]";
- print "not ";
+if (GLOB_ERROR) {
+ fail(GLOB_ERROR);
+} else {
+ is_deeply([EMAIL PROTECTED], ['TEST']);
}
-print "ok 4\n";
# check nonexistent checks
# should return an empty list
# XXX since errfunc is NULL on win32, this test is not valid there
@a = bsd_glob("asdfasdf", 0);
-if (($^O ne 'MSWin32' && $^O ne 'NetWare') and scalar @a != 0) {
- print "# |@a|\nnot ";
+SKIP: {
+ skip $^O, 1 if $^O eq 'MSWin32' || $^O eq 'NetWare';
+ is_deeply([EMAIL PROTECTED], []);
}
-print "ok 5\n";
# check bad protections
# should return an empty list, and set ERROR
-if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'os2' or
$^O eq 'VMS'
- or $^O eq 'cygwin' or Cwd::cwd() =~ m#^$Config{'afsroot'}#s or not $>)
-{
- print "ok 6 # skipped\n";
-}
-else {
- $dir = "pteerslo";
+SKIP: {
+ skip $^O, 2 if $^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'NetWare'
+ or $^O eq 'os2' or $^O eq 'VMS' or $^O eq 'cygwin';
+ skip "AFS", 2 if Cwd::cwd() =~ m#^$Config{'afsroot'}#s;
+ skip "running as root", 2 if not $>;
+
+ my $dir = "pteerslo";
mkdir $dir, 0;
@a = bsd_glob("$dir/*", GLOB_ERR);
- #print "[EMAIL PROTECTED] = ", array(@a);
rmdir $dir;
- if (scalar(@a) != 0 || GLOB_ERROR == 0) {
- if ($^O eq 'vos') {
- print "not ok 6 # TODO hit VOS bug posix-956\n";
- } else {
- print "not ok 6\n";
- }
- }
- else {
- print "ok 6\n";
- }
+ local $TODO = 'hit VOS bug posix-956' if $^O eq 'vos';
+
+ isnt(GLOB_ERROR, 0);
+ is_deeply([EMAIL PROTECTED], []);
}
# check for csh style globbing
@a = bsd_glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC);
-unless (@a == 2 and $a[0] eq 'a' and $a[1] eq 'b') {
- print "not ";
-}
-print "ok 7\n";
+is_deeply([EMAIL PROTECTED], ['a', 'b']);
@a = bsd_glob(
'{TES*,doesntexist*,a,b}',
@@ -123,30 +109,22 @@
print "# @a\n";
-unless (@a == 3
- and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST')
- and $a[1] eq 'a'
- and $a[2] eq 'b')
-{
- print "not ok 8 # @a\n";
-} else {
- print "ok 8\n";
-}
+is_deeply([EMAIL PROTECTED], [($^O eq 'VMS'? 'test.' : 'TEST'), 'a', 'b']);
# "~" should expand to $ENV{HOME}
$ENV{HOME} = "sweet home";
@a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC);
-unless ($^O eq "MacOS" || (@a == 1 and $a[0] eq $ENV{HOME})) {
- print "not ";
+SKIP: {
+ skip $^O, 1 if $^O eq "MacOS";
+ is_deeply([EMAIL PROTECTED], [$ENV{HOME}]);
}
-print "ok 9\n";
# GLOB_ALPHASORT (default) should sort alphabetically regardless of case
mkdir "pteerslo", 0777;
chdir "pteerslo";
[EMAIL PROTECTED] = qw(Ax.pl Bx.pl Cx.pl aY.pl bY.pl cY.pl);
[EMAIL PROTECTED] = qw(Ax.pl aY.pl Bx.pl bY.pl Cx.pl cY.pl);
+my @f_names = qw(Ax.pl Bx.pl Cx.pl aY.pl bY.pl cY.pl);
+my @f_alpha = qw(Ax.pl aY.pl Bx.pl bY.pl Cx.pl cY.pl);
if ('a' lt 'A') { # EBCDIC char sets sort lower case before UPPER
@f_names = sort(@f_names);
}
@@ -160,25 +138,17 @@
close T;
}
-$pat = "*.pl";
+my $pat = "*.pl";
-$ok = 1;
[EMAIL PROTECTED] = bsd_glob($pat, 0);
+my @g_names = bsd_glob($pat, 0);
print "# f_names = @f_names\n";
print "# g_names = @g_names\n";
-for (@f_names) {
- $ok = 0 unless $_ eq shift @g_names;
-}
-print $ok ? "ok 10\n" : "not ok 10\n";
+is_deeply([EMAIL PROTECTED], [EMAIL PROTECTED]);
-$ok = 1;
[EMAIL PROTECTED] = bsd_glob($pat);
+my @g_alpha = bsd_glob($pat);
print "# f_alpha = @f_alpha\n";
print "# g_alpha = @g_alpha\n";
-for (@f_alpha) {
- $ok = 0 unless $_ eq shift @g_alpha;
-}
-print $ok ? "ok 11\n" : "not ok 11\n";
+is_deeply([EMAIL PROTECTED], [EMAIL PROTECTED]);
unlink @f_names;
chdir "..";
@@ -186,7 +156,7 @@
# this can panic if PL_glob_index gets passed as flags to bsd_glob
<*>; <*>;
-print "ok 12\n";
+pass("Don't panic");
{
use File::Temp qw(tempdir);
@@ -203,11 +173,8 @@
chdir $dir
or die "Could not chdir to $dir: $!";
my(@glob_files) = glob("a*{d[e]}j");
- if (!(@glob_files == 1 && "@glob_files" eq "a_dej")) {
- print "not ";
- }
- my $todo = $^O ne 'VMS' ? '' : " # TODO home-made glob doesn't do regexes";
- print "ok 13$todo\n";
chdir $cwd
or die "Could not chdir back to $cwd: $!";
+ local $TODO = "home-made glob doesn't do regexes" if $^O eq 'VMS';
+ is_deeply([EMAIL PROTECTED], ['a_dej']);
}
==== //depot/maint-5.8/perl/lib/Devel/SelfStubber.t#3 (text) ====
Index: perl/lib/Devel/SelfStubber.t
--- perl/lib/Devel/SelfStubber.t#2~22089~ 2004-01-07 05:19:41.000000000
-0800
+++ perl/lib/Devel/SelfStubber.t 2008-05-25 13:30:46.000000000 -0700
@@ -48,7 +48,7 @@
push @cleanup, $file;
open FH, ">$file" or die $!;
select FH;
- Devel::SelfStubber->stub('Child', $inlib);
+ Devel::SelfStubber->stub('xChild', $inlib);
select STDOUT;
print "ok 1\n";
close FH or die $!;
@@ -56,7 +56,7 @@
open FH, $file or die $!;
my @A = <FH>;
- if (@A == 1 && $A[0] =~ /^\s*sub\s+Child::foo\s*;\s*$/) {
+ if (@A == 1 && $A[0] =~ /^\s*sub\s+xChild::foo\s*;\s*$/) {
print "ok 2\n";
} else {
print "not ok 2\n";
@@ -112,14 +112,14 @@
}
# "wrong" and "right" may change if SelfLoader is changed.
-my %wrong = ( Parent => 'Parent', Child => 'Parent' );
-my %right = ( Parent => 'Parent', Child => 'Child' );
+my %wrong = ( xParent => 'xParent', xChild => 'xParent' );
+my %right = ( xParent => 'xParent', xChild => 'xChild' );
if ($^O eq 'VMS') {
# extra line feeds for MBX IPC
- %wrong = ( Parent => "Parent\n", Child => "Parent\n" );
- %right = ( Parent => "Parent\n", Child => "Child\n" );
+ %wrong = ( xParent => "xParent\n", xChild => "xParent\n" );
+ %right = ( xParent => "xParent\n", xChild => "xChild\n" );
}
-my @module = qw(Parent Child)
+my @module = qw(xParent xChild)
;
sub fail {
my ($left, $right) = @_;
@@ -225,18 +225,18 @@
}
__DATA__
-################ Parent.pm
-package Parent;
+################ xParent.pm
+package xParent;
sub foo {
return __PACKAGE__;
}
1;
__END__
-################ Child.pm
-package Child;
-require Parent;
[EMAIL PROTECTED] = 'Parent';
+################ xChild.pm
+package xChild;
+require xParent;
[EMAIL PROTECTED] = 'xParent';
use SelfLoader;
1;
==== //depot/maint-5.8/perl/t/base/rs.t#3 (xtext) ====
Index: perl/t/base/rs.t
--- perl/t/base/rs.t#2~29946~ 2007-01-24 05:23:35.000000000 -0800
+++ perl/t/base/rs.t 2008-05-25 13:30:46.000000000 -0700
@@ -1,9 +1,11 @@
#!./perl
# Test $!
-print "1..17\n";
+print "1..28\n";
+$test_count = 1;
$teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n";
+$teststring2 = "1234567890123456789012345678901234567890";
# Create our test datafile
1 while unlink 'foo'; # in case junk left around
@@ -13,85 +15,25 @@
print TESTFILE $teststring;
close TESTFILE or die "error $! $^E closing";
+$test_count_start = $test_count; # Needed to know how many tests to skip
open TESTFILE, "<./foo";
binmode TESTFILE;
-
-# Check the default $/
-$bar = <TESTFILE>;
-if ($bar eq "1\n") {print "ok 1\n";} else {print "not ok 1\n";}
-
-# explicitly set to \n
-$/ = "\n";
-$bar = <TESTFILE>;
-if ($bar eq "12\n") {print "ok 2\n";} else {print "not ok 2\n";}
-
-# Try a non line terminator
-$/ = 3;
-$bar = <TESTFILE>;
-if ($bar eq "123") {print "ok 3\n";} else {print "not ok 3\n";}
-
-# Eat the line terminator
-$/ = "\n";
-$bar = <TESTFILE>;
-
-# How about a larger terminator
-$/ = "34";
-$bar = <TESTFILE>;
-if ($bar eq "1234") {print "ok 4\n";} else {print "not ok 4\n";}
-
-# Eat the line terminator
-$/ = "\n";
-$bar = <TESTFILE>;
-
-# Does paragraph mode work?
-$/ = '';
-$bar = <TESTFILE>;
-if ($bar eq "1234\n12345\n\n") {print "ok 5\n";} else {print "not ok 5\n";}
-
-# Try slurping the rest of the file
-$/ = undef;
-$bar = <TESTFILE>;
-if ($bar eq "123456\n1234567\n") {print "ok 6\n";} else {print "not ok 6\n";}
+test_string(*TESTFILE);
+close TESTFILE;
+unlink "./foo";
# try the record reading tests. New file so we don't have to worry about
# the size of \n.
-close TESTFILE;
-unlink "./foo";
open TESTFILE, ">./foo";
-print TESTFILE "1234567890123456789012345678901234567890";
+print TESTFILE $teststring2;
binmode TESTFILE;
close TESTFILE;
open TESTFILE, "<./foo";
binmode TESTFILE;
-
-# Test straight number
-$/ = \2;
-$bar = <TESTFILE>;
-if ($bar eq "12") {print "ok 7\n";} else {print "not ok 7\n";}
-
-# Test stringified number
-$/ = \"2";
-$bar = <TESTFILE>;
-if ($bar eq "34") {print "ok 8\n";} else {print "not ok 8\n";}
-
-# Integer variable
-$foo = 2;
-$/ = \$foo;
-$bar = <TESTFILE>;
-if ($bar eq "56") {print "ok 9\n";} else {print "not ok 9\n";}
-
-# String variable
-$foo = "2";
-$/ = \$foo;
-$bar = <TESTFILE>;
-if ($bar eq "78") {print "ok 10\n";} else {print "not ok 10\n";}
-
-# Naughty straight number - should get the rest of the file
-$/ = \0;
-$bar = <TESTFILE>;
-if ($bar eq "90123456789012345678901234567890") {print "ok 11\n";} else {print
"not ok 11\n";}
-
+test_record(*TESTFILE);
close TESTFILE;
+$test_count_end = $test_count; # Needed to know how many tests to skip
+
# Now for the tricky bit--full record reading
if ($^O eq 'VMS') {
@@ -115,23 +57,30 @@
open TESTFILE, "<./foo.bar";
$/ = \10;
$bar = <TESTFILE>;
- if ($bar eq "foo\n") {print "ok 12\n";} else {print "not ok 12\n";}
+ if ($bar eq "foo\n") {print "ok $test_count\n";} else {print "not ok
$test_count\n";}
+ $test_count++;
$bar = <TESTFILE>;
- if ($bar eq "foobar\n") {print "ok 13\n";} else {print "not ok 13\n";}
+ if ($bar eq "foobar\n") {print "ok $test_count\n";} else {print "not ok
$test_count\n";}
+ $test_count++;
# can we do a short read?
$/ = \2;
$bar = <TESTFILE>;
- if ($bar eq "ba") {print "ok 14\n";} else {print "not ok 14\n";}
+ if ($bar eq "ba") {print "ok $test_count\n";} else {print "not ok
$test_count\n";}
+ $test_count++;
# do we get the rest of the record?
$bar = <TESTFILE>;
- if ($bar eq "z\n") {print "ok 15\n";} else {print "not ok 15\n";}
+ if ($bar eq "z\n") {print "ok $test_count\n";} else {print "not ok
$test_count\n";}
+ $test_count++;
close TESTFILE;
1 while unlink qw(foo.bar foo.com foo.fdl);
} else {
# Nobody else does this at the moment (well, maybe OS/390, but they can
# put their own tests in) so we just punt
- foreach $test (12..15) {print "ok $test # skipped on non-VMS system\n"};
+ foreach $test ($test_count..$test_count + 3) {
+ print "ok $test # skipped on non-VMS system\n";
+ $test_count++;
+ }
}
$/ = "\n";
@@ -147,7 +96,8 @@
else {
print "not ";
}
- print "ok 16\n";
+ print "ok $test_count # open/readline/close on our variable\n";
+ $test_count++;
}
{
@@ -160,8 +110,126 @@
else {
print "not ";
}
- print "ok 17\n";
+ print "ok $test_count # open/readline/close on my variable\n";
+ $test_count++;
+}
+
+
+if ($ENV{PERL_CORE_MINITEST} or $ENV{_} =~ m/miniperl/) {
+ # In-memory files necessitate PerlIO::via::scalar, thus a perl with
+ # perlio and dynaloading enabled. miniperl won't be able to run this
+ # test, so skip it
+
+ for $test ($test_count .. $test_count + ($test_count_end - $test_count_start
- 1)) {
+ print "ok $test # skipped - Can't test in memory file with miniperl\n";
+ $test_count++;
+ }
+}
+else {
+ # Test if a file in memory behaves the same as a real file (= re-run the
test with a file in memory)
+ open TESTFILE, "<", \$teststring;
+ test_string(*TESTFILE);
+ close TESTFILE;
+
+ open TESTFILE, "<", \$teststring2;
+ test_record(*TESTFILE);
+ close TESTFILE;
}
# Get rid of the temp file
END { unlink "./foo"; }
+
+sub test_string {
+ *FH = shift;
+
+ # Check the default $/
+ $bar = <FH>;
+ if ($bar ne "1\n") {print "not ";}
+ print "ok $test_count # default \$/\n";
+ $test_count++;
+
+ # explicitly set to \n
+ $/ = "\n";
+ $bar = <FH>;
+ if ($bar ne "12\n") {print "not ";}
+ print "ok $test_count # \$/ = \"\\n\"\n";
+ $test_count++;
+
+ # Try a non line terminator
+ $/ = 3;
+ $bar = <FH>;
+ if ($bar ne "123") {print "not ";}
+ print "ok $test_count # \$/ = 3\n";
+ $test_count++;
+
+ # Eat the line terminator
+ $/ = "\n";
+ $bar = <FH>;
+
+ # How about a larger terminator
+ $/ = "34";
+ $bar = <FH>;
+ if ($bar ne "1234") {print "not ";}
+ print "ok $test_count # \$/ = \"34\"\n";
+ $test_count++;
+
+ # Eat the line terminator
+ $/ = "\n";
+ $bar = <FH>;
+
+ # Does paragraph mode work?
+ $/ = '';
+ $bar = <FH>;
+ if ($bar ne "1234\n12345\n\n") {print "not ";}
+ print "ok $test_count # \$/ = ''\n";
+ $test_count++;
+
+ # Try slurping the rest of the file
+ $/ = undef;
+ $bar = <FH>;
+ if ($bar ne "123456\n1234567\n") {print "not ";}
+ print "ok $test_count # \$/ = undef\n";
+ $test_count++;
+}
+
+sub test_record {
+ *FH = shift;
+
+ # Test straight number
+ $/ = \2;
+ $bar = <FH>;
+ if ($bar ne "12") {print "not ";}
+ print "ok $test_count # \$/ = \\2\n";
+ $test_count++;
+
+ # Test stringified number
+ $/ = \"2";
+ $bar = <FH>;
+ if ($bar ne "34") {print "not ";}
+ print "ok $test_count # \$/ = \"2\"\n";
+ $test_count++;
+
+ # Integer variable
+ $foo = 2;
+ $/ = \$foo;
+ $bar = <FH>;
+ if ($bar ne "56") {print "not ";}
+ print "ok $test_count # \$/ = \\\$foo (\$foo = 2)\n";
+ $test_count++;
+
+ # String variable
+ $foo = "2";
+ $/ = \$foo;
+ $bar = <FH>;
+ if ($bar ne "78") {print "not ";}
+ print "ok $test_count # \$/ = \\\$foo (\$foo = \"2\")\n";
+ $test_count++;
+
+ # Naughty straight number - should get the rest of the file
+ $/ = \0;
+ $bar = <FH>;
+ if ($bar ne "90123456789012345678901234567890") {print "not ";}
+ print "ok $test_count # \$/ = \\0\n";
+ $test_count++;
+}
+
==== //depot/maint-5.8/perl/t/op/dbm.t#1 (text) ====
Index: perl/t/op/dbm.t
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/t/op/dbm.t 2008-05-25 13:30:46.000000000 -0700
@@ -0,0 +1,55 @@
+#!./perl
+
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require './test.pl';
+
+ eval { require AnyDBM_File }; # not all places have dbm* functions
+ skip_all("No dbm functions") if $@;
+}
+
+plan tests => 4;
+
+# This is [20020104.007] "coredump on dbmclose"
+
+my $prog = <<'EOC';
+package Foo;
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ bless($self,$class);
+ my %LT;
+ dbmopen(%LT, "dbmtest", 0666) ||
+ die "Can't open dbmtest because of $!\n";
+ $self->{'LT'} = \%LT;
+ return $self;
+}
+sub DESTROY {
+ my $self = shift;
+ dbmclose(%{$self->{'LT'}});
+ 1 while unlink 'dbmtest';
+ 1 while unlink <dbmtest.*>;
+ print "ok\n";
+}
+package main;
+$test = Foo->new(); # must be package var
+EOC
+
+fresh_perl_is("require AnyDBM_File;\n$prog", 'ok', {}, 'explict require');
+fresh_perl_is($prog, 'ok', {}, 'implicit require');
+
+$prog = <<'EOC';
[EMAIL PROTECTED] = ();
+dbmopen(%LT, "dbmtest", 0666);
+1 while unlink 'dbmtest';
+1 while unlink <dbmtest.*>;
+die "Failed to fail!";
+EOC
+
+fresh_perl_like($prog, qr/No dbm on this machine/, {},
+ 'implicit require fails');
+fresh_perl_like('delete $::{"AnyDBM_File::"}; ' . $prog,
+ qr/No dbm on this machine/, {},
+ 'implicit require and no stash fails');
==== //depot/maint-5.8/perl/t/op/groups.t#5 (xtext) ====
Index: perl/t/op/groups.t
--- perl/t/op/groups.t#4~30522~ 2007-03-09 09:20:49.000000000 -0800
+++ perl/t/op/groups.t 2008-05-25 13:30:46.000000000 -0700
@@ -136,7 +136,7 @@
print "# gr = @gr\n";
my %did;
-if ($^O =~ /^(?:uwin|cygwin|interix|solaris)$/) {
+if ($^O =~ /^(?:uwin|cygwin|interix|solaris|linux)$/) {
# Or anybody else who can have spaces in group names.
$gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr))));
} else {
==== //depot/maint-5.8/perl/t/op/lc.t#15 (text) ====
Index: perl/t/op/lc.t
--- perl/t/op/lc.t#14~33216~ 2008-02-02 14:23:57.000000000 -0800
+++ perl/t/op/lc.t 2008-05-25 13:30:46.000000000 -0700
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 92;
+plan tests => 93;
is(lc(undef), "", "lc(undef) is ''");
is(lcfirst(undef), "", "lcfirst(undef) is ''");
@@ -217,3 +217,6 @@
lc $_;
is($_, "Hello");
}
+
+# new in Unicode 5.1.0
+is(lc("\x{1E9E}"), "\x{df}", "lc(LATIN CAPITAL LETTER SHARP S)");
==== //depot/maint-5.8/perl/t/op/pat.t#52 (xtext) ====
Index: perl/t/op/pat.t
--- perl/t/op/pat.t#51~33216~ 2008-02-02 14:23:57.000000000 -0800
+++ perl/t/op/pat.t 2008-05-25 13:30:46.000000000 -0700
@@ -2034,7 +2034,7 @@
my $test = 687;
-# Force scalar context on the patern match
+# Force scalar context on the pattern match
sub ok ($;$) {
my($ok, $name) = @_;
my $todo = $TODO ? " # TODO $TODO" : '';
@@ -2048,6 +2048,18 @@
return $ok;
}
+sub skip {
+ my $why = shift;
+ $why =~ s/\n.*//s;
+ my $n = @_ ? shift : 1;
+ for (1..$n) {
+ print "ok $test # skip: $why\n";
+ $test++;
+ }
+ local $^W = 0;
+ last SKIP;
+}
+
{
# Check that \x## works. 5.6.1 and 5.005_03 fail some of these.
$x = "\x4e" . "E";
@@ -3585,6 +3597,7 @@
printf "%sok %d - %s$todo\n", ($ok ? "" : "not "), $test,
$name||"$Message:".((caller)[2]);
+ no warnings 'utf8';
printf "# Failed test at line %d\n".
"# expected: %s\n".
"# result: %s\n",
@@ -3821,6 +3834,34 @@
iseq($count,1,"Optimiser should have prevented more than one match");
}
+SKIP: {
+ unless ($ordA == 65) { skip("Assumes ASCII", 4) }
+
+ my @notIsPunct = grep {/[[:punct:]]/ and not /\p{IsPunct}/}
+ map {chr} 0x20..0x7f;
+ iseq( join('', @notIsPunct), '$+<=>^`|~',
+ '[:punct:] disagress with IsPunct on Symbols');
+
+ my @isPrint = grep {not/[[:print:]]/ and /\p{IsPrint}/}
+ map {chr} 0..0x1f, 0x7f..0x9f;
+ iseq( join('', @isPrint), "\x09\x0a\x0b\x0c\x0d\x85",
+ 'IsPrint disagrees with [:print:] on control characters');
+
+ my @isPunct = grep {/[[:punct:]]/ != /\p{IsPunct}/}
+ map {chr} 0x80..0xff;
+ iseq( join('', @isPunct), "\xa1\xab\xb7\xbb\xbf", # ¡ « · » ¿
+ 'IsPunct disagrees with [:punct:] outside ASCII');
+
+ my @isPunctLatin1 = eval q{
+ use encoding 'latin1';
+ grep {/[[:punct:]]/ != /\p{IsPunct}/} map {chr} 0x80..0xff;
+ };
+ if( $@ ){ skip( $@, 1); }
+ iseq( join('', @isPunctLatin1), '',
+ 'IsPunct agrees with [:punct:] with explicit Latin1');
+}
+
+
# Test counter is at bottom of file. Put new tests above here.
#-------------------------------------------------------------------
# Keep the following tests last -- they may crash perl
@@ -3836,4 +3877,4 @@
# Put new tests above the dotted line about a page above this comment
-BEGIN{print "1..1270\n"};
+BEGIN{print "1..1274\n"};
==== //depot/maint-5.8/perl/t/op/pwent.t#3 (xtext) ====
Index: perl/t/op/pwent.t
--- perl/t/op/pwent.t#2~32379~ 2007-11-17 12:42:55.000000000 -0800
+++ perl/t/op/pwent.t 2008-05-25 13:30:46.000000000 -0700
@@ -41,6 +41,71 @@
}
}
+ if (not defined $where && # Try dscl
+ $Config{useperlio} eq 'define') { # need perlio
+
+ # Map dscl items to passwd fields, and provide support for
+ # mucking with the dscl output if we need to (and we do).
+ my %want = do {
+ my $inx = 0;
+ map {$_ => {inx => $inx++, mung => sub {$_[0]}}}
+ qw{RecordName Password UniqueID PrimaryGroupID
+ RealName NFSHomeDirectory UserShell};
+ };
+
+ # The RecordName for a /User record is the username. In some
+ # cases there are synonyms (e.g. _www and www), in which case we
+ # get a blank-delimited list. We prefer the first entry in the
+ # list because getpwnam() does.
+ $want{RecordName}{mung} = sub {(split '\s+', $_[0], 2)[0]};
+
+ # The UniqueID and PrimaryGroupID for a /User record are the
+ # user ID and the primary group ID respectively. In cases where
+ # the high bit is set, 'dscl' returns a negative number, whereas
+ # getpwnam() returns its twos complement. This mungs the dscl
+ # output to agree with what getpwnam() produces. Interestingly
+ # enough, getpwuid(-2) returns the right record ('nobody'), even
+ # though it returns the uid as 4294967294. If you track uid_t
+ # on an i386, you find it is an unsigned int, which makes the
+ # unsigned version the right one; but both /etc/passwd and
+ # /etc/master.passwd contain negative numbers.
+ $want{UniqueID}{mung} = $want{PrimaryGroupID}{mung} = sub {
+ unpack 'L', pack 'l', $_[0]};
+
+ foreach my $dscl (qw(/usr/bin/dscl)) {
+ -x $dscl or next;
+ open (my $fh, '-|', join (' ', $dscl, qw{. -readall /Users},
+ keys %want, '2>/dev/null')) or next;
+ my $data;
+ my @rec;
+ while (<$fh>) {
+ chomp;
+ if ($_ eq '-') {
+ @rec and $data .= join (':', @rec) . "\n";
+ @rec = ();
+ next;
+ }
+ my ($name, $value) = split ':\s+', $_, 2;
+ unless (defined $value) {
+ s/:$//;
+ $name = $_;
+ $value = <$fh>;
+ chomp $value;
+ $value =~ s/^\s+//;
+ }
+ if (defined (my $info = $want{$name})) {
+ $rec[$info->{inx}] = $info->{mung}->($value);
+ }
+ }
+ @rec and $data .= join (':', @rec) . "\n";
+ if (open (PW, '<', \$data)) {
+ $where = "dscl . -readall /Users";
+ undef $reason;
+ last;
+ }
+ }
+ }
+
if (not defined $where) { # Try local.
my $PW = "/etc/passwd";
if (-f $PW && open(PW, $PW) && defined(<PW>)) {
End of Patch.
