From: Jarkko Hietaniemi Date: Mon, 4 Mar 2002 23:42:28 +0000 (+0000) Subject: Upgrade to Tie::File 0.17 from mjd. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=836d996119ed7382be15fe36a0d5f538caaa397e;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Tie::File 0.17 from mjd. p4raw-id: //depot/perl@15026 --- diff --git a/lib/Tie/File.pm b/lib/Tie/File.pm index b22f3e1..aeceb1b 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.16"; +$VERSION = "0.17"; # Idea: The object will always contain an array of byte offsets # this will be filled in as is necessary and convenient. @@ -153,9 +153,9 @@ sub STORESIZE { # file gets shorter $self->_seek($len); $self->_chop_file; - $#{$self->{offsets}} = $len-1; - my @cached = grep $_ > $len, keys %{$self->{cache}}; - delete @{$self->{cache}}{@cached} if @cached; + $#{$self->{offsets}} = $len; + my @cached = grep $_ >= $len, keys %{$self->{cache}}; + $self->_uncache(@cached); } sub PUSH { @@ -208,8 +208,7 @@ sub DELETE { $self->_seek($n); $self->_chop_file; $#{$self->{offsets}}--; - delete $self->{cached}{$n}; - @{$self->{lru}} = grep $_ != $n, @{$self->{lru}}; + $self->_uncache($n); # perhaps in this case I should also remove trailing null records? } else { $self->STORE($n, ""); @@ -302,8 +301,7 @@ sub SPLICE { $self->{cached} += length($new) - length($cached); $self->{cache}{$_} = $new; } else { - delete $self->{cache}{$_}; - $self->{cached} -= length($cached); + $self->_uncache($_); } } # update the read cache, part 2 @@ -471,6 +469,16 @@ sub _cache_insert { $self->_cache_flush if $self->{cached} > $self->{cachesize}; } +sub _uncache { + my $self = shift; + for my $n (@_) { + my $cached = delete $self->{cache}{$n}; + next unless defined $cached; + @{$self->{lru}} = grep $_ != $n, @{$self->{lru}}; + $self->{cached} -= length($cached); + } +} + sub _check_cache { my ($self, $n) = @_; my $rec; @@ -549,7 +557,12 @@ sub _check_integrity { my ($self, $file, $warn) = @_; my $good = 1; - unless ($self->{offsets}[0] == 0) { + + if (not defined $self->{offsets}[0]) { + $warn && print STDERR "# offset 0 is missing!\n"; + $good = 0; + } elsif ($self->{offsets}[0] != 0) { + $warn && print STDERR "# offset 0 is missing!\n"; $warn && print STDERR "# rec 0: offset <$self->{offsets}[0]> s/b 0!\n"; $good = 0; } @@ -605,7 +618,7 @@ sub _check_integrity { } for (keys %{$self->{cache}}) { unless (exists $seen{$_}) { - print "# $record $_ is in the cache but not the LRU queue\n"; + print "# record $_ is in the cache but not the LRU queue\n"; $good = 0; } } @@ -621,7 +634,7 @@ Tie::File - Access the lines of a disk file via a Perl array =head1 SYNOPSIS - # This file documents Tie::File version 0.16 + # This file documents Tie::File version 0.17 tie @array, 'Tie::File', filename or die ...; @@ -801,7 +814,8 @@ 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 call will abort your program. +C call will try to abort your program. This feature is not yet +supported under VMS. =head1 CAVEATS @@ -825,9 +839,9 @@ lines 1 through 999,999; the second iteration must relocate lines 2 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 a mechanism for getting -better performance in such cases, by deferring the writing until it -can be done all at once. +A soon-to-be-released 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 @@ -876,7 +890,7 @@ C. =head1 LICENSE -C version 0.16 is copyright (C) 2002 Mark Jason Dominus. +C version 0.17 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. @@ -904,7 +918,7 @@ For licensing inquiries, contact the author at: =head1 WARRANTY -C version 0.16 comes with ABSOLUTELY NO WARRANTY. +C version 0.17 comes with ABSOLUTELY NO WARRANTY. For details, see the license. =head1 THANKS @@ -920,6 +934,7 @@ testing). More thanks to: Gerrit Haase / +Nick Ing-Simmons / Tassilo von Parseval / H. Dieter Pearcey / Peter Somu / diff --git a/lib/Tie/File/t/05_size.t b/lib/Tie/File/t/05_size.t index dbc2c0a..6cdd4e5 100644 --- a/lib/Tie/File/t/05_size.t +++ b/lib/Tie/File/t/05_size.t @@ -10,7 +10,7 @@ my $file = "tf$$.txt"; my $data = "rec0$/rec1$/rec2$/"; my ($o, $n); -print "1..10\n"; +print "1..15\n"; my $N = 1; use Tie::File; @@ -44,26 +44,39 @@ print $n == 3 ? "ok $N\n" : "not ok $N # $n, s/b 0\n"; $N++; # STORESIZE -# 6 Make it longer: +# (6-7) Make it longer: +populate(); $#a = 4; check_contents("$data$/$/"); -# 7 Make it longer again: +# (8-9) Make it longer again: +populate(); $#a = 6; check_contents("$data$/$/$/$/"); -# 8 Make it shorter: +# (10-11) Make it shorter: +populate(); $#a = 4; check_contents("$data$/$/"); -# 9 Make it shorter again: +# (12-13) Make it shorter again: +populate(); $#a = 2; check_contents($data); -# 10 Get rid of it completely: +# (14-15) Get rid of it completely: +populate(); $#a = -1; check_contents(''); +# In the past, there was a bug in STORESIZE that it didn't correctly +# remove deleted records from the the cache. This wasn't detected +# because these tests were all done with an empty cache. populate() +# will ensure that the cache is fully populated. +sub populate { + my $z; + $z = $a[$_] for 0 .. $#a; +} sub check_contents { my $x = shift; @@ -79,6 +92,9 @@ sub check_contents { print "not ok $N\n# expected <$x>, got <$a>\n"; } $N++; + my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); + print $integrity ? "ok $N\n" : "not ok $N \# integrity\n"; + $N++; } diff --git a/lib/Tie/File/t/16_handle.t b/lib/Tie/File/t/16_handle.t index 5ff3c82..e530dd9 100644 --- a/lib/Tie/File/t/16_handle.t +++ b/lib/Tie/File/t/16_handle.t @@ -5,6 +5,11 @@ my $file = "tf$$.txt"; +if ($^O =~ /vms/i) { + print "1..0\n"; + exit; +} + print "1..39\n"; my $N = 1; diff --git a/lib/Tie/File/t/17_misc_meth.t b/lib/Tie/File/t/17_misc_meth.t index f9f80fc..55b694b 100644 --- a/lib/Tie/File/t/17_misc_meth.t +++ b/lib/Tie/File/t/17_misc_meth.t @@ -4,7 +4,6 @@ # EXTEND, CLEAR, DELETE, EXISTS # -use lib '/home/mjd/src/perl/Tie-File2/lib'; my $file = "tf$$.txt"; 1 while unlink $file;