From: Jarkko Hietaniemi Date: Mon, 4 Mar 2002 01:05:17 +0000 (+0000) Subject: Upgrade to Tie::File 0.15. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7b6b3db1ec99414fb825aa173100ce08654f405e;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Tie::File 0.15. p4raw-id: //depot/perl@14970 --- diff --git a/MANIFEST b/MANIFEST index a6069eb..1482b2a 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1418,21 +1418,21 @@ lib/Tie/Array/splice.t Test for Tie::Array::SPLICE lib/Tie/Array/std.t Test for Tie::StdArray lib/Tie/Array/stdpush.t Test for Tie::StdArray lib/Tie/File.pm Files as tied arrays. -lib/Tie/File/01_gen.t Test for Tie::File. -lib/Tie/File/02_fetchsize.t Test for Tie::File. -lib/Tie/File/03_longfetch.t Test for Tie::File. -lib/Tie/File/04_splice.t Test for Tie::File. -lib/Tie/File/05_size.t Test for Tie::File. -lib/Tie/File/06_fixrec.t Test for Tie::File. -lib/Tie/File/07_rv_splice.t Test for Tie::File. -lib/Tie/File/08_ro.t Test for Tie::File. -lib/Tie/File/09_gen_rs.t Test for Tie::File. -lib/Tie/File/10_splice_rs.t Test for Tie::File. -lib/Tie/File/11_rv_splice_rs.t Test for Tie::File. -lib/Tie/File/12_longfetch_rs.t Test for Tie::File. -lib/Tie/File/13_size_rs.t Test for Tie::File. -lib/Tie/File/14_lock.t Test for Tie::File. -lib/Tie/File/15_pushpop.t Test for Tie::File. +lib/Tie/File/t/01_gen.t Test for Tie::File. +lib/Tie/File/t/02_fetchsize.t Test for Tie::File. +lib/Tie/File/t/03_longfetch.t Test for Tie::File. +lib/Tie/File/t/04_splice.t Test for Tie::File. +lib/Tie/File/t/05_size.t Test for Tie::File. +lib/Tie/File/t/06_fixrec.t Test for Tie::File. +lib/Tie/File/t/07_rv_splice Test for Tie::File. +lib/Tie/File/t/08_ro.t Test for Tie::File. +lib/Tie/File/t/09_gen_rs Test for Tie::File. +lib/Tie/File/t/10_splice_rs Test for Tie::File. +lib/Tie/File/t/11_rv_splice_rs.t Test for Tie::File. +lib/Tie/File/t/12_longfetch_rs.t Test for Tie::File. +lib/Tie/File/t/13_size_rs Test for Tie::File. +lib/Tie/File/t/14_lock.t Test for Tie::File. +lib/Tie/File/t/15_pushpop.t Test for Tie::File. lib/Tie/Handle.pm Base class for tied handles lib/Tie/Handle/stdhandle.t Test for Tie::StdHandle lib/Tie/Hash.pm Base class for tied hashes diff --git a/lib/Tie/File.pm b/lib/Tie/File.pm index 9fc7eab..8ae70a6 100644 --- a/lib/Tie/File.pm +++ b/lib/Tie/File.pm @@ -5,7 +5,7 @@ use POSIX 'SEEK_SET'; use Fcntl 'O_CREAT', 'O_RDWR', 'LOCK_EX'; require 5.005; -$VERSION = "0.14"; +$VERSION = "0.15"; # Idea: The object will always contain an array of byte offsets # this will be filled in as is necessary and convenient. @@ -153,7 +153,10 @@ sub PUSH { sub POP { my $self = shift; - scalar $self->SPLICE(-1, 1); + my $size = $self->FETCHSIZE; + return if $size == 0; +# print STDERR "# POPPITY POP POP POP\n"; + scalar $self->SPLICE($size-1, 1); } sub SHIFT { @@ -207,8 +210,13 @@ sub SPLICE { my ($self, $pos, $nrecs, @data) = @_; my @result; + $pos = 0 unless defined $pos; + + # Deal with negative and other out-of-range positions + # Also set default for $nrecs { my $oldsize = $self->FETCHSIZE; + $nrecs = $oldsize unless defined $nrecs; my $oldpos = $pos; if ($pos < 0) { @@ -525,9 +533,10 @@ sub flock { sub _check_integrity { my ($self, $file, $warn) = @_; my $good = 1; - local *F; - open F, $file or die "Couldn't open file $file: $!"; - binmode F; + local *F = $self->{fh}; + seek F, 0, SEEK_SET; +# open F, $file or die "Couldn't open file $file: $!"; +# binmode F; local $/ = $self->{recsep}; unless ($self->{offsets}[0] == 0) { $warn && print STDERR "# rec 0: offset <$self->{offsets}[0]> s/b 0!\n"; @@ -592,7 +601,7 @@ Tie::File - Access the lines of a disk file via a Perl array =head1 SYNOPSIS - # This file documents Tie::File version 0.14 + # This file documents Tie::File version 0.15 tie @array, 'Tie::File', filename or die ...; @@ -660,7 +669,7 @@ is C<"\n">, then the following two lines do exactly the same thing: The result is that the contents of line 17 of the file will be replaced with "Cherry pie"; a newline character will separate line 17 -from line 18. This means that inparticular, this will do nothing: +from line 18. This means that in particular, this will do nothing: chomp $array[17]; @@ -778,9 +787,9 @@ lines 1 through 999,999; the second iteration must relocate lines 2 through 999,999, and so on. The relocation is done using block writes, however, so it's not as slow as it might be. -A future version of this module will provide some mechanism for -getting better performance in such cases, by deferring the writing -until it can be done all at once. +A future version of this module will provide a mechanism for getting +better performance in such cases, by deferring the writing until it +can be done all at once. =head2 Efficiency Note 2 @@ -829,22 +838,25 @@ C. =head1 LICENSE -C version 0.14 is copyright (C) 2002 Mark Jason Dominus. +C version 0.15 is copyright (C) 2002 Mark Jason Dominus. + +This library is free software; you may redistribute it and/or modify +it under the same terms as Perl itself. -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. +These terms include your choice of (1) the Perl Artistic Licence, or +(2) version 2 of the GNU General Public License as published by the +Free Software Foundation, or (3) any later version of the GNU General +Public License. -This program is distributed in the hope that it will be useful, +This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License -along with this program; it should be in the file C. If not, -write to the Free Software Foundation, Inc., 59 Temple Place, Suite -330, Boston, MA 02111 USA +along with this library program; it should be in the file C. +If not, write to the Free Software Foundation, Inc., 59 Temple Place, +Suite 330, Boston, MA 02111 USA For licensing inquiries, contact the author at: @@ -854,11 +866,13 @@ For licensing inquiries, contact the author at: =head1 WARRANTY -C version 0.14 comes with ABSOLUTELY NO WARRANTY. +C version 0.15 comes with ABSOLUTELY NO WARRANTY. For details, see the license. =head1 TODO +Allow tie to seekable filehandle rather than named file. + Tests for default arguments to SPLICE. Tests for CLEAR/EXTEND. Tests for DELETE/EXISTS. diff --git a/lib/Tie/File/01_gen.t b/lib/Tie/File/t/01_gen.t similarity index 77% rename from lib/Tie/File/01_gen.t rename to lib/Tie/File/t/01_gen.t index d69d232..d0ccb71 100644 --- a/lib/Tie/File/01_gen.t +++ b/lib/Tie/File/t/01_gen.t @@ -63,27 +63,41 @@ check_contents("sh0", "sh1", "short2", "rec3", "rec4"); # try inserting a record into the middle of an empty file - +use POSIX 'SEEK_SET'; sub check_contents { my @c = @_; my $x = join $/, @c, ''; - local *FH; - my $open = open FH, "< $file"; + local *FH = $o->{fh}; + seek FH, 0, SEEK_SET; +# my $open = open FH, "< $file"; my $a; { local $/; $a = } - print (($open && $a eq $x) ? "ok $N\n" : "not ok $N # file @c\n"); + $a = "" unless defined $a; + if ($a eq $x) { + print "ok $N\n"; + } else { + s{$/}{\\n}g for $a, $x; + print "not ok $N\n# expected <$x>, got <$a>\n"; + } $N++; # now check FETCH: my $good = 1; + my $msg; for (0.. $#c) { - $good = 0 unless $a[$_] eq "$c[$_]$/"; + unless ($a[$_] eq "$c[$_]$/") { + $msg = "expected $c[$_]$/, got $a[$_]"; + $msg =~ s{$/}{\\n}g; + $good = 0; + } } - print (($open && $good) ? "ok $N\n" : "not ok $N # fetch @c\n"); + print $good ? "ok $N\n" : "not ok $N # $msg\n"; $N++; } END { + undef $o; + untie @a; 1 while unlink $file; } diff --git a/lib/Tie/File/02_fetchsize.t b/lib/Tie/File/t/02_fetchsize.t similarity index 96% rename from lib/Tie/File/02_fetchsize.t rename to lib/Tie/File/t/02_fetchsize.t index b7ea3a5..78fcea8 100644 --- a/lib/Tie/File/02_fetchsize.t +++ b/lib/Tie/File/t/02_fetchsize.t @@ -43,6 +43,8 @@ print $q eq $data ? "ok $N\n" : "not ok $N # n=$n\n"; $N++; END { + undef $o; + untie @a; 1 while unlink $file; } diff --git a/lib/Tie/File/03_longfetch.t b/lib/Tie/File/t/03_longfetch.t similarity index 96% rename from lib/Tie/File/03_longfetch.t rename to lib/Tie/File/t/03_longfetch.t index 83f011e..a84890a 100644 --- a/lib/Tie/File/03_longfetch.t +++ b/lib/Tie/File/t/03_longfetch.t @@ -34,6 +34,8 @@ for (2, 1, 0) { } END { + undef $o; + untie @a; 1 while unlink $file; } diff --git a/lib/Tie/File/04_splice.t b/lib/Tie/File/t/04_splice.t similarity index 93% rename from lib/Tie/File/04_splice.t rename to lib/Tie/File/t/04_splice.t index f8628a2..e291809 100644 --- a/lib/Tie/File/04_splice.t +++ b/lib/Tie/File/t/04_splice.t @@ -13,7 +13,9 @@ my $file = "tf$$.txt"; my $data = "rec0$/rec1$/rec2$/"; -print "1..97\n"; +print "1..101\n"; + +init_file($data); my $N = 1; use Tie::File; @@ -26,8 +28,6 @@ $N++; my $n; # (3-22) splicing at the beginning -init_file($data); - splice(@a, 0, 0, "rec4"); check_contents("rec4$/$data"); splice(@a, 0, 1, "rec5"); # same length @@ -162,6 +162,12 @@ if ($] < 5.006 || $] > 5.007002) { } $N++; +# (98-101) Test default arguments +splice @a, 0, 0, (0..11); +splice @a, 4; +check_contents("0$/1$/2$/3$/"); +splice @a; +check_contents(""); sub init_file { @@ -172,21 +178,29 @@ sub init_file { close F; } +use POSIX 'SEEK_SET'; sub check_contents { my $x = shift; - local *FH; my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); + local *FH = $o->{fh}; + seek FH, 0, SEEK_SET; print $integrity ? "ok $N\n" : "not ok $N\n"; $N++; - my $open = open FH, "< $file"; - binmode FH; my $a; { local $/; $a = } - print (($open && $a eq $x) ? "ok $N\n" : "not ok $N\n"); + $a = "" unless defined $a; + if ($a eq $x) { + print "ok $N\n"; + } else { + s{$/}{\\n}g for $a, $x; + print "not ok $N\n# expected <$x>, got <$a>\n"; + } $N++; } END { + undef $o; + untie @a; 1 while unlink $file; } diff --git a/lib/Tie/File/05_size.t b/lib/Tie/File/t/05_size.t similarity index 82% rename from lib/Tie/File/05_size.t rename to lib/Tie/File/t/05_size.t index f7a3271..dbc2c0a 100644 --- a/lib/Tie/File/05_size.t +++ b/lib/Tie/File/t/05_size.t @@ -4,6 +4,8 @@ # PUSH POP SHIFT UNSHIFT # +use POSIX 'SEEK_SET'; + my $file = "tf$$.txt"; my $data = "rec0$/rec1$/rec2$/"; my ($o, $n); @@ -65,17 +67,24 @@ check_contents(''); sub check_contents { my $x = shift; - local *FH; - my $open = open FH, "< $file"; - binmode FH; + local *FH = $o->{fh}; + seek FH, 0, SEEK_SET; my $a; { local $/; $a = } - print (($open && $a eq $x) ? "ok $N\n" : "not ok $N\n"); + $a = "" unless defined $a; + if ($a eq $x) { + print "ok $N\n"; + } else { + s{$/}{\\n}g for $a, $x; + print "not ok $N\n# expected <$x>, got <$a>\n"; + } $N++; } END { + undef $o; + untie @a; 1 while unlink $file; } diff --git a/lib/Tie/File/06_fixrec.t b/lib/Tie/File/t/06_fixrec.t similarity index 65% rename from lib/Tie/File/06_fixrec.t rename to lib/Tie/File/t/06_fixrec.t index f191921..62e5579 100644 --- a/lib/Tie/File/06_fixrec.t +++ b/lib/Tie/File/t/06_fixrec.t @@ -1,5 +1,6 @@ #!/usr/bin/perl +use POSIX 'SEEK_SET'; my $file = "tf$$.txt"; print "1..5\n"; @@ -21,17 +22,24 @@ check_contents("rec0$/rec1$/rec2$/$/"); sub check_contents { my $x = shift; - local *FH; - my $open = open FH, "< $file"; - binmode FH; + local *FH = $o->{fh}; + seek FH, 0, SEEK_SET; my $a; { local $/; $a = } - print (($open && $a eq $x) ? "ok $N\n" : "not ok $N\n"); + $a = "" unless defined $a; + if ($a eq $x) { + print "ok $N\n"; + } else { + s{$/}{\\n}g for $a, $x; + print "not ok $N\n# expected <$x>, got <$a>\n"; + } $N++; } END { + undef $o; + untie @a; 1 while unlink $file; } diff --git a/lib/Tie/File/07_rv_splice.t b/lib/Tie/File/t/07_rv_splice.t similarity index 96% rename from lib/Tie/File/07_rv_splice.t rename to lib/Tie/File/t/07_rv_splice.t index 75c8a3a..f5da174 100644 --- a/lib/Tie/File/07_rv_splice.t +++ b/lib/Tie/File/t/07_rv_splice.t @@ -7,12 +7,14 @@ my $file = "tf$$.txt"; my $data = "rec0$/rec1$/rec2$/"; -print "1..48\n"; +print "1..50\n"; my $N = 1; use Tie::File; print "ok $N\n"; $N++; # partial credit just for showing up +init_file($data); + my $o = tie @a, 'Tie::File', $file; print $o ? "ok $N\n" : "not ok $N\n"; $N++; @@ -20,8 +22,6 @@ $N++; my $n; # (3-12) splicing at the beginning -init_file($data); - @r = splice(@a, 0, 0, "rec4"); check_result(); @r = splice(@a, 0, 1, "rec5"); # same length @@ -145,6 +145,12 @@ $r = splice(@a, 0, 2); print $r eq "like$/" ? "ok $N\n" : "not ok $N \# return should have been 'like'\n"; $N++; +# (49-50) Test default arguments +splice @a, 0, 0, (0..11); +@r = splice @a, 4; +check_result(4..11); +@r = splice @a; +check_result(0..3); sub init_file { my $data = shift; @@ -169,6 +175,8 @@ sub check_result { } END { + undef $o; + untie @a; 1 while unlink $file; } diff --git a/lib/Tie/File/08_ro.t b/lib/Tie/File/t/08_ro.t similarity index 96% rename from lib/Tie/File/08_ro.t rename to lib/Tie/File/t/08_ro.t index 2dbe239..245b16f 100644 --- a/lib/Tie/File/08_ro.t +++ b/lib/Tie/File/t/08_ro.t @@ -37,6 +37,8 @@ sub init_file { END { + undef $o; + untie @a; 1 while unlink $file; } diff --git a/lib/Tie/File/09_gen_rs.t b/lib/Tie/File/t/09_gen_rs.t similarity index 79% rename from lib/Tie/File/09_gen_rs.t rename to lib/Tie/File/t/09_gen_rs.t index d5afbe1..bb2fb26 100644 --- a/lib/Tie/File/09_gen_rs.t +++ b/lib/Tie/File/t/09_gen_rs.t @@ -64,28 +64,40 @@ check_contents("sh0", "sh1", "short2", "rec3", "rec4"); # try inserting a record into the middle of an empty file - +use POSIX 'SEEK_SET'; sub check_contents { my @c = @_; my $x = join 'blah', @c, ''; - local *FH; - my $open = open FH, "< $file"; - binmode FH; + local *FH = $o->{fh}; + seek FH, 0, SEEK_SET; my $a; { local $/; $a = } - print (($open && $a eq $x) ? "ok $N\n" : "not ok $N # file @c\n"); + + $a = "" unless defined $a; + if ($a eq $x) { + print "ok $N\n"; + } else { + s{$/}{\\n}g for $a, $x; + print "not ok $N\n# expected <$x>, got <$a>\n"; + } $N++; # now check FETCH: my $good = 1; for (0.. $#c) { - $good = 0 unless $a[$_] eq "$c[$_]blah"; + unless ($a[$_] eq "$c[$_]blah") { + $msg = "expected $c[$_]blah, got $a[$_]"; + $msg =~ s{$/}{\\n}g; + $good = 0; + } } - print (($open && $good) ? "ok $N\n" : "not ok $N # fetch @c\n"); + print $good ? "ok $N\n" : "not ok $N # fetch @c\n"; $N++; } END { + undef $o; + untie @a; 1 while unlink $file; } diff --git a/lib/Tie/File/10_splice_rs.t b/lib/Tie/File/t/10_splice_rs.t similarity index 79% rename from lib/Tie/File/10_splice_rs.t rename to lib/Tie/File/t/10_splice_rs.t index 94f3d01..9e0788c 100644 --- a/lib/Tie/File/10_splice_rs.t +++ b/lib/Tie/File/t/10_splice_rs.t @@ -10,15 +10,19 @@ # Then, it checks the actual contents of the file against the expected # contents. +use POSIX 'SEEK_SET'; + my $file = "tf$$.txt"; my $data = "rec0blahrec1blahrec2blah"; -print "1..88\n"; +print "1..101\n"; my $N = 1; use Tie::File; print "ok $N\n"; $N++; # partial credit just for showing up +init_file($data); + my $o = tie @a, 'Tie::File', $file, recsep => 'blah'; print $o ? "ok $N\n" : "not ok $N\n"; $N++; @@ -26,8 +30,6 @@ $N++; my $n; # (3-22) splicing at the beginning -init_file($data); - splice(@a, 0, 0, "rec4"); check_contents("rec4blah$data"); splice(@a, 0, 1, "rec5"); # same length @@ -136,6 +138,40 @@ check_contents("rec0blahrec1blah"); splice(@a, 0, 17); check_contents(""); +# (89-92) In the past, splicing past the end was not correctly detected +# (1.14) +splice(@a, 89, 3); +check_contents(""); +splice(@a, @a, 3); +check_contents(""); + +# (93-96) Also we did not emulate splice's freaky behavior when inserting +# past the end of the array (1.14) +splice(@a, 89, 0, "I", "like", "pie"); +check_contents("Iblahlikeblahpieblah"); +splice(@a, 89, 0, "pie pie pie"); +check_contents("Iblahlikeblahpieblahpie pie pieblah"); + +# (97) Splicing with too large a negative number should be fatal +# This test ignored because it causes 5.6.1 and 5.7.2 to dump core +# NOT MY FAULT +if ($] < 5.006 || $] > 5.007002) { + eval { splice(@a, -7, 0) }; + print $@ =~ /^Modification of non-creatable array value attempted, subscript -7/ + ? "ok $N\n" : "not ok $N \# \$\@ was '$@'\n"; +} else { + print "ok $N \# skipped (5.6.0 through 5.7.2 dump core here.)\n"; +} +$N++; + +# (98-101) Test default arguments +splice @a, 0, 0, (0..11); +splice @a, 4; +check_contents("0blah1blah2blah3blah"); +splice @a; +check_contents(""); + + sub init_file { my $data = shift; open F, "> $file" or die $!; @@ -146,18 +182,26 @@ sub init_file { sub check_contents { my $x = shift; - local *FH; my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); print $integrity ? "ok $N\n" : "not ok $N\n"; $N++; - my $open = open FH, "< $file"; + local *FH = $o->{fh}; + seek FH, 0, SEEK_SET; my $a; { local $/; $a = } - print (($open && $a eq $x) ? "ok $N\n" : "not ok $N\n"); + $a = "" unless defined $a; + if ($a eq $x) { + print "ok $N\n"; + } else { + s{$/}{\\n}g for $a, $x; + print "not ok $N\n# expected <$x>, got <$a>\n"; + } $N++; } END { + undef $o; + untie @a; 1 while unlink $file; } diff --git a/lib/Tie/File/11_rv_splice_rs.t b/lib/Tie/File/t/11_rv_splice_rs.t similarity index 87% rename from lib/Tie/File/11_rv_splice_rs.t rename to lib/Tie/File/t/11_rv_splice_rs.t index 654b661..ae3c9b3 100644 --- a/lib/Tie/File/11_rv_splice_rs.t +++ b/lib/Tie/File/t/11_rv_splice_rs.t @@ -7,12 +7,14 @@ my $file = "tf$$.txt"; my $data = "rec0blahrec1blahrec2blah"; -print "1..45\n"; +print "1..50\n"; my $N = 1; use Tie::File; print "ok $N\n"; $N++; # partial credit just for showing up +init_file($data); + my $o = tie @a, 'Tie::File', $file, recsep => 'blah'; print $o ? "ok $N\n" : "not ok $N\n"; $N++; @@ -20,8 +22,6 @@ $N++; my $n; # (3-12) splicing at the beginning -init_file($data); - @r = splice(@a, 0, 0, "rec4"); check_result(); @r = splice(@a, 0, 1, "rec5"); # same length @@ -130,6 +130,28 @@ check_result(); @r = splice(@a, 0, 17); check_result('rec0', 'rec1'); +# (46-48) Now check the scalar context return +splice(@a, 0, 0, qw(I like pie)); +my $r; +$r = splice(@a, 0, 0); +print !defined($r) ? "ok $N\n" : "not ok $N \# return should have been undef\n"; +$N++; + +$r = splice(@a, 2, 1); +print $r eq "pieblah" ? "ok $N\n" : "not ok $N \# return should have been 'pie'\n"; +$N++; + +$r = splice(@a, 0, 2); +print $r eq "likeblah" ? "ok $N\n" : "not ok $N \# return should have been 'like'\n"; +$N++; + +# (49-50) Test default arguments +splice @a, 0, 0, (0..11); +@r = splice @a, 4; +check_result(4..11); +@r = splice @a; +check_result(0..3); + sub init_file { my $data = shift; open F, "> $file" or die $!; @@ -153,6 +175,8 @@ sub check_result { } END { + undef $o; + untie @a; 1 while unlink $file; } diff --git a/lib/Tie/File/12_longfetch_rs.t b/lib/Tie/File/t/12_longfetch_rs.t similarity index 96% rename from lib/Tie/File/12_longfetch_rs.t rename to lib/Tie/File/t/12_longfetch_rs.t index de40e92..2d1a3bb 100644 --- a/lib/Tie/File/12_longfetch_rs.t +++ b/lib/Tie/File/t/12_longfetch_rs.t @@ -34,6 +34,8 @@ for (2, 1, 0) { } END { + undef $o; + untie @a; 1 while unlink $file; } diff --git a/lib/Tie/File/13_size_rs.t b/lib/Tie/File/t/13_size_rs.t similarity index 82% rename from lib/Tie/File/13_size_rs.t rename to lib/Tie/File/t/13_size_rs.t index 254f3ab..284d2d3 100644 --- a/lib/Tie/File/13_size_rs.t +++ b/lib/Tie/File/t/13_size_rs.t @@ -4,6 +4,8 @@ # PUSH POP SHIFT UNSHIFT # +use POSIX 'SEEK_SET'; + my $file = "tf$$.txt"; my $data = "rec0blahrec1blahrec2blah"; my ($o, $n); @@ -63,16 +65,24 @@ check_contents(''); sub check_contents { my $x = shift; - local *FH; - my $open = open FH, "< $file"; + local *FH = $o->{fh}; + seek FH, 0, SEEK_SET; my $a; { local $/; $a = } - print (($open && $a eq $x) ? "ok $N\n" : "not ok $N\n"); + $a = "" unless defined $a; + if ($a eq $x) { + print "ok $N\n"; + } else { + s{$/}{\\n}g for $a, $x; + print "not ok $N\n# expected <$x>, got <$a>\n"; + } $N++; } END { + undef $o; + untie @a; 1 while unlink $file; } diff --git a/lib/Tie/File/14_lock.t b/lib/Tie/File/t/14_lock.t similarity index 86% rename from lib/Tie/File/14_lock.t rename to lib/Tie/File/t/14_lock.t index a771d8d..cab4812 100644 --- a/lib/Tie/File/14_lock.t +++ b/lib/Tie/File/t/14_lock.t @@ -8,6 +8,14 @@ # portable test for flocking. I checked the Perl core distribution, # and found that Perl doesn't test flock either! +BEGIN { + eval { flock STDOUT, 0 }; + if ($@ && $@ =~ /unimplemented/) { + print "1..0\n"; + exit; + } +} + use Fcntl ':flock'; # This works at least back to 5.004_04 my $file = "tf$$.txt"; @@ -35,6 +43,8 @@ $N++; END { + undef $o; + untie @a; 1 while unlink $file; } diff --git a/lib/Tie/File/15_pushpop.t b/lib/Tie/File/t/15_pushpop.t similarity index 89% rename from lib/Tie/File/15_pushpop.t rename to lib/Tie/File/t/15_pushpop.t index 76fe4c1..79af19a 100644 --- a/lib/Tie/File/15_pushpop.t +++ b/lib/Tie/File/t/15_pushpop.t @@ -1,6 +1,6 @@ #!/usr/bin/perl # -# Check PUSH, POP, SHIF, and UNSHIFT +# Check PUSH, POP, SHIFT, and UNSHIFT # # Each call to 'check_contents' actually performs two tests. # First, it calls the tied object's own 'check_integrity' method, @@ -9,7 +9,8 @@ # Then, it checks the actual contents of the file against the expected # contents. -use lib '/home/mjd/src/perl/Tie-File2/lib'; +use POSIX 'SEEK_SET'; + my $file = "tf$$.txt"; 1 while unlink $file; my $data = "rec0$/rec1$/rec2$/"; @@ -99,29 +100,29 @@ print ! defined $n ? "ok $N\n" : "not ok $N # last rec should be undef, is $n\n" $N++; -sub init_file { - my $data = shift; - open F, "> $file" or die $!; - binmode F; - print F $data; - close F; -} - sub check_contents { my $x = shift; - local *FH; my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); print $integrity ? "ok $N\n" : "not ok $N\n"; $N++; - my $open = open FH, "< $file"; - binmode FH; + + local *FH = $o->{fh}; + seek FH, 0, SEEK_SET; my $a; { local $/; $a = } - print (($open && $a eq $x) ? "ok $N\n" : "not ok $N\n"); + $a = "" unless defined $a; + if ($a eq $x) { + print "ok $N\n"; + } else { + s{$/}{\\n}g for $a, $x; + print "not ok $N\n# expected <$x>, got <$a>\n"; + } $N++; } END { + undef $o; + untie @a; 1 while unlink $file; }