From: Abhijit Menon-Sen <ams@wiw.org>
Date: Sat, 16 Mar 2002 18:14:04 +0000 (+0000)
Subject:    Upgrade to Tie::File 0.20.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0b28bc9ad3d1c2dbf9c662b82926642b3432623d;p=p5sagit%2Fp5-mst-13.2.git

   Upgrade to Tie::File 0.20.

p4raw-id: //depot/perl@15261
---

diff --git a/MANIFEST b/MANIFEST
index aa0fce6..3416aa4 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1444,6 +1444,8 @@ lib/Tie/File/t/18_rs_fixrec.t   Test for Tie::File.
 lib/Tie/File/t/19_cache.t       Test for Tie::File.
 lib/Tie/File/t/20_cache_full.t  Test for Tie::File.
 lib/Tie/File/t/21_win32.t       Test for Tie::File.
+lib/Tie/File/t/22_autochomp.t   Test for Tie::File.
+lib/Tie/File/t/23_rv_ac_splice.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 f0a864d..5b545aa 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.19";
+$VERSION = "0.20";
 
 # Idea: The object will always contain an array of byte offsets
 # this will be filled in as is necessary and convenient.
@@ -22,7 +22,7 @@ $VERSION = "0.19";
 my $DEFAULT_MEMORY_SIZE = 1<<21;    # 2 megabytes
 
 my %good_opt = map {$_ => 1, "-$_" => 1} 
-               qw(memory dw_size mode recsep discipline);
+               qw(memory dw_size mode recsep discipline autochomp);
 
 sub TIEARRAY {
   if (@_ % 2 != 0) {
@@ -71,6 +71,8 @@ sub TIEARRAY {
     croak "Empty record separator not supported by $pack";
   }
 
+  $opts{autochomp} = 1 unless defined $opts{autochomp};
+
   my $mode = defined($opts{mode}) ? $opts{mode} : O_CREAT|O_RDWR;
   my $fh;
 
@@ -100,6 +102,32 @@ sub TIEARRAY {
 
 sub FETCH {
   my ($self, $n) = @_;
+  $self->_chomp1($self->_fetch($n));
+}
+
+# Chomp many records in-place; return nothing useful
+sub _chomp {
+  my $self = shift;
+  return unless $self->{autochomp};
+  if ($self->{autochomp}) {
+    for (@_) {
+      next unless defined;
+      substr($_, - $self->{recseplen}) = "";
+    }
+  }
+}
+
+# Chomp one record in-place; return modified record
+sub _chomp1 {
+  my ($self, $rec) = @_;
+  return $rec unless $self->{autochomp};
+  return unless defined $rec;
+  substr($rec, - $self->{recseplen}) = "";
+  $rec;
+}
+
+sub _fetch {
+  my ($self, $n) = @_;
 
   # check the record cache
   { my $cached = $self->_check_cache($n);
@@ -142,7 +170,7 @@ sub STORE {
   # We need this to decide whether the new record will fit
   # It incidentally populates the offsets table 
   # Note we have to do this before we alter the cache
-  my $oldrec = $self->FETCH($n);
+  my $oldrec = $self->_fetch($n);
 
   # _check_cache promotes record $n to MRU.  Is this correct behavior?
   if (my $cached = $self->_check_cache($n)) {
@@ -282,7 +310,12 @@ sub EXISTS {
 sub SPLICE {
   my $self = shift;
   $self->_flush if $self->{defer};
-  $self->_splice(@_);
+  if (wantarray) {
+    $self->_chomp(my @a = $self->_splice(@_));
+    @a;
+  } else {
+    $self->_chomp1(scalar $self->_splice(@_));
+  }
 }
 
 sub DESTROY {
@@ -323,7 +356,7 @@ sub _splice {
   # compute length of data being removed
   # Incidentally fills offsets table
   for ($pos .. $pos+$nrecs-1) {
-    my $rec = $self->FETCH($_);
+    my $rec = $self->_fetch($_);
     last unless defined $rec;
     push @result, $rec;
     $oldlen += length($rec);
@@ -638,6 +671,18 @@ sub defer {
   $self->{defer} = 1;
 }
 
+# Get/set autochomp option
+sub autochomp {
+  my $self = shift;
+  if (@_) {
+    my $old = $self->{autochomp};
+    $self->{autochomp} = shift;
+    $old;
+  } else {
+    $self->{autochomp};
+  }
+}
+
 # Flush deferred writes
 #
 # This could be better optimized to write the file in one pass, instead
@@ -773,7 +818,7 @@ Tie::File - Access the lines of a disk file via a Perl array
 
 =head1 SYNOPSIS
 
-	# This file documents Tie::File version 0.19
+	# This file documents Tie::File version 0.20
 
 	tie @array, 'Tie::File', filename or die ...;
 
@@ -825,21 +870,27 @@ contained the following data:
 
 then the C<@array> would appear to have four elements: 
 
-	"Curse thes"
-	"e pes"
-	"ky flies"
+	"Curse th"
+	"e p"
+	"ky fli"
 	"!\n"
 
 An undefined value is not permitted as a record separator.  Perl's
 special "paragraph mode" semantics (E<agrave> la C<$/ = "">) are not
 emulated.
 
-Records read from the tied array will have the record separator string
-on the end, just as if they were read from the C<E<lt>...E<gt>>
-operator.  Records stored into the array will have the record
-separator string appended before they are written to the file, if they
-don't have one already.  For example, if the record separator string
-is C<"\n">, then the following two lines do exactly the same thing:
+Records read from the tied array do not have the record separator
+string on the end; this is to allow 
+
+	$array[17] .= "extra";
+
+to work as expected.
+
+(See L<"autochomp">, below.)  Records stored into the array will have
+the record separator string appended before they are written to the
+file, if they don't have one already.  For example, if the record
+separator string is C<"\n">, then the following two lines do exactly
+the same thing:
 
 	$array[17] = "Cherry pie";
 	$array[17] = "Cherry pie\n";
@@ -858,6 +909,24 @@ Inserting records that I<contain> the record separator string will
 produce a reasonable result, but if you can't foresee what this result
 will be, you'd better avoid doing this.
 
+=head2 C<autochomp>
+
+Normally, array elements have the record separator removed, so that if
+the file contains the text
+
+	Gold
+	Frankincense
+	Myrrh
+
+the tied array will appear to contain C<("Gold", "Frankincense", "Myrrh")>.
+If you set C<autochomp> to a false value, the record separator will not be removed.  If the file above was tied with
+
+	tie @gifts, "Tie::File", $gifts, autochomp => 0;
+
+then the array C<@gifts> would appear to contain C<("Gold\n",
+"Frankincense\n", "Myrrh\n")>, or (on Win32 systems) C<("Gold\r\n",
+"Frankincense\r\n", "Myrrh\r\n")>.
+
 =head2 C<mode>
 
 Normally, the specified file will be opened for read and write access,
@@ -950,7 +1019,16 @@ have a green light, that does not prevent the idiot coming the other
 way from plowing into you sideways; it merely guarantees to you that
 the idiot does not also have a green light at the same time.
 
-=head2 Tying to an already-opened filehandle
+=head2 C<autochomp>
+
+	my $old_value = $o->autochomp(0);    # disable autochomp option
+	my $old_value = $o->autochomp(1);    #  enable autochomp option
+
+	my $ac = $o->autochomp();   # recover current value
+
+See L<"autochomp">, above.
+
+=head1 Tying to an already-opened filehandle
 
 If C<$fh> is a filehandle, such as is returned by C<IO::File> or one
 of the other C<IO> modules, you may use:
@@ -1139,7 +1217,7 @@ C<mjd-perl-tiefile-subscribe@plover.com>.
 
 =head1 LICENSE
 
-C<Tie::File> version 0.19 is copyright (C) 2002 Mark Jason Dominus.
+C<Tie::File> version 0.20 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.
@@ -1167,7 +1245,7 @@ For licensing inquiries, contact the author at:
 
 =head1 WARRANTY
 
-C<Tie::File> version 0.19 comes with ABSOLUTELY NO WARRANTY.
+C<Tie::File> version 0.20 comes with ABSOLUTELY NO WARRANTY.
 For details, see the license.
 
 =head1 THANKS
diff --git a/lib/Tie/File/t/00_version.t b/lib/Tie/File/t/00_version.t
index 565651a..8a154b1 100644
--- a/lib/Tie/File/t/00_version.t
+++ b/lib/Tie/File/t/00_version.t
@@ -4,12 +4,12 @@ print "1..1\n";
 
 use Tie::File;
 
-if ($Tie::File::VERSION != 0.19) {
+if ($Tie::File::VERSION != 0.20) {
   print STDERR "
 WHOA THERE!!
 
 You seem to be running version $Tie::File::VERSION of the module against
-version 0.19 of the test suite!
+version 0.20 of the test suite!
 
 None of the other test results will be reliable.
 ";
diff --git a/lib/Tie/File/t/01_gen.t b/lib/Tie/File/t/01_gen.t
index 5be638b..fd1dd2e 100644
--- a/lib/Tie/File/t/01_gen.t
+++ b/lib/Tie/File/t/01_gen.t
@@ -8,7 +8,7 @@ my $N = 1;
 use Tie::File;
 print "ok $N\n"; $N++;
 
-my $o = tie @a, 'Tie::File', $file;
+my $o = tie @a, 'Tie::File', $file, autochomp => 0;
 print $o ? "ok $N\n" : "not ok $N\n";
 $N++;
 
@@ -92,8 +92,9 @@ sub check_contents {
   my $good = 1;
   my $msg;
   for (0.. $#c) {
-    unless ($a[$_] eq "$c[$_]$:") {
-      $msg = "expected $c[$_]$:, got $a[$_]";
+    my $aa = $a[$_];
+    unless ($aa eq "$c[$_]$:") {
+      $msg = "expected <$c[$_]$:>, got <$aa>";
       ctrlfix($msg);
       $good = 0;
     }
diff --git a/lib/Tie/File/t/02_fetchsize.t b/lib/Tie/File/t/02_fetchsize.t
index 08ac9cb..12d2b51 100644
--- a/lib/Tie/File/t/02_fetchsize.t
+++ b/lib/Tie/File/t/02_fetchsize.t
@@ -16,7 +16,7 @@ print F $data;
 close F;
 
 
-my $o = tie @a, 'Tie::File', $file;
+my $o = tie @a, 'Tie::File', $file, autochomp => 0;
 print $o ? "ok $N\n" : "not ok $N\n";
 $N++;
 
diff --git a/lib/Tie/File/t/03_longfetch.t b/lib/Tie/File/t/03_longfetch.t
index 265de93..7d5a388 100644
--- a/lib/Tie/File/t/03_longfetch.t
+++ b/lib/Tie/File/t/03_longfetch.t
@@ -3,6 +3,8 @@
 # Make sure we can fetch a record in the middle of the file
 # before we've ever looked at any records before it
 #
+# Make sure fetching past the end of the file returns the undefined value
+#
 # (tests _fill_offsets_to() )
 #
 
@@ -10,7 +12,7 @@ my $file = "tf$$.txt";
 $: = Tie::File::_default_recsep();
 my $data = "rec0$:rec1$:rec2$:";
 
-print "1..5\n";
+print "1..8\n";
 
 my $N = 1;
 use Tie::File;
@@ -22,7 +24,7 @@ print F $data;
 close F;
 
 
-my $o = tie @a, 'Tie::File', $file;
+my $o = tie @a, 'Tie::File', $file, autochomp => 0;
 print $o ? "ok $N\n" : "not ok $N\n";
 $N++;
 
@@ -32,7 +34,15 @@ my $n;
 
 # 3-5
 for (2, 1, 0) {
-  print $a[$_] eq "rec$_$:" ? "ok $N\n" : "not ok $N # rec=$a[$_] ?\n";
+  my $rec = $a[$_];
+  print $rec eq "rec$_$:" ? "ok $N\n" : "not ok $N # rec=<$rec> ?\n";
+  $N++;
+}
+
+# 6-8
+for (3, 4, 6) {
+  my $rec = $a[$_];
+  print ((not defined $rec) ? "ok $N\n" : "not ok $N # rec=<$rec> is defined\n");
   $N++;
 }
 
diff --git a/lib/Tie/File/t/07_rv_splice.t b/lib/Tie/File/t/07_rv_splice.t
index 69858b2..acc4341 100644
--- a/lib/Tie/File/t/07_rv_splice.t
+++ b/lib/Tie/File/t/07_rv_splice.t
@@ -4,6 +4,7 @@
 # (04_splice.t checks its effect on the file)
 #
 
+
 my $file = "tf$$.txt";
 $: = Tie::File::_default_recsep();
 my $data = "rec0$:rec1$:rec2$:";
@@ -16,7 +17,7 @@ print "ok $N\n"; $N++;  # partial credit just for showing up
 
 init_file($data);
 
-my $o = tie @a, 'Tie::File', $file;
+my $o = tie @a, 'Tie::File', $file, autochomp => 0;
 print $o ? "ok $N\n" : "not ok $N\n";
 $N++;
 
@@ -135,15 +136,15 @@ check_result('rec0', 'rec1');
 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";
+print !defined($r) ? "ok $N\n" : "not ok $N \# return should have been undef, was <$r>\n";
 $N++;
 
 $r = splice(@a, 2, 1);
-print $r eq "pie$:" ? "ok $N\n" : "not ok $N \# return should have been 'pie'\n";
+print $r eq "pie$:" ? "ok $N\n" : "not ok $N \# return should have been 'pie\\n', was <$r>\n";
 $N++;
 
 $r = splice(@a, 0, 2);
-print $r eq "like$:" ? "ok $N\n" : "not ok $N \# return should have been 'like'\n";
+print $r eq "like$:" ? "ok $N\n" : "not ok $N \# return should have been 'like\\n', was <$r>\n";
 $N++;
 
 # (49-50) Test default arguments
diff --git a/lib/Tie/File/t/08_ro.t b/lib/Tie/File/t/08_ro.t
index 218a4e4..8f3d998 100644
--- a/lib/Tie/File/t/08_ro.t
+++ b/lib/Tie/File/t/08_ro.t
@@ -16,7 +16,7 @@ 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;
+my $o = tie @a, 'Tie::File', $file, mode => O_RDONLY, autochomp => 0;
 print $o ? "ok $N\n" : "not ok $N\n";
 $N++;
 
diff --git a/lib/Tie/File/t/09_gen_rs.t b/lib/Tie/File/t/09_gen_rs.t
index 120080b..f9f5ccc 100644
--- a/lib/Tie/File/t/09_gen_rs.t
+++ b/lib/Tie/File/t/09_gen_rs.t
@@ -8,7 +8,7 @@ my $N = 1;
 use Tie::File;
 print "ok $N\n"; $N++;
 
-my $o = tie @a, 'Tie::File', $file, recsep => 'blah';
+my $o = tie @a, 'Tie::File', $file, recsep => 'blah', autochomp => 0;
 print $o ? "ok $N\n" : "not ok $N\n";
 $N++;
 
diff --git a/lib/Tie/File/t/11_rv_splice_rs.t b/lib/Tie/File/t/11_rv_splice_rs.t
index ae3c9b3..ae10538 100644
--- a/lib/Tie/File/t/11_rv_splice_rs.t
+++ b/lib/Tie/File/t/11_rv_splice_rs.t
@@ -15,7 +15,7 @@ print "ok $N\n"; $N++;  # partial credit just for showing up
 
 init_file($data);
 
-my $o = tie @a, 'Tie::File', $file, recsep => 'blah';
+my $o = tie @a, 'Tie::File', $file, autochomp => 0, recsep => 'blah';
 print $o ? "ok $N\n" : "not ok $N\n";
 $N++;
 
diff --git a/lib/Tie/File/t/12_longfetch_rs.t b/lib/Tie/File/t/12_longfetch_rs.t
index 2d1a3bb..6f1905d 100644
--- a/lib/Tie/File/t/12_longfetch_rs.t
+++ b/lib/Tie/File/t/12_longfetch_rs.t
@@ -21,7 +21,7 @@ print F $data;
 close F;
 
 
-my $o = tie @a, 'Tie::File', $file, recsep => 'blah';
+my $o = tie @a, 'Tie::File', $file, autochomp => 0, recsep => 'blah';
 print $o ? "ok $N\n" : "not ok $N\n";
 $N++;
 
diff --git a/lib/Tie/File/t/15_pushpop.t b/lib/Tie/File/t/15_pushpop.t
index d6c379b..cc09b02 100644
--- a/lib/Tie/File/t/15_pushpop.t
+++ b/lib/Tie/File/t/15_pushpop.t
@@ -22,7 +22,7 @@ my $N = 1;
 use Tie::File;
 print "ok $N\n"; $N++;  # partial credit just for showing up
 
-my $o = tie @a, 'Tie::File', $file;
+my $o = tie @a, 'Tie::File', $file, autochomp => 0;
 print $o ? "ok $N\n" : "not ok $N\n";
 $N++;
 my ($n, @r);
diff --git a/lib/Tie/File/t/16_handle.t b/lib/Tie/File/t/16_handle.t
index 3c9b327..b109b48 100644
--- a/lib/Tie/File/t/16_handle.t
+++ b/lib/Tie/File/t/16_handle.t
@@ -22,7 +22,7 @@ sysopen F, $file, O_CREAT | O_RDWR
   or die "Couldn't create temp file $file: $!; aborting";
 binmode F;
 
-my $o = tie @a, 'Tie::File', \*F;
+my $o = tie @a, 'Tie::File', \*F, autochomp => 0;
 print $o ? "ok $N\n" : "not ok $N\n";
 $N++;
 
diff --git a/lib/Tie/File/t/22_autochomp.t b/lib/Tie/File/t/22_autochomp.t
new file mode 100644
index 0000000..70974d4
--- /dev/null
+++ b/lib/Tie/File/t/22_autochomp.t
@@ -0,0 +1,167 @@
+#!/usr/bin/perl
+
+my $file = "tf$$.txt";
+$: = Tie::File::_default_recsep();
+
+print "1..71\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++;
+
+my $o = tie @a, 'Tie::File', $file, autochomp => 1;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+# 3-5 create
+$a[0] = 'rec0';
+check_contents("rec0");
+
+# 6-11 append
+$a[1] = 'rec1';
+check_contents("rec0", "rec1");
+$a[2] = 'rec2';
+check_contents("rec0", "rec1", "rec2");
+
+# 12-20 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");
+
+# 21-35 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");
+
+# 36-50 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");
+
+# (51-56) file with holes
+$a[4] = 'rec4';
+check_contents("sh0", "sh1", "short2", "", "rec4");
+$a[3] = 'rec3';
+check_contents("sh0", "sh1", "short2", "rec3", "rec4");
+
+# (57-59) zero out file
+@a = ();
+check_contents();
+
+# (60-62) insert into the middle of an empty file
+$a[3] = "rec3";
+check_contents("", "", "", "rec3");
+
+# (63-68) Test the ->autochomp() method
+@a = qw(Gold Frankincense Myrrh);
+my $ac;
+$ac = $o->autochomp();
+expect($ac);
+# See if that accidentally changed it
+$ac = $o->autochomp();
+expect($ac);
+# Now clear it
+$ac = $o->autochomp(0);
+expect($ac);
+expect(join("-", @a), "Gold$:-Frankincense$:-Myrrh$:");
+# Now set it again
+$ac = $o->autochomp(1);
+expect(!$ac);
+expect(join("-", @a), "Gold-Frankincense-Myrrh");
+
+# (69) Does 'splice' work correctly with autochomp?
+my @sr;
+@sr = splice @a, 0, 2;
+expect(join("-", @sr), "Gold-Frankincense");
+
+# (70-71) Didn't you forget that fetch may return an unchomped cached record?
+$a1 = $a[0];                    # populate cache
+$a2 = $a[0];
+expect($a1, "Myrrh");
+expect($a2, "Myrrh");
+# Actually no, you didn't---_fetch might return such a record, but 
+# the chomping is done by FETCH.
+
+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 {
+    ctrlfix($a, $x);
+    print "not ok $N\n# expected <$x>, got <$a>\n";
+  }
+  $N++;
+
+  # now check FETCH:
+  my $good = 1;
+  my $msg;
+  for (0.. $#c) {
+    my $aa = $a[$_];
+    unless ($aa eq $c[$_]) {
+      $msg = "expected <$c[$_]>, got <$aa>";
+      ctrlfix($msg);
+      $good = 0;
+    }
+  }
+  print $good ? "ok $N\n" : "not ok $N # $msg\n";
+  $N++;
+
+  print $o->_check_integrity($file, $ENV{INTEGRITY}) 
+      ? "ok $N\n" : "not ok $N\n";
+  $N++;
+}
+
+sub expect {
+  if (@_ == 1) {
+    print $_[0] ? "ok $N\n" : "not ok $N\n";
+  } elsif (@_ == 2) {
+    my ($a, $x) = @_;
+    if ($a eq $x) { print "ok $N\n" }
+    else {
+      ctrlfix(my $msg = "expected <$x>, got <$a>");
+      print "not ok $N # $msg\n";
+    }
+  } else {
+    die "expect() got ", scalar(@_), " args, should have been 1 or 2";
+  }
+  $N++;
+}
+
+sub ctrlfix {
+  for (@_) {
+    s/\n/\\n/g;
+    s/\r/\\r/g;
+  }
+}
+
+END {
+  undef $o;
+  untie @a;
+  1 while unlink $file;
+}
+
diff --git a/lib/Tie/File/t/23_rv_ac_splice.t b/lib/Tie/File/t/23_rv_ac_splice.t
new file mode 100644
index 0000000..be22957
--- /dev/null
+++ b/lib/Tie/File/t/23_rv_ac_splice.t
@@ -0,0 +1,182 @@
+#!/usr/bin/perl
+#
+# Check SPLICE function's return value when autochoping is now
+# (07_rv_splice.t checks it aith autochomping off)
+#
+
+my $file = "tf$$.txt";
+$: = Tie::File::_default_recsep();
+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, autochomp => 1;
+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, was <$r>\n";
+$N++;
+
+$r = splice(@a, 2, 1);
+print $r eq "pie" ? "ok $N\n" : "not ok $N \# return should have been 'pie', was <$r>\n";
+$N++;
+
+$r = splice(@a, 0, 2);
+print $r eq "like" ? "ok $N\n" : "not ok $N \# return should have been 'like', was <$r>\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 = @_;
+  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;
+}
+