Change 33823 by [EMAIL PROTECTED] on 2008/05/12 10:24:27
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]>
Affected files ...
... //depot/maint-5.10/perl/MANIFEST#22 integrate
... //depot/maint-5.10/perl/ext/File/Glob/t/basic.t#3 integrate
... //depot/maint-5.10/perl/pod/perlre.pod#3 integrate
... //depot/maint-5.10/perl/t/base/rs.t#2 integrate
... //depot/maint-5.10/perl/t/op/dbm.t#1 branch
... //depot/maint-5.10/perl/t/op/fork.t#2 integrate
... //depot/maint-5.10/perl/t/op/groups.t#2 integrate
... //depot/maint-5.10/perl/t/op/lc.t#3 integrate
... //depot/maint-5.10/perl/t/op/pat.t#7 integrate
... //depot/maint-5.10/perl/t/op/sprintf2.t#2 integrate
... //depot/maint-5.10/perl/t/run/fresh_perl.t#2 integrate
Differences ...
==== //depot/maint-5.10/perl/MANIFEST#22 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#21~33821~ 2008-05-11 04:19:32.000000000 -0700
+++ perl/MANIFEST 2008-05-12 03:24:27.000000000 -0700
@@ -3753,6 +3753,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.10/perl/ext/File/Glob/t/basic.t#3 (xtext) ====
Index: perl/ext/File/Glob/t/basic.t
--- perl/ext/File/Glob/t/basic.t#2~33628~ 2008-04-02 09:51:24.000000000
-0700
+++ perl/ext/File/Glob/t/basic.t 2008-05-12 03:24:27.000000000 -0700
@@ -173,8 +173,8 @@
chdir $dir
or die "Could not chdir to $dir: $!";
my(@glob_files) = glob("a*{d[e]}j");
- local $TODO = "home-made glob doesn't do regexes" if $^O eq 'VMS';
- is_deeply([EMAIL PROTECTED], ['a_dej']);
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.10/perl/pod/perlre.pod#3 (text) ====
Index: perl/pod/perlre.pod
--- perl/pod/perlre.pod#2~33610~ 2008-03-30 16:20:46.000000000 -0700
+++ perl/pod/perlre.pod 2008-05-12 03:24:27.000000000 -0700
@@ -375,20 +375,60 @@
digit IsDigit \d
graph IsGraph
lower IsLower
- print IsPrint
- punct IsPunct
+ print IsPrint (but see [2] below)
+ punct IsPunct (but see [3] below)
space IsSpace
IsSpacePerl \s
upper IsUpper
- word IsWord
+ word IsWord \w
xdigit IsXDigit
For example C<[[:lower:]]> and C<\p{IsLower}> are equivalent.
+However, the equivalence between C<[[:xxxxx:]]> and C<\p{IsXxxxx}>
+is not exact.
+
+=over 4
+
+=item [1]
+
If the C<utf8> pragma is not used but the C<locale> pragma is, the
classes correlate with the usual isalpha(3) interface (except for
"word" and "blank").
+But if the C<locale> or C<encoding> pragmas are not used and
+the string is not C<utf8>, then C<[[:xxxxx:]]> (and C<\w>, etc.)
+will not match characters 0x80-0xff; whereas C<\p{IsXxxxx}> will
+force the string to C<utf8> and can match these characters
+(as Unicode).
+
+=item [2]
+
+C<\p{IsPrint}> matches characters 0x09-0x0d but C<[[:print:]]> does not.
+
+=item [3]
+
+C<[[:punct::]]> matches the following but C<\p{IsPunct}> does not,
+because they are classed as symbols (not punctuation) in Unicode.
+
+=over 4
+
+=item C<$>
+
+Currency symbol
+
+=item C<+> C<< < >> C<=> C<< > >> C<|> C<~>
+
+Mathematical symbols
+
+=item C<^> C<`>
+
+Modifier symbols (accents)
+
+=back
+
+=back
+
The other named classes are:
=over 4
==== //depot/maint-5.10/perl/t/base/rs.t#2 (xtext) ====
Index: perl/t/base/rs.t
--- perl/t/base/rs.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/t/base/rs.t 2008-05-12 03:24:27.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.10/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-12 03:24:27.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.10/perl/t/op/fork.t#2 (xtext) ====
Index: perl/t/op/fork.t
--- perl/t/op/fork.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/t/op/fork.t 2008-05-12 03:24:27.000000000 -0700
@@ -445,16 +445,14 @@
my $pid = fork;
die "fork: $!" if !defined $pid;
if ($pid == 0) {
- my $rand_child = rand;
close RDR;
- print WTR $rand_child, "\n";
+ print WTR "STRING_FROM_CHILD\n";
close WTR;
} else {
- my $rand_parent = rand;
close WTR;
- chomp(my $rand_child = <RDR>);
+ chomp(my $string_from_child = <RDR>);
close RDR;
- print $rand_child ne $rand_parent, "\n";
+ print $string_from_child eq "STRING_FROM_CHILD", "\n";
}
EXPECT
1
==== //depot/maint-5.10/perl/t/op/groups.t#2 (xtext) ====
Index: perl/t/op/groups.t
--- perl/t/op/groups.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/t/op/groups.t 2008-05-12 03:24:27.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.10/perl/t/op/lc.t#3 (text) ====
Index: perl/t/op/lc.t
--- perl/t/op/lc.t#2~33133~ 2008-01-30 10:46:51.000000000 -0800
+++ perl/t/op/lc.t 2008-05-12 03:24:27.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.10/perl/t/op/pat.t#7 (xtext) ====
Index: perl/t/op/pat.t
--- perl/t/op/pat.t#6~33732~ 2008-04-22 12:53:49.000000000 -0700
+++ perl/t/op/pat.t 2008-05-12 03:24:27.000000000 -0700
@@ -2030,7 +2030,7 @@
$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" : '';
@@ -2044,6 +2044,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";
@@ -4552,6 +4564,32 @@
iseq($te[0], '../');
}
+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.
@@ -4612,6 +4650,6 @@
iseq(0+$::test,$::TestCount,"Got the right number of tests!");
# Don't forget to update this!
BEGIN {
- $::TestCount = 4020;
+ $::TestCount = 4024;
print "1..$::TestCount\n";
}
==== //depot/maint-5.10/perl/t/op/sprintf2.t#2 (text) ====
Index: perl/t/op/sprintf2.t
--- perl/t/op/sprintf2.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/t/op/sprintf2.t 2008-05-12 03:24:27.000000000 -0700
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 1292;
+plan tests => 1295;
is(
sprintf("%.40g ",0.01),
@@ -134,3 +134,8 @@
}
}
+# test that %f doesn't panic with +Inf, -Inf, NaN [perl #45383]
+foreach my $n (2**1e100, -2**1e100, 2**1e100/2**1e100) { # +Inf, -Inf, NaN
+ eval { my $f = sprintf("%f", $n); };
+ is $@, "", "sprintf(\"%f\", $n)";
+}
==== //depot/maint-5.10/perl/t/run/fresh_perl.t#2 (text) ====
Index: perl/t/run/fresh_perl.t
--- perl/t/run/fresh_perl.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/t/run/fresh_perl.t 2008-05-12 03:24:27.000000000 -0700
@@ -716,36 +716,6 @@
print join '', @a, "\n";
EXPECT
123456789
-######## [ID 20020104.007] "coredump on dbmclose"
-package Foo;
-eval { require AnyDBM_File }; # not all places have dbm* functions
-if ($@) {
- print "ok\n";
- exit 0;
-}
-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
-EXPECT
-ok
######## example from Camel 5, ch. 15, pp.406 (with my)
# SKIP: ord "A" == 193 # EBCDIC
use strict;
End of Patch.
