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
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.
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 {
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) {
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";
=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 ...;
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];
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
=head1 LICENSE
-C<Tie::File> version 0.14 is copyright (C) 2002 Mark Jason Dominus.
+C<Tie::File> 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<COPYING>. 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<COPYING>.
+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:
=head1 WARRANTY
-C<Tie::File> version 0.14 comes with ABSOLUTELY NO WARRANTY.
+C<Tie::File> 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.
# 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 = <FH> }
- 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;
}
$N++;
END {
+ undef $o;
+ untie @a;
1 while unlink $file;
}
}
END {
+ undef $o;
+ untie @a;
1 while unlink $file;
}
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;
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
}
$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 {
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 = <FH> }
- 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;
}
# PUSH POP SHIFT UNSHIFT
#
+use POSIX 'SEEK_SET';
+
my $file = "tf$$.txt";
my $data = "rec0$/rec1$/rec2$/";
my ($o, $n);
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 = <FH> }
- 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;
}
#!/usr/bin/perl
+use POSIX 'SEEK_SET';
my $file = "tf$$.txt";
print "1..5\n";
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 = <FH> }
- 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;
}
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++;
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
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;
}
END {
+ undef $o;
+ untie @a;
1 while unlink $file;
}
END {
+ undef $o;
+ untie @a;
1 while unlink $file;
}
# 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 = <FH> }
- 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;
}
# 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++;
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
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 $!;
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 = <FH> }
- 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;
}
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++;
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
@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 $!;
}
END {
+ undef $o;
+ untie @a;
1 while unlink $file;
}
}
END {
+ undef $o;
+ untie @a;
1 while unlink $file;
}
# PUSH POP SHIFT UNSHIFT
#
+use POSIX 'SEEK_SET';
+
my $file = "tf$$.txt";
my $data = "rec0blahrec1blahrec2blah";
my ($o, $n);
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 = <FH> }
- 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;
}
# 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";
END {
+ undef $o;
+ untie @a;
1 while unlink $file;
}
#!/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,
# 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$/";
$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 = <FH> }
- 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;
}
projects / p5sagit/p5-mst-13.2.git / commitdiff