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]...";
97 $fh = \do { local *FH }; # only works in 5.005 and later
98 sysopen $fh, $file, $opts{mode}, 0666 or return;
101 { my $ofh = select $fh; $| = 1; select $ofh } # autoflush on write
102 if (defined $opts{discipline} && $] >= 5.006) {
103 # This avoids a compile-time warning under 5.005
104 eval 'binmode($fh, $opts{discipline})';
105 croak $@ if $@ =~ /unknown discipline/i;
110 bless \%opts => $pack;
117 # check the defer buffer
118 $rec = $self->{deferred}{$n} if exists $self->{deferred}{$n};
119 $rec = $self->_fetch($n) unless defined $rec;
122 substr($rec, - $self->{recseplen}) = ""
123 if defined $rec && $self->{autochomp};
127 # Chomp many records in-place; return nothing useful
130 return unless $self->{autochomp};
131 if ($self->{autochomp}) {
134 substr($_, - $self->{recseplen}) = "";
139 # Chomp one record in-place; return modified record
141 my ($self, $rec) = @_;
142 return $rec unless $self->{autochomp};
143 return unless defined $rec;
144 substr($rec, - $self->{recseplen}) = "";
151 # check the record cache
152 { my $cached = $self->{cache}->lookup($n);
153 return $cached if defined $cached;
156 if ($#{$self->{offsets}} < $n) {
157 return if $self->{eof}; # request for record beyond end of file
158 my $o = $self->_fill_offsets_to($n);
159 # If it's still undefined, there is no such record, so return 'undef'
160 return unless defined $o;
163 my $fh = $self->{FH};
164 $self->_seek($n); # we can do this now that offsets is populated
165 my $rec = $self->_read_record;
167 # If we happen to have just read the first record, check to see if
168 # the length of the record matches what 'tell' says. If not, Tie::File
169 # won't work, and should drop dead.
171 # if ($n == 0 && defined($rec) && tell($self->{fh}) != length($rec)) {
172 # if (defined $self->{discipline}) {
173 # croak "I/O discipline $self->{discipline} not supported";
175 # croak "File encoding not supported";
179 $self->{cache}->insert($n, $rec) if defined $rec && not $self->{flushing};
184 my ($self, $n, $rec) = @_;
185 die "STORE called from _check_integrity!" if $DIAGNOSTIC;
187 $self->_fixrecs($rec);
189 if ($self->{autodefer}) {
190 $self->_annotate_ad_history($n);
193 return $self->_store_deferred($n, $rec) if $self->_is_deferring;
196 # We need this to decide whether the new record will fit
197 # It incidentally populates the offsets table
198 # Note we have to do this before we alter the cache
199 # 20020324 Wait, but this DOES alter the cache. TODO BUG?
200 my $oldrec = $self->_fetch($n);
202 if (not defined $oldrec) {
203 # We're storing a record beyond the end of the file
204 $self->_extend_file_to($n+1);
205 $oldrec = $self->{recsep};
207 # return if $oldrec eq $rec; # don't bother
208 my $len_diff = length($rec) - length($oldrec);
210 # length($oldrec) here is not consistent with text mode TODO XXX BUG
211 $self->_mtwrite($rec, $self->{offsets}[$n], length($oldrec));
212 $self->_oadjust([$n, 1, $rec]);
213 $self->{cache}->update($n, $rec);
216 sub _store_deferred {
217 my ($self, $n, $rec) = @_;
218 $self->{cache}->remove($n);
219 my $old_deferred = $self->{deferred}{$n};
221 if (defined $self->{deferred_max} && $n > $self->{deferred_max}) {
222 $self->{deferred_max} = $n;
224 $self->{deferred}{$n} = $rec;
226 my $len_diff = length($rec);
227 $len_diff -= length($old_deferred) if defined $old_deferred;
228 $self->{deferred_s} += $len_diff;
229 $self->{cache}->adj_limit(-$len_diff);
230 if ($self->{deferred_s} > $self->{dw_size}) {
232 } elsif ($self->_cache_too_full) {
237 # Remove a single record from the deferred-write buffer without writing it
238 # The record need not be present
239 sub _delete_deferred {
241 my $rec = delete $self->{deferred}{$n};
242 return unless defined $rec;
244 if (defined $self->{deferred_max}
245 && $n == $self->{deferred_max}) {
246 undef $self->{deferred_max};
249 $self->{deferred_s} -= length $rec;
250 $self->{cache}->adj_limit(length $rec);
255 my $n = $self->{eof} ? $#{$self->{offsets}} : $self->_fill_offsets;
257 my $top_deferred = $self->_defer_max;
258 $n = $top_deferred+1 if defined $top_deferred && $n < $top_deferred+1;
263 my ($self, $len) = @_;
265 if ($self->{autodefer}) {
266 $self->_annotate_ad_history('STORESIZE');
269 my $olen = $self->FETCHSIZE;
270 return if $len == $olen; # Woo-hoo!
274 if ($self->_is_deferring) {
275 for ($olen .. $len-1) {
276 $self->_store_deferred($_, $self->{recsep});
279 $self->_extend_file_to($len);
285 if ($self->_is_deferring) {
286 # TODO maybe replace this with map-plus-assignment?
287 for (grep $_ >= $len, keys %{$self->{deferred}}) {
288 $self->_delete_deferred($_);
290 $self->{deferred_max} = $len-1;
295 $#{$self->{offsets}} = $len;
296 # $self->{offsets}[0] = 0; # in case we just chopped this
298 $self->{cache}->remove(grep $_ >= $len, $self->{cache}->ckeys);
302 ### It should not be necessary to do FETCHSIZE
303 ### Just seek to the end of the file.
306 $self->SPLICE($self->FETCHSIZE, scalar(@_), @_);
309 # $self->FETCHSIZE; # because av.c takes care of this for me
314 my $size = $self->FETCHSIZE;
315 return if $size == 0;
316 # print STDERR "# POPPITY POP POP POP\n";
317 scalar $self->SPLICE($size-1, 1);
322 scalar $self->SPLICE(0, 1);
327 $self->SPLICE(0, 0, @_);
328 # $self->FETCHSIZE; # av.c takes care of this for me
334 if ($self->{autodefer}) {
335 $self->_annotate_ad_history('CLEAR');
340 $self->{cache}->set_limit($self->{memory});
341 $self->{cache}->empty;
342 @{$self->{offsets}} = (0);
343 %{$self->{deferred}}= ();
344 $self->{deferred_s} = 0;
345 $self->{deferred_max} = -1;
351 # No need to pre-extend anything in this case
352 return if $self->_is_deferring;
354 $self->_fill_offsets_to($n);
355 $self->_extend_file_to($n);
361 if ($self->{autodefer}) {
362 $self->_annotate_ad_history('DELETE');
365 my $lastrec = $self->FETCHSIZE-1;
366 my $rec = $self->FETCH($n);
367 $self->_delete_deferred($n) if $self->_is_deferring;
368 if ($n == $lastrec) {
371 $#{$self->{offsets}}--;
372 $self->{cache}->remove($n);
373 # perhaps in this case I should also remove trailing null records?
375 # Note that delete @a[-3..-1] deletes the records in the wrong order,
376 # so we only chop the very last one out of the file. We could repair this
377 # by tracking deleted records inside the object.
378 } elsif ($n < $lastrec) {
379 $self->STORE($n, "");
386 return 1 if exists $self->{deferred}{$n};
387 $n < $self->FETCHSIZE;
393 if ($self->{autodefer}) {
394 $self->_annotate_ad_history('SPLICE');
397 $self->_flush if $self->_is_deferring; # move this up?
399 $self->_chomp(my @a = $self->_splice(@_));
402 $self->_chomp1(scalar $self->_splice(@_));
408 $self->flush if $self->_is_deferring;
409 $self->{cache}->delink if defined $self->{cache}; # break circular link
413 my ($self, $pos, $nrecs, @data) = @_;
416 $pos = 0 unless defined $pos;
418 # Deal with negative and other out-of-range positions
419 # Also set default for $nrecs
421 my $oldsize = $self->FETCHSIZE;
422 $nrecs = $oldsize unless defined $nrecs;
428 croak "Modification of non-creatable array value attempted, subscript $oldpos";
432 if ($pos > $oldsize) {
434 $pos = $oldsize; # This is what perl does for normal arrays
437 # The manual is very unclear here
439 $nrecs = $oldsize - $pos + $nrecs;
440 $nrecs = 0 if $nrecs < 0;
443 # nrecs is too big---it really means "until the end"
445 if ($nrecs + $pos > $oldsize) {
446 $nrecs = $oldsize - $pos;
450 $self->_fixrecs(@data);
451 my $data = join '', @data;
452 my $datalen = length $data;
455 # compute length of data being removed
456 for ($pos .. $pos+$nrecs-1) {
457 last unless defined $self->_fill_offsets_to($_);
458 my $rec = $self->_fetch($_);
459 last unless defined $rec;
462 # Why don't we just use length($rec) here?
463 # Because that record might have come from the cache. _splice
464 # might have been called to flush out the deferred-write records,
465 # and in this case length($rec) is the length of the record to be
466 # *written*, not the length of the actual record in the file. But
467 # the offsets are still true. 20020322
468 $oldlen += $self->{offsets}[$_+1] - $self->{offsets}[$_]
469 if defined $self->{offsets}[$_+1];
471 $self->_fill_offsets_to($pos+$nrecs);
474 $self->_mtwrite($data, $self->{offsets}[$pos], $oldlen);
475 # Adjust the offsets table
476 $self->_oadjust([$pos, $nrecs, @data]);
478 { # Take this read cache stuff out into a separate function
479 # You made a half-attempt to put it into _oadjust.
480 # Finish something like that up eventually.
481 # STORE also needs to do something similarish
483 # update the read cache, part 1
485 for ($pos .. $pos+$nrecs-1) {
486 my $new = $data[$_-$pos];
488 $self->{cache}->update($_, $new);
490 $self->{cache}->remove($_);
494 # update the read cache, part 2
495 # moved records - records past the site of the change
496 # need to be renumbered
497 # Maybe merge this with the previous block?
499 my @oldkeys = grep $_ >= $pos + $nrecs, $self->{cache}->ckeys;
500 my @newkeys = map $_-$nrecs+@data, @oldkeys;
501 $self->{cache}->rekey(\@oldkeys, \@newkeys);
504 # Now there might be too much data in the cache, if we spliced out
505 # some short records and spliced in some long ones. If so, flush
510 # Yes, the return value of 'splice' *is* actually this complicated
511 wantarray ? @result : @result ? $result[-1] : undef;
515 # write data into the file
516 # $data is the data to be written.
517 # it should be written at position $pos, and should overwrite
518 # exactly $len of the following bytes.
519 # Note that if length($data) > $len, the subsequent bytes will have to
520 # be moved up, and if length($data) < $len, they will have to
523 my ($self, $data, $pos, $len) = @_;
525 unless (defined $pos) {
526 die "\$pos was undefined in _twrite";
529 my $len_diff = length($data) - $len;
531 if ($len_diff == 0) { # Woo-hoo!
532 my $fh = $self->{fh};
534 $self->_write_record($data);
535 return; # well, that was easy.
538 # the two records are of different lengths
539 # our strategy here: rewrite the tail of the file,
540 # reading ahead one buffer at a time
541 # $bufsize is required to be at least as large as the data we're overwriting
542 my $bufsize = _bufsize($len_diff);
543 my ($writepos, $readpos) = ($pos, $pos+$len);
547 # Seems like there ought to be a way to avoid the repeated code
548 # and the special case here. The read(1) is also a little weird.
551 $self->_seekb($readpos);
552 my $br = read $self->{fh}, $next_block, $bufsize;
553 $more_data = read $self->{fh}, my($dummy), 1;
554 $self->_seekb($writepos);
555 $self->_write_record($data);
557 $writepos += length $data;
560 $self->_seekb($writepos);
561 $self->_write_record($next_block);
563 # There might be leftover data at the end of the file
564 $self->_chop_file if $len_diff < 0;
568 # Insert text D at position S.
569 # Let C = E-S-|D|. If C < 0; die.
570 # Data in [S,S+C) is copied to [S+D,S+D+C) = [S+D,E).
571 # Data in [S+C = E-D, E) is returned. Data in [E, oo) is untouched.
573 # In a later version, don't read the entire intervening area into
574 # memory at once; do the copying block by block.
577 my ($D, $s, $e) = @_;
580 local *FH = $self->{fh};
581 confess "Not enough space to insert $d bytes between $s and $e"
583 confess "[$s,$e) is an invalid insertion range" if $e < $s;
586 read FH, my $buf, $e-$s;
588 $D .= substr($buf, 0, $c, "");
591 $self->_write_record($D);
596 # Like _twrite, but the data-pos-len triple may be repeated; you may
597 # write several chunks. All the writing will be done in
598 # one pass. Chunks SHALL be in ascending order and SHALL NOT overlap.
605 or die "Arguments to _mtwrite did not come in groups of three";
608 my ($data, $pos, $len) = splice @_, 0, 3;
609 my $end = $pos + $len; # The OLD end of the segment to be replaced
610 $data = $unwritten . $data;
611 $delta -= length($unwritten);
613 $pos += $delta; # This is where the data goes now
614 my $dlen = length $data;
616 if ($len >= $dlen) { # the data will fit
617 $self->_write_record($data);
618 $delta += ($dlen - $len); # everything following moves down by this much
619 $data = ""; # All the data in the buffer has been written
621 my $writable = substr($data, 0, $len - $delta, "");
622 $self->_write_record($writable);
623 $delta += ($dlen - $len); # everything following moves down by this much
626 # At this point we've written some but maybe not all of the data.
627 # There might be a gap to close up, or $data might still contain a
628 # bunch of unwritten data that didn't fit.
629 my $ndlen = length $data;
631 $self->_write_record($data);
632 } elsif ($delta < 0) {
633 # upcopy (close up gap)
635 $self->_upcopy($end, $end + $delta, $_[1] - $end);
637 $self->_upcopy($end, $end + $delta);
640 # downcopy (insert data that didn't fit; replace this data in memory
641 # with _later_ data that doesn't fit)
643 $unwritten = $self->_downcopy($data, $end, $_[1] - $end);
645 # Make the file longer to accomodate the last segment that doesn'
646 $unwritten = $self->_downcopy($data, $end);
652 # Copy block of data of length $len from position $spos to position $dpos
653 # $dpos must be <= $spos
655 # If $len is undefined, go all the way to the end of the file
656 # and then truncate it ($spos - $dpos bytes will be removed)
658 my $blocksize = 8192;
659 my ($self, $spos, $dpos, $len) = @_;
661 die "source ($spos) was upstream of destination ($dpos) in _upcopy";
662 } elsif ($dpos == $spos) {
666 while (! defined ($len) || $len > 0) {
667 my $readsize = ! defined($len) ? $blocksize
668 : $len > $blocksize ? $blocksize
671 my $fh = $self->{fh};
672 $self->_seekb($spos);
673 my $bytes_read = read $fh, my($data), $readsize;
674 $self->_seekb($dpos);
679 $self->_write_record($data);
680 $spos += $bytes_read;
681 $dpos += $bytes_read;
682 $len -= $bytes_read if defined $len;
686 # Write $data into a block of length $len at position $pos,
687 # moving everything in the block forwards to make room.
688 # Instead of writing the last length($data) bytes from the block
689 # (because there isn't room for them any longer) return them.
691 my $blocksize = 8192;
692 my ($self, $data, $pos, $len) = @_;
693 my $fh = $self->{fh};
695 while (! defined $len || $len > 0) {
696 my $readsize = ! defined($len) ? $blocksize
697 : $len > $blocksize? $blocksize : $len;
699 read $fh, my($old), $readsize;
702 my $writable = substr($data, 0, $readsize, "");
703 last if $writable eq "";
704 $self->_write_record($writable);
705 $len -= $readsize if defined $len;
711 # Adjust the object data structures following an '_mtwrite'
713 # [$pos, $nrecs, @length] items
714 # indicating that $nrecs records were removed at $recpos (a record offset)
715 # and replaced with records of length @length...
716 # Arguments guarantee that $recpos is strictly increasing.
726 my ($pos, $nrecs, @data) = @$_;
729 # Adjust the offsets of the records after the previous batch up
730 # to the first new one of this batch
731 for my $i ($prev_end+2 .. $pos - 1) {
732 $self->{offsets}[$i] += $delta;
733 $newkey{$i} = $i + $delta_recs;
736 $prev_end = $pos + @data - 1; # last record moved on this pass
738 # Remove the offsets for the removed records;
739 # replace with the offsets for the inserted records
740 my @newoff = ($self->{offsets}[$pos] + $delta);
741 for my $i (0 .. $#data) {
742 my $newlen = length $data[$i];
743 push @newoff, $newoff[$i] + $newlen;
747 for my $i ($pos .. $pos+$nrecs-1) {
748 last if $i+1 > $#{$self->{offsets}};
749 my $oldlen = $self->{offsets}[$i+1] - $self->{offsets}[$i];
753 # # also this data has changed, so update it in the cache
754 # for (0 .. $#data) {
755 # $self->{cache}->update($pos + $_, $data[$_]);
758 # my @oldkeys = grep $_ >= $pos + @data, $self->{cache}->ckeys;
759 # my @newkeys = map $_ + $delta_recs, @oldkeys;
760 # $self->{cache}->rekey(\@oldkeys, \@newkeys);
763 # replace old offsets with new
764 splice @{$self->{offsets}}, $pos, $nrecs+1, @newoff;
765 # What if we just spliced out the end of the offsets table?
766 # shouldn't we clear $self->{eof}? Test for this XXX BUG TODO
768 $delta_recs += @data - $nrecs; # net change in total number of records
771 # The trailing records at the very end of the file
773 for my $i ($prev_end+2 .. $#{$self->{offsets}}) {
774 $self->{offsets}[$i] += $delta;
778 # If we scrubbed out all known offsets, regenerate the trivial table
779 # that knows that the file does indeed start at 0.
780 $self->{offsets}[0] = 0 unless @{$self->{offsets}};
781 # If the file got longer, the offsets table is no longer complete
782 # $self->{eof} = 0 if $delta_recs > 0;
784 # Now there might be too much data in the cache, if we spliced out
785 # some short records and spliced in some long ones. If so, flush
790 # If a record does not already end with the appropriate terminator
791 # string, append one.
795 $_ = "" unless defined $_;
796 $_ .= $self->{recsep}
797 unless substr($_, - $self->{recseplen}) eq $self->{recsep};
802 ################################################################
804 # Basic read, write, and seek
807 # seek to the beginning of record #$n
808 # Assumes that the offsets table is already correctly populated
810 # Note that $n=-1 has a special meaning here: It means the start of
811 # the last known record; this may or may not be the very last record
812 # in the file, depending on whether the offsets table is fully populated.
816 my $o = $self->{offsets}[$n];
818 or confess("logic error: undefined offset for record $n");
819 seek $self->{fh}, $o, SEEK_SET
820 or confess "Couldn't seek filehandle: $!"; # "Should never happen."
823 # seek to byte $b in the file
826 seek $self->{fh}, $b, SEEK_SET
827 or die "Couldn't seek filehandle: $!"; # "Should never happen."
830 # populate the offsets table up to the beginning of record $n
831 # return the offset of record $n
832 sub _fill_offsets_to {
835 return $self->{offsets}[$n] if $self->{eof};
837 my $fh = $self->{fh};
838 local *OFF = $self->{offsets};
841 until ($#OFF >= $n) {
842 $self->_seek(-1); # tricky -- see comment at _seek
843 $rec = $self->_read_record;
845 push @OFF, int(tell $fh); # Tels says that int() saves memory here
848 return; # It turns out there is no such record
852 # we have now read all the records up to record n-1,
853 # so we can return the offset of record n
860 my $fh = $self->{fh};
861 local *OFF = $self->{offsets};
863 $self->_seek(-1); # tricky -- see comment at _seek
865 # Tels says that inlining read_record() would make this loop
866 # five times faster. 20030508
867 while ( defined $self->_read_record()) {
868 # int() saves us memory here
869 push @OFF, int(tell $fh);
876 # assumes that $rec is already suitably terminated
878 my ($self, $rec) = @_;
879 my $fh = $self->{fh};
882 or die "Couldn't write record: $!"; # "Should never happen."
883 # $self->{_written} += length($rec);
889 { local $/ = $self->{recsep};
890 my $fh = $self->{fh};
893 return unless defined $rec;
894 if (! $self->{sawlastrec} &&
895 substr($rec, -$self->{recseplen}) ne $self->{recsep}) {
896 # improperly terminated final record --- quietly fix it.
897 # my $ac = substr($rec, -$self->{recseplen});
899 $self->{sawlastrec} = 1;
900 unless ($self->{rdonly}) {
902 my $fh = $self->{fh};
903 print $fh $self->{recsep};
905 $rec .= $self->{recsep};
907 # $self->{_read} += length($rec) if defined $rec;
913 @{$self}{'_read', '_written'};
916 ################################################################
918 # Read cache management
922 $self->{cache}->reduce_size_to($self->{memory} - $self->{deferred_s});
925 sub _cache_too_full {
927 $self->{cache}->bytes + $self->{deferred_s} >= $self->{memory};
930 ################################################################
932 # File custodial services
936 # We have read to the end of the file and have the offsets table
937 # entirely populated. Now we need to write a new record beyond
938 # the end of the file. We prepare for this by writing
939 # empty records into the file up to the position we want
941 # assumes that the offsets table already contains the offset of record $n,
942 # if it exists, and extends to the end of the file if not.
943 sub _extend_file_to {
945 $self->_seek(-1); # position after the end of the last record
946 my $pos = $self->{offsets}[-1];
948 # the offsets table has one entry more than the total number of records
949 my $extras = $n - $#{$self->{offsets}};
951 # Todo : just use $self->{recsep} x $extras here?
952 while ($extras-- > 0) {
953 $self->_write_record($self->{recsep});
954 push @{$self->{offsets}}, int(tell $self->{fh});
958 # Truncate the file at the current position
961 truncate $self->{fh}, tell($self->{fh});
965 # compute the size of a buffer suitable for moving
966 # all the data in a file forward $n bytes
967 # ($n may be negative)
968 # The result should be at least $n.
971 return 8192 if $n <= 0;
973 $b += 8192 if $n & 8191;
977 ################################################################
979 # Miscellaneous public methods
984 my ($self, $op) = @_;
986 my $pack = ref $self;
987 croak "Usage: $pack\->flock([OPERATION])";
989 my $fh = $self->{fh};
990 $op = LOCK_EX unless defined $op;
991 my $locked = flock $fh, $op;
993 if ($locked && ($op & (LOCK_EX | LOCK_SH))) {
994 # If you're locking the file, then presumably it's because
995 # there might have been a write access by another process.
996 # In that case, the read cache contents and the offsets table
997 # might be invalid, so discard them. 20030508
998 $self->{offsets} = [0];
999 $self->{cache}->empty;
1005 # Get/set autochomp option
1009 my $old = $self->{autochomp};
1010 $self->{autochomp} = shift;
1017 # Get offset table entries; returns offset of nth record
1019 my ($self, $n) = @_;
1021 if ($#{$self->{offsets}} < $n) {
1022 return if $self->{eof}; # request for record beyond the end of file
1023 my $o = $self->_fill_offsets_to($n);
1024 # If it's still undefined, there is no such record, so return 'undef'
1025 return unless defined $o;
1028 $self->{offsets}[$n];
1031 sub discard_offsets {
1033 $self->{offsets} = [0];
1036 ################################################################
1038 # Matters related to deferred writing
1044 $self->_stop_autodeferring;
1045 @{$self->{ad_history}} = ();
1049 # Flush deferred writes
1051 # This could be better optimized to write the file in one pass, instead
1052 # of one pass per block of records. But that will require modifications
1053 # to _twrite, so I should have a good _twrite test suite first.
1063 my @writable = sort {$a<=>$b} (keys %{$self->{deferred}});
1066 # gather all consecutive records from the front of @writable
1067 my $first_rec = shift @writable;
1068 my $last_rec = $first_rec+1;
1069 ++$last_rec, shift @writable while @writable && $last_rec == $writable[0];
1071 $self->_fill_offsets_to($last_rec);
1072 $self->_extend_file_to($last_rec);
1073 $self->_splice($first_rec, $last_rec-$first_rec+1,
1074 @{$self->{deferred}}{$first_rec .. $last_rec});
1077 $self->_discard; # clear out defered-write-cache
1082 my @writable = sort {$a<=>$b} (keys %{$self->{deferred}});
1087 # gather all consecutive records from the front of @writable
1088 my $first_rec = shift @writable;
1089 my $last_rec = $first_rec+1;
1090 ++$last_rec, shift @writable while @writable && $last_rec == $writable[0];
1092 my $end = $self->_fill_offsets_to($last_rec+1);
1093 if (not defined $end) {
1094 $self->_extend_file_to($last_rec);
1095 $end = $self->{offsets}[$last_rec];
1097 my ($start) = $self->{offsets}[$first_rec];
1099 join("", @{$self->{deferred}}{$first_rec .. $last_rec}), # data
1101 $end-$start; # length
1102 push @adjust, [$first_rec, # starting at this position...
1103 $last_rec-$first_rec+1, # this many records...
1104 # are replaced with these...
1105 @{$self->{deferred}}{$first_rec .. $last_rec},
1109 $self->_mtwrite(@args); # write multiple record groups
1110 $self->_discard; # clear out defered-write-cache
1111 $self->_oadjust(@adjust);
1114 # Discard deferred writes and disable future deferred writes
1121 # Discard deferred writes, but retain old deferred writing mode
1124 %{$self->{deferred}} = ();
1125 $self->{deferred_s} = 0;
1126 $self->{deferred_max} = -1;
1127 $self->{cache}->set_limit($self->{memory});
1130 # Deferred writing is enabled, either explicitly ($self->{defer})
1131 # or automatically ($self->{autodeferring})
1134 $self->{defer} || $self->{autodeferring};
1137 # The largest record number of any deferred record
1140 return $self->{deferred_max} if defined $self->{deferred_max};
1142 for my $key (keys %{$self->{deferred}}) {
1143 $max = $key if $key > $max;
1145 $self->{deferred_max} = $max;
1149 ################################################################
1151 # Matters related to autodeferment
1154 # Get/set autodefer option
1158 my $old = $self->{autodefer};
1159 $self->{autodefer} = shift;
1161 $self->_stop_autodeferring;
1162 @{$self->{ad_history}} = ();
1170 # The user is trying to store record #$n Record that in the history,
1171 # and then enable (or disable) autodeferment if that seems useful.
1172 # Note that it's OK for $n to be a non-number, as long as the function
1173 # is prepared to deal with that. Nobody else looks at the ad_history.
1175 # Now, what does the ad_history mean, and what is this function doing?
1176 # Essentially, the idea is to enable autodeferring when we see that the
1177 # user has made three consecutive STORE calls to three consecutive records.
1178 # ("Three" is actually ->{autodefer_threshhold}.)
1179 # A STORE call for record #$n inserts $n into the autodefer history,
1180 # and if the history contains three consecutive records, we enable
1181 # autodeferment. An ad_history of [X, Y] means that the most recent
1182 # STOREs were for records X, X+1, ..., Y, in that order.
1184 # Inserting a nonconsecutive number erases the history and starts over.
1186 # Performing a special operation like SPLICE erases the history.
1188 # There's one special case: CLEAR means that CLEAR was just called.
1189 # In this case, we prime the history with [-2, -1] so that if the next
1190 # write is for record 0, autodeferring goes on immediately. This is for
1191 # the common special case of "@a = (...)".
1193 sub _annotate_ad_history {
1194 my ($self, $n) = @_;
1195 return unless $self->{autodefer}; # feature is disabled
1196 return if $self->{defer}; # already in explicit defer mode
1197 return unless $self->{offsets}[-1] >= $self->{autodefer_filelen_threshhold};
1199 local *H = $self->{ad_history};
1200 if ($n eq 'CLEAR') {
1201 @H = (-2, -1); # prime the history with fake records
1202 $self->_stop_autodeferring;
1203 } elsif ($n =~ /^\d+$/) {
1207 if ($H[1] == $n-1) { # another consecutive record
1209 if ($H[1] - $H[0] + 1 >= $self->{autodefer_threshhold}) {
1210 $self->{autodeferring} = 1;
1212 } else { # nonconsecutive- erase and start over
1214 $self->_stop_autodeferring;
1217 } else { # SPLICE or STORESIZE or some such
1219 $self->_stop_autodeferring;
1223 # If autodeferring was enabled, cut it out and discard the history
1224 sub _stop_autodeferring {
1226 if ($self->{autodeferring}) {
1229 $self->{autodeferring} = 0;
1232 ################################################################
1235 # This is NOT a method. It is here for two reasons:
1236 # 1. To factor a fairly complicated block out of the constructor
1237 # 2. To provide access for the test suite, which need to be sure
1238 # files are being written properly.
1239 sub _default_recsep {
1241 if ($^O eq 'MSWin32') { # Dos too?
1242 # Windows users expect files to be terminated with \r\n
1243 # But $/ is set to \n instead
1244 # Note that this also transforms \n\n into \r\n\r\n.
1245 # That is a feature.
1246 $recsep =~ s/\n/\r\n/g;
1251 # Utility function for _check_integrity
1259 # Given a file, make sure the cache is consistent with the
1260 # file contents and the internal data structures are consistent with
1261 # each other. Returns true if everything checks out, false if not
1263 # The $file argument is no longer used. It is retained for compatibility
1264 # with the existing test suite.
1265 sub _check_integrity {
1266 my ($self, $file, $warn) = @_;
1267 my $rsl = $self->{recseplen};
1268 my $rs = $self->{recsep};
1270 local *_; # local $_ does not work here
1271 local $DIAGNOSTIC = 1;
1273 if (not defined $rs) {
1274 _ci_warn("recsep is undef!");
1276 } elsif ($rs eq "") {
1277 _ci_warn("recsep is empty!");
1279 } elsif ($rsl != length $rs) {
1280 my $ln = length $rs;
1281 _ci_warn("recsep <$rs> has length $ln, should be $rsl");
1285 if (not defined $self->{offsets}[0]) {
1286 _ci_warn("offset 0 is missing!");
1289 } elsif ($self->{offsets}[0] != 0) {
1290 _ci_warn("rec 0: offset <$self->{offsets}[0]> s/b 0!");
1296 local *F = $self->{fh};
1297 seek F, 0, SEEK_SET;
1303 my $cached = $self->{cache}->_produce($n);
1304 my $offset = $self->{offsets}[$.];
1306 if (defined $offset && $offset != $ao) {
1307 _ci_warn("rec $n: offset <$offset> actual <$ao>");
1310 if (defined $cached && $_ ne $cached && ! $self->{deferred}{$n}) {
1312 _ci_warn("rec $n: cached <$cached> actual <$_>");
1314 if (defined $cached && substr($cached, -$rsl) ne $rs) {
1316 _ci_warn("rec $n in the cache is missing the record separator");
1318 if (! defined $offset && $self->{eof}) {
1320 _ci_warn("The offset table was marked complete, but it is missing element $.");
1323 if (@{$self->{offsets}} > $.+1) {
1325 my $n = @{$self->{offsets}};
1326 _ci_warn("The offset table has $n items, but the file has only $.");
1329 my $deferring = $self->_is_deferring;
1330 for my $n ($self->{cache}->ckeys) {
1331 my $r = $self->{cache}->_produce($n);
1332 $cached += length($r);
1333 next if $n+1 <= $.; # checked this already
1334 _ci_warn("spurious caching of record $n");
1337 my $b = $self->{cache}->bytes;
1338 if ($cached != $b) {
1339 _ci_warn("cache size is $b, should be $cached");
1344 # That cache has its own set of tests
1345 $good = 0 unless $self->{cache}->_check_integrity;
1347 # Now let's check the deferbuffer
1348 # Unless deferred writing is enabled, it should be empty
1349 if (! $self->_is_deferring && %{$self->{deferred}}) {
1350 _ci_warn("deferred writing disabled, but deferbuffer nonempty");
1354 # Any record in the deferbuffer should *not* be present in the readcache
1356 while (my ($n, $r) = each %{$self->{deferred}}) {
1357 $deferred_s += length($r);
1358 if (defined $self->{cache}->_produce($n)) {
1359 _ci_warn("record $n is in the deferbuffer *and* the readcache");
1362 if (substr($r, -$rsl) ne $rs) {
1363 _ci_warn("rec $n in the deferbuffer is missing the record separator");
1368 # Total size of deferbuffer should match internal total
1369 if ($deferred_s != $self->{deferred_s}) {
1370 _ci_warn("buffer size is $self->{deferred_s}, should be $deferred_s");
1374 # Total size of deferbuffer should not exceed the specified limit
1375 if ($deferred_s > $self->{dw_size}) {
1376 _ci_warn("buffer size is $self->{deferred_s} which exceeds the limit of $self->{dw_size}");
1380 # Total size of cached data should not exceed the specified limit
1381 if ($deferred_s + $cached > $self->{memory}) {
1382 my $total = $deferred_s + $cached;
1383 _ci_warn("total stored data size is $total which exceeds the limit of $self->{memory}");
1387 # Stuff related to autodeferment
1388 if (!$self->{autodefer} && @{$self->{ad_history}}) {
1389 _ci_warn("autodefer is disabled, but ad_history is nonempty");
1392 if ($self->{autodeferring} && $self->{defer}) {
1393 _ci_warn("both autodeferring and explicit deferring are active");
1396 if (@{$self->{ad_history}} == 0) {
1397 # That's OK, no additional tests required
1398 } elsif (@{$self->{ad_history}} == 2) {
1399 my @non_number = grep !/^-?\d+$/, @{$self->{ad_history}};
1403 $msg = "ad_history contains non-numbers (@{$self->{ad_history}})";
1407 } elsif ($self->{ad_history}[1] < $self->{ad_history}[0]) {
1408 _ci_warn("ad_history has nonsensical values @{$self->{ad_history}}");
1412 _ci_warn("ad_history has bad length <@{$self->{ad_history}}>");
1419 ################################################################
1425 package Tie::File::Cache;
1426 $Tie::File::Cache::VERSION = $Tie::File::VERSION;
1427 use Carp ':DEFAULT', 'confess';
1433 #sub STAT () { 4 } # Array with request statistics for each record
1434 #sub MISS () { 5 } # Total number of cache misses
1435 #sub REQ () { 6 } # Total number of cache requests
1439 my ($pack, $max) = @_;
1441 croak "missing argument to ->new" unless defined $max;
1443 bless $self => $pack;
1444 @$self = (Tie::File::Heap->new($self), {}, $max, 0);
1449 my ($self, $n) = @_;
1454 my ($self, $n) = @_;
1458 # For internal use only
1459 # Will be called by the heap structure to notify us that a certain
1460 # piece of data has moved from one heap element to another.
1461 # $k is the hash key of the item
1462 # $n is the new index into the heap at which it is stored
1463 # If $n is undefined, the item has been removed from the heap.
1465 my ($self, $k, $n) = @_;
1467 $self->[HASH]{$k} = $n;
1469 delete $self->[HASH]{$k};
1474 my ($self, $key, $val) = @_;
1476 croak "missing argument to ->insert" unless defined $key;
1477 unless (defined $self->[MAX]) {
1478 confess "undefined max" ;
1480 confess "undefined val" unless defined $val;
1481 return if length($val) > $self->[MAX];
1483 # if ($self->[STAT]) {
1484 # $self->[STAT][$key] = 1;
1488 my $oldnode = $self->[HASH]{$key};
1489 if (defined $oldnode) {
1490 my $oldval = $self->[HEAP]->set_val($oldnode, $val);
1491 $self->[BYTES] -= length($oldval);
1493 $self->[HEAP]->insert($key, $val);
1495 $self->[BYTES] += length($val);
1496 $self->flush if $self->[BYTES] > $self->[MAX];
1501 my $old_data = $self->[HEAP]->popheap;
1502 return unless defined $old_data;
1503 $self->[BYTES] -= length $old_data;
1508 my ($self, @keys) = @_;
1511 # if ($self->[STAT]) {
1512 # for my $key (@keys) {
1513 # $self->[STAT][$key] = 0;
1518 for my $key (@keys) {
1519 next unless exists $self->[HASH]{$key};
1520 my $old_data = $self->[HEAP]->remove($self->[HASH]{$key});
1521 $self->[BYTES] -= length $old_data;
1522 push @result, $old_data;
1528 my ($self, $key) = @_;
1530 croak "missing argument to ->lookup" unless defined $key;
1532 # if ($self->[STAT]) {
1533 # $self->[MISS]++ if $self->[STAT][$key]++ == 0;
1535 # my $hit_rate = 1 - $self->[MISS] / $self->[REQ];
1536 # # Do some testing to determine this threshhold
1537 # $#$self = STAT - 1 if $hit_rate > 0.20;
1540 if (exists $self->[HASH]{$key}) {
1541 $self->[HEAP]->lookup($self->[HASH]{$key});
1547 # For internal use only
1549 my ($self, $key) = @_;
1550 my $loc = $self->[HASH]{$key};
1551 return unless defined $loc;
1552 $self->[HEAP][$loc][2];
1555 # For internal use only
1557 my ($self, $key) = @_;
1558 $self->[HEAP]->promote($self->[HASH]{$key});
1563 %{$self->[HASH]} = ();
1565 $self->[HEAP]->empty;
1566 # @{$self->[STAT]} = ();
1567 # $self->[MISS] = 0;
1573 keys %{$self->[HASH]} == 0;
1577 my ($self, $key, $val) = @_;
1579 croak "missing argument to ->update" unless defined $key;
1580 if (length($val) > $self->[MAX]) {
1581 my ($oldval) = $self->remove($key);
1582 $self->[BYTES] -= length($oldval) if defined $oldval;
1583 } elsif (exists $self->[HASH]{$key}) {
1584 my $oldval = $self->[HEAP]->set_val($self->[HASH]{$key}, $val);
1585 $self->[BYTES] += length($val);
1586 $self->[BYTES] -= length($oldval) if defined $oldval;
1588 $self->[HEAP]->insert($key, $val);
1589 $self->[BYTES] += length($val);
1595 my ($self, $okeys, $nkeys) = @_;
1598 @map{@$okeys} = @$nkeys;
1599 croak "missing argument to ->rekey" unless defined $nkeys;
1600 croak "length mismatch in ->rekey arguments" unless @$nkeys == @$okeys;
1601 my %adjusted; # map new keys to heap indices
1602 # You should be able to cut this to one loop TODO XXX
1603 for (0 .. $#$okeys) {
1604 $adjusted{$nkeys->[$_]} = delete $self->[HASH]{$okeys->[$_]};
1606 while (my ($nk, $ix) = each %adjusted) {
1607 # @{$self->[HASH]}{keys %adjusted} = values %adjusted;
1608 $self->[HEAP]->rekey($ix, $nk);
1609 $self->[HASH]{$nk} = $ix;
1615 my @a = keys %{$self->[HASH]};
1619 # Return total amount of cached data
1625 # Expire oldest item from cache until cache size is smaller than $max
1626 sub reduce_size_to {
1627 my ($self, $max) = @_;
1628 until ($self->[BYTES] <= $max) {
1629 # Note that Tie::File::Cache::expire has been inlined here
1630 my $old_data = $self->[HEAP]->popheap;
1631 return unless defined $old_data;
1632 $self->[BYTES] -= length $old_data;
1636 # Why not just $self->reduce_size_to($self->[MAX])?
1637 # Try this when things stabilize TODO XXX
1638 # If the cache is too full, expire the oldest records
1641 $self->reduce_size_to($self->[MAX]) if $self->[BYTES] > $self->[MAX];
1644 # For internal use only
1647 $self->[HEAP]->expire_order;
1650 BEGIN { *_ci_warn = \&Tie::File::_ci_warn }
1652 sub _check_integrity { # For CACHE
1657 $self->[HEAP]->_check_integrity or $good = 0;
1661 for my $k (keys %{$self->[HASH]}) {
1662 if ($k ne '0' && $k !~ /^[1-9][0-9]*$/) {
1664 _ci_warn "Cache hash key <$k> is non-numeric";
1667 my $h = $self->[HASH]{$k};
1670 _ci_warn "Heap index number for key $k is undefined";
1673 _ci_warn "Heap index number for key $k is zero";
1675 my $j = $self->[HEAP][$h];
1678 _ci_warn "Heap contents key $k (=> $h) are undefined";
1680 $bytes += length($j->[2]);
1681 if ($k ne $j->[1]) {
1683 _ci_warn "Heap contents key $k (=> $h) is $j->[1], should be $k";
1690 if ($bytes != $self->[BYTES]) {
1692 _ci_warn "Total data in cache is $bytes, expected $self->[BYTES]";
1696 if ($bytes > $self->[MAX]) {
1698 _ci_warn "Total data in cache is $bytes, exceeds maximum $self->[MAX]";
1706 $self->[HEAP] = undef; # Bye bye heap
1709 ################################################################
1713 # Heap data structure for use by cache LRU routines
1715 package Tie::File::Heap;
1716 use Carp ':DEFAULT', 'confess';
1717 $Tie::File::Heap::VERSION = $Tie::File::Cache::VERSION;
1723 my ($pack, $cache) = @_;
1724 die "$pack: Parent cache object $cache does not support _heap_move method"
1725 unless eval { $cache->can('_heap_move') };
1726 my $self = [[0,$cache,0]];
1727 bless $self => $pack;
1730 # Allocate a new sequence number, larger than all previously allocated numbers
1765 $self->[0][0] = 0; # might as well reset the sequence numbers
1768 # notify the parent cache object that we moved something
1771 $self->_cache->_heap_move(@_);
1774 # Insert a piece of data into the heap with the indicated sequence number.
1775 # The item with the smallest sequence number is always at the top.
1776 # If no sequence number is specified, allocate a new one and insert the
1777 # item at the bottom.
1779 my ($self, $key, $data, $seq) = @_;
1780 $seq = $self->_nseq unless defined $seq;
1781 $self->_insert_new([$seq, $key, $data]);
1784 # Insert a new, fresh item at the bottom of the heap
1786 my ($self, $item) = @_;
1788 $i = int($i/2) until defined $self->[$i/2];
1789 $self->[$i] = $item;
1790 $self->[0][1]->_heap_move($self->[$i][KEY], $i);
1794 # Insert [$data, $seq] pair at or below item $i in the heap.
1795 # If $i is omitted, default to 1 (the top element.)
1797 my ($self, $item, $i) = @_;
1798 # $self->_check_loc($i) if defined $i;
1799 $i = 1 unless defined $i;
1800 until (! defined $self->[$i]) {
1801 if ($self->[$i][SEQ] > $item->[SEQ]) { # inserted item is older
1802 ($self->[$i], $item) = ($item, $self->[$i]);
1803 $self->[0][1]->_heap_move($self->[$i][KEY], $i);
1805 # If either is undefined, go that way. Otherwise, choose at random
1807 $dir = 0 if !defined $self->[2*$i];
1808 $dir = 1 if !defined $self->[2*$i+1];
1809 $dir = int(rand(2)) unless defined $dir;
1812 $self->[$i] = $item;
1813 $self->[0][1]->_heap_move($self->[$i][KEY], $i);
1817 # Remove the item at node $i from the heap, moving child items upwards.
1818 # The item with the smallest sequence number is always at the top.
1819 # Moving items upwards maintains this condition.
1820 # Return the removed item. Return undef if there was no item at node $i.
1822 my ($self, $i) = @_;
1823 $i = 1 unless defined $i;
1824 my $top = $self->[$i];
1825 return unless defined $top;
1828 my ($L, $R) = (2*$i, 2*$i+1);
1830 # If either is undefined, go the other way.
1831 # Otherwise, go towards the smallest.
1832 last unless defined $self->[$L] || defined $self->[$R];
1833 $ii = $R if not defined $self->[$L];
1834 $ii = $L if not defined $self->[$R];
1835 unless (defined $ii) {
1836 $ii = $self->[$L][SEQ] < $self->[$R][SEQ] ? $L : $R;
1839 $self->[$i] = $self->[$ii]; # Promote child to fill vacated spot
1840 $self->[0][1]->_heap_move($self->[$i][KEY], $i);
1841 $i = $ii; # Fill new vacated spot
1843 $self->[0][1]->_heap_move($top->[KEY], undef);
1854 # set the sequence number of the indicated item to a higher number
1855 # than any other item in the heap, and bubble the item down to the
1858 my ($self, $n) = @_;
1859 # $self->_check_loc($n);
1860 $self->[$n][SEQ] = $self->_nseq;
1863 my ($L, $R) = (2*$i, 2*$i+1);
1865 last unless defined $self->[$L] || defined $self->[$R];
1866 $dir = $R unless defined $self->[$L];
1867 $dir = $L unless defined $self->[$R];
1868 unless (defined $dir) {
1869 $dir = $self->[$L][SEQ] < $self->[$R][SEQ] ? $L : $R;
1871 @{$self}[$i, $dir] = @{$self}[$dir, $i];
1873 $self->[0][1]->_heap_move($self->[$_][KEY], $_) if defined $self->[$_];
1879 # Return item $n from the heap, promoting its LRU status
1881 my ($self, $n) = @_;
1882 # $self->_check_loc($n);
1883 my $val = $self->[$n];
1889 # Assign a new value for node $n, promoting it to the bottom of the heap
1891 my ($self, $n, $val) = @_;
1892 # $self->_check_loc($n);
1893 my $oval = $self->[$n][DAT];
1894 $self->[$n][DAT] = $val;
1899 # The hask key has changed for an item;
1900 # alter the heap's record of the hash key
1902 my ($self, $n, $new_key) = @_;
1903 # $self->_check_loc($n);
1904 $self->[$n][KEY] = $new_key;
1908 my ($self, $n) = @_;
1909 unless (1 || defined $self->[$n]) {
1910 confess "_check_loc($n) failed";
1914 BEGIN { *_ci_warn = \&Tie::File::_ci_warn }
1916 sub _check_integrity {
1921 unless (eval {$self->[0][1]->isa("Tie::File::Cache")}) {
1922 _ci_warn "Element 0 of heap corrupt";
1925 $good = 0 unless $self->_satisfies_heap_condition(1);
1926 for my $i (2 .. $#{$self}) {
1927 my $p = int($i/2); # index of parent node
1928 if (defined $self->[$i] && ! defined $self->[$p]) {
1929 _ci_warn "Element $i of heap defined, but parent $p isn't";
1933 if (defined $self->[$i]) {
1934 if ($seq{$self->[$i][SEQ]}) {
1935 my $seq = $self->[$i][SEQ];
1936 _ci_warn "Nodes $i and $seq{$seq} both have SEQ=$seq";
1939 $seq{$self->[$i][SEQ]} = $i;
1947 sub _satisfies_heap_condition {
1953 next unless defined $self->[$c];
1954 if ($self->[$n][SEQ] >= $self->[$c]) {
1955 _ci_warn "Node $n of heap does not predate node $c";
1958 $good = 0 unless $self->_satisfies_heap_condition($c);
1963 # Return a list of all the values, sorted by expiration order
1966 my @nodes = sort {$a->[SEQ] <=> $b->[SEQ]} $self->_nodes;
1967 map { $_->[KEY] } @nodes;
1973 return unless defined $self->[$i];
1974 ($self->[$i], $self->_nodes($i*2), $self->_nodes($i*2+1));
1977 "Cogito, ergo sum."; # don't forget to return a true value from the file
1983 Tie::File - Access the lines of a disk file via a Perl array
1987 # This file documents Tie::File version 0.95
1990 tie @array, 'Tie::File', filename or die ...;
1992 $array[13] = 'blah'; # line 13 of the file is now 'blah'
1993 print $array[42]; # display line 42 of the file
1995 $n_recs = @array; # how many records are in the file?
1996 $#array -= 2; # chop two records off the end
2000 s/PERL/Perl/g; # Replace PERL with Perl everywhere in the file
2003 # These are just like regular push, pop, unshift, shift, and splice
2004 # Except that they modify the file in the way you would expect
2006 push @array, new recs...;
2007 my $r1 = pop @array;
2008 unshift @array, new recs...;
2009 my $r2 = shift @array;
2010 @old_recs = splice @array, 3, 7, new recs...;
2012 untie @array; # all finished
2017 C<Tie::File> represents a regular text file as a Perl array. Each
2018 element in the array corresponds to a record in the file. The first
2019 line of the file is element 0 of the array; the second line is element
2022 The file is I<not> loaded into memory, so this will work even for
2025 Changes to the array are reflected in the file immediately.
2027 Lazy people and beginners may now stop reading the manual.
2031 What is a 'record'? By default, the meaning is the same as for the
2032 C<E<lt>...E<gt>> operator: It's a string terminated by C<$/>, which is
2033 probably C<"\n">. (Minor exception: on DOS and Win32 systems, a
2034 'record' is a string terminated by C<"\r\n">.) You may change the
2035 definition of "record" by supplying the C<recsep> option in the C<tie>
2038 tie @array, 'Tie::File', $file, recsep => 'es';
2040 This says that records are delimited by the string C<es>. If the file
2041 contained the following data:
2043 Curse these pesky flies!\n
2045 then the C<@array> would appear to have four elements:
2052 An undefined value is not permitted as a record separator. Perl's
2053 special "paragraph mode" semantics (E<agrave> la C<$/ = "">) are not
2056 Records read from the tied array do not have the record separator
2057 string on the end; this is to allow
2059 $array[17] .= "extra";
2061 to work as expected.
2063 (See L<"autochomp">, below.) Records stored into the array will have
2064 the record separator string appended before they are written to the
2065 file, if they don't have one already. For example, if the record
2066 separator string is C<"\n">, then the following two lines do exactly
2069 $array[17] = "Cherry pie";
2070 $array[17] = "Cherry pie\n";
2072 The result is that the contents of line 17 of the file will be
2073 replaced with "Cherry pie"; a newline character will separate line 17
2074 from line 18. This means that this code will do nothing:
2078 Because the C<chomp>ed value will have the separator reattached when
2079 it is written back to the file. There is no way to create a file
2080 whose trailing record separator string is missing.
2082 Inserting records that I<contain> the record separator string is not
2083 supported by this module. It will probably produce a reasonable
2084 result, but what this result will be may change in a future version.
2085 Use 'splice' to insert records or to replace one record with several.
2089 Normally, array elements have the record separator removed, so that if
2090 the file contains the text
2096 the tied array will appear to contain C<("Gold", "Frankincense",
2097 "Myrrh")>. If you set C<autochomp> to a false value, the record
2098 separator will not be removed. If the file above was tied with
2100 tie @gifts, "Tie::File", $gifts, autochomp => 0;
2102 then the array C<@gifts> would appear to contain C<("Gold\n",
2103 "Frankincense\n", "Myrrh\n")>, or (on Win32 systems) C<("Gold\r\n",
2104 "Frankincense\r\n", "Myrrh\r\n")>.
2108 Normally, the specified file will be opened for read and write access,
2109 and will be created if it does not exist. (That is, the flags
2110 C<O_RDWR | O_CREAT> are supplied in the C<open> call.) If you want to
2111 change this, you may supply alternative flags in the C<mode> option.
2112 See L<Fcntl> for a listing of available flags.
2115 # open the file if it exists, but fail if it does not exist
2117 tie @array, 'Tie::File', $file, mode => O_RDWR;
2119 # create the file if it does not exist
2120 use Fcntl 'O_RDWR', 'O_CREAT';
2121 tie @array, 'Tie::File', $file, mode => O_RDWR | O_CREAT;
2123 # open an existing file in read-only mode
2124 use Fcntl 'O_RDONLY';
2125 tie @array, 'Tie::File', $file, mode => O_RDONLY;
2127 Opening the data file in write-only or append mode is not supported.
2131 This is an upper limit on the amount of memory that C<Tie::File> will
2132 consume at any time while managing the file. This is used for two
2133 things: managing the I<read cache> and managing the I<deferred write
2136 Records read in from the file are cached, to avoid having to re-read
2137 them repeatedly. If you read the same record twice, the first time it
2138 will be stored in memory, and the second time it will be fetched from
2139 the I<read cache>. The amount of data in the read cache will not
2140 exceed the value you specified for C<memory>. If C<Tie::File> wants
2141 to cache a new record, but the read cache is full, it will make room
2142 by expiring the least-recently visited records from the read cache.
2144 The default memory limit is 2Mib. You can adjust the maximum read
2145 cache size by supplying the C<memory> option. The argument is the
2146 desired cache size, in bytes.
2148 # I have a lot of memory, so use a large cache to speed up access
2149 tie @array, 'Tie::File', $file, memory => 20_000_000;
2151 Setting the memory limit to 0 will inhibit caching; records will be
2152 fetched from disk every time you examine them.
2154 The C<memory> value is not an absolute or exact limit on the memory
2155 used. C<Tie::File> objects contains some structures besides the read
2156 cache and the deferred write buffer, whose sizes are not charged
2159 The cache itself consumes about 310 bytes per cached record, so if
2160 your file has many short records, you may want to decrease the cache
2161 memory limit, or else the cache overhead may exceed the size of the
2167 (This is an advanced feature. Skip this section on first reading.)
2169 If you use deferred writing (See L<"Deferred Writing">, below) then
2170 data you write into the array will not be written directly to the
2171 file; instead, it will be saved in the I<deferred write buffer> to be
2172 written out later. Data in the deferred write buffer is also charged
2173 against the memory limit you set with the C<memory> option.
2175 You may set the C<dw_size> option to limit the amount of data that can
2176 be saved in the deferred write buffer. This limit may not exceed the
2177 total memory limit. For example, if you set C<dw_size> to 1000 and
2178 C<memory> to 2500, that means that no more than 1000 bytes of deferred
2179 writes will be saved up. The space available for the read cache will
2180 vary, but it will always be at least 1500 bytes (if the deferred write
2181 buffer is full) and it could grow as large as 2500 bytes (if the
2182 deferred write buffer is empty.)
2184 If you don't specify a C<dw_size>, it defaults to the entire memory
2187 =head2 Option Format
2189 C<-mode> is a synonym for C<mode>. C<-recsep> is a synonym for
2190 C<recsep>. C<-memory> is a synonym for C<memory>. You get the
2193 =head1 Public Methods
2195 The C<tie> call returns an object, say C<$o>. You may call
2197 $rec = $o->FETCH($n);
2198 $o->STORE($n, $rec);
2200 to fetch or store the record at line C<$n>, respectively; similarly
2201 the other tied array methods. (See L<perltie> for details.) You may
2202 also call the following methods on this object:
2208 will lock the tied file. C<MODE> has the same meaning as the second
2209 argument to the Perl built-in C<flock> function; for example
2210 C<LOCK_SH> or C<LOCK_EX | LOCK_NB>. (These constants are provided by
2211 the C<use Fcntl ':flock'> declaration.)
2213 C<MODE> is optional; the default is C<LOCK_EX>.
2215 C<Tie::File> maintains an internal table of the byte offset of each
2216 record it has seen in the file.
2218 When you use C<flock> to lock the file, C<Tie::File> assumes that the
2219 read cache is no longer trustworthy, because another process might
2220 have modified the file since the last time it was read. Therefore, a
2221 successful call to C<flock> discards the contents of the read cache
2222 and the internal record offset table.
2224 C<Tie::File> promises that the following sequence of operations will
2227 my $o = tie @array, "Tie::File", $filename;
2230 In particular, C<Tie::File> will I<not> read or write the file during
2231 the C<tie> call. (Exception: Using C<mode =E<gt> O_TRUNC> will, of
2232 course, erase the file during the C<tie> call. If you want to do this
2233 safely, then open the file without C<O_TRUNC>, lock the file, and use
2236 The best way to unlock a file is to discard the object and untie the
2237 array. It is probably unsafe to unlock the file without also untying
2238 it, because if you do, changes may remain unwritten inside the object.
2239 That is why there is no shortcut for unlocking. If you really want to
2240 unlock the file prematurely, you know what to do; if you don't know
2241 what to do, then don't do it.
2243 All the usual warnings about file locking apply here. In particular,
2244 note that file locking in Perl is B<advisory>, which means that
2245 holding a lock will not prevent anyone else from reading, writing, or
2246 erasing the file; it only prevents them from getting another lock at
2247 the same time. Locks are analogous to green traffic lights: If you
2248 have a green light, that does not prevent the idiot coming the other
2249 way from plowing into you sideways; it merely guarantees to you that
2250 the idiot does not also have a green light at the same time.
2254 my $old_value = $o->autochomp(0); # disable autochomp option
2255 my $old_value = $o->autochomp(1); # enable autochomp option
2257 my $ac = $o->autochomp(); # recover current value
2259 See L<"autochomp">, above.
2261 =head2 C<defer>, C<flush>, C<discard>, and C<autodefer>
2263 See L<"Deferred Writing">, below.
2267 $off = $o->offset($n);
2269 This method returns the byte offset of the start of the C<$n>th record
2270 in the file. If there is no such record, it returns an undefined
2273 =head1 Tying to an already-opened filehandle
2275 If C<$fh> is a filehandle, such as is returned by C<IO::File> or one
2276 of the other C<IO> modules, you may use:
2278 tie @array, 'Tie::File', $fh, ...;
2280 Similarly if you opened that handle C<FH> with regular C<open> or
2281 C<sysopen>, you may use:
2283 tie @array, 'Tie::File', \*FH, ...;
2285 Handles that were opened write-only won't work. Handles that were
2286 opened read-only will work as long as you don't try to modify the
2287 array. Handles must be attached to seekable sources of data---that
2288 means no pipes or sockets. If C<Tie::File> can detect that you
2289 supplied a non-seekable handle, the C<tie> call will throw an
2290 exception. (On Unix systems, it can detect this.)
2292 =head1 Deferred Writing
2294 (This is an advanced feature. Skip this section on first reading.)
2296 Normally, modifying a C<Tie::File> array writes to the underlying file
2297 immediately. Every assignment like C<$a[3] = ...> rewrites as much of
2298 the file as is necessary; typically, everything from line 3 through
2299 the end will need to be rewritten. This is the simplest and most
2300 transparent behavior. Performance even for large files is reasonably
2303 However, under some circumstances, this behavior may be excessively
2304 slow. For example, suppose you have a million-record file, and you
2311 The first time through the loop, you will rewrite the entire file,
2312 from line 0 through the end. The second time through the loop, you
2313 will rewrite the entire file from line 1 through the end. The third
2314 time through the loop, you will rewrite the entire file from line 2 to
2317 If the performance in such cases is unacceptable, you may defer the
2318 actual writing, and then have it done all at once. The following loop
2319 will perform much better for large files:
2327 If C<Tie::File>'s memory limit is large enough, all the writing will
2328 done in memory. Then, when you call C<-E<gt>flush>, the entire file
2329 will be rewritten in a single pass.
2331 (Actually, the preceding discussion is something of a fib. You don't
2332 need to enable deferred writing to get good performance for this
2333 common case, because C<Tie::File> will do it for you automatically
2334 unless you specifically tell it not to. See L<"autodeferring">,
2337 Calling C<-E<gt>flush> returns the array to immediate-write mode. If
2338 you wish to discard the deferred writes, you may call C<-E<gt>discard>
2339 instead of C<-E<gt>flush>. Note that in some cases, some of the data
2340 will have been written already, and it will be too late for
2341 C<-E<gt>discard> to discard all the changes. Support for
2342 C<-E<gt>discard> may be withdrawn in a future version of C<Tie::File>.
2344 Deferred writes are cached in memory up to the limit specified by the
2345 C<dw_size> option (see above). If the deferred-write buffer is full
2346 and you try to write still more deferred data, the buffer will be
2347 flushed. All buffered data will be written immediately, the buffer
2348 will be emptied, and the now-empty space will be used for future
2351 If the deferred-write buffer isn't yet full, but the total size of the
2352 buffer and the read cache would exceed the C<memory> limit, the oldest
2353 records will be expired from the read cache until the total size is
2356 C<push>, C<pop>, C<shift>, C<unshift>, and C<splice> cannot be
2357 deferred. When you perform one of these operations, any deferred data
2358 is written to the file and the operation is performed immediately.
2359 This may change in a future version.
2361 If you resize the array with deferred writing enabled, the file will
2362 be resized immediately, but deferred records will not be written.
2363 This has a surprising consequence: C<@a = (...)> erases the file
2364 immediately, but the writing of the actual data is deferred. This
2365 might be a bug. If it is a bug, it will be fixed in a future version.
2367 =head2 Autodeferring
2369 C<Tie::File> tries to guess when deferred writing might be helpful,
2370 and to turn it on and off automatically.
2376 In this example, only the first two assignments will be done
2377 immediately; after this, all the changes to the file will be deferred
2378 up to the user-specified memory limit.
2380 You should usually be able to ignore this and just use the module
2381 without thinking about deferring. However, special applications may
2382 require fine control over which writes are deferred, or may require
2383 that all writes be immediate. To disable the autodeferment feature,
2386 (tied @o)->autodefer(0);
2390 tie @array, 'Tie::File', $file, autodefer => 0;
2393 Similarly, C<-E<gt>autodefer(1)> re-enables autodeferment, and
2394 C<-E<gt>autodefer()> recovers the current value of the autodefer setting.
2397 =head1 CONCURRENT ACCESS TO FILES
2399 Caching and deferred writing are inappropriate if you want the same
2400 file to be accessed simultaneously from more than one process. You
2401 will want to disable these features. You should do that by including
2402 the C<memory =E<gt> 0> option in your C<tie> calls; this will inhibit
2403 caching and deferred writing.
2405 You will also want to lock the file while reading or writing it. You
2406 can use the C<-E<gt>flock> method for this. A future version of this
2407 module may provide an 'autolocking' mode.
2411 (That's Latin for 'warnings'.)
2417 Reasonable effort was made to make this module efficient. Nevertheless,
2418 changing the size of a record in the middle of a large file will
2419 always be fairly slow, because everything after the new record must be
2424 The behavior of tied arrays is not precisely the same as for regular
2425 arrays. For example:
2427 # This DOES print "How unusual!"
2428 undef $a[10]; print "How unusual!\n" if defined $a[10];
2430 C<undef>-ing a C<Tie::File> array element just blanks out the
2431 corresponding record in the file. When you read it back again, you'll
2432 get the empty string, so the supposedly-C<undef>'ed value will be
2433 defined. Similarly, if you have C<autochomp> disabled, then
2435 # This DOES print "How unusual!" if 'autochomp' is disabled
2437 print "How unusual!\n" if $a[10];
2439 Because when C<autochomp> is disabled, C<$a[10]> will read back as
2440 C<"\n"> (or whatever the record separator string is.)
2442 There are other minor differences, particularly regarding C<exists>
2443 and C<delete>, but in general, the correspondence is extremely close.
2447 I have supposed that since this module is concerned with file I/O,
2448 almost all normal use of it will be heavily I/O bound. This means
2449 that the time to maintain complicated data structures inside the
2450 module will be dominated by the time to actually perform the I/O.
2451 When there was an opportunity to spend CPU time to avoid doing I/O, I
2452 usually tried to take it.
2456 You might be tempted to think that deferred writing is like
2457 transactions, with C<flush> as C<commit> and C<discard> as
2458 C<rollback>, but it isn't, so don't.
2462 There is a large memory overhead for each record offset and for each
2463 cache entry: about 310 bytes per cached data record, and about 21 bytes per offset table entry.
2465 The per-record overhead will limit the maximum number of records you
2466 can access per file. Note that I<accessing> the length of the array
2467 via C<$x = scalar @tied_file> accesses B<all> records and stores their
2468 offsets. The same for C<foreach (@tied_file)>, even if you exit the
2475 This version promises absolutely nothing about the internals, which
2476 may change without notice. A future version of the module will have a
2477 well-defined and stable subclassing API.
2479 =head1 WHAT ABOUT C<DB_File>?
2481 People sometimes point out that L<DB_File> will do something similar,
2482 and ask why C<Tie::File> module is necessary.
2484 There are a number of reasons that you might prefer C<Tie::File>.
2485 A list is available at C<http://perl.plover.com/TieFile/why-not-DB_File>.
2491 To contact the author, send email to: C<mjd-perl-tiefile+@plover.com>
2493 To receive an announcement whenever a new version of this module is
2494 released, send a blank email message to
2495 C<mjd-perl-tiefile-subscribe@plover.com>.
2497 The most recent version of this module, including documentation and
2498 any news of importance, will be available at
2500 http://perl.plover.com/TieFile/
2505 C<Tie::File> version 0.95 is copyright (C) 2002 Mark Jason Dominus.
2507 This library is free software; you may redistribute it and/or modify
2508 it under the same terms as Perl itself.
2510 These terms are your choice of any of (1) the Perl Artistic Licence,
2511 or (2) version 2 of the GNU General Public License as published by the
2512 Free Software Foundation, or (3) any later version of the GNU General
2515 This library is distributed in the hope that it will be useful,
2516 but WITHOUT ANY WARRANTY; without even the implied warranty of
2517 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2518 GNU General Public License for more details.
2520 You should have received a copy of the GNU General Public License
2521 along with this library program; it should be in the file C<COPYING>.
2522 If not, write to the Free Software Foundation, Inc., 59 Temple Place,
2523 Suite 330, Boston, MA 02111 USA
2525 For licensing inquiries, contact the author at:
2529 Philadelphia, PA 19107
2533 C<Tie::File> version 0.95 comes with ABSOLUTELY NO WARRANTY.
2534 For details, see the license.
2538 Gigantic thanks to Jarkko Hietaniemi, for agreeing to put this in the
2539 core when I hadn't written it yet, and for generally being helpful,
2540 supportive, and competent. (Usually the rule is "choose any one.")
2541 Also big thanks to Abhijit Menon-Sen for all of the same things.
2543 Special thanks to Craig Berry and Peter Prymmer (for VMS portability
2544 help), Randy Kobes (for Win32 portability help), Clinton Pierce and
2545 Autrijus Tang (for heroic eleventh-hour Win32 testing above and beyond
2546 the call of duty), Michael G Schwern (for testing advice), and the
2547 rest of the CPAN testers (for testing generally).
2549 Special thanks to Tels for suggesting several speed and memory
2552 Additional thanks to:
2556 Jarkko Hietaniemi (again) /
2560 Tassilo von Parseval /
2566 Autrijus Tang (again) /
2572 More tests. (Stuff I didn't think of yet.)
2576 Fixed-length mode. Leave-blanks mode.
2578 Maybe an autolocking mode?
2580 For many common uses of the module, the read cache is a liability.
2581 For example, a program that inserts a single record, or that scans the
2582 file once, will have a cache hit rate of zero. This suggests a major
2583 optimization: The cache should be initially disabled. Here's a hybrid
2584 approach: Initially, the cache is disabled, but the cache code
2585 maintains statistics about how high the hit rate would be *if* it were
2586 enabled. When it sees the hit rate get high enough, it enables
2587 itself. The STAT comments in this code are the beginning of an
2588 implementation of this.
2590 Record locking with fcntl()? Then the module might support an undo
2591 log and get real transactions. What a tour de force that would be.
2593 Keeping track of the highest cached record. This would allow reads-in-a-row
2594 to skip the cache lookup faster (if reading from 1..N with empty cache at
2595 start, the last cached value will be always N-1).