Change 14970 by jhi@alpha on 2002/03/04 01:05:17
Upgrade to Tie::File 0.15.
Affected files ...
.... //depot/perl/MANIFEST#751 edit
.... //depot/perl/lib/Tie/File.pm#4 edit
.... //depot/perl/lib/Tie/File/01_gen.t#4 delete
.... //depot/perl/lib/Tie/File/02_fetchsize.t#3 delete
.... //depot/perl/lib/Tie/File/03_longfetch.t#3 delete
.... //depot/perl/lib/Tie/File/04_splice.t#4 delete
.... //depot/perl/lib/Tie/File/05_size.t#3 delete
.... //depot/perl/lib/Tie/File/06_fixrec.t#3 delete
.... //depot/perl/lib/Tie/File/07_rv_splice.t#4 delete
.... //depot/perl/lib/Tie/File/08_ro.t#3 delete
.... //depot/perl/lib/Tie/File/09_gen_rs.t#3 delete
.... //depot/perl/lib/Tie/File/10_splice_rs.t#3 delete
.... //depot/perl/lib/Tie/File/11_rv_splice_rs.t#3 delete
.... //depot/perl/lib/Tie/File/12_longfetch_rs.t#3 delete
.... //depot/perl/lib/Tie/File/13_size_rs.t#3 delete
.... //depot/perl/lib/Tie/File/14_lock.t#2 delete
.... //depot/perl/lib/Tie/File/15_pushpop.t#2 delete
.... //depot/perl/lib/Tie/File/t/01_gen.t#1 add
.... //depot/perl/lib/Tie/File/t/02_fetchsize.t#1 add
.... //depot/perl/lib/Tie/File/t/03_longfetch.t#1 add
.... //depot/perl/lib/Tie/File/t/04_splice.t#1 add
.... //depot/perl/lib/Tie/File/t/05_size.t#1 add
.... //depot/perl/lib/Tie/File/t/06_fixrec.t#1 add
.... //depot/perl/lib/Tie/File/t/07_rv_splice.t#1 add
.... //depot/perl/lib/Tie/File/t/08_ro.t#1 add
.... //depot/perl/lib/Tie/File/t/09_gen_rs.t#1 add
.... //depot/perl/lib/Tie/File/t/10_splice_rs.t#1 add
.... //depot/perl/lib/Tie/File/t/11_rv_splice_rs.t#1 add
.... //depot/perl/lib/Tie/File/t/12_longfetch_rs.t#1 add
.... //depot/perl/lib/Tie/File/t/13_size_rs.t#1 add
.... //depot/perl/lib/Tie/File/t/14_lock.t#1 add
.... //depot/perl/lib/Tie/File/t/15_pushpop.t#1 add
Differences ...
==== //depot/perl/MANIFEST#751 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST.~1~ Sun Mar 3 18:15:05 2002
+++ perl/MANIFEST Sun Mar 3 18:15:05 2002
@@ -1418,21 +1418,21 @@
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
==== //depot/perl/lib/Tie/File.pm#4 (text) ====
Index: perl/lib/Tie/File.pm
--- perl/lib/Tie/File.pm.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File.pm Sun Mar 3 18:15:05 2002
@@ -5,7 +5,7 @@
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 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 @@
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 _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 @@
=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 @@
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 @@
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 @@
=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:
@@ -854,11 +866,13 @@
=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.
==== //depot/perl/lib/Tie/File/t/01_gen.t#1 (text) ====
Index: perl/lib/Tie/File/t/01_gen.t
--- perl/lib/Tie/File/t/01_gen.t.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File/t/01_gen.t Sun Mar 3 18:15:05 2002
@@ -0,0 +1,103 @@
+#!/usr/bin/perl
+
+my $file = "tf$$.txt";
+
+print "1..38\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++;
+
+my $o = tie @a, 'Tie::File', $file;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+# 3-4 create
+$a[0] = 'rec0';
+check_contents("rec0");
+
+# 5-8 append
+$a[1] = 'rec1';
+check_contents("rec0", "rec1");
+$a[2] = 'rec2';
+check_contents("rec0", "rec1", "rec2");
+
+# 9-14 same-length alterations
+$a[0] = 'new0';
+check_contents("new0", "rec1", "rec2");
+$a[1] = 'new1';
+check_contents("new0", "new1", "rec2");
+$a[2] = 'new2';
+check_contents("new0", "new1", "new2");
+
+# 15-24 lengthening alterations
+$a[0] = 'long0';
+check_contents("long0", "new1", "new2");
+$a[1] = 'long1';
+check_contents("long0", "long1", "new2");
+$a[2] = 'long2';
+check_contents("long0", "long1", "long2");
+$a[1] = 'longer1';
+check_contents("long0", "longer1", "long2");
+$a[0] = 'longer0';
+check_contents("longer0", "longer1", "long2");
+
+# 25-34 shortening alterations, including truncation
+$a[0] = 'short0';
+check_contents("short0", "longer1", "long2");
+$a[1] = 'short1';
+check_contents("short0", "short1", "long2");
+$a[2] = 'short2';
+check_contents("short0", "short1", "short2");
+$a[1] = 'sh1';
+check_contents("short0", "sh1", "short2");
+$a[0] = 'sh0';
+check_contents("sh0", "sh1", "short2");
+
+# file with holes
+$a[4] = 'rec4';
+check_contents("sh0", "sh1", "short2", "", "rec4");
+$a[3] = 'rec3';
+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 = $o->{fh};
+ seek FH, 0, SEEK_SET;
+# my $open = open FH, "< $file";
+ my $a;
+ { local $/; $a = <FH> }
+ $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) {
+ unless ($a[$_] eq "$c[$_]$/") {
+ $msg = "expected $c[$_]$/, got $a[$_]";
+ $msg =~ s{$/}{\\n}g;
+ $good = 0;
+ }
+ }
+ print $good ? "ok $N\n" : "not ok $N # $msg\n";
+ $N++;
+}
+
+END {
+ undef $o;
+ untie @a;
+ 1 while unlink $file;
+}
+
==== //depot/perl/lib/Tie/File/t/02_fetchsize.t#1 (text) ====
Index: perl/lib/Tie/File/t/02_fetchsize.t
--- perl/lib/Tie/File/t/02_fetchsize.t.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File/t/02_fetchsize.t Sun Mar 3 18:15:05 2002
@@ -0,0 +1,50 @@
+#!/usr/bin/perl
+
+my $file = "tf$$.txt";
+my $data = "rec1$/rec2$/rec3$/";
+
+print "1..6\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++;
+
+open F, "> $file" or die $!;
+binmode F;
+print F $data;
+close F;
+
+
+my $o = tie @a, 'Tie::File', $file;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+my $n;
+
+# 3 test array element count
+$n = @a;
+print $n == 3 ? "ok $N\n" : "not ok $N # n=$n\n";
+$N++;
+
+# 4 same thing again
+$n = @a;
+print $n == 3 ? "ok $N\n" : "not ok $N # n=$n\n";
+$N++;
+
+# 5 test $#a notation
+$n = $#a;
+print $n == 2 ? "ok $N\n" : "not ok $N # n=$n\n";
+$N++;
+
+# 6 test looping over array elements
+my $q;
+for (@a) { $q .= $_ }
+print $q eq $data ? "ok $N\n" : "not ok $N # n=$n\n";
+$N++;
+
+END {
+ undef $o;
+ untie @a;
+ 1 while unlink $file;
+}
+
==== //depot/perl/lib/Tie/File/t/03_longfetch.t#1 (text) ====
Index: perl/lib/Tie/File/t/03_longfetch.t
--- perl/lib/Tie/File/t/03_longfetch.t.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File/t/03_longfetch.t Sun Mar 3 18:15:05 2002
@@ -0,0 +1,41 @@
+#!/usr/bin/perl
+#
+# Make sure we can fetch a record in the middle of the file
+# before we've ever looked at any records before it
+#
+# (tests _fill_offsets_to() )
+#
+
+my $file = "tf$$.txt";
+my $data = "rec0$/rec1$/rec2$/";
+
+print "1..5\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++;
+
+open F, "> $file" or die $!;
+binmode F;
+print F $data;
+close F;
+
+
+my $o = tie @a, 'Tie::File', $file;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+my $n;
+
+# 3-5
+for (2, 1, 0) {
+ print $a[$_] eq "rec$_$/" ? "ok $N\n" : "not ok $N # rec=$a[$_] ?\n";
+ $N++;
+}
+
+END {
+ undef $o;
+ untie @a;
+ 1 while unlink $file;
+}
+
==== //depot/perl/lib/Tie/File/t/04_splice.t#1 (text) ====
Index: perl/lib/Tie/File/t/04_splice.t
--- perl/lib/Tie/File/t/04_splice.t.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File/t/04_splice.t Sun Mar 3 18:15:05 2002
@@ -0,0 +1,206 @@
+#!/usr/bin/perl
+#
+# Check SPLICE function's effect on the file
+# (07_rv_splice.t checks its return value)
+#
+# Each call to 'check_contents' actually performs two tests.
+# First, it calls the tied object's own 'check_integrity' method,
+# which makes sure that the contents of the read cache and offset tables
+# accurately reflect the contents of the file.
+# Then, it checks the actual contents of the file against the expected
+# contents.
+
+my $file = "tf$$.txt";
+my $data = "rec0$/rec1$/rec2$/";
+
+print "1..101\n";
+
+init_file($data);
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++; # partial credit just for showing up
+
+my $o = tie @a, 'Tie::File', $file;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+my $n;
+
+# (3-22) splicing at the beginning
+splice(@a, 0, 0, "rec4");
+check_contents("rec4$/$data");
+splice(@a, 0, 1, "rec5"); # same length
+check_contents("rec5$/$data");
+splice(@a, 0, 1, "record5"); # longer
+check_contents("record5$/$data");
+
+splice(@a, 0, 1, "r5"); # shorter
+check_contents("r5$/$data");
+splice(@a, 0, 1); # removal
+check_contents("$data");
+splice(@a, 0, 0); # no-op
+check_contents("$data");
+splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one
+check_contents("r7$/rec8$/$data");
+splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_contents("rec7$/record8$/rec9$/$data");
+
+splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert
+check_contents("record9$/rec10$/$data");
+splice(@a, 0, 2); # delete more than one
+check_contents("$data");
+
+
+# (23-42) splicing in the middle
+splice(@a, 1, 0, "rec4");
+check_contents("rec0$/rec4$/rec1$/rec2$/");
+splice(@a, 1, 1, "rec5"); # same length
+check_contents("rec0$/rec5$/rec1$/rec2$/");
+splice(@a, 1, 1, "record5"); # longer
+check_contents("rec0$/record5$/rec1$/rec2$/");
+
+splice(@a, 1, 1, "r5"); # shorter
+check_contents("rec0$/r5$/rec1$/rec2$/");
+splice(@a, 1, 1); # removal
+check_contents("$data");
+splice(@a, 1, 0); # no-op
+check_contents("$data");
+splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one
+check_contents("rec0$/r7$/rec8$/rec1$/rec2$/");
+splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_contents("rec0$/rec7$/record8$/rec9$/rec1$/rec2$/");
+
+splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert
+check_contents("rec0$/record9$/rec10$/rec1$/rec2$/");
+splice(@a, 1, 2); # delete more than one
+check_contents("$data");
+
+# (43-62) splicing at the end
+splice(@a, 3, 0, "rec4");
+check_contents("$ {data}rec4$/");
+splice(@a, 3, 1, "rec5"); # same length
+check_contents("$ {data}rec5$/");
+splice(@a, 3, 1, "record5"); # longer
+check_contents("$ {data}record5$/");
+
+splice(@a, 3, 1, "r5"); # shorter
+check_contents("$ {data}r5$/");
+splice(@a, 3, 1); # removal
+check_contents("$data");
+splice(@a, 3, 0); # no-op
+check_contents("$data");
+splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one
+check_contents("$ {data}r7$/rec8$/");
+splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_contents("$ {data}rec7$/record8$/rec9$/");
+
+splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert
+check_contents("$ {data}record9$/rec10$/");
+splice(@a, 3, 2); # delete more than one
+check_contents("$data");
+
+# (63-82) splicing with negative subscript
+splice(@a, -1, 0, "rec4");
+check_contents("rec0$/rec1$/rec4$/rec2$/");
+splice(@a, -1, 1, "rec5"); # same length
+check_contents("rec0$/rec1$/rec4$/rec5$/");
+splice(@a, -1, 1, "record5"); # longer
+check_contents("rec0$/rec1$/rec4$/record5$/");
+
+splice(@a, -1, 1, "r5"); # shorter
+check_contents("rec0$/rec1$/rec4$/r5$/");
+splice(@a, -1, 1); # removal
+check_contents("rec0$/rec1$/rec4$/");
+splice(@a, -1, 0); # no-op
+check_contents("rec0$/rec1$/rec4$/");
+splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one
+check_contents("rec0$/rec1$/r7$/rec8$/rec4$/");
+splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_contents("rec0$/rec1$/r7$/rec8$/rec7$/record8$/rec9$/");
+
+splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert
+check_contents("rec0$/rec1$/r7$/rec8$/record9$/rec10$/");
+splice(@a, -4, 3); # delete more than one
+check_contents("rec0$/rec1$/rec10$/");
+
+# (83-84) scrub it all out
+splice(@a, 0, 3);
+check_contents("");
+
+# (85-86) put some back in
+splice(@a, 0, 0, "rec0", "rec1");
+check_contents("rec0$/rec1$/");
+
+# (87-88) what if we remove too many records?
+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("I$/like$/pie$/");
+splice(@a, 89, 0, "pie pie pie");
+check_contents("I$/like$/pie$/pie pie pie$/");
+
+# (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("0$/1$/2$/3$/");
+splice @a;
+check_contents("");
+
+
+sub init_file {
+ my $data = shift;
+ open F, "> $file" or die $!;
+ binmode F;
+ print F $data;
+ close F;
+}
+
+use POSIX 'SEEK_SET';
+sub check_contents {
+ my $x = shift;
+ 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 $a;
+ { local $/; $a = <FH> }
+ $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;
+}
+
==== //depot/perl/lib/Tie/File/t/05_size.t#1 (text) ====
Index: perl/lib/Tie/File/t/05_size.t
--- perl/lib/Tie/File/t/05_size.t.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File/t/05_size.t Sun Mar 3 18:15:05 2002
@@ -0,0 +1,90 @@
+#!/usr/bin/perl
+#
+# Check FETCHSIZE and SETSIZE functions
+# PUSH POP SHIFT UNSHIFT
+#
+
+use POSIX 'SEEK_SET';
+
+my $file = "tf$$.txt";
+my $data = "rec0$/rec1$/rec2$/";
+my ($o, $n);
+
+print "1..10\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++;
+
+# 2-3 FETCHSIZE 0-length file
+open F, "> $file" or die $!;
+binmode F;
+close F;
+$o = tie @a, 'Tie::File', $file;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+$n = @a;
+print $n == 0 ? "ok $N\n" : "not ok $N # $n, s/b 0\n";
+$N++;
+
+# Reset everything
+undef $o;
+untie @a;
+
+# 4-5 FETCHSIZE positive-length file
+open F, "> $file" or die $!;
+binmode F;
+print F $data;
+close F;
+$o = tie @a, 'Tie::File', $file;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+$n = @a;
+print $n == 3 ? "ok $N\n" : "not ok $N # $n, s/b 0\n";
+$N++;
+
+# STORESIZE
+# 6 Make it longer:
+$#a = 4;
+check_contents("$data$/$/");
+
+# 7 Make it longer again:
+$#a = 6;
+check_contents("$data$/$/$/$/");
+
+# 8 Make it shorter:
+$#a = 4;
+check_contents("$data$/$/");
+
+# 9 Make it shorter again:
+$#a = 2;
+check_contents($data);
+
+# 10 Get rid of it completely:
+$#a = -1;
+check_contents('');
+
+
+sub check_contents {
+ my $x = shift;
+ local *FH = $o->{fh};
+ seek FH, 0, SEEK_SET;
+ my $a;
+ { local $/; $a = <FH> }
+ $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;
+}
+
==== //depot/perl/lib/Tie/File/t/06_fixrec.t#1 (text) ====
Index: perl/lib/Tie/File/t/06_fixrec.t
--- perl/lib/Tie/File/t/06_fixrec.t.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File/t/06_fixrec.t Sun Mar 3 18:15:05 2002
@@ -0,0 +1,45 @@
+#!/usr/bin/perl
+
+use POSIX 'SEEK_SET';
+my $file = "tf$$.txt";
+
+print "1..5\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++;
+
+my $o = tie @a, 'Tie::File', $file;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+$a[0] = 'rec0';
+check_contents("rec0$/");
+$a[1] = "rec1$/";
+check_contents("rec0$/rec1$/");
+$a[2] = "rec2$/$/"; # should we detect this?
+check_contents("rec0$/rec1$/rec2$/$/");
+
+sub check_contents {
+ my $x = shift;
+ local *FH = $o->{fh};
+ seek FH, 0, SEEK_SET;
+ my $a;
+ { local $/; $a = <FH> }
+ $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;
+}
+
==== //depot/perl/lib/Tie/File/t/07_rv_splice.t#1 (text) ====
Index: perl/lib/Tie/File/t/07_rv_splice.t
--- perl/lib/Tie/File/t/07_rv_splice.t.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File/t/07_rv_splice.t Sun Mar 3 18:15:05 2002
@@ -0,0 +1,182 @@
+#!/usr/bin/perl
+#
+# Check SPLICE function's return value
+# (04_splice.t checks its effect on the file)
+#
+
+my $file = "tf$$.txt";
+my $data = "rec0$/rec1$/rec2$/";
+
+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
+@r = splice(@a, 0, 0, "rec4");
+check_result();
+@r = splice(@a, 0, 1, "rec5"); # same length
+check_result("rec4");
+@r = splice(@a, 0, 1, "record5"); # longer
+check_result("rec5");
+
+@r = splice(@a, 0, 1, "r5"); # shorter
+check_result("record5");
+@r = splice(@a, 0, 1); # removal
+check_result("r5");
+@r = splice(@a, 0, 0); # no-op
+check_result();
+@r = splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one
+check_result();
+@r = splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_result('r7', 'rec8');
+
+@r = splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert
+check_result('rec7', 'record8', 'rec9');
+@r = splice(@a, 0, 2); # delete more than one
+check_result('record9', 'rec10');
+
+
+# (13-22) splicing in the middle
+@r = splice(@a, 1, 0, "rec4");
+check_result();
+@r = splice(@a, 1, 1, "rec5"); # same length
+check_result('rec4');
+@r = splice(@a, 1, 1, "record5"); # longer
+check_result('rec5');
+
+@r = splice(@a, 1, 1, "r5"); # shorter
+check_result("record5");
+@r = splice(@a, 1, 1); # removal
+check_result("r5");
+@r = splice(@a, 1, 0); # no-op
+check_result();
+@r = splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one
+check_result();
+@r = splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_result('r7', 'rec8');
+
+@r = splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert
+check_result('rec7', 'record8', 'rec9');
+@r = splice(@a, 1, 2); # delete more than one
+check_result('record9','rec10');
+
+# (23-32) splicing at the end
+@r = splice(@a, 3, 0, "rec4");
+check_result();
+@r = splice(@a, 3, 1, "rec5"); # same length
+check_result('rec4');
+@r = splice(@a, 3, 1, "record5"); # longer
+check_result('rec5');
+
+@r = splice(@a, 3, 1, "r5"); # shorter
+check_result('record5');
+@r = splice(@a, 3, 1); # removal
+check_result('r5');
+@r = splice(@a, 3, 0); # no-op
+check_result();
+@r = splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one
+check_result();
+@r = splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_result('r7', 'rec8');
+
+@r = splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert
+check_result('rec7', 'record8', 'rec9');
+@r = splice(@a, 3, 2); # delete more than one
+check_result('record9', 'rec10');
+
+# (33-42) splicing with negative subscript
+@r = splice(@a, -1, 0, "rec4");
+check_result();
+@r = splice(@a, -1, 1, "rec5"); # same length
+check_result('rec2');
+@r = splice(@a, -1, 1, "record5"); # longer
+check_result("rec5");
+
+@r = splice(@a, -1, 1, "r5"); # shorter
+check_result("record5");
+@r = splice(@a, -1, 1); # removal
+check_result("r5");
+@r = splice(@a, -1, 0); # no-op
+check_result();
+@r = splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one
+check_result();
+@r = splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_result('rec4');
+
+@r = splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert
+check_result('rec7', 'record8', 'rec9');
+@r = splice(@a, -4, 3); # delete more than one
+check_result('r7', 'rec8', 'record9');
+
+# (43) scrub it all out
+@r = splice(@a, 0, 3);
+check_result('rec0', 'rec1', 'rec10');
+
+# (44) put some back in
+@r = splice(@a, 0, 0, "rec0", "rec1");
+check_result();
+
+# (45) what if we remove too many records?
+@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 "pie$/" ? "ok $N\n" : "not ok $N \# return should have been 'pie'\n";
+$N++;
+
+$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;
+ open F, "> $file" or die $!;
+ binmode F;
+ print F $data;
+ close F;
+}
+
+# actual results are in @r.
+# expected results are in @_
+sub check_result {
+ my @x = @_;
+ chomp @r;
+ my $good = 1;
+ $good = 0 unless @r == @x;
+ for my $i (0 .. $#r) {
+ $good = 0 unless $r[$i] eq $x[$i];
+ }
+ print $good ? "ok $N\n" : "not ok $N \# was (@r); should be (@x)\n";
+ $N++;
+}
+
+END {
+ undef $o;
+ untie @a;
+ 1 while unlink $file;
+}
+
==== //depot/perl/lib/Tie/File/t/08_ro.t#1 (text) ====
Index: perl/lib/Tie/File/t/08_ro.t
--- perl/lib/Tie/File/t/08_ro.t.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File/t/08_ro.t Sun Mar 3 18:15:05 2002
@@ -0,0 +1,44 @@
+#!/usr/bin/perl
+#
+# Make sure it works to open the file in read-only mode
+#
+
+my $file = "tf$$.txt";
+
+print "1..9\n";
+
+my $N = 1;
+use Tie::File;
+use Fcntl 'O_RDONLY';
+print "ok $N\n"; $N++;
+
+my @items = qw(Gold Frankincense Myrrh Ivory Apes Peacocks);
+init_file(join $/, @items, '');
+
+my $o = tie @a, 'Tie::File', $file, mode => O_RDONLY;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+$#a == $#items ? print "ok $N\n" : print "not ok $N\n";
+$N++;
+
+for my $i (0..$#items) {
+ ("$items[$i]$/" eq $a[$i]) ? print "ok $N\n" : print "not ok $N\n";
+ $N++;
+}
+
+sub init_file {
+ my $data = shift;
+ open F, "> $file" or die $!;
+ binmode F;
+ print F $data;
+ close F;
+}
+
+
+END {
+ undef $o;
+ untie @a;
+ 1 while unlink $file;
+}
+
==== //depot/perl/lib/Tie/File/t/09_gen_rs.t#1 (text) ====
Index: perl/lib/Tie/File/t/09_gen_rs.t
--- perl/lib/Tie/File/t/09_gen_rs.t.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File/t/09_gen_rs.t Sun Mar 3 18:15:05 2002
@@ -0,0 +1,103 @@
+#!/usr/bin/perl
+
+my $file = "tf$$.txt";
+
+print "1..38\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++;
+
+my $o = tie @a, 'Tie::File', $file, recsep => 'blah';
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+
+# 3-4 create
+$a[0] = 'rec0';
+check_contents("rec0");
+
+# 5-8 append
+$a[1] = 'rec1';
+check_contents("rec0", "rec1");
+$a[2] = 'rec2';
+check_contents("rec0", "rec1", "rec2");
+
+# 9-14 same-length alterations
+$a[0] = 'new0';
+check_contents("new0", "rec1", "rec2");
+$a[1] = 'new1';
+check_contents("new0", "new1", "rec2");
+$a[2] = 'new2';
+check_contents("new0", "new1", "new2");
+
+# 15-24 lengthening alterations
+$a[0] = 'long0';
+check_contents("long0", "new1", "new2");
+$a[1] = 'long1';
+check_contents("long0", "long1", "new2");
+$a[2] = 'long2';
+check_contents("long0", "long1", "long2");
+$a[1] = 'longer1';
+check_contents("long0", "longer1", "long2");
+$a[0] = 'longer0';
+check_contents("longer0", "longer1", "long2");
+
+# 25-34 shortening alterations, including truncation
+$a[0] = 'short0';
+check_contents("short0", "longer1", "long2");
+$a[1] = 'short1';
+check_contents("short0", "short1", "long2");
+$a[2] = 'short2';
+check_contents("short0", "short1", "short2");
+$a[1] = 'sh1';
+check_contents("short0", "sh1", "short2");
+$a[0] = 'sh0';
+check_contents("sh0", "sh1", "short2");
+
+# file with holes
+$a[4] = 'rec4';
+check_contents("sh0", "sh1", "short2", "", "rec4");
+$a[3] = 'rec3';
+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 = $o->{fh};
+ seek FH, 0, SEEK_SET;
+ my $a;
+ { local $/; $a = <FH> }
+
+ $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) {
+ unless ($a[$_] eq "$c[$_]blah") {
+ $msg = "expected $c[$_]blah, got $a[$_]";
+ $msg =~ s{$/}{\\n}g;
+ $good = 0;
+ }
+ }
+ print $good ? "ok $N\n" : "not ok $N # fetch @c\n";
+ $N++;
+}
+
+END {
+ undef $o;
+ untie @a;
+ 1 while unlink $file;
+}
+
==== //depot/perl/lib/Tie/File/t/10_splice_rs.t#1 (text) ====
Index: perl/lib/Tie/File/t/10_splice_rs.t
--- perl/lib/Tie/File/t/10_splice_rs.t.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File/t/10_splice_rs.t Sun Mar 3 18:15:05 2002
@@ -0,0 +1,207 @@
+#!/usr/bin/perl
+#
+# Check SPLICE function's effect on the file
+# (07_rv_splice.t checks its return value)
+#
+# Each call to 'check_contents' actually performs two tests.
+# First, it calls the tied object's own 'check_integrity' method,
+# which makes sure that the contents of the read cache and offset tables
+# accurately reflect the contents of the 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..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
+splice(@a, 0, 0, "rec4");
+check_contents("rec4blah$data");
+splice(@a, 0, 1, "rec5"); # same length
+check_contents("rec5blah$data");
+splice(@a, 0, 1, "record5"); # longer
+check_contents("record5blah$data");
+
+splice(@a, 0, 1, "r5"); # shorter
+check_contents("r5blah$data");
+splice(@a, 0, 1); # removal
+check_contents("$data");
+splice(@a, 0, 0); # no-op
+check_contents("$data");
+splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one
+check_contents("r7blahrec8blah$data");
+splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_contents("rec7blahrecord8blahrec9blah$data");
+
+splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert
+check_contents("record9blahrec10blah$data");
+splice(@a, 0, 2); # delete more than one
+check_contents("$data");
+
+
+# (23-42) splicing in the middle
+splice(@a, 1, 0, "rec4");
+check_contents("rec0blahrec4blahrec1blahrec2blah");
+splice(@a, 1, 1, "rec5"); # same length
+check_contents("rec0blahrec5blahrec1blahrec2blah");
+splice(@a, 1, 1, "record5"); # longer
+check_contents("rec0blahrecord5blahrec1blahrec2blah");
+
+splice(@a, 1, 1, "r5"); # shorter
+check_contents("rec0blahr5blahrec1blahrec2blah");
+splice(@a, 1, 1); # removal
+check_contents("$data");
+splice(@a, 1, 0); # no-op
+check_contents("$data");
+splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one
+check_contents("rec0blahr7blahrec8blahrec1blahrec2blah");
+splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_contents("rec0blahrec7blahrecord8blahrec9blahrec1blahrec2blah");
+
+splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert
+check_contents("rec0blahrecord9blahrec10blahrec1blahrec2blah");
+splice(@a, 1, 2); # delete more than one
+check_contents("$data");
+
+# (43-62) splicing at the end
+splice(@a, 3, 0, "rec4");
+check_contents("$ {data}rec4blah");
+splice(@a, 3, 1, "rec5"); # same length
+check_contents("$ {data}rec5blah");
+splice(@a, 3, 1, "record5"); # longer
+check_contents("$ {data}record5blah");
+
+splice(@a, 3, 1, "r5"); # shorter
+check_contents("$ {data}r5blah");
+splice(@a, 3, 1); # removal
+check_contents("$data");
+splice(@a, 3, 0); # no-op
+check_contents("$data");
+splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one
+check_contents("$ {data}r7blahrec8blah");
+splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_contents("$ {data}rec7blahrecord8blahrec9blah");
+
+splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert
+check_contents("$ {data}record9blahrec10blah");
+splice(@a, 3, 2); # delete more than one
+check_contents("$data");
+
+# (63-82) splicing with negative subscript
+splice(@a, -1, 0, "rec4");
+check_contents("rec0blahrec1blahrec4blahrec2blah");
+splice(@a, -1, 1, "rec5"); # same length
+check_contents("rec0blahrec1blahrec4blahrec5blah");
+splice(@a, -1, 1, "record5"); # longer
+check_contents("rec0blahrec1blahrec4blahrecord5blah");
+
+splice(@a, -1, 1, "r5"); # shorter
+check_contents("rec0blahrec1blahrec4blahr5blah");
+splice(@a, -1, 1); # removal
+check_contents("rec0blahrec1blahrec4blah");
+splice(@a, -1, 0); # no-op
+check_contents("rec0blahrec1blahrec4blah");
+splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one
+check_contents("rec0blahrec1blahr7blahrec8blahrec4blah");
+splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_contents("rec0blahrec1blahr7blahrec8blahrec7blahrecord8blahrec9blah");
+
+splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert
+check_contents("rec0blahrec1blahr7blahrec8blahrecord9blahrec10blah");
+splice(@a, -4, 3); # delete more than one
+check_contents("rec0blahrec1blahrec10blah");
+
+# (83-84) scrub it all out
+splice(@a, 0, 3);
+check_contents("");
+
+# (85-86) put some back in
+splice(@a, 0, 0, "rec0", "rec1");
+check_contents("rec0blahrec1blah");
+
+# (87-88) what if we remove too many records?
+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 $!;
+ binmode F;
+ print F $data;
+ close F;
+}
+
+sub check_contents {
+ my $x = shift;
+ my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
+ print $integrity ? "ok $N\n" : "not ok $N\n";
+ $N++;
+ local *FH = $o->{fh};
+ seek FH, 0, SEEK_SET;
+ my $a;
+ { local $/; $a = <FH> }
+ $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;
+}
+
==== //depot/perl/lib/Tie/File/t/11_rv_splice_rs.t#1 (text) ====
Index: perl/lib/Tie/File/t/11_rv_splice_rs.t
--- perl/lib/Tie/File/t/11_rv_splice_rs.t.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File/t/11_rv_splice_rs.t Sun Mar 3 18:15:05 2002
@@ -0,0 +1,182 @@
+#!/usr/bin/perl
+#
+# Check SPLICE function's return value
+# (04_splice.t checks its effect on the file)
+#
+
+my $file = "tf$$.txt";
+my $data = "rec0blahrec1blahrec2blah";
+
+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
+@r = splice(@a, 0, 0, "rec4");
+check_result();
+@r = splice(@a, 0, 1, "rec5"); # same length
+check_result("rec4");
+@r = splice(@a, 0, 1, "record5"); # longer
+check_result("rec5");
+
+@r = splice(@a, 0, 1, "r5"); # shorter
+check_result("record5");
+@r = splice(@a, 0, 1); # removal
+check_result("r5");
+@r = splice(@a, 0, 0); # no-op
+check_result();
+@r = splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one
+check_result();
+@r = splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_result('r7', 'rec8');
+
+@r = splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert
+check_result('rec7', 'record8', 'rec9');
+@r = splice(@a, 0, 2); # delete more than one
+check_result('record9', 'rec10');
+
+
+# (13-22) splicing in the middle
+@r = splice(@a, 1, 0, "rec4");
+check_result();
+@r = splice(@a, 1, 1, "rec5"); # same length
+check_result('rec4');
+@r = splice(@a, 1, 1, "record5"); # longer
+check_result('rec5');
+
+@r = splice(@a, 1, 1, "r5"); # shorter
+check_result("record5");
+@r = splice(@a, 1, 1); # removal
+check_result("r5");
+@r = splice(@a, 1, 0); # no-op
+check_result();
+@r = splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one
+check_result();
+@r = splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_result('r7', 'rec8');
+
+@r = splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert
+check_result('rec7', 'record8', 'rec9');
+@r = splice(@a, 1, 2); # delete more than one
+check_result('record9','rec10');
+
+# (23-32) splicing at the end
+@r = splice(@a, 3, 0, "rec4");
+check_result();
+@r = splice(@a, 3, 1, "rec5"); # same length
+check_result('rec4');
+@r = splice(@a, 3, 1, "record5"); # longer
+check_result('rec5');
+
+@r = splice(@a, 3, 1, "r5"); # shorter
+check_result('record5');
+@r = splice(@a, 3, 1); # removal
+check_result('r5');
+@r = splice(@a, 3, 0); # no-op
+check_result();
+@r = splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one
+check_result();
+@r = splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_result('r7', 'rec8');
+
+@r = splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert
+check_result('rec7', 'record8', 'rec9');
+@r = splice(@a, 3, 2); # delete more than one
+check_result('record9', 'rec10');
+
+# (33-42) splicing with negative subscript
+@r = splice(@a, -1, 0, "rec4");
+check_result();
+@r = splice(@a, -1, 1, "rec5"); # same length
+check_result('rec2');
+@r = splice(@a, -1, 1, "record5"); # longer
+check_result("rec5");
+
+@r = splice(@a, -1, 1, "r5"); # shorter
+check_result("record5");
+@r = splice(@a, -1, 1); # removal
+check_result("r5");
+@r = splice(@a, -1, 0); # no-op
+check_result();
+@r = splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one
+check_result();
+@r = splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_result('rec4');
+
+@r = splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert
+check_result('rec7', 'record8', 'rec9');
+@r = splice(@a, -4, 3); # delete more than one
+check_result('r7', 'rec8', 'record9');
+
+# (43) scrub it all out
+@r = splice(@a, 0, 3);
+check_result('rec0', 'rec1', 'rec10');
+
+# (44) put some back in
+@r = splice(@a, 0, 0, "rec0", "rec1");
+check_result();
+
+# (45) what if we remove too many records?
+@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 $!;
+ binmode F;
+ print F $data;
+ close F;
+}
+
+# actual results are in @r.
+# expected results are in @_
+sub check_result {
+ my @x = @_;
+ s/blah$// for @r;
+ my $good = 1;
+ $good = 0 unless @r == @x;
+ for my $i (0 .. $#r) {
+ $good = 0 unless $r[$i] eq $x[$i];
+ }
+ print $good ? "ok $N\n" : "not ok $N \# was (@r); should be (@x)\n";
+ $N++;
+}
+
+END {
+ undef $o;
+ untie @a;
+ 1 while unlink $file;
+}
+
==== //depot/perl/lib/Tie/File/t/12_longfetch_rs.t#1 (text) ====
Index: perl/lib/Tie/File/t/12_longfetch_rs.t
--- perl/lib/Tie/File/t/12_longfetch_rs.t.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File/t/12_longfetch_rs.t Sun Mar 3 18:15:05 2002
@@ -0,0 +1,41 @@
+#!/usr/bin/perl
+#
+# Make sure we can fetch a record in the middle of the file
+# before we've ever looked at any records before it
+#
+# (tests _fill_offsets_to() )
+#
+
+my $file = "tf$$.txt";
+my $data = "rec0blahrec1blahrec2blah";
+
+print "1..5\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++;
+
+open F, "> $file" or die $!;
+binmode F;
+print F $data;
+close F;
+
+
+my $o = tie @a, 'Tie::File', $file, recsep => 'blah';
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+my $n;
+
+# 3-5
+for (2, 1, 0) {
+ print $a[$_] eq "rec${_}blah" ? "ok $N\n" : "not ok $N # rec=$a[$_] ?\n";
+ $N++;
+}
+
+END {
+ undef $o;
+ untie @a;
+ 1 while unlink $file;
+}
+
==== //depot/perl/lib/Tie/File/t/13_size_rs.t#1 (text) ====
Index: perl/lib/Tie/File/t/13_size_rs.t
--- perl/lib/Tie/File/t/13_size_rs.t.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File/t/13_size_rs.t Sun Mar 3 18:15:05 2002
@@ -0,0 +1,88 @@
+#!/usr/bin/perl
+#
+# Check FETCHSIZE and SETSIZE functions
+# PUSH POP SHIFT UNSHIFT
+#
+
+use POSIX 'SEEK_SET';
+
+my $file = "tf$$.txt";
+my $data = "rec0blahrec1blahrec2blah";
+my ($o, $n);
+
+print "1..10\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++;
+
+# 2-3 FETCHSIZE 0-length file
+open F, "> $file" or die $!;
+close F;
+$o = tie @a, 'Tie::File', $file, recsep => 'blah';
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+$n = @a;
+print $n == 0 ? "ok $N\n" : "not ok $N # $n, s/b 0\n";
+$N++;
+
+# Reset everything
+undef $o;
+untie @a;
+
+# 4-5 FETCHSIZE positive-length file
+open F, "> $file" or die $!;
+print F $data;
+close F;
+$o = tie @a, 'Tie::File', $file, recsep => 'blah';
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+$n = @a;
+print $n == 3 ? "ok $N\n" : "not ok $N # $n, s/b 0\n";
+$N++;
+
+# STORESIZE
+# 6 Make it longer:
+$#a = 4;
+check_contents("${data}blahblah");
+
+# 7 Make it longer again:
+$#a = 6;
+check_contents("${data}blahblahblahblah");
+
+# 8 Make it shorter:
+$#a = 4;
+check_contents("${data}blahblah");
+
+# 9 Make it shorter again:
+$#a = 2;
+check_contents($data);
+
+# 10 Get rid of it completely:
+$#a = -1;
+check_contents('');
+
+
+sub check_contents {
+ my $x = shift;
+ local *FH = $o->{fh};
+ seek FH, 0, SEEK_SET;
+ my $a;
+ { local $/; $a = <FH> }
+ $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;
+}
+
==== //depot/perl/lib/Tie/File/t/14_lock.t#1 (text) ====
Index: perl/lib/Tie/File/t/14_lock.t
--- perl/lib/Tie/File/t/14_lock.t.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File/t/14_lock.t Sun Mar 3 18:15:05 2002
@@ -0,0 +1,50 @@
+#!/usr/bin/perl
+#
+# Check flock() feature
+#
+# This isn't a real test; it just checks to make sure we can call the method.
+# It doesn't even check to make sure that the default behavior
+# (LOCK_EX) is occurring. This is because I don't know how to write a good
+# 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";
+my ($o, $n);
+my @a;
+
+print "1..4\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++;
+
+# 2-4 Who the heck knows?
+open F, "> $file" or die $!;
+close F;
+$o = tie @a, 'Tie::File', $file, recsep => 'blah';
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+print $o->flock() ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+print $o->flock(LOCK_UN) ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+
+END {
+ undef $o;
+ untie @a;
+ 1 while unlink $file;
+}
+
==== //depot/perl/lib/Tie/File/t/15_pushpop.t#1 (text) ====
Index: perl/lib/Tie/File/t/15_pushpop.t
--- perl/lib/Tie/File/t/15_pushpop.t.~1~ Sun Mar 3 18:15:05 2002
+++ perl/lib/Tie/File/t/15_pushpop.t Sun Mar 3 18:15:05 2002
@@ -0,0 +1,128 @@
+#!/usr/bin/perl
+#
+# 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,
+# which makes sure that the contents of the read cache and offset tables
+# accurately reflect the contents of the file.
+# Then, it checks the actual contents of the file against the expected
+# contents.
+
+use POSIX 'SEEK_SET';
+
+my $file = "tf$$.txt";
+1 while unlink $file;
+my $data = "rec0$/rec1$/rec2$/";
+
+print "1..38\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++; # partial credit just for showing up
+
+my $o = tie @a, 'Tie::File', $file;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+my ($n, @r);
+
+
+
+# (3-11) PUSH tests
+$n = push @a, "rec0", "rec1", "rec2";
+check_contents($data);
+print $n == 3 ? "ok $N\n" : "not ok $N # size is $n, should be 3\n";
+$N++;
+
+$n = push @a, "rec3", "rec4\n";
+check_contents("$ {data}rec3$/rec4$/");
+print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
+$N++;
+
+# Trivial push
+$n = push @a;
+check_contents("$ {data}rec3$/rec4$/");
+print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
+$N++;
+
+# (12-20) POP tests
+$n = pop @a;
+check_contents("$ {data}rec3$/");
+print $n eq "rec4$/" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n";
+$N++;
+
+# Presumably we have already tested this to death
+splice(@a, 1, 3);
+$n = pop @a;
+check_contents("");
+print $n eq "rec0$/" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec0\n";
+$N++;
+
+$n = pop @a;
+check_contents("");
+print ! defined $n ? "ok $N\n" : "not ok $N # last rec should be undef, is $n\n";
+$N++;
+
+
+# (21-29) UNSHIFT tests
+$n = unshift @a, "rec0", "rec1", "rec2";
+check_contents($data);
+print $n == 3 ? "ok $N\n" : "not ok $N # size is $n, should be 3\n";
+$N++;
+
+$n = unshift @a, "rec3", "rec4\n";
+check_contents("rec3$/rec4$/$data");
+print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
+$N++;
+
+# Trivial unshift
+$n = unshift @a;
+check_contents("rec3$/rec4$/$data");
+print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
+$N++;
+
+# (30-38) SHIFT tests
+$n = shift @a;
+check_contents("rec4$/$data");
+print $n eq "rec3$/" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec3\n";
+$N++;
+
+# Presumably we have already tested this to death
+splice(@a, 1, 3);
+$n = shift @a;
+check_contents("");
+print $n eq "rec4$/" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n";
+$N++;
+
+$n = shift @a;
+check_contents("");
+print ! defined $n ? "ok $N\n" : "not ok $N # last rec should be undef, is $n\n";
+$N++;
+
+
+sub check_contents {
+ my $x = shift;
+ my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
+ print $integrity ? "ok $N\n" : "not ok $N\n";
+ $N++;
+
+ local *FH = $o->{fh};
+ seek FH, 0, SEEK_SET;
+ my $a;
+ { local $/; $a = <FH> }
+ $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;
+}
+
End of Patch.
