Upgrade to Tie::File 0.16.
authorAbhijit Menon-Sen <ams@wiw.org>
Mon, 4 Mar 2002 08:59:27 +0000 (08:59 +0000)
committerAbhijit Menon-Sen <ams@wiw.org>
Mon, 4 Mar 2002 08:59:27 +0000 (08:59 +0000)
p4raw-id: //depot/perl@14988

lib/Tie/File.pm
lib/Tie/File/t/01_gen.t
lib/Tie/File/t/04_splice.t
lib/Tie/File/t/10_splice_rs.t
lib/Tie/File/t/16_handle.t [new file with mode: 0644]
lib/Tie/File/t/17_misc_meth.t [new file with mode: 0644]

index 8ae70a6..b22f3e1 100644 (file)
@@ -5,7 +5,7 @@ use POSIX 'SEEK_SET';
 use Fcntl 'O_CREAT', 'O_RDWR', 'LOCK_EX';
 require 5.005;
 
-$VERSION = "0.15";
+$VERSION = "0.16";
 
 # Idea: The object will always contain an array of byte offsets
 # this will be filled in as is necessary and convenient.
@@ -52,10 +52,20 @@ sub TIEARRAY {
   }
 
   my $mode = defined($opts{mode}) ? $opts{mode} : O_CREAT|O_RDWR;
+  my $fh;
 
-  my $fh = \do { local *FH };   # only works in 5.005 and later
-  sysopen $fh, $file, $mode, 0666 or return;
-  binmode $fh;
+  if (UNIVERSAL::isa($file, 'GLOB')) {
+    unless (seek $file, 0, SEEK_SET) {
+      croak "$pack: your filehandle does not appear to be seekable";
+    }
+    $fh = $file;
+  } elsif (ref $file) {
+    croak "usage: tie \@array, $pack, filename, [option => value]...";
+  } else {
+    $fh = \do { local *FH };   # only works in 5.005 and later
+    sysopen $fh, $file, $mode, 0666 or return;
+    binmode $fh;
+  }
   { my $ofh = select $fh; $| = 1; select $ofh } # autoflush on write
   $opts{fh} = $fh;
 
@@ -98,7 +108,10 @@ sub STORE {
   my $oldrec = $self->FETCH($n);
 
   # _check_cache promotes record $n to MRU.  Is this correct behavior?
-  $self->{cache}{$n} = $rec if $self->_check_cache($n);
+  if (my $cached = $self->_check_cache($n)) {
+    $self->{cache}{$n} = $rec;
+    $self->{cached} += length($rec) - length($cached);
+  }
 
   if (not defined $oldrec) {
     # We're storing a record beyond the end of the file
@@ -194,6 +207,9 @@ sub DELETE {
   if ($n == $lastrec) {
     $self->_seek($n);
     $self->_chop_file;
+    $#{$self->{offsets}}--;
+    delete $self->{cached}{$n};
+    @{$self->{lru}} = grep $_ != $n, @{$self->{lru}};
     # perhaps in this case I should also remove trailing null records?
   } else {
     $self->STORE($n, "");
@@ -493,8 +509,7 @@ sub _extend_file_to {
   # Todo : just use $self->{recsep} x $extras here?
   while ($extras-- > 0) {
     $self->_write_record($self->{recsep});
-    $pos += $self->{recseplen};
-    push @{$self->{offsets}}, $pos;
+    push @{$self->{offsets}}, tell $self->{fh};
   }
 }
 
@@ -533,15 +548,17 @@ sub flock {
 sub _check_integrity {
   my ($self, $file, $warn) = @_;
   my $good = 1; 
-  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";
     $good = 0;
   }
+
+  local *F = $self->{fh};
+  seek F, 0, SEEK_SET;
+  local $/ = $self->{recsep};
+  $. = 0;
+
   while (<F>) {
     my $n = $. - 1;
     my $cached = $self->{cache}{$n};
@@ -549,6 +566,7 @@ sub _check_integrity {
     my $ao = tell F;
     if (defined $offset && $offset != $ao) {
       $warn && print STDERR "# rec $n: offset <$offset> actual <$ao>\n";
+      $good = 0;
     }
     if (defined $cached && $_ ne $cached) {
       $good = 0;
@@ -595,13 +613,15 @@ sub _check_integrity {
   $good;
 }
 
+"Cogito, ergo sum.";  # don't forget to return a true value from the file
+
 =head1 NAME
 
 Tie::File - Access the lines of a disk file via a Perl array
 
 =head1 SYNOPSIS
 
-       # This file documents Tie::File version 0.15
+       # This file documents Tie::File version 0.16
 
        tie @array, 'Tie::File', filename or die ...;
 
@@ -746,7 +766,7 @@ argument to the Perl built-in C<flock> function; for example
 C<LOCK_SH> or C<LOCK_EX | LOCK_NB>.  (These constants are provided by
 the C<use Fcntl ':flock'> declaration.)
 
-C<MODE> is optional; C<< $o->flock >> simply locks the file with
+C<MODE> is optional; C<$o-E<gt>flock> simply locks the file with
 C<LOCK_EX>.
 
 The best way to unlock a file is to discard the object and untie the
@@ -765,6 +785,24 @@ 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
+
+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:
+
+       tie @array, 'Tie::File', $fh, ...;
+
+Similarly if you opened that handle C<FH> with regular C<open> or
+C<sysopen>, you may use:
+
+       tie @array, 'Tie::File', \*FH, ...;
+
+Handles that were opened write-only won't work.  Handles that were
+opened read-only will work as long as you don't try to write to them.
+Handles must be attached to seekable sources of data---that means no
+pipes or sockets.  If you try to supply a non-seekable handle, the
+C<tie> call will abort your program.
+
 =head1 CAVEATS
 
 (That's Latin for 'warnings'.)
@@ -773,7 +811,7 @@ the idiot does not also have a green light at the same time.
 
 Every effort was made to make this module efficient.  Nevertheless,
 changing the size of a record in the middle of a large file will
-always be slow, because everything after the new record must be move.
+always be slow, because everything after the new record must be moved.
 
 In particular, note that:
 
@@ -805,7 +843,7 @@ The author has supposed that since this module is concerned with file
 I/O, almost all normal use of it will be heavily I/O bound, and that
 the time to maintain complicated data structures inside the module
 will be dominated by the time to actually perform the I/O.  This
-suggests, for example, that and LRU read-cache is a good tradeoff,
+suggests, for example, that an LRU read-cache is a good tradeoff,
 even if it requires substantial adjustment following a C<splice>
 operation.
 
@@ -838,7 +876,7 @@ C<mjd-perl-tiefile-subscribe@plover.com>.
 
 =head1 LICENSE
 
-C<Tie::File> version 0.15 is copyright (C) 2002 Mark Jason Dominus.
+C<Tie::File> version 0.16 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.
@@ -866,19 +904,34 @@ For licensing inquiries, contact the author at:
 
 =head1 WARRANTY
 
-C<Tie::File> version 0.15 comes with ABSOLUTELY NO WARRANTY.
+C<Tie::File> version 0.16 comes with ABSOLUTELY NO WARRANTY.
 For details, see the license.
 
-=head1 TODO
+=head1 THANKS
+
+Gigantic thanks to Jarkko Hietaniemi, for agreeing to put this in the
+core when I hadn't written it yet, and for generally being helpful,
+supportive, and competent.  (Usually the rule is "choose any one.")
+Also big thanks to Abhijit Menon-Sen for all of the same things.
+
+Special thanks to Craig Berry (for VMS portability help), Randy Kobes
+(for Win32 portability help), the rest of the CPAN testers (for
+testing).
 
-Allow tie to seekable filehandle rather than named file.
+More thanks to:
+Gerrit Haase /
+Tassilo von Parseval /
+H. Dieter Pearcey /
+Peter Somu /
+Tels
 
-Tests for default arguments to SPLICE.  Tests for CLEAR/EXTEND.
-Tests for DELETE/EXISTS.
+=head1 TODO
+
+Test DELETE machinery more carefully.
 
-More tests.  (Configuration options, cache flushery, locking.  _twrite
-should be tested separately, because there are a lot of weird special
-cases lurking in there.)
+More tests.  (Configuration options, cache flushery.  _twrite should
+be tested separately, because there are a lot of weird special cases
+lurking in there.)
 
 More tests.  (Stuff I didn't think of yet.)
 
@@ -890,5 +943,7 @@ More tests.
 
 Fixed-length mode.
 
+Maybe an autolocking mode?
+
 =cut
 
index d0ccb71..e383b7f 100644 (file)
@@ -2,7 +2,7 @@
 
 my $file = "tf$$.txt";
 
-print "1..38\n";
+print "1..56\n";
 
 my $N = 1;
 use Tie::File;
@@ -12,17 +12,17 @@ my $o = tie @a, 'Tie::File', $file;
 print $o ? "ok $N\n" : "not ok $N\n";
 $N++;
 
-# 3-4 create
+# 3-5 create
 $a[0] = 'rec0';
 check_contents("rec0");
 
-# 5-8 append
+# 6-11 append
 $a[1] = 'rec1';
 check_contents("rec0", "rec1");
 $a[2] = 'rec2';
 check_contents("rec0", "rec1", "rec2");
 
-# 9-14 same-length alterations
+# 12-20 same-length alterations
 $a[0] = 'new0';
 check_contents("new0", "rec1", "rec2");
 $a[1] = 'new1';
@@ -30,7 +30,7 @@ check_contents("new0", "new1", "rec2");
 $a[2] = 'new2';
 check_contents("new0", "new1", "new2");
 
-# 15-24 lengthening alterations
+# 21-35 lengthening alterations
 $a[0] = 'long0';
 check_contents("long0", "new1", "new2");
 $a[1] = 'long1';
@@ -42,7 +42,7 @@ check_contents("long0", "longer1", "long2");
 $a[0] = 'longer0';
 check_contents("longer0", "longer1", "long2");
 
-# 25-34 shortening alterations, including truncation
+# 36-50 shortening alterations, including truncation
 $a[0] = 'short0';
 check_contents("short0", "longer1", "long2");
 $a[1] = 'short1';
@@ -54,7 +54,7 @@ check_contents("short0", "sh1", "short2");
 $a[0] = 'sh0';
 check_contents("sh0", "sh1", "short2");
 
-# file with holes
+# (51-56) file with holes
 $a[4] = 'rec4';
 check_contents("sh0", "sh1", "short2", "", "rec4");
 $a[3] = 'rec3';
@@ -93,6 +93,10 @@ sub check_contents {
   }
   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++;
 }
 
 END {
index e291809..08e001b 100644 (file)
@@ -153,12 +153,12 @@ 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) {
+if ($] < 5.006 || $] > 5.007003) {
   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";
+  print "ok $N \# skipped (5.6.0 through 5.7.3 dump core here.)\n";
 }
 $N++;
        
index 9e0788c..aa33bcf 100644 (file)
@@ -153,14 +153,14 @@ 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
+# This test ignored because it causes 5.6.1 and 5.7.3 to dump core
 # NOT MY FAULT
-if ($] < 5.006 || $] > 5.007002) {
+if ($] < 5.006 || $] > 5.007003) {
   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";
+  print "ok $N \# skipped (5.6.0 through 5.7.3 dump core here.)\n";
 }
 $N++;
        
diff --git a/lib/Tie/File/t/16_handle.t b/lib/Tie/File/t/16_handle.t
new file mode 100644 (file)
index 0000000..a438612
--- /dev/null
@@ -0,0 +1,130 @@
+#!/usr/bin/perl
+#
+# Basic operation, initializing the object from an already-open handle
+# instead of from a filename
+
+my $file = "tf$$.txt";
+
+print "1..39\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++;
+
+use Fcntl 'O_CREAT', 'O_RDWR';
+sysopen F, $file, O_CREAT | O_RDWR 
+  or die "Couldn't create temp file $file: $!; aborting";
+
+my $o = tie @a, 'Tie::File', \*F;
+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");
+
+close F;
+undef $o;
+untie @a;
+
+# Does it correctly detect a non-seekable handle?
+{  eval {pipe *R, *W};
+   close R;
+   if ($@) {
+     print "ok $N # skipped\n";
+     last;
+   }
+   $o = eval {tie @a, 'Tie::File', \*W};
+   if ($@ && $@ =~ /filehandle does not appear to be seekable/) {
+     print "ok $N\n";
+   } else {
+     print "not ok $N\n";
+   }
+   $N++;
+}
+
+# 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;
+}
+
+
diff --git a/lib/Tie/File/t/17_misc_meth.t b/lib/Tie/File/t/17_misc_meth.t
new file mode 100644 (file)
index 0000000..f9f80fc
--- /dev/null
@@ -0,0 +1,86 @@
+#!/usr/bin/perl
+#
+# Check miscellaneous tied-array interface methods
+# EXTEND, CLEAR, DELETE, EXISTS
+#
+
+use lib '/home/mjd/src/perl/Tie-File2/lib';
+my $file = "tf$$.txt";
+1 while unlink $file;
+
+print "1..24\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-8) EXTEND
+$o->EXTEND(3);
+check_contents("$/$/$/");
+$o->EXTEND(4);
+check_contents("$/$/$/$/");
+$o->EXTEND(3);
+check_contents("$/$/$/$/");
+
+# (9-10) CLEAR
+@a = ();
+check_contents("");
+
+# (11-16) EXISTS
+print !exists $a[0] ? "ok $N\n" : "not ok $N\n";
+$N++;
+$a[0] = "I like pie.";
+print exists $a[0] ? "ok $N\n" : "not ok $N\n";
+$N++;
+print !exists $a[1] ? "ok $N\n" : "not ok $N\n";
+$N++;
+$a[2] = "GIVE ME PIE";
+print exists $a[0] ? "ok $N\n" : "not ok $N\n";
+$N++;
+# exists $a[1] is not defined by this module under these circumstances
+print exists $a[1] ? "ok $N\n" : "ok $N\n";
+$N++;
+print exists $a[2] ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+# (17-24) DELETE
+delete $a[0];
+check_contents("$/$/GIVE ME PIE$/");
+delete $a[2];
+check_contents("$/$/");
+delete $a[0];
+check_contents("$/$/");
+delete $a[1];
+check_contents("$/");
+
+
+use POSIX 'SEEK_SET';
+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++;
+  print $o->_check_integrity($file, $ENV{INTEGRITY}) ? "ok $N\n" : "not ok $N\n";
+  $N++;
+}
+
+END {
+  undef $o;
+  untie @a;
+  1 while unlink $file;
+}
+
+