lib/Tie/File/t/19_cache.t Test for Tie::File.
lib/Tie/File/t/20_cache_full.t Test for Tie::File.
lib/Tie/File/t/21_win32.t Test for Tie::File.
+lib/Tie/File/t/22_autochomp.t Test for Tie::File.
+lib/Tie/File/t/23_rv_ac_splice.t Test for Tie::File.
lib/Tie/Handle.pm Base class for tied handles
lib/Tie/Handle/stdhandle.t Test for Tie::StdHandle
lib/Tie/Hash.pm Base class for tied hashes
use Fcntl 'O_CREAT', 'O_RDWR', 'LOCK_EX';
require 5.005;
-$VERSION = "0.19";
+$VERSION = "0.20";
# Idea: The object will always contain an array of byte offsets
# this will be filled in as is necessary and convenient.
my $DEFAULT_MEMORY_SIZE = 1<<21; # 2 megabytes
my %good_opt = map {$_ => 1, "-$_" => 1}
- qw(memory dw_size mode recsep discipline);
+ qw(memory dw_size mode recsep discipline autochomp);
sub TIEARRAY {
if (@_ % 2 != 0) {
croak "Empty record separator not supported by $pack";
}
+ $opts{autochomp} = 1 unless defined $opts{autochomp};
+
my $mode = defined($opts{mode}) ? $opts{mode} : O_CREAT|O_RDWR;
my $fh;
sub FETCH {
my ($self, $n) = @_;
+ $self->_chomp1($self->_fetch($n));
+}
+
+# Chomp many records in-place; return nothing useful
+sub _chomp {
+ my $self = shift;
+ return unless $self->{autochomp};
+ if ($self->{autochomp}) {
+ for (@_) {
+ next unless defined;
+ substr($_, - $self->{recseplen}) = "";
+ }
+ }
+}
+
+# Chomp one record in-place; return modified record
+sub _chomp1 {
+ my ($self, $rec) = @_;
+ return $rec unless $self->{autochomp};
+ return unless defined $rec;
+ substr($rec, - $self->{recseplen}) = "";
+ $rec;
+}
+
+sub _fetch {
+ my ($self, $n) = @_;
# check the record cache
{ my $cached = $self->_check_cache($n);
# We need this to decide whether the new record will fit
# It incidentally populates the offsets table
# Note we have to do this before we alter the cache
- my $oldrec = $self->FETCH($n);
+ my $oldrec = $self->_fetch($n);
# _check_cache promotes record $n to MRU. Is this correct behavior?
if (my $cached = $self->_check_cache($n)) {
sub SPLICE {
my $self = shift;
$self->_flush if $self->{defer};
- $self->_splice(@_);
+ if (wantarray) {
+ $self->_chomp(my @a = $self->_splice(@_));
+ @a;
+ } else {
+ $self->_chomp1(scalar $self->_splice(@_));
+ }
}
sub DESTROY {
# compute length of data being removed
# Incidentally fills offsets table
for ($pos .. $pos+$nrecs-1) {
- my $rec = $self->FETCH($_);
+ my $rec = $self->_fetch($_);
last unless defined $rec;
push @result, $rec;
$oldlen += length($rec);
$self->{defer} = 1;
}
+# Get/set autochomp option
+sub autochomp {
+ my $self = shift;
+ if (@_) {
+ my $old = $self->{autochomp};
+ $self->{autochomp} = shift;
+ $old;
+ } else {
+ $self->{autochomp};
+ }
+}
+
# Flush deferred writes
#
# This could be better optimized to write the file in one pass, instead
=head1 SYNOPSIS
- # This file documents Tie::File version 0.19
+ # This file documents Tie::File version 0.20
tie @array, 'Tie::File', filename or die ...;
then the C<@array> would appear to have four elements:
- "Curse thes"
- "e pes"
- "ky flies"
+ "Curse th"
+ "e p"
+ "ky fli"
"!\n"
An undefined value is not permitted as a record separator. Perl's
special "paragraph mode" semantics (E<agrave> la C<$/ = "">) are not
emulated.
-Records read from the tied array will have the record separator string
-on the end, just as if they were read from the C<E<lt>...E<gt>>
-operator. Records stored into the array will have the record
-separator string appended before they are written to the file, if they
-don't have one already. For example, if the record separator string
-is C<"\n">, then the following two lines do exactly the same thing:
+Records read from the tied array do not have the record separator
+string on the end; this is to allow
+
+ $array[17] .= "extra";
+
+to work as expected.
+
+(See L<"autochomp">, below.) Records stored into the array will have
+the record separator string appended before they are written to the
+file, if they don't have one already. For example, if the record
+separator string is C<"\n">, then the following two lines do exactly
+the same thing:
$array[17] = "Cherry pie";
$array[17] = "Cherry pie\n";
produce a reasonable result, but if you can't foresee what this result
will be, you'd better avoid doing this.
+=head2 C<autochomp>
+
+Normally, array elements have the record separator removed, so that if
+the file contains the text
+
+ Gold
+ Frankincense
+ Myrrh
+
+the tied array will appear to contain C<("Gold", "Frankincense", "Myrrh")>.
+If you set C<autochomp> to a false value, the record separator will not be removed. If the file above was tied with
+
+ tie @gifts, "Tie::File", $gifts, autochomp => 0;
+
+then the array C<@gifts> would appear to contain C<("Gold\n",
+"Frankincense\n", "Myrrh\n")>, or (on Win32 systems) C<("Gold\r\n",
+"Frankincense\r\n", "Myrrh\r\n")>.
+
=head2 C<mode>
Normally, the specified file will be opened for read and write access,
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
+=head2 C<autochomp>
+
+ my $old_value = $o->autochomp(0); # disable autochomp option
+ my $old_value = $o->autochomp(1); # enable autochomp option
+
+ my $ac = $o->autochomp(); # recover current value
+
+See L<"autochomp">, above.
+
+=head1 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:
=head1 LICENSE
-C<Tie::File> version 0.19 is copyright (C) 2002 Mark Jason Dominus.
+C<Tie::File> version 0.20 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.
=head1 WARRANTY
-C<Tie::File> version 0.19 comes with ABSOLUTELY NO WARRANTY.
+C<Tie::File> version 0.20 comes with ABSOLUTELY NO WARRANTY.
For details, see the license.
=head1 THANKS
use Tie::File;
-if ($Tie::File::VERSION != 0.19) {
+if ($Tie::File::VERSION != 0.20) {
print STDERR "
WHOA THERE!!
You seem to be running version $Tie::File::VERSION of the module against
-version 0.19 of the test suite!
+version 0.20 of the test suite!
None of the other test results will be reliable.
";
use Tie::File;
print "ok $N\n"; $N++;
-my $o = tie @a, 'Tie::File', $file;
+my $o = tie @a, 'Tie::File', $file, autochomp => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;
my $good = 1;
my $msg;
for (0.. $#c) {
- unless ($a[$_] eq "$c[$_]$:") {
- $msg = "expected $c[$_]$:, got $a[$_]";
+ my $aa = $a[$_];
+ unless ($aa eq "$c[$_]$:") {
+ $msg = "expected <$c[$_]$:>, got <$aa>";
ctrlfix($msg);
$good = 0;
}
close F;
-my $o = tie @a, 'Tie::File', $file;
+my $o = tie @a, 'Tie::File', $file, autochomp => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;
# Make sure we can fetch a record in the middle of the file
# before we've ever looked at any records before it
#
+# Make sure fetching past the end of the file returns the undefined value
+#
# (tests _fill_offsets_to() )
#
$: = Tie::File::_default_recsep();
my $data = "rec0$:rec1$:rec2$:";
-print "1..5\n";
+print "1..8\n";
my $N = 1;
use Tie::File;
close F;
-my $o = tie @a, 'Tie::File', $file;
+my $o = tie @a, 'Tie::File', $file, autochomp => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;
# 3-5
for (2, 1, 0) {
- print $a[$_] eq "rec$_$:" ? "ok $N\n" : "not ok $N # rec=$a[$_] ?\n";
+ my $rec = $a[$_];
+ print $rec eq "rec$_$:" ? "ok $N\n" : "not ok $N # rec=<$rec> ?\n";
+ $N++;
+}
+
+# 6-8
+for (3, 4, 6) {
+ my $rec = $a[$_];
+ print ((not defined $rec) ? "ok $N\n" : "not ok $N # rec=<$rec> is defined\n");
$N++;
}
# (04_splice.t checks its effect on the file)
#
+
my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();
my $data = "rec0$:rec1$:rec2$:";
init_file($data);
-my $o = tie @a, 'Tie::File', $file;
+my $o = tie @a, 'Tie::File', $file, autochomp => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;
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";
+print !defined($r) ? "ok $N\n" : "not ok $N \# return should have been undef, was <$r>\n";
$N++;
$r = splice(@a, 2, 1);
-print $r eq "pie$:" ? "ok $N\n" : "not ok $N \# return should have been 'pie'\n";
+print $r eq "pie$:" ? "ok $N\n" : "not ok $N \# return should have been 'pie\\n', was <$r>\n";
$N++;
$r = splice(@a, 0, 2);
-print $r eq "like$:" ? "ok $N\n" : "not ok $N \# return should have been 'like'\n";
+print $r eq "like$:" ? "ok $N\n" : "not ok $N \# return should have been 'like\\n', was <$r>\n";
$N++;
# (49-50) Test default arguments
my @items = qw(Gold Frankincense Myrrh Ivory Apes Peacocks);
init_file(join $:, @items, '');
-my $o = tie @a, 'Tie::File', $file, mode => O_RDONLY;
+my $o = tie @a, 'Tie::File', $file, mode => O_RDONLY, autochomp => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;
use Tie::File;
print "ok $N\n"; $N++;
-my $o = tie @a, 'Tie::File', $file, recsep => 'blah';
+my $o = tie @a, 'Tie::File', $file, recsep => 'blah', autochomp => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;
init_file($data);
-my $o = tie @a, 'Tie::File', $file, recsep => 'blah';
+my $o = tie @a, 'Tie::File', $file, autochomp => 0, recsep => 'blah';
print $o ? "ok $N\n" : "not ok $N\n";
$N++;
close F;
-my $o = tie @a, 'Tie::File', $file, recsep => 'blah';
+my $o = tie @a, 'Tie::File', $file, autochomp => 0, recsep => 'blah';
print $o ? "ok $N\n" : "not ok $N\n";
$N++;
use Tie::File;
print "ok $N\n"; $N++; # partial credit just for showing up
-my $o = tie @a, 'Tie::File', $file;
+my $o = tie @a, 'Tie::File', $file, autochomp => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;
my ($n, @r);
or die "Couldn't create temp file $file: $!; aborting";
binmode F;
-my $o = tie @a, 'Tie::File', \*F;
+my $o = tie @a, 'Tie::File', \*F, autochomp => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;
--- /dev/null
+#!/usr/bin/perl
+
+my $file = "tf$$.txt";
+$: = Tie::File::_default_recsep();
+
+print "1..71\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++;
+
+my $o = tie @a, 'Tie::File', $file, autochomp => 1;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+# 3-5 create
+$a[0] = 'rec0';
+check_contents("rec0");
+
+# 6-11 append
+$a[1] = 'rec1';
+check_contents("rec0", "rec1");
+$a[2] = 'rec2';
+check_contents("rec0", "rec1", "rec2");
+
+# 12-20 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");
+
+# 21-35 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");
+
+# 36-50 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");
+
+# (51-56) file with holes
+$a[4] = 'rec4';
+check_contents("sh0", "sh1", "short2", "", "rec4");
+$a[3] = 'rec3';
+check_contents("sh0", "sh1", "short2", "rec3", "rec4");
+
+# (57-59) zero out file
+@a = ();
+check_contents();
+
+# (60-62) insert into the middle of an empty file
+$a[3] = "rec3";
+check_contents("", "", "", "rec3");
+
+# (63-68) Test the ->autochomp() method
+@a = qw(Gold Frankincense Myrrh);
+my $ac;
+$ac = $o->autochomp();
+expect($ac);
+# See if that accidentally changed it
+$ac = $o->autochomp();
+expect($ac);
+# Now clear it
+$ac = $o->autochomp(0);
+expect($ac);
+expect(join("-", @a), "Gold$:-Frankincense$:-Myrrh$:");
+# Now set it again
+$ac = $o->autochomp(1);
+expect(!$ac);
+expect(join("-", @a), "Gold-Frankincense-Myrrh");
+
+# (69) Does 'splice' work correctly with autochomp?
+my @sr;
+@sr = splice @a, 0, 2;
+expect(join("-", @sr), "Gold-Frankincense");
+
+# (70-71) Didn't you forget that fetch may return an unchomped cached record?
+$a1 = $a[0]; # populate cache
+$a2 = $a[0];
+expect($a1, "Myrrh");
+expect($a2, "Myrrh");
+# Actually no, you didn't---_fetch might return such a record, but
+# the chomping is done by FETCH.
+
+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 {
+ ctrlfix($a, $x);
+ print "not ok $N\n# expected <$x>, got <$a>\n";
+ }
+ $N++;
+
+ # now check FETCH:
+ my $good = 1;
+ my $msg;
+ for (0.. $#c) {
+ my $aa = $a[$_];
+ unless ($aa eq $c[$_]) {
+ $msg = "expected <$c[$_]>, got <$aa>";
+ ctrlfix($msg);
+ $good = 0;
+ }
+ }
+ 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++;
+}
+
+sub expect {
+ if (@_ == 1) {
+ print $_[0] ? "ok $N\n" : "not ok $N\n";
+ } elsif (@_ == 2) {
+ my ($a, $x) = @_;
+ if ($a eq $x) { print "ok $N\n" }
+ else {
+ ctrlfix(my $msg = "expected <$x>, got <$a>");
+ print "not ok $N # $msg\n";
+ }
+ } else {
+ die "expect() got ", scalar(@_), " args, should have been 1 or 2";
+ }
+ $N++;
+}
+
+sub ctrlfix {
+ for (@_) {
+ s/\n/\\n/g;
+ s/\r/\\r/g;
+ }
+}
+
+END {
+ undef $o;
+ untie @a;
+ 1 while unlink $file;
+}
+
--- /dev/null
+#!/usr/bin/perl
+#
+# Check SPLICE function's return value when autochoping is now
+# (07_rv_splice.t checks it aith autochomping off)
+#
+
+my $file = "tf$$.txt";
+$: = Tie::File::_default_recsep();
+my $data = "rec0$:rec1$:rec2$:";
+
+print "1..50\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++; # partial credit just for showing up
+
+init_file($data);
+
+my $o = tie @a, 'Tie::File', $file, autochomp => 1;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+my $n;
+
+# (3-12) splicing at the beginning
+@r = splice(@a, 0, 0, "rec4");
+check_result();
+@r = splice(@a, 0, 1, "rec5"); # same length
+check_result("rec4");
+@r = splice(@a, 0, 1, "record5"); # longer
+check_result("rec5");
+
+@r = splice(@a, 0, 1, "r5"); # shorter
+check_result("record5");
+@r = splice(@a, 0, 1); # removal
+check_result("r5");
+@r = splice(@a, 0, 0); # no-op
+check_result();
+@r = splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one
+check_result();
+@r = splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_result('r7', 'rec8');
+
+@r = splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert
+check_result('rec7', 'record8', 'rec9');
+@r = splice(@a, 0, 2); # delete more than one
+check_result('record9', 'rec10');
+
+
+# (13-22) splicing in the middle
+@r = splice(@a, 1, 0, "rec4");
+check_result();
+@r = splice(@a, 1, 1, "rec5"); # same length
+check_result('rec4');
+@r = splice(@a, 1, 1, "record5"); # longer
+check_result('rec5');
+
+@r = splice(@a, 1, 1, "r5"); # shorter
+check_result("record5");
+@r = splice(@a, 1, 1); # removal
+check_result("r5");
+@r = splice(@a, 1, 0); # no-op
+check_result();
+@r = splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one
+check_result();
+@r = splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_result('r7', 'rec8');
+
+@r = splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert
+check_result('rec7', 'record8', 'rec9');
+@r = splice(@a, 1, 2); # delete more than one
+check_result('record9','rec10');
+
+# (23-32) splicing at the end
+@r = splice(@a, 3, 0, "rec4");
+check_result();
+@r = splice(@a, 3, 1, "rec5"); # same length
+check_result('rec4');
+@r = splice(@a, 3, 1, "record5"); # longer
+check_result('rec5');
+
+@r = splice(@a, 3, 1, "r5"); # shorter
+check_result('record5');
+@r = splice(@a, 3, 1); # removal
+check_result('r5');
+@r = splice(@a, 3, 0); # no-op
+check_result();
+@r = splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one
+check_result();
+@r = splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_result('r7', 'rec8');
+
+@r = splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert
+check_result('rec7', 'record8', 'rec9');
+@r = splice(@a, 3, 2); # delete more than one
+check_result('record9', 'rec10');
+
+# (33-42) splicing with negative subscript
+@r = splice(@a, -1, 0, "rec4");
+check_result();
+@r = splice(@a, -1, 1, "rec5"); # same length
+check_result('rec2');
+@r = splice(@a, -1, 1, "record5"); # longer
+check_result("rec5");
+
+@r = splice(@a, -1, 1, "r5"); # shorter
+check_result("record5");
+@r = splice(@a, -1, 1); # removal
+check_result("r5");
+@r = splice(@a, -1, 0); # no-op
+check_result();
+@r = splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one
+check_result();
+@r = splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
+check_result('rec4');
+
+@r = splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert
+check_result('rec7', 'record8', 'rec9');
+@r = splice(@a, -4, 3); # delete more than one
+check_result('r7', 'rec8', 'record9');
+
+# (43) scrub it all out
+@r = splice(@a, 0, 3);
+check_result('rec0', 'rec1', 'rec10');
+
+# (44) put some back in
+@r = splice(@a, 0, 0, "rec0", "rec1");
+check_result();
+
+# (45) what if we remove too many records?
+@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, was <$r>\n";
+$N++;
+
+$r = splice(@a, 2, 1);
+print $r eq "pie" ? "ok $N\n" : "not ok $N \# return should have been 'pie', was <$r>\n";
+$N++;
+
+$r = splice(@a, 0, 2);
+print $r eq "like" ? "ok $N\n" : "not ok $N \# return should have been 'like', was <$r>\n";
+$N++;
+
+# (49-50) Test default arguments
+splice @a, 0, 0, (0..11);
+@r = splice @a, 4;
+check_result(4..11);
+@r = splice @a;
+check_result(0..3);
+
+sub init_file {
+ my $data = shift;
+ open F, "> $file" or die $!;
+ binmode F;
+ print F $data;
+ close F;
+}
+
+# actual results are in @r.
+# expected results are in @_
+sub check_result {
+ my @x = @_;
+ my $good = 1;
+ $good = 0 unless @r == @x;
+ for my $i (0 .. $#r) {
+ $good = 0 unless $r[$i] eq $x[$i];
+ }
+ print $good ? "ok $N\n" : "not ok $N \# was (@r); should be (@x)\n";
+ $N++;
+}
+
+END {
+ undef $o;
+ untie @a;
+ 1 while unlink $file;
+}
+
projects / p5sagit/p5-mst-13.2.git / commitdiff