X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FTie%2FFile.pm;h=9528ab1bfdb76d3ff14e8ae1b9dd91f278b24fa3;hb=aaf9c2b26697492a8234a7efe890beef8868ea9b;hp=a47868868fefae55a1eeaa33702131e9ba52b0c9;hpb=0ca4ce0d843a0dcf48769457f5c67ca9b976899a;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/Tie/File.pm b/lib/Tie/File.pm
index a478688..9528ab1 100644
--- a/lib/Tie/File.pm
+++ b/lib/Tie/File.pm
@@ -7,14 +7,14 @@ use Fcntl 'O_CREAT', 'O_RDWR', 'LOCK_EX', 'LOCK_SH', 'O_WRONLY', 'O_RDONLY';
 sub O_ACCMODE () { O_RDONLY | O_RDWR | O_WRONLY }
 
 
-$VERSION = "0.95";
+$VERSION = "0.97_02";
 my $DEFAULT_MEMORY_SIZE = 1<<21;    # 2 megabytes
 my $DEFAULT_AUTODEFER_THRESHHOLD = 3; # 3 records
 my $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD = 65536; # 16 disk blocksful
 
 my %good_opt = map {$_ => 1, "-$_" => 1}
                  qw(memory dw_size mode recsep discipline 
-                    autodefer autochomp autodefer_threshhold);
+                    autodefer autochomp autodefer_threshhold concurrent);
 
 sub TIEARRAY {
   if (@_ % 2 != 0) {
@@ -33,6 +33,10 @@ sub TIEARRAY {
     }
   }
 
+  if ($opts{concurrent}) {
+    croak("$pack: concurrent access not supported yet\n");
+  }
+
   unless (defined $opts{memory}) {
     # default is the larger of the default cache size and the 
     # deferred-write buffer size (if specified)
@@ -89,14 +93,20 @@ sub TIEARRAY {
     unless (seek $file, 1, SEEK_SET) {
       croak "$pack: your filehandle does not appear to be seekable";
     }
-    seek $file, 0, SEEK_SET     # put it back
+    seek $file, 0, SEEK_SET;    # put it back
     $fh = $file;                # setting binmode is the user's problem
   } elsif (ref $file) {
     croak "usage: tie \@array, $pack, filename, [option => value]...";
   } else {
-    $fh = \do { local *FH };   # only works in 5.005 and later
+    # $fh = \do { local *FH };  # XXX this is buggy
+    if ($] < 5.006) {
+	# perl 5.005 and earlier don't autovivify filehandles
+	require Symbol;
+	$fh = Symbol::gensym();
+    }
     sysopen $fh, $file, $opts{mode}, 0666 or return;
     binmode $fh;
+    ++$opts{ourfh};
   }
   { my $ofh = select $fh; $| = 1; select $ofh } # autoflush on write
   if (defined $opts{discipline} && $] >= 5.006) {
@@ -407,6 +417,10 @@ sub DESTROY {
   my $self = shift;
   $self->flush if $self->_is_deferring;
   $self->{cache}->delink if defined $self->{cache}; # break circular link
+  if ($self->{fh} and $self->{ourfh}) {
+      delete $self->{ourfh};
+      close delete $self->{fh};
+  }
 }
 
 sub _splice {
@@ -642,7 +656,7 @@ sub _mtwrite {
       if (@_) {
         $unwritten = $self->_downcopy($data, $end, $_[1] - $end);
       } else {
-        # Make the file longer to accomodate the last segment that doesn'
+        # Make the file longer to accommodate the last segment that doesn'
         $unwritten = $self->_downcopy($data, $end);
       }
     }
@@ -687,6 +701,8 @@ sub _upcopy {
 # moving everything in the block forwards to make room.
 # Instead of writing the last length($data) bytes from the block
 # (because there isn't room for them any longer) return them.
+#
+# Undefined $len means 'until the end of the file'
 sub _downcopy {
   my $blocksize = 8192;
   my ($self, $data, $pos, $len) = @_;
@@ -697,11 +713,21 @@ sub _downcopy {
       : $len > $blocksize? $blocksize : $len;
     $self->_seekb($pos);
     read $fh, my($old), $readsize;
+    my $last_read_was_short = length($old) < $readsize;
     $data .= $old;
-    $self->_seekb($pos);
-    my $writable = substr($data, 0, $readsize, "");
+    my $writable;
+    if ($last_read_was_short) {
+      # If last read was short, then $data now contains the entire rest
+      # of the file, so there's no need to write only one block of it
+      $writable = $data;
+      $data = "";
+    } else {
+      $writable = substr($data, 0, $readsize, "");
+    }
     last if $writable eq "";
+    $self->_seekb($pos);
     $self->_write_record($writable);
+    last if $last_read_was_short && $data eq "";
     $len -= $readsize if defined $len;
     $pos += $readsize;
   }
@@ -891,8 +917,7 @@ sub _read_record {
     $rec = <$fh>;
   }
   return unless defined $rec;
-  if (! $self->{sawlastrec} && 
-      substr($rec, -$self->{recseplen}) ne $self->{recsep}) {
+  if (substr($rec, -$self->{recseplen}) ne $self->{recsep}) {
     # improperly terminated final record --- quietly fix it.
 #    my $ac = substr($rec, -$self->{recseplen});
 #    $ac =~ s/\n/\\n/g;
@@ -1984,7 +2009,7 @@ Tie::File - Access the lines of a disk file via a Perl array
 
 =head1 SYNOPSIS
 
-	# This file documents Tie::File version 0.95
+	# This file documents Tie::File version 0.97
 	use Tie::File;
 
 	tie @array, 'Tie::File', filename or die ...;
@@ -2289,6 +2314,11 @@ means no pipes or sockets.  If C<Tie::File> can detect that you
 supplied a non-seekable handle, the C<tie> call will throw an
 exception.  (On Unix systems, it can detect this.)
 
+Note that Tie::File will only close any filehandles that it opened
+internally.  If you passed it a filehandle as above, you "own" the
+filehandle, and are responsible for closing it after you have untied
+the @array.
+
 =head1 Deferred Writing
 
 (This is an advanced feature.  Skip this section on first reading.)
@@ -2397,14 +2427,14 @@ C<-E<gt>autodefer()> recovers the current value of the autodefer setting.
 =head1 CONCURRENT ACCESS TO FILES
 
 Caching and deferred writing are inappropriate if you want the same
-file to be accessed simultaneously from more than one process.  You
-will want to disable these features.  You should do that by including
-the C<memory =E<gt> 0> option in your C<tie> calls; this will inhibit
-caching and deferred writing.
+file to be accessed simultaneously from more than one process.  Other
+optimizations performed internally by this module are also
+incompatible with concurrent access.  A future version of this module will
+support a C<concurrent =E<gt> 1> option that enables safe concurrent access.
 
-You will also want to lock the file while reading or writing it.  You
-can use the C<-E<gt>flock> method for this.  A future version of this
-module may provide an 'autolocking' mode.
+Previous versions of this documentation suggested using C<memory
+=E<gt> 0> for safe concurrent access.  This was mistaken.  Tie::File
+will not support safe concurrent access before version 0.98.
 
 =head1 CAVEATS
 
@@ -2502,7 +2532,7 @@ any news of importance, will be available at
 
 =head1 LICENSE
 
-C<Tie::File> version 0.95 is copyright (C) 2002 Mark Jason Dominus.
+C<Tie::File> version 0.97 is copyright (C) 2003 Mark Jason Dominus.
 
 This library is free software; you may redistribute it and/or modify
 it under the same terms as Perl itself.
@@ -2519,8 +2549,8 @@ GNU General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 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
+If not, write to the Free Software Foundation, Inc., 51 Franklin Street,
+Fifth Floor, Boston, MA  02110-1301, USA
 
 For licensing inquiries, contact the author at:
 
@@ -2530,7 +2560,7 @@ For licensing inquiries, contact the author at:
 
 =head1 WARRANTY
 
-C<Tie::File> version 0.95 comes with ABSOLUTELY NO WARRANTY.
+C<Tie::File> version 0.97 comes with ABSOLUTELY NO WARRANTY.
 For details, see the license.
 
 =head1 THANKS
@@ -2552,7 +2582,9 @@ optimizations.
 Additional thanks to:
 Edward Avis /
 Mattia Barbon /
+Tom Christiansen /
 Gerrit Haase /
+Gurusamy Sarathy /
 Jarkko Hietaniemi (again) /
 Nikola Knezevic /
 John Kominetz /