4 use Carp ':DEFAULT', 'confess';
6 use Fcntl 'O_CREAT', 'O_RDWR', 'LOCK_EX', 'LOCK_SH', 'O_WRONLY', 'O_RDONLY';
7 sub O_ACCMODE () { O_RDONLY | O_RDWR | O_WRONLY }
11 my $DEFAULT_MEMORY_SIZE = 1<<21; # 2 megabytes
12 my $DEFAULT_AUTODEFER_THRESHHOLD = 3; # 3 records
13 my $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD = 65536; # 16 disk blocksful
15 my %good_opt = map {$_ => 1, "-$_" => 1}
16 qw(memory dw_size mode recsep discipline
17 autodefer autochomp autodefer_threshhold);
21 croak "usage: tie \@array, $_[0], filename, [option => value]...";
23 my ($pack, $file, %opts) = @_;
25 # transform '-foo' keys into 'foo' keys
26 for my $key (keys %opts) {
27 unless ($good_opt{$key}) {
28 croak("$pack: Unrecognized option '$key'\n");
31 if ($key =~ s/^-+//) {
32 $opts{$key} = delete $opts{$okey};
36 unless (defined $opts{memory}) {
37 # default is the larger of the default cache size and the
38 # deferred-write buffer size (if specified)
39 $opts{memory} = $DEFAULT_MEMORY_SIZE;
40 $opts{memory} = $opts{dw_size}
41 if defined $opts{dw_size} && $opts{dw_size} > $DEFAULT_MEMORY_SIZE;
44 $opts{dw_size} = $opts{memory} unless defined $opts{dw_size};
45 if ($opts{dw_size} > $opts{memory}) {
46 croak("$pack: dw_size may not be larger than total memory allocation\n");
48 # are we in deferred-write mode?
49 $opts{defer} = 0 unless defined $opts{defer};
50 $opts{deferred} = {}; # no records are presently deferred
51 $opts{deferred_s} = 0; # count of total bytes in ->{deferred}
52 $opts{deferred_max} = -1; # empty
54 # What's a good way to arrange that this class can be overridden?
55 $opts{cache} = Tie::File::Cache->new($opts{memory});
57 # autodeferment is enabled by default
58 $opts{autodefer} = 1 unless defined $opts{autodefer};
59 $opts{autodeferring} = 0; # but is not initially active
60 $opts{ad_history} = [];
61 $opts{autodefer_threshhold} = $DEFAULT_AUTODEFER_THRESHHOLD
62 unless defined $opts{autodefer_threshhold};
63 $opts{autodefer_filelen_threshhold} = $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD
64 unless defined $opts{autodefer_filelen_threshhold};
67 $opts{filename} = $file;
68 unless (defined $opts{recsep}) {
69 $opts{recsep} = _default_recsep();
71 $opts{recseplen} = length($opts{recsep});
72 if ($opts{recseplen} == 0) {
73 croak "Empty record separator not supported by $pack";
76 $opts{autochomp} = 1 unless defined $opts{autochomp};
78 $opts{mode} = O_CREAT|O_RDWR unless defined $opts{mode};
79 $opts{rdonly} = (($opts{mode} & O_ACCMODE) == O_RDONLY);
80 $opts{sawlastrec} = undef;
84 if (UNIVERSAL::isa($file, 'GLOB')) {
85 # We use 1 here on the theory that some systems
86 # may not indicate failure if we use 0.
87 # MSWin32 does not indicate failure with 0, but I don't know if
88 # it will indicate failure with 1 or not.
89 unless (seek $file, 1, SEEK_SET) {
90 croak "$pack: your filehandle does not appear to be seekable";
92 seek $file, 0, SEEK_SET # put it back
93 $fh = $file; # setting binmode is the user's problem
95 croak "usage: tie \@array, $pack, filename, [option => value]...";
98 # perl 5.005 and earlier don't autovivify filehandles
100 $fh = Symbol::gensym();
102 sysopen $fh, $file, $opts{mode}, 0666 or return;
106 { my $ofh = select $fh; $| = 1; select $ofh } # autoflush on write
107 if (defined $opts{discipline} && $] >= 5.006) {
108 # This avoids a compile-time warning under 5.005
109 eval 'binmode($fh, $opts{discipline})';
110 croak $@ if $@ =~ /unknown discipline/i;
115 bless \%opts => $pack;
122 # check the defer buffer
123 $rec = $self->{deferred}{$n} if exists $self->{deferred}{$n};
124 $rec = $self->_fetch($n) unless defined $rec;
127 substr($rec, - $self->{recseplen}) = ""
128 if defined $rec && $self->{autochomp};
132 # Chomp many records in-place; return nothing useful
135 return unless $self->{autochomp};
136 if ($self->{autochomp}) {
139 substr($_, - $self->{recseplen}) = "";
144 # Chomp one record in-place; return modified record
146 my ($self, $rec) = @_;
147 return $rec unless $self->{autochomp};
148 return unless defined $rec;
149 substr($rec, - $self->{recseplen}) = "";
156 # check the record cache
157 { my $cached = $self->{cache}->lookup($n);
158 return $cached if defined $cached;
161 if ($#{$self->{offsets}} < $n) {
162 return if $self->{eof}; # request for record beyond end of file
163 my $o = $self->_fill_offsets_to($n);
164 # If it's still undefined, there is no such record, so return 'undef'
165 return unless defined $o;
168 my $fh = $self->{FH};
169 $self->_seek($n); # we can do this now that offsets is populated
170 my $rec = $self->_read_record;
172 # If we happen to have just read the first record, check to see if
173 # the length of the record matches what 'tell' says. If not, Tie::File
174 # won't work, and should drop dead.
176 # if ($n == 0 && defined($rec) && tell($self->{fh}) != length($rec)) {
177 # if (defined $self->{discipline}) {
178 # croak "I/O discipline $self->{discipline} not supported";
180 # croak "File encoding not supported";
184 $self->{cache}->insert($n, $rec) if defined $rec && not $self->{flushing};
189 my ($self, $n, $rec) = @_;
190 die "STORE called from _check_integrity!" if $DIAGNOSTIC;
192 $self->_fixrecs($rec);
194 if ($self->{autodefer}) {
195 $self->_annotate_ad_history($n);
198 return $self->_store_deferred($n, $rec) if $self->_is_deferring;
201 # We need this to decide whether the new record will fit
202 # It incidentally populates the offsets table
203 # Note we have to do this before we alter the cache
204 # 20020324 Wait, but this DOES alter the cache. TODO BUG?
205 my $oldrec = $self->_fetch($n);
207 if (not defined $oldrec) {
208 # We're storing a record beyond the end of the file
209 $self->_extend_file_to($n+1);
210 $oldrec = $self->{recsep};
212 # return if $oldrec eq $rec; # don't bother
213 my $len_diff = length($rec) - length($oldrec);
215 # length($oldrec) here is not consistent with text mode TODO XXX BUG
216 $self->_mtwrite($rec, $self->{offsets}[$n], length($oldrec));
217 $self->_oadjust([$n, 1, $rec]);
218 $self->{cache}->update($n, $rec);
221 sub _store_deferred {
222 my ($self, $n, $rec) = @_;
223 $self->{cache}->remove($n);
224 my $old_deferred = $self->{deferred}{$n};
226 if (defined $self->{deferred_max} && $n > $self->{deferred_max}) {
227 $self->{deferred_max} = $n;
229 $self->{deferred}{$n} = $rec;
231 my $len_diff = length($rec);
232 $len_diff -= length($old_deferred) if defined $old_deferred;
233 $self->{deferred_s} += $len_diff;
234 $self->{cache}->adj_limit(-$len_diff);
235 if ($self->{deferred_s} > $self->{dw_size}) {
237 } elsif ($self->_cache_too_full) {
242 # Remove a single record from the deferred-write buffer without writing it
243 # The record need not be present
244 sub _delete_deferred {
246 my $rec = delete $self->{deferred}{$n};
247 return unless defined $rec;
249 if (defined $self->{deferred_max}
250 && $n == $self->{deferred_max}) {
251 undef $self->{deferred_max};
254 $self->{deferred_s} -= length $rec;
255 $self->{cache}->adj_limit(length $rec);
260 my $n = $self->{eof} ? $#{$self->{offsets}} : $self->_fill_offsets;
262 my $top_deferred = $self->_defer_max;
263 $n = $top_deferred+1 if defined $top_deferred && $n < $top_deferred+1;
268 my ($self, $len) = @_;
270 if ($self->{autodefer}) {
271 $self->_annotate_ad_history('STORESIZE');
274 my $olen = $self->FETCHSIZE;
275 return if $len == $olen; # Woo-hoo!
279 if ($self->_is_deferring) {
280 for ($olen .. $len-1) {
281 $self->_store_deferred($_, $self->{recsep});
284 $self->_extend_file_to($len);
290 if ($self->_is_deferring) {
291 # TODO maybe replace this with map-plus-assignment?
292 for (grep $_ >= $len, keys %{$self->{deferred}}) {
293 $self->_delete_deferred($_);
295 $self->{deferred_max} = $len-1;
300 $#{$self->{offsets}} = $len;
301 # $self->{offsets}[0] = 0; # in case we just chopped this
303 $self->{cache}->remove(grep $_ >= $len, $self->{cache}->ckeys);
307 ### It should not be necessary to do FETCHSIZE
308 ### Just seek to the end of the file.
311 $self->SPLICE($self->FETCHSIZE, scalar(@_), @_);
314 # $self->FETCHSIZE; # because av.c takes care of this for me
319 my $size = $self->FETCHSIZE;
320 return if $size == 0;
321 # print STDERR "# POPPITY POP POP POP\n";
322 scalar $self->SPLICE($size-1, 1);
327 scalar $self->SPLICE(0, 1);
332 $self->SPLICE(0, 0, @_);
333 # $self->FETCHSIZE; # av.c takes care of this for me
339 if ($self->{autodefer}) {
340 $self->_annotate_ad_history('CLEAR');
345 $self->{cache}->set_limit($self->{memory});
346 $self->{cache}->empty;
347 @{$self->{offsets}} = (0);
348 %{$self->{deferred}}= ();
349 $self->{deferred_s} = 0;
350 $self->{deferred_max} = -1;
356 # No need to pre-extend anything in this case
357 return if $self->_is_deferring;
359 $self->_fill_offsets_to($n);
360 $self->_extend_file_to($n);
366 if ($self->{autodefer}) {
367 $self->_annotate_ad_history('DELETE');
370 my $lastrec = $self->FETCHSIZE-1;
371 my $rec = $self->FETCH($n);
372 $self->_delete_deferred($n) if $self->_is_deferring;
373 if ($n == $lastrec) {
376 $#{$self->{offsets}}--;
377 $self->{cache}->remove($n);
378 # perhaps in this case I should also remove trailing null records?
380 # Note that delete @a[-3..-1] deletes the records in the wrong order,
381 # so we only chop the very last one out of the file. We could repair this
382 # by tracking deleted records inside the object.
383 } elsif ($n < $lastrec) {
384 $self->STORE($n, "");
391 return 1 if exists $self->{deferred}{$n};
392 $n < $self->FETCHSIZE;
398 if ($self->{autodefer}) {
399 $self->_annotate_ad_history('SPLICE');
402 $self->_flush if $self->_is_deferring; # move this up?
404 $self->_chomp(my @a = $self->_splice(@_));
407 $self->_chomp1(scalar $self->_splice(@_));
413 $self->flush if $self->_is_deferring;
414 $self->{cache}->delink if defined $self->{cache}; # break circular link
415 if ($self->{fh} and $self->{ourfh}) {
416 delete $self->{ourfh};
417 close delete $self->{fh};
422 my ($self, $pos, $nrecs, @data) = @_;
425 $pos = 0 unless defined $pos;
427 # Deal with negative and other out-of-range positions
428 # Also set default for $nrecs
430 my $oldsize = $self->FETCHSIZE;
431 $nrecs = $oldsize unless defined $nrecs;
437 croak "Modification of non-creatable array value attempted, subscript $oldpos";
441 if ($pos > $oldsize) {
443 $pos = $oldsize; # This is what perl does for normal arrays
446 # The manual is very unclear here
448 $nrecs = $oldsize - $pos + $nrecs;
449 $nrecs = 0 if $nrecs < 0;
452 # nrecs is too big---it really means "until the end"
454 if ($nrecs + $pos > $oldsize) {
455 $nrecs = $oldsize - $pos;
459 $self->_fixrecs(@data);
460 my $data = join '', @data;
461 my $datalen = length $data;
464 # compute length of data being removed
465 for ($pos .. $pos+$nrecs-1) {
466 last unless defined $self->_fill_offsets_to($_);
467 my $rec = $self->_fetch($_);
468 last unless defined $rec;
471 # Why don't we just use length($rec) here?
472 # Because that record might have come from the cache. _splice
473 # might have been called to flush out the deferred-write records,
474 # and in this case length($rec) is the length of the record to be
475 # *written*, not the length of the actual record in the file. But
476 # the offsets are still true. 20020322
477 $oldlen += $self->{offsets}[$_+1] - $self->{offsets}[$_]
478 if defined $self->{offsets}[$_+1];
480 $self->_fill_offsets_to($pos+$nrecs);
483 $self->_mtwrite($data, $self->{offsets}[$pos], $oldlen);
484 # Adjust the offsets table
485 $self->_oadjust([$pos, $nrecs, @data]);
487 { # Take this read cache stuff out into a separate function
488 # You made a half-attempt to put it into _oadjust.
489 # Finish something like that up eventually.
490 # STORE also needs to do something similarish
492 # update the read cache, part 1
494 for ($pos .. $pos+$nrecs-1) {
495 my $new = $data[$_-$pos];
497 $self->{cache}->update($_, $new);
499 $self->{cache}->remove($_);
503 # update the read cache, part 2
504 # moved records - records past the site of the change
505 # need to be renumbered
506 # Maybe merge this with the previous block?
508 my @oldkeys = grep $_ >= $pos + $nrecs, $self->{cache}->ckeys;
509 my @newkeys = map $_-$nrecs+@data, @oldkeys;
510 $self->{cache}->rekey(\@oldkeys, \@newkeys);
513 # Now there might be too much data in the cache, if we spliced out
514 # some short records and spliced in some long ones. If so, flush
519 # Yes, the return value of 'splice' *is* actually this complicated
520 wantarray ? @result : @result ? $result[-1] : undef;
524 # write data into the file
525 # $data is the data to be written.
526 # it should be written at position $pos, and should overwrite
527 # exactly $len of the following bytes.
528 # Note that if length($data) > $len, the subsequent bytes will have to
529 # be moved up, and if length($data) < $len, they will have to
532 my ($self, $data, $pos, $len) = @_;
534 unless (defined $pos) {
535 die "\$pos was undefined in _twrite";
538 my $len_diff = length($data) - $len;
540 if ($len_diff == 0) { # Woo-hoo!
541 my $fh = $self->{fh};
543 $self->_write_record($data);
544 return; # well, that was easy.
547 # the two records are of different lengths
548 # our strategy here: rewrite the tail of the file,
549 # reading ahead one buffer at a time
550 # $bufsize is required to be at least as large as the data we're overwriting
551 my $bufsize = _bufsize($len_diff);
552 my ($writepos, $readpos) = ($pos, $pos+$len);
556 # Seems like there ought to be a way to avoid the repeated code
557 # and the special case here. The read(1) is also a little weird.
560 $self->_seekb($readpos);
561 my $br = read $self->{fh}, $next_block, $bufsize;
562 $more_data = read $self->{fh}, my($dummy), 1;
563 $self->_seekb($writepos);
564 $self->_write_record($data);
566 $writepos += length $data;
569 $self->_seekb($writepos);
570 $self->_write_record($next_block);
572 # There might be leftover data at the end of the file
573 $self->_chop_file if $len_diff < 0;
577 # Insert text D at position S.
578 # Let C = E-S-|D|. If C < 0; die.
579 # Data in [S,S+C) is copied to [S+D,S+D+C) = [S+D,E).
580 # Data in [S+C = E-D, E) is returned. Data in [E, oo) is untouched.
582 # In a later version, don't read the entire intervening area into
583 # memory at once; do the copying block by block.
586 my ($D, $s, $e) = @_;
589 local *FH = $self->{fh};
590 confess "Not enough space to insert $d bytes between $s and $e"
592 confess "[$s,$e) is an invalid insertion range" if $e < $s;
595 read FH, my $buf, $e-$s;
597 $D .= substr($buf, 0, $c, "");
600 $self->_write_record($D);
605 # Like _twrite, but the data-pos-len triple may be repeated; you may
606 # write several chunks. All the writing will be done in
607 # one pass. Chunks SHALL be in ascending order and SHALL NOT overlap.
614 or die "Arguments to _mtwrite did not come in groups of three";
617 my ($data, $pos, $len) = splice @_, 0, 3;
618 my $end = $pos + $len; # The OLD end of the segment to be replaced
619 $data = $unwritten . $data;
620 $delta -= length($unwritten);
622 $pos += $delta; # This is where the data goes now
623 my $dlen = length $data;
625 if ($len >= $dlen) { # the data will fit
626 $self->_write_record($data);
627 $delta += ($dlen - $len); # everything following moves down by this much
628 $data = ""; # All the data in the buffer has been written
630 my $writable = substr($data, 0, $len - $delta, "");
631 $self->_write_record($writable);
632 $delta += ($dlen - $len); # everything following moves down by this much
635 # At this point we've written some but maybe not all of the data.
636 # There might be a gap to close up, or $data might still contain a
637 # bunch of unwritten data that didn't fit.
638 my $ndlen = length $data;
640 $self->_write_record($data);
641 } elsif ($delta < 0) {
642 # upcopy (close up gap)
644 $self->_upcopy($end, $end + $delta, $_[1] - $end);
646 $self->_upcopy($end, $end + $delta);
649 # downcopy (insert data that didn't fit; replace this data in memory
650 # with _later_ data that doesn't fit)
652 $unwritten = $self->_downcopy($data, $end, $_[1] - $end);
654 # Make the file longer to accomodate the last segment that doesn'
655 $unwritten = $self->_downcopy($data, $end);
661 # Copy block of data of length $len from position $spos to position $dpos
662 # $dpos must be <= $spos
664 # If $len is undefined, go all the way to the end of the file
665 # and then truncate it ($spos - $dpos bytes will be removed)
667 my $blocksize = 8192;
668 my ($self, $spos, $dpos, $len) = @_;
670 die "source ($spos) was upstream of destination ($dpos) in _upcopy";
671 } elsif ($dpos == $spos) {
675 while (! defined ($len) || $len > 0) {
676 my $readsize = ! defined($len) ? $blocksize
677 : $len > $blocksize ? $blocksize
680 my $fh = $self->{fh};
681 $self->_seekb($spos);
682 my $bytes_read = read $fh, my($data), $readsize;
683 $self->_seekb($dpos);
688 $self->_write_record($data);
689 $spos += $bytes_read;
690 $dpos += $bytes_read;
691 $len -= $bytes_read if defined $len;
695 # Write $data into a block of length $len at position $pos,
696 # moving everything in the block forwards to make room.
697 # Instead of writing the last length($data) bytes from the block
698 # (because there isn't room for them any longer) return them.
700 my $blocksize = 8192;
701 my ($self, $data, $pos, $len) = @_;
702 my $fh = $self->{fh};
704 while (! defined $len || $len > 0) {
705 my $readsize = ! defined($len) ? $blocksize
706 : $len > $blocksize? $blocksize : $len;
708 read $fh, my($old), $readsize;
711 my $writable = substr($data, 0, $readsize, "");
712 last if $writable eq "";
713 $self->_write_record($writable);
714 $len -= $readsize if defined $len;
720 # Adjust the object data structures following an '_mtwrite'
722 # [$pos, $nrecs, @length] items
723 # indicating that $nrecs records were removed at $recpos (a record offset)
724 # and replaced with records of length @length...
725 # Arguments guarantee that $recpos is strictly increasing.
735 my ($pos, $nrecs, @data) = @$_;
738 # Adjust the offsets of the records after the previous batch up
739 # to the first new one of this batch
740 for my $i ($prev_end+2 .. $pos - 1) {
741 $self->{offsets}[$i] += $delta;
742 $newkey{$i} = $i + $delta_recs;
745 $prev_end = $pos + @data - 1; # last record moved on this pass
747 # Remove the offsets for the removed records;
748 # replace with the offsets for the inserted records
749 my @newoff = ($self->{offsets}[$pos] + $delta);
750 for my $i (0 .. $#data) {
751 my $newlen = length $data[$i];
752 push @newoff, $newoff[$i] + $newlen;
756 for my $i ($pos .. $pos+$nrecs-1) {
757 last if $i+1 > $#{$self->{offsets}};
758 my $oldlen = $self->{offsets}[$i+1] - $self->{offsets}[$i];
762 # # also this data has changed, so update it in the cache
763 # for (0 .. $#data) {
764 # $self->{cache}->update($pos + $_, $data[$_]);
767 # my @oldkeys = grep $_ >= $pos + @data, $self->{cache}->ckeys;
768 # my @newkeys = map $_ + $delta_recs, @oldkeys;
769 # $self->{cache}->rekey(\@oldkeys, \@newkeys);
772 # replace old offsets with new
773 splice @{$self->{offsets}}, $pos, $nrecs+1, @newoff;
774 # What if we just spliced out the end of the offsets table?
775 # shouldn't we clear $self->{eof}? Test for this XXX BUG TODO
777 $delta_recs += @data - $nrecs; # net change in total number of records
780 # The trailing records at the very end of the file
782 for my $i ($prev_end+2 .. $#{$self->{offsets}}) {
783 $self->{offsets}[$i] += $delta;
787 # If we scrubbed out all known offsets, regenerate the trivial table
788 # that knows that the file does indeed start at 0.
789 $self->{offsets}[0] = 0 unless @{$self->{offsets}};
790 # If the file got longer, the offsets table is no longer complete
791 # $self->{eof} = 0 if $delta_recs > 0;
793 # Now there might be too much data in the cache, if we spliced out
794 # some short records and spliced in some long ones. If so, flush
799 # If a record does not already end with the appropriate terminator
800 # string, append one.
804 $_ = "" unless defined $_;
805 $_ .= $self->{recsep}
806 unless substr($_, - $self->{recseplen}) eq $self->{recsep};
811 ################################################################
813 # Basic read, write, and seek
816 # seek to the beginning of record #$n
817 # Assumes that the offsets table is already correctly populated
819 # Note that $n=-1 has a special meaning here: It means the start of
820 # the last known record; this may or may not be the very last record
821 # in the file, depending on whether the offsets table is fully populated.
825 my $o = $self->{offsets}[$n];
827 or confess("logic error: undefined offset for record $n");
828 seek $self->{fh}, $o, SEEK_SET
829 or confess "Couldn't seek filehandle: $!"; # "Should never happen."
832 # seek to byte $b in the file
835 seek $self->{fh}, $b, SEEK_SET
836 or die "Couldn't seek filehandle: $!"; # "Should never happen."
839 # populate the offsets table up to the beginning of record $n
840 # return the offset of record $n
841 sub _fill_offsets_to {
844 return $self->{offsets}[$n] if $self->{eof};
846 my $fh = $self->{fh};
847 local *OFF = $self->{offsets};
850 until ($#OFF >= $n) {
851 $self->_seek(-1); # tricky -- see comment at _seek
852 $rec = $self->_read_record;
854 push @OFF, int(tell $fh); # Tels says that int() saves memory here
857 return; # It turns out there is no such record
861 # we have now read all the records up to record n-1,
862 # so we can return the offset of record n
869 my $fh = $self->{fh};
870 local *OFF = $self->{offsets};
872 $self->_seek(-1); # tricky -- see comment at _seek
874 # Tels says that inlining read_record() would make this loop
875 # five times faster. 20030508
876 while ( defined $self->_read_record()) {
877 # int() saves us memory here
878 push @OFF, int(tell $fh);
885 # assumes that $rec is already suitably terminated
887 my ($self, $rec) = @_;
888 my $fh = $self->{fh};
891 or die "Couldn't write record: $!"; # "Should never happen."
892 # $self->{_written} += length($rec);
898 { local $/ = $self->{recsep};
899 my $fh = $self->{fh};
902 return unless defined $rec;
903 if (! $self->{sawlastrec} &&
904 substr($rec, -$self->{recseplen}) ne $self->{recsep}) {
905 # improperly terminated final record --- quietly fix it.
906 # my $ac = substr($rec, -$self->{recseplen});
908 $self->{sawlastrec} = 1;
909 unless ($self->{rdonly}) {
911 my $fh = $self->{fh};
912 print $fh $self->{recsep};
914 $rec .= $self->{recsep};
916 # $self->{_read} += length($rec) if defined $rec;
922 @{$self}{'_read', '_written'};
925 ################################################################
927 # Read cache management
931 $self->{cache}->reduce_size_to($self->{memory} - $self->{deferred_s});
934 sub _cache_too_full {
936 $self->{cache}->bytes + $self->{deferred_s} >= $self->{memory};
939 ################################################################
941 # File custodial services
945 # We have read to the end of the file and have the offsets table
946 # entirely populated. Now we need to write a new record beyond
947 # the end of the file. We prepare for this by writing
948 # empty records into the file up to the position we want
950 # assumes that the offsets table already contains the offset of record $n,
951 # if it exists, and extends to the end of the file if not.
952 sub _extend_file_to {
954 $self->_seek(-1); # position after the end of the last record
955 my $pos = $self->{offsets}[-1];
957 # the offsets table has one entry more than the total number of records
958 my $extras = $n - $#{$self->{offsets}};
960 # Todo : just use $self->{recsep} x $extras here?
961 while ($extras-- > 0) {
962 $self->_write_record($self->{recsep});
963 push @{$self->{offsets}}, int(tell $self->{fh});
967 # Truncate the file at the current position
970 truncate $self->{fh}, tell($self->{fh});
974 # compute the size of a buffer suitable for moving
975 # all the data in a file forward $n bytes
976 # ($n may be negative)
977 # The result should be at least $n.
980 return 8192 if $n <= 0;
982 $b += 8192 if $n & 8191;
986 ################################################################
988 # Miscellaneous public methods
993 my ($self, $op) = @_;
995 my $pack = ref $self;
996 croak "Usage: $pack\->flock([OPERATION])";
998 my $fh = $self->{fh};
999 $op = LOCK_EX unless defined $op;
1000 my $locked = flock $fh, $op;
1002 if ($locked && ($op & (LOCK_EX | LOCK_SH))) {
1003 # If you're locking the file, then presumably it's because
1004 # there might have been a write access by another process.
1005 # In that case, the read cache contents and the offsets table
1006 # might be invalid, so discard them. 20030508
1007 $self->{offsets} = [0];
1008 $self->{cache}->empty;
1014 # Get/set autochomp option
1018 my $old = $self->{autochomp};
1019 $self->{autochomp} = shift;
1026 # Get offset table entries; returns offset of nth record
1028 my ($self, $n) = @_;
1030 if ($#{$self->{offsets}} < $n) {
1031 return if $self->{eof}; # request for record beyond the end of file
1032 my $o = $self->_fill_offsets_to($n);
1033 # If it's still undefined, there is no such record, so return 'undef'
1034 return unless defined $o;
1037 $self->{offsets}[$n];
1040 sub discard_offsets {
1042 $self->{offsets} = [0];
1045 ################################################################
1047 # Matters related to deferred writing
1053 $self->_stop_autodeferring;
1054 @{$self->{ad_history}} = ();
1058 # Flush deferred writes
1060 # This could be better optimized to write the file in one pass, instead
1061 # of one pass per block of records. But that will require modifications
1062 # to _twrite, so I should have a good _twrite test suite first.
1072 my @writable = sort {$a<=>$b} (keys %{$self->{deferred}});
1075 # gather all consecutive records from the front of @writable
1076 my $first_rec = shift @writable;
1077 my $last_rec = $first_rec+1;
1078 ++$last_rec, shift @writable while @writable && $last_rec == $writable[0];
1080 $self->_fill_offsets_to($last_rec);
1081 $self->_extend_file_to($last_rec);
1082 $self->_splice($first_rec, $last_rec-$first_rec+1,
1083 @{$self->{deferred}}{$first_rec .. $last_rec});
1086 $self->_discard; # clear out defered-write-cache
1091 my @writable = sort {$a<=>$b} (keys %{$self->{deferred}});
1096 # gather all consecutive records from the front of @writable
1097 my $first_rec = shift @writable;
1098 my $last_rec = $first_rec+1;
1099 ++$last_rec, shift @writable while @writable && $last_rec == $writable[0];
1101 my $end = $self->_fill_offsets_to($last_rec+1);
1102 if (not defined $end) {
1103 $self->_extend_file_to($last_rec);
1104 $end = $self->{offsets}[$last_rec];
1106 my ($start) = $self->{offsets}[$first_rec];
1108 join("", @{$self->{deferred}}{$first_rec .. $last_rec}), # data
1110 $end-$start; # length
1111 push @adjust, [$first_rec, # starting at this position...
1112 $last_rec-$first_rec+1, # this many records...
1113 # are replaced with these...
1114 @{$self->{deferred}}{$first_rec .. $last_rec},
1118 $self->_mtwrite(@args); # write multiple record groups
1119 $self->_discard; # clear out defered-write-cache
1120 $self->_oadjust(@adjust);
1123 # Discard deferred writes and disable future deferred writes
1130 # Discard deferred writes, but retain old deferred writing mode
1133 %{$self->{deferred}} = ();
1134 $self->{deferred_s} = 0;
1135 $self->{deferred_max} = -1;
1136 $self->{cache}->set_limit($self->{memory});
1139 # Deferred writing is enabled, either explicitly ($self->{defer})
1140 # or automatically ($self->{autodeferring})
1143 $self->{defer} || $self->{autodeferring};
1146 # The largest record number of any deferred record
1149 return $self->{deferred_max} if defined $self->{deferred_max};
1151 for my $key (keys %{$self->{deferred}}) {
1152 $max = $key if $key > $max;
1154 $self->{deferred_max} = $max;
1158 ################################################################
1160 # Matters related to autodeferment
1163 # Get/set autodefer option
1167 my $old = $self->{autodefer};
1168 $self->{autodefer} = shift;
1170 $self->_stop_autodeferring;
1171 @{$self->{ad_history}} = ();
1179 # The user is trying to store record #$n Record that in the history,
1180 # and then enable (or disable) autodeferment if that seems useful.
1181 # Note that it's OK for $n to be a non-number, as long as the function
1182 # is prepared to deal with that. Nobody else looks at the ad_history.
1184 # Now, what does the ad_history mean, and what is this function doing?
1185 # Essentially, the idea is to enable autodeferring when we see that the
1186 # user has made three consecutive STORE calls to three consecutive records.
1187 # ("Three" is actually ->{autodefer_threshhold}.)
1188 # A STORE call for record #$n inserts $n into the autodefer history,
1189 # and if the history contains three consecutive records, we enable
1190 # autodeferment. An ad_history of [X, Y] means that the most recent
1191 # STOREs were for records X, X+1, ..., Y, in that order.
1193 # Inserting a nonconsecutive number erases the history and starts over.
1195 # Performing a special operation like SPLICE erases the history.
1197 # There's one special case: CLEAR means that CLEAR was just called.
1198 # In this case, we prime the history with [-2, -1] so that if the next
1199 # write is for record 0, autodeferring goes on immediately. This is for
1200 # the common special case of "@a = (...)".
1202 sub _annotate_ad_history {
1203 my ($self, $n) = @_;
1204 return unless $self->{autodefer}; # feature is disabled
1205 return if $self->{defer}; # already in explicit defer mode
1206 return unless $self->{offsets}[-1] >= $self->{autodefer_filelen_threshhold};
1208 local *H = $self->{ad_history};
1209 if ($n eq 'CLEAR') {
1210 @H = (-2, -1); # prime the history with fake records
1211 $self->_stop_autodeferring;
1212 } elsif ($n =~ /^\d+$/) {
1216 if ($H[1] == $n-1) { # another consecutive record
1218 if ($H[1] - $H[0] + 1 >= $self->{autodefer_threshhold}) {
1219 $self->{autodeferring} = 1;
1221 } else { # nonconsecutive- erase and start over
1223 $self->_stop_autodeferring;
1226 } else { # SPLICE or STORESIZE or some such
1228 $self->_stop_autodeferring;
1232 # If autodeferring was enabled, cut it out and discard the history
1233 sub _stop_autodeferring {
1235 if ($self->{autodeferring}) {
1238 $self->{autodeferring} = 0;
1241 ################################################################
1244 # This is NOT a method. It is here for two reasons:
1245 # 1. To factor a fairly complicated block out of the constructor
1246 # 2. To provide access for the test suite, which need to be sure
1247 # files are being written properly.
1248 sub _default_recsep {
1250 if ($^O eq 'MSWin32') { # Dos too?
1251 # Windows users expect files to be terminated with \r\n
1252 # But $/ is set to \n instead
1253 # Note that this also transforms \n\n into \r\n\r\n.
1254 # That is a feature.
1255 $recsep =~ s/\n/\r\n/g;
1260 # Utility function for _check_integrity
1268 # Given a file, make sure the cache is consistent with the
1269 # file contents and the internal data structures are consistent with
1270 # each other. Returns true if everything checks out, false if not
1272 # The $file argument is no longer used. It is retained for compatibility
1273 # with the existing test suite.
1274 sub _check_integrity {
1275 my ($self, $file, $warn) = @_;
1276 my $rsl = $self->{recseplen};
1277 my $rs = $self->{recsep};
1279 local *_; # local $_ does not work here
1280 local $DIAGNOSTIC = 1;
1282 if (not defined $rs) {
1283 _ci_warn("recsep is undef!");
1285 } elsif ($rs eq "") {
1286 _ci_warn("recsep is empty!");
1288 } elsif ($rsl != length $rs) {
1289 my $ln = length $rs;
1290 _ci_warn("recsep <$rs> has length $ln, should be $rsl");
1294 if (not defined $self->{offsets}[0]) {
1295 _ci_warn("offset 0 is missing!");
1298 } elsif ($self->{offsets}[0] != 0) {
1299 _ci_warn("rec 0: offset <$self->{offsets}[0]> s/b 0!");
1305 local *F = $self->{fh};
1306 seek F, 0, SEEK_SET;
1312 my $cached = $self->{cache}->_produce($n);
1313 my $offset = $self->{offsets}[$.];
1315 if (defined $offset && $offset != $ao) {
1316 _ci_warn("rec $n: offset <$offset> actual <$ao>");
1319 if (defined $cached && $_ ne $cached && ! $self->{deferred}{$n}) {
1321 _ci_warn("rec $n: cached <$cached> actual <$_>");
1323 if (defined $cached && substr($cached, -$rsl) ne $rs) {
1325 _ci_warn("rec $n in the cache is missing the record separator");
1327 if (! defined $offset && $self->{eof}) {
1329 _ci_warn("The offset table was marked complete, but it is missing element $.");
1332 if (@{$self->{offsets}} > $.+1) {
1334 my $n = @{$self->{offsets}};
1335 _ci_warn("The offset table has $n items, but the file has only $.");
1338 my $deferring = $self->_is_deferring;
1339 for my $n ($self->{cache}->ckeys) {
1340 my $r = $self->{cache}->_produce($n);
1341 $cached += length($r);
1342 next if $n+1 <= $.; # checked this already
1343 _ci_warn("spurious caching of record $n");
1346 my $b = $self->{cache}->bytes;
1347 if ($cached != $b) {
1348 _ci_warn("cache size is $b, should be $cached");
1353 # That cache has its own set of tests
1354 $good = 0 unless $self->{cache}->_check_integrity;
1356 # Now let's check the deferbuffer
1357 # Unless deferred writing is enabled, it should be empty
1358 if (! $self->_is_deferring && %{$self->{deferred}}) {
1359 _ci_warn("deferred writing disabled, but deferbuffer nonempty");
1363 # Any record in the deferbuffer should *not* be present in the readcache
1365 while (my ($n, $r) = each %{$self->{deferred}}) {
1366 $deferred_s += length($r);
1367 if (defined $self->{cache}->_produce($n)) {
1368 _ci_warn("record $n is in the deferbuffer *and* the readcache");
1371 if (substr($r, -$rsl) ne $rs) {
1372 _ci_warn("rec $n in the deferbuffer is missing the record separator");
1377 # Total size of deferbuffer should match internal total
1378 if ($deferred_s != $self->{deferred_s}) {
1379 _ci_warn("buffer size is $self->{deferred_s}, should be $deferred_s");
1383 # Total size of deferbuffer should not exceed the specified limit
1384 if ($deferred_s > $self->{dw_size}) {
1385 _ci_warn("buffer size is $self->{deferred_s} which exceeds the limit of $self->{dw_size}");
1389 # Total size of cached data should not exceed the specified limit
1390 if ($deferred_s + $cached > $self->{memory}) {
1391 my $total = $deferred_s + $cached;
1392 _ci_warn("total stored data size is $total which exceeds the limit of $self->{memory}");
1396 # Stuff related to autodeferment
1397 if (!$self->{autodefer} && @{$self->{ad_history}}) {
1398 _ci_warn("autodefer is disabled, but ad_history is nonempty");
1401 if ($self->{autodeferring} && $self->{defer}) {
1402 _ci_warn("both autodeferring and explicit deferring are active");
1405 if (@{$self->{ad_history}} == 0) {
1406 # That's OK, no additional tests required
1407 } elsif (@{$self->{ad_history}} == 2) {
1408 my @non_number = grep !/^-?\d+$/, @{$self->{ad_history}};
1412 $msg = "ad_history contains non-numbers (@{$self->{ad_history}})";
1416 } elsif ($self->{ad_history}[1] < $self->{ad_history}[0]) {
1417 _ci_warn("ad_history has nonsensical values @{$self->{ad_history}}");
1421 _ci_warn("ad_history has bad length <@{$self->{ad_history}}>");
1428 ################################################################
1434 package Tie::File::Cache;
1435 $Tie::File::Cache::VERSION = $Tie::File::VERSION;
1436 use Carp ':DEFAULT', 'confess';
1442 #sub STAT () { 4 } # Array with request statistics for each record
1443 #sub MISS () { 5 } # Total number of cache misses
1444 #sub REQ () { 6 } # Total number of cache requests
1448 my ($pack, $max) = @_;
1450 croak "missing argument to ->new" unless defined $max;
1452 bless $self => $pack;
1453 @$self = (Tie::File::Heap->new($self), {}, $max, 0);
1458 my ($self, $n) = @_;
1463 my ($self, $n) = @_;
1467 # For internal use only
1468 # Will be called by the heap structure to notify us that a certain
1469 # piece of data has moved from one heap element to another.
1470 # $k is the hash key of the item
1471 # $n is the new index into the heap at which it is stored
1472 # If $n is undefined, the item has been removed from the heap.
1474 my ($self, $k, $n) = @_;
1476 $self->[HASH]{$k} = $n;
1478 delete $self->[HASH]{$k};
1483 my ($self, $key, $val) = @_;
1485 croak "missing argument to ->insert" unless defined $key;
1486 unless (defined $self->[MAX]) {
1487 confess "undefined max" ;
1489 confess "undefined val" unless defined $val;
1490 return if length($val) > $self->[MAX];
1492 # if ($self->[STAT]) {
1493 # $self->[STAT][$key] = 1;
1497 my $oldnode = $self->[HASH]{$key};
1498 if (defined $oldnode) {
1499 my $oldval = $self->[HEAP]->set_val($oldnode, $val);
1500 $self->[BYTES] -= length($oldval);
1502 $self->[HEAP]->insert($key, $val);
1504 $self->[BYTES] += length($val);
1505 $self->flush if $self->[BYTES] > $self->[MAX];
1510 my $old_data = $self->[HEAP]->popheap;
1511 return unless defined $old_data;
1512 $self->[BYTES] -= length $old_data;
1517 my ($self, @keys) = @_;
1520 # if ($self->[STAT]) {
1521 # for my $key (@keys) {
1522 # $self->[STAT][$key] = 0;
1527 for my $key (@keys) {
1528 next unless exists $self->[HASH]{$key};
1529 my $old_data = $self->[HEAP]->remove($self->[HASH]{$key});
1530 $self->[BYTES] -= length $old_data;
1531 push @result, $old_data;
1537 my ($self, $key) = @_;
1539 croak "missing argument to ->lookup" unless defined $key;
1541 # if ($self->[STAT]) {
1542 # $self->[MISS]++ if $self->[STAT][$key]++ == 0;
1544 # my $hit_rate = 1 - $self->[MISS] / $self->[REQ];
1545 # # Do some testing to determine this threshhold
1546 # $#$self = STAT - 1 if $hit_rate > 0.20;
1549 if (exists $self->[HASH]{$key}) {
1550 $self->[HEAP]->lookup($self->[HASH]{$key});
1556 # For internal use only
1558 my ($self, $key) = @_;
1559 my $loc = $self->[HASH]{$key};
1560 return unless defined $loc;
1561 $self->[HEAP][$loc][2];
1564 # For internal use only
1566 my ($self, $key) = @_;
1567 $self->[HEAP]->promote($self->[HASH]{$key});
1572 %{$self->[HASH]} = ();
1574 $self->[HEAP]->empty;
1575 # @{$self->[STAT]} = ();
1576 # $self->[MISS] = 0;
1582 keys %{$self->[HASH]} == 0;
1586 my ($self, $key, $val) = @_;
1588 croak "missing argument to ->update" unless defined $key;
1589 if (length($val) > $self->[MAX]) {
1590 my ($oldval) = $self->remove($key);
1591 $self->[BYTES] -= length($oldval) if defined $oldval;
1592 } elsif (exists $self->[HASH]{$key}) {
1593 my $oldval = $self->[HEAP]->set_val($self->[HASH]{$key}, $val);
1594 $self->[BYTES] += length($val);
1595 $self->[BYTES] -= length($oldval) if defined $oldval;
1597 $self->[HEAP]->insert($key, $val);
1598 $self->[BYTES] += length($val);
1604 my ($self, $okeys, $nkeys) = @_;
1607 @map{@$okeys} = @$nkeys;
1608 croak "missing argument to ->rekey" unless defined $nkeys;
1609 croak "length mismatch in ->rekey arguments" unless @$nkeys == @$okeys;
1610 my %adjusted; # map new keys to heap indices
1611 # You should be able to cut this to one loop TODO XXX
1612 for (0 .. $#$okeys) {
1613 $adjusted{$nkeys->[$_]} = delete $self->[HASH]{$okeys->[$_]};
1615 while (my ($nk, $ix) = each %adjusted) {
1616 # @{$self->[HASH]}{keys %adjusted} = values %adjusted;
1617 $self->[HEAP]->rekey($ix, $nk);
1618 $self->[HASH]{$nk} = $ix;
1624 my @a = keys %{$self->[HASH]};
1628 # Return total amount of cached data
1634 # Expire oldest item from cache until cache size is smaller than $max
1635 sub reduce_size_to {
1636 my ($self, $max) = @_;
1637 until ($self->[BYTES] <= $max) {
1638 # Note that Tie::File::Cache::expire has been inlined here
1639 my $old_data = $self->[HEAP]->popheap;
1640 return unless defined $old_data;
1641 $self->[BYTES] -= length $old_data;
1645 # Why not just $self->reduce_size_to($self->[MAX])?
1646 # Try this when things stabilize TODO XXX
1647 # If the cache is too full, expire the oldest records
1650 $self->reduce_size_to($self->[MAX]) if $self->[BYTES] > $self->[MAX];
1653 # For internal use only
1656 $self->[HEAP]->expire_order;
1659 BEGIN { *_ci_warn = \&Tie::File::_ci_warn }
1661 sub _check_integrity { # For CACHE
1666 $self->[HEAP]->_check_integrity or $good = 0;
1670 for my $k (keys %{$self->[HASH]}) {
1671 if ($k ne '0' && $k !~ /^[1-9][0-9]*$/) {
1673 _ci_warn "Cache hash key <$k> is non-numeric";
1676 my $h = $self->[HASH]{$k};
1679 _ci_warn "Heap index number for key $k is undefined";
1682 _ci_warn "Heap index number for key $k is zero";
1684 my $j = $self->[HEAP][$h];
1687 _ci_warn "Heap contents key $k (=> $h) are undefined";
1689 $bytes += length($j->[2]);
1690 if ($k ne $j->[1]) {
1692 _ci_warn "Heap contents key $k (=> $h) is $j->[1], should be $k";
1699 if ($bytes != $self->[BYTES]) {
1701 _ci_warn "Total data in cache is $bytes, expected $self->[BYTES]";
1705 if ($bytes > $self->[MAX]) {
1707 _ci_warn "Total data in cache is $bytes, exceeds maximum $self->[MAX]";
1715 $self->[HEAP] = undef; # Bye bye heap
1718 ################################################################
1722 # Heap data structure for use by cache LRU routines
1724 package Tie::File::Heap;
1725 use Carp ':DEFAULT', 'confess';
1726 $Tie::File::Heap::VERSION = $Tie::File::Cache::VERSION;
1732 my ($pack, $cache) = @_;
1733 die "$pack: Parent cache object $cache does not support _heap_move method"
1734 unless eval { $cache->can('_heap_move') };
1735 my $self = [[0,$cache,0]];
1736 bless $self => $pack;
1739 # Allocate a new sequence number, larger than all previously allocated numbers
1774 $self->[0][0] = 0; # might as well reset the sequence numbers
1777 # notify the parent cache object that we moved something
1780 $self->_cache->_heap_move(@_);
1783 # Insert a piece of data into the heap with the indicated sequence number.
1784 # The item with the smallest sequence number is always at the top.
1785 # If no sequence number is specified, allocate a new one and insert the
1786 # item at the bottom.
1788 my ($self, $key, $data, $seq) = @_;
1789 $seq = $self->_nseq unless defined $seq;
1790 $self->_insert_new([$seq, $key, $data]);
1793 # Insert a new, fresh item at the bottom of the heap
1795 my ($self, $item) = @_;
1797 $i = int($i/2) until defined $self->[$i/2];
1798 $self->[$i] = $item;
1799 $self->[0][1]->_heap_move($self->[$i][KEY], $i);
1803 # Insert [$data, $seq] pair at or below item $i in the heap.
1804 # If $i is omitted, default to 1 (the top element.)
1806 my ($self, $item, $i) = @_;
1807 # $self->_check_loc($i) if defined $i;
1808 $i = 1 unless defined $i;
1809 until (! defined $self->[$i]) {
1810 if ($self->[$i][SEQ] > $item->[SEQ]) { # inserted item is older
1811 ($self->[$i], $item) = ($item, $self->[$i]);
1812 $self->[0][1]->_heap_move($self->[$i][KEY], $i);
1814 # If either is undefined, go that way. Otherwise, choose at random
1816 $dir = 0 if !defined $self->[2*$i];
1817 $dir = 1 if !defined $self->[2*$i+1];
1818 $dir = int(rand(2)) unless defined $dir;
1821 $self->[$i] = $item;
1822 $self->[0][1]->_heap_move($self->[$i][KEY], $i);
1826 # Remove the item at node $i from the heap, moving child items upwards.
1827 # The item with the smallest sequence number is always at the top.
1828 # Moving items upwards maintains this condition.
1829 # Return the removed item. Return undef if there was no item at node $i.
1831 my ($self, $i) = @_;
1832 $i = 1 unless defined $i;
1833 my $top = $self->[$i];
1834 return unless defined $top;
1837 my ($L, $R) = (2*$i, 2*$i+1);
1839 # If either is undefined, go the other way.
1840 # Otherwise, go towards the smallest.
1841 last unless defined $self->[$L] || defined $self->[$R];
1842 $ii = $R if not defined $self->[$L];
1843 $ii = $L if not defined $self->[$R];
1844 unless (defined $ii) {
1845 $ii = $self->[$L][SEQ] < $self->[$R][SEQ] ? $L : $R;
1848 $self->[$i] = $self->[$ii]; # Promote child to fill vacated spot
1849 $self->[0][1]->_heap_move($self->[$i][KEY], $i);
1850 $i = $ii; # Fill new vacated spot
1852 $self->[0][1]->_heap_move($top->[KEY], undef);
1863 # set the sequence number of the indicated item to a higher number
1864 # than any other item in the heap, and bubble the item down to the
1867 my ($self, $n) = @_;
1868 # $self->_check_loc($n);
1869 $self->[$n][SEQ] = $self->_nseq;
1872 my ($L, $R) = (2*$i, 2*$i+1);
1874 last unless defined $self->[$L] || defined $self->[$R];
1875 $dir = $R unless defined $self->[$L];
1876 $dir = $L unless defined $self->[$R];
1877 unless (defined $dir) {
1878 $dir = $self->[$L][SEQ] < $self->[$R][SEQ] ? $L : $R;
1880 @{$self}[$i, $dir] = @{$self}[$dir, $i];
1882 $self->[0][1]->_heap_move($self->[$_][KEY], $_) if defined $self->[$_];
1888 # Return item $n from the heap, promoting its LRU status
1890 my ($self, $n) = @_;
1891 # $self->_check_loc($n);
1892 my $val = $self->[$n];
1898 # Assign a new value for node $n, promoting it to the bottom of the heap
1900 my ($self, $n, $val) = @_;
1901 # $self->_check_loc($n);
1902 my $oval = $self->[$n][DAT];
1903 $self->[$n][DAT] = $val;
1908 # The hask key has changed for an item;
1909 # alter the heap's record of the hash key
1911 my ($self, $n, $new_key) = @_;
1912 # $self->_check_loc($n);
1913 $self->[$n][KEY] = $new_key;
1917 my ($self, $n) = @_;
1918 unless (1 || defined $self->[$n]) {
1919 confess "_check_loc($n) failed";
1923 BEGIN { *_ci_warn = \&Tie::File::_ci_warn }
1925 sub _check_integrity {
1930 unless (eval {$self->[0][1]->isa("Tie::File::Cache")}) {
1931 _ci_warn "Element 0 of heap corrupt";
1934 $good = 0 unless $self->_satisfies_heap_condition(1);
1935 for my $i (2 .. $#{$self}) {
1936 my $p = int($i/2); # index of parent node
1937 if (defined $self->[$i] && ! defined $self->[$p]) {
1938 _ci_warn "Element $i of heap defined, but parent $p isn't";
1942 if (defined $self->[$i]) {
1943 if ($seq{$self->[$i][SEQ]}) {
1944 my $seq = $self->[$i][SEQ];
1945 _ci_warn "Nodes $i and $seq{$seq} both have SEQ=$seq";
1948 $seq{$self->[$i][SEQ]} = $i;
1956 sub _satisfies_heap_condition {
1962 next unless defined $self->[$c];
1963 if ($self->[$n][SEQ] >= $self->[$c]) {
1964 _ci_warn "Node $n of heap does not predate node $c";
1967 $good = 0 unless $self->_satisfies_heap_condition($c);
1972 # Return a list of all the values, sorted by expiration order
1975 my @nodes = sort {$a->[SEQ] <=> $b->[SEQ]} $self->_nodes;
1976 map { $_->[KEY] } @nodes;
1982 return unless defined $self->[$i];
1983 ($self->[$i], $self->_nodes($i*2), $self->_nodes($i*2+1));
1986 "Cogito, ergo sum."; # don't forget to return a true value from the file
1992 Tie::File - Access the lines of a disk file via a Perl array
1996 # This file documents Tie::File version 0.95
1999 tie @array, 'Tie::File', filename or die ...;
2001 $array[13] = 'blah'; # line 13 of the file is now 'blah'
2002 print $array[42]; # display line 42 of the file
2004 $n_recs = @array; # how many records are in the file?
2005 $#array -= 2; # chop two records off the end
2009 s/PERL/Perl/g; # Replace PERL with Perl everywhere in the file
2012 # These are just like regular push, pop, unshift, shift, and splice
2013 # Except that they modify the file in the way you would expect
2015 push @array, new recs...;
2016 my $r1 = pop @array;
2017 unshift @array, new recs...;
2018 my $r2 = shift @array;
2019 @old_recs = splice @array, 3, 7, new recs...;
2021 untie @array; # all finished
2026 C<Tie::File> represents a regular text file as a Perl array. Each
2027 element in the array corresponds to a record in the file. The first
2028 line of the file is element 0 of the array; the second line is element
2031 The file is I<not> loaded into memory, so this will work even for
2034 Changes to the array are reflected in the file immediately.
2036 Lazy people and beginners may now stop reading the manual.
2040 What is a 'record'? By default, the meaning is the same as for the
2041 C<E<lt>...E<gt>> operator: It's a string terminated by C<$/>, which is
2042 probably C<"\n">. (Minor exception: on DOS and Win32 systems, a
2043 'record' is a string terminated by C<"\r\n">.) You may change the
2044 definition of "record" by supplying the C<recsep> option in the C<tie>
2047 tie @array, 'Tie::File', $file, recsep => 'es';
2049 This says that records are delimited by the string C<es>. If the file
2050 contained the following data:
2052 Curse these pesky flies!\n
2054 then the C<@array> would appear to have four elements:
2061 An undefined value is not permitted as a record separator. Perl's
2062 special "paragraph mode" semantics (E<agrave> la C<$/ = "">) are not
2065 Records read from the tied array do not have the record separator
2066 string on the end; this is to allow
2068 $array[17] .= "extra";
2070 to work as expected.
2072 (See L<"autochomp">, below.) Records stored into the array will have
2073 the record separator string appended before they are written to the
2074 file, if they don't have one already. For example, if the record
2075 separator string is C<"\n">, then the following two lines do exactly
2078 $array[17] = "Cherry pie";
2079 $array[17] = "Cherry pie\n";
2081 The result is that the contents of line 17 of the file will be
2082 replaced with "Cherry pie"; a newline character will separate line 17
2083 from line 18. This means that this code will do nothing:
2087 Because the C<chomp>ed value will have the separator reattached when
2088 it is written back to the file. There is no way to create a file
2089 whose trailing record separator string is missing.
2091 Inserting records that I<contain> the record separator string is not
2092 supported by this module. It will probably produce a reasonable
2093 result, but what this result will be may change in a future version.
2094 Use 'splice' to insert records or to replace one record with several.
2098 Normally, array elements have the record separator removed, so that if
2099 the file contains the text
2105 the tied array will appear to contain C<("Gold", "Frankincense",
2106 "Myrrh")>. If you set C<autochomp> to a false value, the record
2107 separator will not be removed. If the file above was tied with
2109 tie @gifts, "Tie::File", $gifts, autochomp => 0;
2111 then the array C<@gifts> would appear to contain C<("Gold\n",
2112 "Frankincense\n", "Myrrh\n")>, or (on Win32 systems) C<("Gold\r\n",
2113 "Frankincense\r\n", "Myrrh\r\n")>.
2117 Normally, the specified file will be opened for read and write access,
2118 and will be created if it does not exist. (That is, the flags
2119 C<O_RDWR | O_CREAT> are supplied in the C<open> call.) If you want to
2120 change this, you may supply alternative flags in the C<mode> option.
2121 See L<Fcntl> for a listing of available flags.
2124 # open the file if it exists, but fail if it does not exist
2126 tie @array, 'Tie::File', $file, mode => O_RDWR;
2128 # create the file if it does not exist
2129 use Fcntl 'O_RDWR', 'O_CREAT';
2130 tie @array, 'Tie::File', $file, mode => O_RDWR | O_CREAT;
2132 # open an existing file in read-only mode
2133 use Fcntl 'O_RDONLY';
2134 tie @array, 'Tie::File', $file, mode => O_RDONLY;
2136 Opening the data file in write-only or append mode is not supported.
2140 This is an upper limit on the amount of memory that C<Tie::File> will
2141 consume at any time while managing the file. This is used for two
2142 things: managing the I<read cache> and managing the I<deferred write
2145 Records read in from the file are cached, to avoid having to re-read
2146 them repeatedly. If you read the same record twice, the first time it
2147 will be stored in memory, and the second time it will be fetched from
2148 the I<read cache>. The amount of data in the read cache will not
2149 exceed the value you specified for C<memory>. If C<Tie::File> wants
2150 to cache a new record, but the read cache is full, it will make room
2151 by expiring the least-recently visited records from the read cache.
2153 The default memory limit is 2Mib. You can adjust the maximum read
2154 cache size by supplying the C<memory> option. The argument is the
2155 desired cache size, in bytes.
2157 # I have a lot of memory, so use a large cache to speed up access
2158 tie @array, 'Tie::File', $file, memory => 20_000_000;
2160 Setting the memory limit to 0 will inhibit caching; records will be
2161 fetched from disk every time you examine them.
2163 The C<memory> value is not an absolute or exact limit on the memory
2164 used. C<Tie::File> objects contains some structures besides the read
2165 cache and the deferred write buffer, whose sizes are not charged
2168 The cache itself consumes about 310 bytes per cached record, so if
2169 your file has many short records, you may want to decrease the cache
2170 memory limit, or else the cache overhead may exceed the size of the
2176 (This is an advanced feature. Skip this section on first reading.)
2178 If you use deferred writing (See L<"Deferred Writing">, below) then
2179 data you write into the array will not be written directly to the
2180 file; instead, it will be saved in the I<deferred write buffer> to be
2181 written out later. Data in the deferred write buffer is also charged
2182 against the memory limit you set with the C<memory> option.
2184 You may set the C<dw_size> option to limit the amount of data that can
2185 be saved in the deferred write buffer. This limit may not exceed the
2186 total memory limit. For example, if you set C<dw_size> to 1000 and
2187 C<memory> to 2500, that means that no more than 1000 bytes of deferred
2188 writes will be saved up. The space available for the read cache will
2189 vary, but it will always be at least 1500 bytes (if the deferred write
2190 buffer is full) and it could grow as large as 2500 bytes (if the
2191 deferred write buffer is empty.)
2193 If you don't specify a C<dw_size>, it defaults to the entire memory
2196 =head2 Option Format
2198 C<-mode> is a synonym for C<mode>. C<-recsep> is a synonym for
2199 C<recsep>. C<-memory> is a synonym for C<memory>. You get the
2202 =head1 Public Methods
2204 The C<tie> call returns an object, say C<$o>. You may call
2206 $rec = $o->FETCH($n);
2207 $o->STORE($n, $rec);
2209 to fetch or store the record at line C<$n>, respectively; similarly
2210 the other tied array methods. (See L<perltie> for details.) You may
2211 also call the following methods on this object:
2217 will lock the tied file. C<MODE> has the same meaning as the second
2218 argument to the Perl built-in C<flock> function; for example
2219 C<LOCK_SH> or C<LOCK_EX | LOCK_NB>. (These constants are provided by
2220 the C<use Fcntl ':flock'> declaration.)
2222 C<MODE> is optional; the default is C<LOCK_EX>.
2224 C<Tie::File> maintains an internal table of the byte offset of each
2225 record it has seen in the file.
2227 When you use C<flock> to lock the file, C<Tie::File> assumes that the
2228 read cache is no longer trustworthy, because another process might
2229 have modified the file since the last time it was read. Therefore, a
2230 successful call to C<flock> discards the contents of the read cache
2231 and the internal record offset table.
2233 C<Tie::File> promises that the following sequence of operations will
2236 my $o = tie @array, "Tie::File", $filename;
2239 In particular, C<Tie::File> will I<not> read or write the file during
2240 the C<tie> call. (Exception: Using C<mode =E<gt> O_TRUNC> will, of
2241 course, erase the file during the C<tie> call. If you want to do this
2242 safely, then open the file without C<O_TRUNC>, lock the file, and use
2245 The best way to unlock a file is to discard the object and untie the
2246 array. It is probably unsafe to unlock the file without also untying
2247 it, because if you do, changes may remain unwritten inside the object.
2248 That is why there is no shortcut for unlocking. If you really want to
2249 unlock the file prematurely, you know what to do; if you don't know
2250 what to do, then don't do it.
2252 All the usual warnings about file locking apply here. In particular,
2253 note that file locking in Perl is B<advisory>, which means that
2254 holding a lock will not prevent anyone else from reading, writing, or
2255 erasing the file; it only prevents them from getting another lock at
2256 the same time. Locks are analogous to green traffic lights: If you
2257 have a green light, that does not prevent the idiot coming the other
2258 way from plowing into you sideways; it merely guarantees to you that
2259 the idiot does not also have a green light at the same time.
2263 my $old_value = $o->autochomp(0); # disable autochomp option
2264 my $old_value = $o->autochomp(1); # enable autochomp option
2266 my $ac = $o->autochomp(); # recover current value
2268 See L<"autochomp">, above.
2270 =head2 C<defer>, C<flush>, C<discard>, and C<autodefer>
2272 See L<"Deferred Writing">, below.
2276 $off = $o->offset($n);
2278 This method returns the byte offset of the start of the C<$n>th record
2279 in the file. If there is no such record, it returns an undefined
2282 =head1 Tying to an already-opened filehandle
2284 If C<$fh> is a filehandle, such as is returned by C<IO::File> or one
2285 of the other C<IO> modules, you may use:
2287 tie @array, 'Tie::File', $fh, ...;
2289 Similarly if you opened that handle C<FH> with regular C<open> or
2290 C<sysopen>, you may use:
2292 tie @array, 'Tie::File', \*FH, ...;
2294 Handles that were opened write-only won't work. Handles that were
2295 opened read-only will work as long as you don't try to modify the
2296 array. Handles must be attached to seekable sources of data---that
2297 means no pipes or sockets. If C<Tie::File> can detect that you
2298 supplied a non-seekable handle, the C<tie> call will throw an
2299 exception. (On Unix systems, it can detect this.)
2301 Note that Tie::File will only close any filehandles that it opened
2302 internally. If you passed it a filehandle as above, you "own" the
2303 filehandle, and are responsible for closing it after you have untied
2306 =head1 Deferred Writing
2308 (This is an advanced feature. Skip this section on first reading.)
2310 Normally, modifying a C<Tie::File> array writes to the underlying file
2311 immediately. Every assignment like C<$a[3] = ...> rewrites as much of
2312 the file as is necessary; typically, everything from line 3 through
2313 the end will need to be rewritten. This is the simplest and most
2314 transparent behavior. Performance even for large files is reasonably
2317 However, under some circumstances, this behavior may be excessively
2318 slow. For example, suppose you have a million-record file, and you
2325 The first time through the loop, you will rewrite the entire file,
2326 from line 0 through the end. The second time through the loop, you
2327 will rewrite the entire file from line 1 through the end. The third
2328 time through the loop, you will rewrite the entire file from line 2 to
2331 If the performance in such cases is unacceptable, you may defer the
2332 actual writing, and then have it done all at once. The following loop
2333 will perform much better for large files:
2341 If C<Tie::File>'s memory limit is large enough, all the writing will
2342 done in memory. Then, when you call C<-E<gt>flush>, the entire file
2343 will be rewritten in a single pass.
2345 (Actually, the preceding discussion is something of a fib. You don't
2346 need to enable deferred writing to get good performance for this
2347 common case, because C<Tie::File> will do it for you automatically
2348 unless you specifically tell it not to. See L<"autodeferring">,
2351 Calling C<-E<gt>flush> returns the array to immediate-write mode. If
2352 you wish to discard the deferred writes, you may call C<-E<gt>discard>
2353 instead of C<-E<gt>flush>. Note that in some cases, some of the data
2354 will have been written already, and it will be too late for
2355 C<-E<gt>discard> to discard all the changes. Support for
2356 C<-E<gt>discard> may be withdrawn in a future version of C<Tie::File>.
2358 Deferred writes are cached in memory up to the limit specified by the
2359 C<dw_size> option (see above). If the deferred-write buffer is full
2360 and you try to write still more deferred data, the buffer will be
2361 flushed. All buffered data will be written immediately, the buffer
2362 will be emptied, and the now-empty space will be used for future
2365 If the deferred-write buffer isn't yet full, but the total size of the
2366 buffer and the read cache would exceed the C<memory> limit, the oldest
2367 records will be expired from the read cache until the total size is
2370 C<push>, C<pop>, C<shift>, C<unshift>, and C<splice> cannot be
2371 deferred. When you perform one of these operations, any deferred data
2372 is written to the file and the operation is performed immediately.
2373 This may change in a future version.
2375 If you resize the array with deferred writing enabled, the file will
2376 be resized immediately, but deferred records will not be written.
2377 This has a surprising consequence: C<@a = (...)> erases the file
2378 immediately, but the writing of the actual data is deferred. This
2379 might be a bug. If it is a bug, it will be fixed in a future version.
2381 =head2 Autodeferring
2383 C<Tie::File> tries to guess when deferred writing might be helpful,
2384 and to turn it on and off automatically.
2390 In this example, only the first two assignments will be done
2391 immediately; after this, all the changes to the file will be deferred
2392 up to the user-specified memory limit.
2394 You should usually be able to ignore this and just use the module
2395 without thinking about deferring. However, special applications may
2396 require fine control over which writes are deferred, or may require
2397 that all writes be immediate. To disable the autodeferment feature,
2400 (tied @o)->autodefer(0);
2404 tie @array, 'Tie::File', $file, autodefer => 0;
2407 Similarly, C<-E<gt>autodefer(1)> re-enables autodeferment, and
2408 C<-E<gt>autodefer()> recovers the current value of the autodefer setting.
2411 =head1 CONCURRENT ACCESS TO FILES
2413 Caching and deferred writing are inappropriate if you want the same
2414 file to be accessed simultaneously from more than one process. You
2415 will want to disable these features. You should do that by including
2416 the C<memory =E<gt> 0> option in your C<tie> calls; this will inhibit
2417 caching and deferred writing.
2419 You will also want to lock the file while reading or writing it. You
2420 can use the C<-E<gt>flock> method for this. A future version of this
2421 module may provide an 'autolocking' mode.
2425 (That's Latin for 'warnings'.)
2431 Reasonable effort was made to make this module efficient. Nevertheless,
2432 changing the size of a record in the middle of a large file will
2433 always be fairly slow, because everything after the new record must be
2438 The behavior of tied arrays is not precisely the same as for regular
2439 arrays. For example:
2441 # This DOES print "How unusual!"
2442 undef $a[10]; print "How unusual!\n" if defined $a[10];
2444 C<undef>-ing a C<Tie::File> array element just blanks out the
2445 corresponding record in the file. When you read it back again, you'll
2446 get the empty string, so the supposedly-C<undef>'ed value will be
2447 defined. Similarly, if you have C<autochomp> disabled, then
2449 # This DOES print "How unusual!" if 'autochomp' is disabled
2451 print "How unusual!\n" if $a[10];
2453 Because when C<autochomp> is disabled, C<$a[10]> will read back as
2454 C<"\n"> (or whatever the record separator string is.)
2456 There are other minor differences, particularly regarding C<exists>
2457 and C<delete>, but in general, the correspondence is extremely close.
2461 I have supposed that since this module is concerned with file I/O,
2462 almost all normal use of it will be heavily I/O bound. This means
2463 that the time to maintain complicated data structures inside the
2464 module will be dominated by the time to actually perform the I/O.
2465 When there was an opportunity to spend CPU time to avoid doing I/O, I
2466 usually tried to take it.
2470 You might be tempted to think that deferred writing is like
2471 transactions, with C<flush> as C<commit> and C<discard> as
2472 C<rollback>, but it isn't, so don't.
2476 There is a large memory overhead for each record offset and for each
2477 cache entry: about 310 bytes per cached data record, and about 21 bytes per offset table entry.
2479 The per-record overhead will limit the maximum number of records you
2480 can access per file. Note that I<accessing> the length of the array
2481 via C<$x = scalar @tied_file> accesses B<all> records and stores their
2482 offsets. The same for C<foreach (@tied_file)>, even if you exit the
2489 This version promises absolutely nothing about the internals, which
2490 may change without notice. A future version of the module will have a
2491 well-defined and stable subclassing API.
2493 =head1 WHAT ABOUT C<DB_File>?
2495 People sometimes point out that L<DB_File> will do something similar,
2496 and ask why C<Tie::File> module is necessary.
2498 There are a number of reasons that you might prefer C<Tie::File>.
2499 A list is available at C<http://perl.plover.com/TieFile/why-not-DB_File>.
2505 To contact the author, send email to: C<mjd-perl-tiefile+@plover.com>
2507 To receive an announcement whenever a new version of this module is
2508 released, send a blank email message to
2509 C<mjd-perl-tiefile-subscribe@plover.com>.
2511 The most recent version of this module, including documentation and
2512 any news of importance, will be available at
2514 http://perl.plover.com/TieFile/
2519 C<Tie::File> version 0.95 is copyright (C) 2002 Mark Jason Dominus.
2521 This library is free software; you may redistribute it and/or modify
2522 it under the same terms as Perl itself.
2524 These terms are your choice of any of (1) the Perl Artistic Licence,
2525 or (2) version 2 of the GNU General Public License as published by the
2526 Free Software Foundation, or (3) any later version of the GNU General
2529 This library is distributed in the hope that it will be useful,
2530 but WITHOUT ANY WARRANTY; without even the implied warranty of
2531 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2532 GNU General Public License for more details.
2534 You should have received a copy of the GNU General Public License
2535 along with this library program; it should be in the file C<COPYING>.
2536 If not, write to the Free Software Foundation, Inc., 59 Temple Place,
2537 Suite 330, Boston, MA 02111 USA
2539 For licensing inquiries, contact the author at:
2543 Philadelphia, PA 19107
2547 C<Tie::File> version 0.95 comes with ABSOLUTELY NO WARRANTY.
2548 For details, see the license.
2552 Gigantic thanks to Jarkko Hietaniemi, for agreeing to put this in the
2553 core when I hadn't written it yet, and for generally being helpful,
2554 supportive, and competent. (Usually the rule is "choose any one.")
2555 Also big thanks to Abhijit Menon-Sen for all of the same things.
2557 Special thanks to Craig Berry and Peter Prymmer (for VMS portability
2558 help), Randy Kobes (for Win32 portability help), Clinton Pierce and
2559 Autrijus Tang (for heroic eleventh-hour Win32 testing above and beyond
2560 the call of duty), Michael G Schwern (for testing advice), and the
2561 rest of the CPAN testers (for testing generally).
2563 Special thanks to Tels for suggesting several speed and memory
2566 Additional thanks to:
2570 Jarkko Hietaniemi (again) /
2574 Tassilo von Parseval /
2580 Autrijus Tang (again) /
2586 More tests. (Stuff I didn't think of yet.)
2590 Fixed-length mode. Leave-blanks mode.
2592 Maybe an autolocking mode?
2594 For many common uses of the module, the read cache is a liability.
2595 For example, a program that inserts a single record, or that scans the
2596 file once, will have a cache hit rate of zero. This suggests a major
2597 optimization: The cache should be initially disabled. Here's a hybrid
2598 approach: Initially, the cache is disabled, but the cache code
2599 maintains statistics about how high the hit rate would be *if* it were
2600 enabled. When it sees the hit rate get high enough, it enables
2601 itself. The STAT comments in this code are the beginning of an
2602 implementation of this.
2604 Record locking with fcntl()? Then the module might support an undo
2605 log and get real transactions. What a tour de force that would be.
2607 Keeping track of the highest cached record. This would allow reads-in-a-row
2608 to skip the cache lookup faster (if reading from 1..N with empty cache at
2609 start, the last cached value will be always N-1).