diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Tie/File.pm | 197 | ||||
| -rw-r--r-- | lib/Tie/File/01_gen.t | 2 | ||||
| -rw-r--r-- | lib/Tie/File/04_splice.t | 31 | ||||
| -rw-r--r-- | lib/Tie/File/07_rv_splice.t | 18 | ||||
| -rw-r--r-- | lib/Tie/File/14_lock.t | 40 | ||||
| -rw-r--r-- | lib/Tie/File/15_pushpop.t | 127 |
6 files changed, 380 insertions, 35 deletions
diff --git a/lib/Tie/File.pm b/lib/Tie/File.pm index 2b6c9a5db3..9fc7eab689 100644 --- a/lib/Tie/File.pm +++ b/lib/Tie/File.pm @@ -2,10 +2,10 @@ package Tie::File; use Carp; use POSIX 'SEEK_SET'; -use Fcntl 'O_CREAT', 'O_RDWR'; +use Fcntl 'O_CREAT', 'O_RDWR', 'LOCK_EX'; require 5.005; -$VERSION = "0.13"; +$VERSION = "0.14"; # Idea: The object will always contain an array of byte offsets # this will be filled in as is necessary and convenient. @@ -102,7 +102,7 @@ sub STORE { if (not defined $oldrec) { # We're storing a record beyond the end of the file - $self->_extend_file_to($n); + $self->_extend_file_to($n+1); $oldrec = $self->{recsep}; } my $len_diff = length($rec) - length($oldrec); @@ -133,7 +133,7 @@ sub STORESIZE { # file gets longer if ($len > $olen) { - $self->_extend_file_to($len-1); # record numbers from 0 .. $len-1 + $self->_extend_file_to($len); return; } @@ -145,11 +145,84 @@ sub STORESIZE { delete @{$self->{cache}}{@cached} if @cached; } +sub PUSH { + my $self = shift; + $self->SPLICE($self->FETCHSIZE, scalar(@_), @_); + $self->FETCHSIZE; +} + +sub POP { + my $self = shift; + scalar $self->SPLICE(-1, 1); +} + +sub SHIFT { + my $self = shift; + scalar $self->SPLICE(0, 1); +} + +sub UNSHIFT { + my $self = shift; + $self->SPLICE(0, 0, @_); + $self->FETCHSIZE; +} + +sub CLEAR { + # And enable auto-defer mode, since it's likely that they just + # did @a = (...); + my $self = shift; + $self->_seekb(0); + $self->_chop_file; + %{$self->{cache}} = (); + $self->{cached} = 0; + @{$self->{lru}} = (); + @{$self->{offsets}} = (0); +} + +sub EXTEND { + my ($self, $n) = @_; + $self->_fill_offsets_to($n); + $self->_extend_file_to($n); +} + +sub DELETE { + my ($self, $n) = @_; + my $lastrec = $self->FETCHSIZE-1; + if ($n == $lastrec) { + $self->_seek($n); + $self->_chop_file; + # perhaps in this case I should also remove trailing null records? + } else { + $self->STORE($n, ""); + } +} + +sub EXISTS { + my ($self, $n) = @_; + $self->_fill_offsets_to($n); + 0 <= $n && $n < $self->FETCHSIZE; +} + sub SPLICE { my ($self, $pos, $nrecs, @data) = @_; my @result; - $pos += $self->FETCHSIZE if $pos < 0; + { + my $oldsize = $self->FETCHSIZE; + my $oldpos = $pos; + + if ($pos < 0) { + $pos += $oldsize; + if ($pos < 0) { + croak "Modification of non-creatable array value attempted, subscript $oldpos"; + } + } + + if ($pos > $oldsize) { + return unless @data; + $pos = $oldsize; # This is what perl does for normal arrays + } + } $self->_fixrecs(@data); my $data = join '', @data; @@ -157,6 +230,7 @@ sub SPLICE { my $oldlen = 0; # compute length of data being removed + # Incidentally fills offsets table for ($pos .. $pos+$nrecs-1) { my $rec = $self->FETCH($_); last unless defined $rec; @@ -164,7 +238,7 @@ sub SPLICE { $oldlen += length($rec); } - $self->_fill_offsets_to($pos); + # Modify the file $self->_twrite($data, $self->{offsets}[$pos], $oldlen); # update the offsets table part 1 @@ -187,6 +261,12 @@ sub SPLICE { # that knows that the file does indeed start at 0. $self->{offsets}[0] = 0 unless @{$self->{offsets}}; + # Perhaps the following cache foolery could be factored out + # into a bunch of mor opaque cache functions. For example, + # it's odd to delete a record from the cache and then remove + # it from the LRU queue later on; there should be a function to + # do both at once. + # update the read cache, part 1 # modified records # Consider this carefully for correctness @@ -224,7 +304,8 @@ sub SPLICE { } @{$self->{lru}} = (@new, @changed); - @result; + # Yes, the return value of 'splice' *is* actually this complicated + wantarray ? @result : @result ? $result[-1] : undef; } # write data into the file @@ -256,24 +337,23 @@ sub _twrite { # $bufsize is required to be at least as large as the data we're overwriting my $bufsize = _bufsize($len_diff); my ($writepos, $readpos) = ($pos, $pos+$len); + my $next_block; # Seems like there ought to be a way to avoid the repeated code # and the special case here. The read(1) is also a little weird. # Think about this. do { $self->_seekb($readpos); - my $br = read $self->{fh}, my($next_block), $bufsize; + my $br = read $self->{fh}, $next_block, $bufsize; my $more_data = read $self->{fh}, my($dummy), 1; $self->_seekb($writepos); $self->_write_record($data); $readpos += $br; $writepos += length $data; $data = $next_block; - unless ($more_data) { - $self->_seekb($writepos); - $self->_write_record($next_block); - } } while $more_data; + $self->_seekb($writepos); + $self->_write_record($next_block); # There might be leftover data at the end of the file $self->_chop_file if $len_diff < 0; @@ -324,7 +404,7 @@ sub _fill_offsets_to { $self->_seek(-1); # tricky -- see comment at _seek $rec = $self->_read_record; if (defined $rec) { - push @OFF, $o+length($rec); + push @OFF, tell $fh; } else { return; # It turns out there is no such record } @@ -391,14 +471,16 @@ sub _cache_flush { # entirely populated. Now we need to write a new record beyond # the end of the file. We prepare for this by writing # empty records into the file up to the position we want -# $n here is the record number of the last record we're going to write +# +# assumes that the offsets table already contains the offset of record $n, +# if it exists, and extends to the end of the file if not. sub _extend_file_to { my ($self, $n) = @_; $self->_seek(-1); # position after the end of the last record my $pos = $self->{offsets}[-1]; # the offsets table has one entry more than the total number of records - $extras = $n - ($#{$self->{offsets}} - 1); + $extras = $n - $#{$self->{offsets}}; # Todo : just use $self->{recsep} x $extras here? while ($extras-- > 0) { @@ -426,6 +508,17 @@ sub _bufsize { $b; } +# Lock the file +sub flock { + my ($self, $op) = @_; + unless (@_ <= 3) { + my $pack = ref $self; + croak "Usage: $pack\->flock([OPERATION])"; + } + my $fh = $self->{fh}; + $op = LOCK_EX unless defined $op; + flock $fh, $op; +} # Given a file, make sure the cache is consistent with the # file contents @@ -499,7 +592,7 @@ Tie::File - Access the lines of a disk file via a Perl array =head1 SYNOPSIS - # This file documents Tie::File version 0.13 + # This file documents Tie::File version 0.14 tie @array, 'Tie::File', filename or die ...; @@ -509,7 +602,12 @@ Tie::File - Access the lines of a disk file via a Perl array $n_recs = @array; # how many records are in the file? $#array = $n_recs - 2; # chop records off the end - # As you would expect + # As you would expect: + + push @array, new recs...; + my $r1 = pop @array; + unshift @array, new recs...; + my $r1 = shift @array; @old_recs = splice @array, 3, 7, new recs...; untie @array; # all finished @@ -628,8 +726,35 @@ The C<tie> call returns an object, say C<$o>. You may call $rec = $o->FETCH($n); $o->STORE($n, $rec); -to fetch or store the record at line C<$n>, respectively. There are -no other public methods in this package. +to fetch or store the record at line C<$n>, respectively. The only other public method in this package is: + +=head2 C<flock> + + $o->flock(MODE) + +will lock the tied file. C<MODE> has the same meaning as the second +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<LOCK_EX>. + +The best way to unlock a file is to discard the object and untie the +array. It is probably unsafe to unlock the file without also untying +it, because if you do, changes may remain unwritten inside the object. +That is why there is no shortcut for unlocking. If you really want to +unlock the file prematurely, you know what to do; if you don't know +what to do, then don't do it. + +All the usual warnings about file locking apply here. In particular, +note that file locking in Perl is B<advisory>, which means that +holding a lock will not prevent anyone else from reading, writing, or +erasing the file; it only prevents them from getting another lock at +the same time. Locks are analogous to green traffic lights: If you +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. =head1 CAVEATS @@ -675,11 +800,22 @@ suggests, for example, that and LRU read-cache is a good tradeoff, even if it requires substantial adjustment following a C<splice> operation. -=head2 Missing Methods +=head1 CAVEATS + +(That's Latin for 'warnings'.) + +The behavior of tied arrays is not precisely the same as for regular +arrays. For example: -The tied array does not yet support C<push>, C<pop>, C<shift>, -C<unshift>, C<splice>, or size-setting via C<$#array = $n>. I will -put these in soon. + undef $a[10]; print "How unusual!\n" if $a[10]; + +C<undef>-ing a C<Tie::File> array element just blanks out the +corresponding record in the file. When you read it back again, you'll +see the record separator (typically, $a[10] will appear to contain +"\n") so the supposedly-C<undef>'ed value will be true. + +There are other minor differences, but in general, the correspondence +is extremely close. =head1 AUTHOR @@ -693,7 +829,7 @@ C<mjd-perl-tiefile-subscribe@plover.com>. =head1 LICENSE -C<Tie::File> version 0.13 is copyright (C) 2002 Mark Jason Dominus. +C<Tie::File> version 0.14 is copyright (C) 2002 Mark Jason Dominus. 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 @@ -718,21 +854,20 @@ For licensing inquiries, contact the author at: =head1 WARRANTY -C<Tie::File> version 0.13 comes with ABSOLUTELY NO WARRANTY. +C<Tie::File> version 0.14 comes with ABSOLUTELY NO WARRANTY. For details, see the license. =head1 TODO -C<push>, C<pop>, C<shift>, C<unshift>. +Tests for default arguments to SPLICE. Tests for CLEAR/EXTEND. +Tests for DELETE/EXISTS. -More tests. (Configuration options, cache flushery. _twrite shoule -be tested separately, because there are a lot of weird special cases -lurking in there.) +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. (Stuff I didn't think of yet.) -File locking. - Deferred writing. (!!!) Paragraph mode? diff --git a/lib/Tie/File/01_gen.t b/lib/Tie/File/01_gen.t index 58c7a9732c..d69d232b67 100644 --- a/lib/Tie/File/01_gen.t +++ b/lib/Tie/File/01_gen.t @@ -77,7 +77,7 @@ sub check_contents { # now check FETCH: my $good = 1; for (0.. $#c) { - $good = 0 unless $a[$_] eq "$c[$_]\n"; + $good = 0 unless $a[$_] eq "$c[$_]$/"; } print (($open && $good) ? "ok $N\n" : "not ok $N # fetch @c\n"); $N++; diff --git a/lib/Tie/File/04_splice.t b/lib/Tie/File/04_splice.t index aae678f664..f8628a2e11 100644 --- a/lib/Tie/File/04_splice.t +++ b/lib/Tie/File/04_splice.t @@ -10,11 +10,10 @@ # Then, it checks the actual contents of the file against the expected # contents. -use lib '/home/mjd/src/perl/Tie-File2/lib'; my $file = "tf$$.txt"; my $data = "rec0$/rec1$/rec2$/"; -print "1..88\n"; +print "1..97\n"; my $N = 1; use Tie::File; @@ -137,6 +136,34 @@ check_contents("rec0$/rec1$/"); 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++; + + + sub init_file { my $data = shift; open F, "> $file" or die $!; diff --git a/lib/Tie/File/07_rv_splice.t b/lib/Tie/File/07_rv_splice.t index aaab1f7d6b..75c8a3af51 100644 --- a/lib/Tie/File/07_rv_splice.t +++ b/lib/Tie/File/07_rv_splice.t @@ -7,7 +7,7 @@ my $file = "tf$$.txt"; my $data = "rec0$/rec1$/rec2$/"; -print "1..45\n"; +print "1..48\n"; my $N = 1; use Tie::File; @@ -130,6 +130,22 @@ check_result(); @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++; + + sub init_file { my $data = shift; open F, "> $file" or die $!; diff --git a/lib/Tie/File/14_lock.t b/lib/Tie/File/14_lock.t new file mode 100644 index 0000000000..a771d8deef --- /dev/null +++ b/lib/Tie/File/14_lock.t @@ -0,0 +1,40 @@ +#!/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! + +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 { + 1 while unlink $file; +} + diff --git a/lib/Tie/File/15_pushpop.t b/lib/Tie/File/15_pushpop.t new file mode 100644 index 0000000000..76fe4c1653 --- /dev/null +++ b/lib/Tie/File/15_pushpop.t @@ -0,0 +1,127 @@ +#!/usr/bin/perl +# +# Check PUSH, POP, SHIF, 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 lib '/home/mjd/src/perl/Tie-File2/lib'; +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 init_file { + my $data = shift; + open F, "> $file" or die $!; + binmode F; + print F $data; + close F; +} + +sub check_contents { + my $x = shift; + local *FH; + my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); + print $integrity ? "ok $N\n" : "not ok $N\n"; + $N++; + my $open = open FH, "< $file"; + binmode FH; + my $a; + { local $/; $a = <FH> } + print (($open && $a eq $x) ? "ok $N\n" : "not ok $N\n"); + $N++; +} + +END { + 1 while unlink $file; +} + |