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.
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);
# file gets longer
if ($len > $olen) {
- $self->_extend_file_to($len-1); # record numbers from 0 .. $len-1
+ $self->_extend_file_to($len);
return;
}
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;
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;
$oldlen += length($rec);
}
- $self->_fill_offsets_to($pos);
+ # Modify the file
$self->_twrite($data, $self->{offsets}[$pos], $oldlen);
# update the offsets table part 1
# 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
}
@{$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
# $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;
$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
}
# 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) {
$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
=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 ...;
$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
$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
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
=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
=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?
--- /dev/null
+#!/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;
+}
+
projects / p5sagit/p5-mst-13.2.git / commitdiff