This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
typo fixes for Tie::File
[perl5.git] / dist / Tie-File / lib / Tie / File.pm
CommitLineData
b5aed31e
AMS
1
2package Tie::File;
6fc0ea7e 3require 5.005;
6ae23f41 4use Carp ':DEFAULT', 'confess';
b5aed31e 5use POSIX 'SEEK_SET';
6ae23f41 6use Fcntl 'O_CREAT', 'O_RDWR', 'LOCK_EX', 'LOCK_SH', 'O_WRONLY', 'O_RDONLY';
95f36366 7sub O_ACCMODE () { O_RDONLY | O_RDWR | O_WRONLY }
b5aed31e 8
6ae23f41 9
2ded50a3 10$VERSION = "1.00";
b3fe5a4c 11my $DEFAULT_MEMORY_SIZE = 1<<21; # 2 megabytes
6fc0ea7e
JH
12my $DEFAULT_AUTODEFER_THRESHHOLD = 3; # 3 records
13my $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD = 65536; # 16 disk blocksful
b3fe5a4c 14
6ae23f41
JH
15my %good_opt = map {$_ => 1, "-$_" => 1}
16 qw(memory dw_size mode recsep discipline
bc2f65e0 17 autodefer autochomp autodefer_threshhold concurrent);
b5aed31e
AMS
18
19sub TIEARRAY {
20 if (@_ % 2 != 0) {
21 croak "usage: tie \@array, $_[0], filename, [option => value]...";
22 }
23 my ($pack, $file, %opts) = @_;
24
25 # transform '-foo' keys into 'foo' keys
26 for my $key (keys %opts) {
b3fe5a4c
AMS
27 unless ($good_opt{$key}) {
28 croak("$pack: Unrecognized option '$key'\n");
29 }
b5aed31e
AMS
30 my $okey = $key;
31 if ($key =~ s/^-+//) {
32 $opts{$key} = delete $opts{$okey};
33 }
34 }
35
bc2f65e0
JH
36 if ($opts{concurrent}) {
37 croak("$pack: concurrent access not supported yet\n");
38 }
39
b3fe5a4c
AMS
40 unless (defined $opts{memory}) {
41 # default is the larger of the default cache size and the
42 # deferred-write buffer size (if specified)
43 $opts{memory} = $DEFAULT_MEMORY_SIZE;
6ae23f41 44 $opts{memory} = $opts{dw_size}
b3fe5a4c 45 if defined $opts{dw_size} && $opts{dw_size} > $DEFAULT_MEMORY_SIZE;
57c7bc08 46 # Dora Winifred Read
b3fe5a4c
AMS
47 }
48 $opts{dw_size} = $opts{memory} unless defined $opts{dw_size};
49 if ($opts{dw_size} > $opts{memory}) {
50 croak("$pack: dw_size may not be larger than total memory allocation\n");
51 }
57c7bc08
AMS
52 # are we in deferred-write mode?
53 $opts{defer} = 0 unless defined $opts{defer};
54 $opts{deferred} = {}; # no records are presently deferred
b3fe5a4c 55 $opts{deferred_s} = 0; # count of total bytes in ->{deferred}
6fc0ea7e 56 $opts{deferred_max} = -1; # empty
b5aed31e 57
6ae23f41
JH
58 # What's a good way to arrange that this class can be overridden?
59 $opts{cache} = Tie::File::Cache->new($opts{memory});
6fc0ea7e
JH
60
61 # autodeferment is enabled by default
62 $opts{autodefer} = 1 unless defined $opts{autodefer};
63 $opts{autodeferring} = 0; # but is not initially active
64 $opts{ad_history} = [];
65 $opts{autodefer_threshhold} = $DEFAULT_AUTODEFER_THRESHHOLD
66 unless defined $opts{autodefer_threshhold};
67 $opts{autodefer_filelen_threshhold} = $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD
68 unless defined $opts{autodefer_filelen_threshhold};
b5aed31e
AMS
69
70 $opts{offsets} = [0];
71 $opts{filename} = $file;
b3fe5a4c
AMS
72 unless (defined $opts{recsep}) {
73 $opts{recsep} = _default_recsep();
74 }
b5aed31e
AMS
75 $opts{recseplen} = length($opts{recsep});
76 if ($opts{recseplen} == 0) {
77 croak "Empty record separator not supported by $pack";
78 }
79
0b28bc9a
AMS
80 $opts{autochomp} = 1 unless defined $opts{autochomp};
81
27531ffb
JH
82 $opts{mode} = O_CREAT|O_RDWR unless defined $opts{mode};
83 $opts{rdonly} = (($opts{mode} & O_ACCMODE) == O_RDONLY);
bf919750 84 $opts{sawlastrec} = undef;
27531ffb 85
fa408a35 86 my $fh;
b5aed31e 87
fa408a35 88 if (UNIVERSAL::isa($file, 'GLOB')) {
57c7bc08
AMS
89 # We use 1 here on the theory that some systems
90 # may not indicate failure if we use 0.
91 # MSWin32 does not indicate failure with 0, but I don't know if
92 # it will indicate failure with 1 or not.
93 unless (seek $file, 1, SEEK_SET) {
fa408a35
AMS
94 croak "$pack: your filehandle does not appear to be seekable";
95 }
56ee885b 96 seek $file, 0, SEEK_SET; # put it back
57c7bc08 97 $fh = $file; # setting binmode is the user's problem
fa408a35
AMS
98 } elsif (ref $file) {
99 croak "usage: tie \@array, $pack, filename, [option => value]...";
100 } else {
f7363f9d 101 # $fh = \do { local *FH }; # XXX this is buggy
e0cf91d5
GS
102 if ($] < 5.006) {
103 # perl 5.005 and earlier don't autovivify filehandles
104 require Symbol;
105 $fh = Symbol::gensym();
106 }
27531ffb 107 sysopen $fh, $file, $opts{mode}, 0666 or return;
fa408a35 108 binmode $fh;
2a00e2a4 109 ++$opts{ourfh};
fa408a35 110 }
b5aed31e 111 { my $ofh = select $fh; $| = 1; select $ofh } # autoflush on write
b3fe5a4c
AMS
112 if (defined $opts{discipline} && $] >= 5.006) {
113 # This avoids a compile-time warning under 5.005
114 eval 'binmode($fh, $opts{discipline})';
115 croak $@ if $@ =~ /unknown discipline/i;
116 die if $@;
117 }
b5aed31e
AMS
118 $opts{fh} = $fh;
119
120 bless \%opts => $pack;
121}
122
123sub FETCH {
124 my ($self, $n) = @_;
6fc0ea7e
JH
125 my $rec;
126
127 # check the defer buffer
6ae23f41
JH
128 $rec = $self->{deferred}{$n} if exists $self->{deferred}{$n};
129 $rec = $self->_fetch($n) unless defined $rec;
6fc0ea7e 130
6ae23f41
JH
131 # inlined _chomp1
132 substr($rec, - $self->{recseplen}) = ""
133 if defined $rec && $self->{autochomp};
134 $rec;
0b28bc9a
AMS
135}
136
137# Chomp many records in-place; return nothing useful
138sub _chomp {
139 my $self = shift;
140 return unless $self->{autochomp};
141 if ($self->{autochomp}) {
142 for (@_) {
143 next unless defined;
144 substr($_, - $self->{recseplen}) = "";
145 }
146 }
147}
148
149# Chomp one record in-place; return modified record
150sub _chomp1 {
151 my ($self, $rec) = @_;
152 return $rec unless $self->{autochomp};
153 return unless defined $rec;
154 substr($rec, - $self->{recseplen}) = "";
155 $rec;
156}
157
158sub _fetch {
159 my ($self, $n) = @_;
b5aed31e
AMS
160
161 # check the record cache
6fc0ea7e 162 { my $cached = $self->{cache}->lookup($n);
b5aed31e
AMS
163 return $cached if defined $cached;
164 }
165
27531ffb 166 if ($#{$self->{offsets}} < $n) {
6ae23f41 167 return if $self->{eof}; # request for record beyond end of file
b5aed31e
AMS
168 my $o = $self->_fill_offsets_to($n);
169 # If it's still undefined, there is no such record, so return 'undef'
170 return unless defined $o;
171 }
172
173 my $fh = $self->{FH};
174 $self->_seek($n); # we can do this now that offsets is populated
175 my $rec = $self->_read_record;
b3fe5a4c
AMS
176
177# If we happen to have just read the first record, check to see if
178# the length of the record matches what 'tell' says. If not, Tie::File
179# won't work, and should drop dead.
180#
181# if ($n == 0 && defined($rec) && tell($self->{fh}) != length($rec)) {
182# if (defined $self->{discipline}) {
183# croak "I/O discipline $self->{discipline} not supported";
184# } else {
185# croak "File encoding not supported";
186# }
187# }
188
6fc0ea7e 189 $self->{cache}->insert($n, $rec) if defined $rec && not $self->{flushing};
b5aed31e
AMS
190 $rec;
191}
192
193sub STORE {
194 my ($self, $n, $rec) = @_;
6fc0ea7e 195 die "STORE called from _check_integrity!" if $DIAGNOSTIC;
b5aed31e
AMS
196
197 $self->_fixrecs($rec);
198
6fc0ea7e
JH
199 if ($self->{autodefer}) {
200 $self->_annotate_ad_history($n);
201 }
202
203 return $self->_store_deferred($n, $rec) if $self->_is_deferring;
204
b5aed31e
AMS
205
206 # We need this to decide whether the new record will fit
207 # It incidentally populates the offsets table
208 # Note we have to do this before we alter the cache
6fc0ea7e 209 # 20020324 Wait, but this DOES alter the cache. TODO BUG?
0b28bc9a 210 my $oldrec = $self->_fetch($n);
b5aed31e 211
b5aed31e
AMS
212 if (not defined $oldrec) {
213 # We're storing a record beyond the end of the file
51efdd02 214 $self->_extend_file_to($n+1);
b5aed31e
AMS
215 $oldrec = $self->{recsep};
216 }
6ae23f41 217# return if $oldrec eq $rec; # don't bother
b5aed31e
AMS
218 my $len_diff = length($rec) - length($oldrec);
219
b3fe5a4c 220 # length($oldrec) here is not consistent with text mode TODO XXX BUG
6ae23f41
JH
221 $self->_mtwrite($rec, $self->{offsets}[$n], length($oldrec));
222 $self->_oadjust([$n, 1, $rec]);
223 $self->{cache}->update($n, $rec);
b5aed31e
AMS
224}
225
b3fe5a4c
AMS
226sub _store_deferred {
227 my ($self, $n, $rec) = @_;
6fc0ea7e 228 $self->{cache}->remove($n);
b3fe5a4c 229 my $old_deferred = $self->{deferred}{$n};
6fc0ea7e
JH
230
231 if (defined $self->{deferred_max} && $n > $self->{deferred_max}) {
232 $self->{deferred_max} = $n;
233 }
b3fe5a4c 234 $self->{deferred}{$n} = $rec;
6fc0ea7e
JH
235
236 my $len_diff = length($rec);
237 $len_diff -= length($old_deferred) if defined $old_deferred;
238 $self->{deferred_s} += $len_diff;
239 $self->{cache}->adj_limit(-$len_diff);
b3fe5a4c 240 if ($self->{deferred_s} > $self->{dw_size}) {
57c7bc08
AMS
241 $self->_flush;
242 } elsif ($self->_cache_too_full) {
b3fe5a4c
AMS
243 $self->_cache_flush;
244 }
245}
246
57c7bc08
AMS
247# Remove a single record from the deferred-write buffer without writing it
248# The record need not be present
249sub _delete_deferred {
250 my ($self, $n) = @_;
251 my $rec = delete $self->{deferred}{$n};
252 return unless defined $rec;
6fc0ea7e
JH
253
254 if (defined $self->{deferred_max}
255 && $n == $self->{deferred_max}) {
256 undef $self->{deferred_max};
257 }
258
57c7bc08 259 $self->{deferred_s} -= length $rec;
6fc0ea7e 260 $self->{cache}->adj_limit(length $rec);
57c7bc08
AMS
261}
262
b5aed31e
AMS
263sub FETCHSIZE {
264 my $self = shift;
6ae23f41
JH
265 my $n = $self->{eof} ? $#{$self->{offsets}} : $self->_fill_offsets;
266
6fc0ea7e
JH
267 my $top_deferred = $self->_defer_max;
268 $n = $top_deferred+1 if defined $top_deferred && $n < $top_deferred+1;
b5aed31e
AMS
269 $n;
270}
271
272sub STORESIZE {
273 my ($self, $len) = @_;
6fc0ea7e
JH
274
275 if ($self->{autodefer}) {
276 $self->_annotate_ad_history('STORESIZE');
277 }
278
b5aed31e
AMS
279 my $olen = $self->FETCHSIZE;
280 return if $len == $olen; # Woo-hoo!
281
282 # file gets longer
283 if ($len > $olen) {
6fc0ea7e 284 if ($self->_is_deferring) {
57c7bc08
AMS
285 for ($olen .. $len-1) {
286 $self->_store_deferred($_, $self->{recsep});
287 }
288 } else {
289 $self->_extend_file_to($len);
290 }
b5aed31e
AMS
291 return;
292 }
293
294 # file gets shorter
6fc0ea7e
JH
295 if ($self->_is_deferring) {
296 # TODO maybe replace this with map-plus-assignment?
57c7bc08
AMS
297 for (grep $_ >= $len, keys %{$self->{deferred}}) {
298 $self->_delete_deferred($_);
299 }
6fc0ea7e 300 $self->{deferred_max} = $len-1;
57c7bc08
AMS
301 }
302
b5aed31e
AMS
303 $self->_seek($len);
304 $self->_chop_file;
836d9961 305 $#{$self->{offsets}} = $len;
b3fe5a4c 306# $self->{offsets}[0] = 0; # in case we just chopped this
6fc0ea7e 307
bf919750 308 $self->{cache}->remove(grep $_ >= $len, $self->{cache}->ckeys);
b5aed31e
AMS
309}
310
6ae23f41
JH
311### OPTIMIZE ME
312### It should not be necessary to do FETCHSIZE
313### Just seek to the end of the file.
51efdd02
AMS
314sub PUSH {
315 my $self = shift;
316 $self->SPLICE($self->FETCHSIZE, scalar(@_), @_);
6ae23f41
JH
317
318 # No need to return:
319 # $self->FETCHSIZE; # because av.c takes care of this for me
51efdd02
AMS
320}
321
322sub POP {
323 my $self = shift;
7b6b3db1
JH
324 my $size = $self->FETCHSIZE;
325 return if $size == 0;
326# print STDERR "# POPPITY POP POP POP\n";
327 scalar $self->SPLICE($size-1, 1);
51efdd02
AMS
328}
329
330sub SHIFT {
331 my $self = shift;
332 scalar $self->SPLICE(0, 1);
333}
334
335sub UNSHIFT {
336 my $self = shift;
337 $self->SPLICE(0, 0, @_);
57c7bc08 338 # $self->FETCHSIZE; # av.c takes care of this for me
51efdd02
AMS
339}
340
341sub CLEAR {
51efdd02 342 my $self = shift;
6fc0ea7e
JH
343
344 if ($self->{autodefer}) {
345 $self->_annotate_ad_history('CLEAR');
346 }
347
51efdd02
AMS
348 $self->_seekb(0);
349 $self->_chop_file;
6fc0ea7e
JH
350 $self->{cache}->set_limit($self->{memory});
351 $self->{cache}->empty;
51efdd02 352 @{$self->{offsets}} = (0);
57c7bc08
AMS
353 %{$self->{deferred}}= ();
354 $self->{deferred_s} = 0;
6fc0ea7e 355 $self->{deferred_max} = -1;
51efdd02
AMS
356}
357
358sub EXTEND {
359 my ($self, $n) = @_;
57c7bc08
AMS
360
361 # No need to pre-extend anything in this case
6fc0ea7e 362 return if $self->_is_deferring;
57c7bc08 363
51efdd02
AMS
364 $self->_fill_offsets_to($n);
365 $self->_extend_file_to($n);
366}
367
368sub DELETE {
369 my ($self, $n) = @_;
6fc0ea7e
JH
370
371 if ($self->{autodefer}) {
372 $self->_annotate_ad_history('DELETE');
373 }
374
51efdd02 375 my $lastrec = $self->FETCHSIZE-1;
57c7bc08 376 my $rec = $self->FETCH($n);
6fc0ea7e 377 $self->_delete_deferred($n) if $self->_is_deferring;
51efdd02
AMS
378 if ($n == $lastrec) {
379 $self->_seek($n);
380 $self->_chop_file;
fa408a35 381 $#{$self->{offsets}}--;
6fc0ea7e 382 $self->{cache}->remove($n);
51efdd02 383 # perhaps in this case I should also remove trailing null records?
57c7bc08
AMS
384 # 20020316
385 # Note that delete @a[-3..-1] deletes the records in the wrong order,
386 # so we only chop the very last one out of the file. We could repair this
387 # by tracking deleted records inside the object.
388 } elsif ($n < $lastrec) {
51efdd02
AMS
389 $self->STORE($n, "");
390 }
57c7bc08 391 $rec;
51efdd02
AMS
392}
393
394sub EXISTS {
395 my ($self, $n) = @_;
57c7bc08 396 return 1 if exists $self->{deferred}{$n};
57c7bc08 397 $n < $self->FETCHSIZE;
51efdd02
AMS
398}
399
b5aed31e 400sub SPLICE {
b3fe5a4c 401 my $self = shift;
6fc0ea7e
JH
402
403 if ($self->{autodefer}) {
404 $self->_annotate_ad_history('SPLICE');
405 }
406
407 $self->_flush if $self->_is_deferring; # move this up?
0b28bc9a
AMS
408 if (wantarray) {
409 $self->_chomp(my @a = $self->_splice(@_));
410 @a;
411 } else {
412 $self->_chomp1(scalar $self->_splice(@_));
413 }
b3fe5a4c
AMS
414}
415
416sub DESTROY {
57c7bc08 417 my $self = shift;
6fc0ea7e
JH
418 $self->flush if $self->_is_deferring;
419 $self->{cache}->delink if defined $self->{cache}; # break circular link
2a00e2a4
JH
420 if ($self->{fh} and $self->{ourfh}) {
421 delete $self->{ourfh};
422 close delete $self->{fh};
2a00e2a4 423 }
b3fe5a4c
AMS
424}
425
426sub _splice {
b5aed31e
AMS
427 my ($self, $pos, $nrecs, @data) = @_;
428 my @result;
429
7b6b3db1
JH
430 $pos = 0 unless defined $pos;
431
432 # Deal with negative and other out-of-range positions
433 # Also set default for $nrecs
51efdd02
AMS
434 {
435 my $oldsize = $self->FETCHSIZE;
7b6b3db1 436 $nrecs = $oldsize unless defined $nrecs;
51efdd02
AMS
437 my $oldpos = $pos;
438
439 if ($pos < 0) {
440 $pos += $oldsize;
441 if ($pos < 0) {
442 croak "Modification of non-creatable array value attempted, subscript $oldpos";
443 }
444 }
445
446 if ($pos > $oldsize) {
447 return unless @data;
448 $pos = $oldsize; # This is what perl does for normal arrays
449 }
bf919750
JH
450
451 # The manual is very unclear here
452 if ($nrecs < 0) {
453 $nrecs = $oldsize - $pos + $nrecs;
454 $nrecs = 0 if $nrecs < 0;
455 }
6ae23f41
JH
456
457 # nrecs is too big---it really means "until the end"
458 # 20030507
459 if ($nrecs + $pos > $oldsize) {
460 $nrecs = $oldsize - $pos;
461 }
51efdd02 462 }
b5aed31e
AMS
463
464 $self->_fixrecs(@data);
465 my $data = join '', @data;
466 my $datalen = length $data;
467 my $oldlen = 0;
468
469 # compute length of data being removed
470 for ($pos .. $pos+$nrecs-1) {
27531ffb 471 last unless defined $self->_fill_offsets_to($_);
0b28bc9a 472 my $rec = $self->_fetch($_);
b5aed31e
AMS
473 last unless defined $rec;
474 push @result, $rec;
6fc0ea7e
JH
475
476 # Why don't we just use length($rec) here?
477 # Because that record might have come from the cache. _splice
478 # might have been called to flush out the deferred-write records,
27531ffb
JH
479 # and in this case length($rec) is the length of the record to be
480 # *written*, not the length of the actual record in the file. But
481 # the offsets are still true. 20020322
6fc0ea7e
JH
482 $oldlen += $self->{offsets}[$_+1] - $self->{offsets}[$_]
483 if defined $self->{offsets}[$_+1];
b5aed31e 484 }
6ae23f41 485 $self->_fill_offsets_to($pos+$nrecs);
b5aed31e 486
51efdd02 487 # Modify the file
6ae23f41
JH
488 $self->_mtwrite($data, $self->{offsets}[$pos], $oldlen);
489 # Adjust the offsets table
490 $self->_oadjust([$pos, $nrecs, @data]);
491
492 { # Take this read cache stuff out into a separate function
493 # You made a half-attempt to put it into _oadjust.
494 # Finish something like that up eventually.
495 # STORE also needs to do something similarish
496
497 # update the read cache, part 1
498 # modified records
499 for ($pos .. $pos+$nrecs-1) {
500 my $new = $data[$_-$pos];
501 if (defined $new) {
502 $self->{cache}->update($_, $new);
503 } else {
504 $self->{cache}->remove($_);
505 }
b5aed31e 506 }
6ae23f41
JH
507
508 # update the read cache, part 2
509 # moved records - records past the site of the change
510 # need to be renumbered
511 # Maybe merge this with the previous block?
512 {
513 my @oldkeys = grep $_ >= $pos + $nrecs, $self->{cache}->ckeys;
514 my @newkeys = map $_-$nrecs+@data, @oldkeys;
515 $self->{cache}->rekey(\@oldkeys, \@newkeys);
b5aed31e 516 }
6fc0ea7e 517
6ae23f41
JH
518 # Now there might be too much data in the cache, if we spliced out
519 # some short records and spliced in some long ones. If so, flush
520 # the cache.
521 $self->_cache_flush;
b5aed31e 522 }
b5aed31e 523
51efdd02
AMS
524 # Yes, the return value of 'splice' *is* actually this complicated
525 wantarray ? @result : @result ? $result[-1] : undef;
b5aed31e
AMS
526}
527
6ae23f41 528
b5aed31e 529# write data into the file
6ae23f41 530# $data is the data to be written.
b5aed31e
AMS
531# it should be written at position $pos, and should overwrite
532# exactly $len of the following bytes.
533# Note that if length($data) > $len, the subsequent bytes will have to
534# be moved up, and if length($data) < $len, they will have to
535# be moved down
536sub _twrite {
537 my ($self, $data, $pos, $len) = @_;
538
539 unless (defined $pos) {
540 die "\$pos was undefined in _twrite";
541 }
542
543 my $len_diff = length($data) - $len;
544
545 if ($len_diff == 0) { # Woo-hoo!
546 my $fh = $self->{fh};
547 $self->_seekb($pos);
548 $self->_write_record($data);
549 return; # well, that was easy.
550 }
551
552 # the two records are of different lengths
553 # our strategy here: rewrite the tail of the file,
554 # reading ahead one buffer at a time
555 # $bufsize is required to be at least as large as the data we're overwriting
556 my $bufsize = _bufsize($len_diff);
557 my ($writepos, $readpos) = ($pos, $pos+$len);
51efdd02 558 my $next_block;
6fc0ea7e 559 my $more_data;
b5aed31e
AMS
560
561 # Seems like there ought to be a way to avoid the repeated code
562 # and the special case here. The read(1) is also a little weird.
563 # Think about this.
564 do {
565 $self->_seekb($readpos);
51efdd02 566 my $br = read $self->{fh}, $next_block, $bufsize;
6fc0ea7e 567 $more_data = read $self->{fh}, my($dummy), 1;
b5aed31e
AMS
568 $self->_seekb($writepos);
569 $self->_write_record($data);
570 $readpos += $br;
571 $writepos += length $data;
572 $data = $next_block;
6ae23f41 573 } while $more_data;
51efdd02
AMS
574 $self->_seekb($writepos);
575 $self->_write_record($next_block);
b5aed31e
AMS
576
577 # There might be leftover data at the end of the file
578 $self->_chop_file if $len_diff < 0;
579}
580
6ae23f41
JH
581# _iwrite(D, S, E)
582# Insert text D at position S.
583# Let C = E-S-|D|. If C < 0; die.
584# Data in [S,S+C) is copied to [S+D,S+D+C) = [S+D,E).
585# Data in [S+C = E-D, E) is returned. Data in [E, oo) is untouched.
586#
587# In a later version, don't read the entire intervening area into
588# memory at once; do the copying block by block.
589sub _iwrite {
590 my $self = shift;
591 my ($D, $s, $e) = @_;
592 my $d = length $D;
593 my $c = $e-$s-$d;
594 local *FH = $self->{fh};
595 confess "Not enough space to insert $d bytes between $s and $e"
596 if $c < 0;
597 confess "[$s,$e) is an invalid insertion range" if $e < $s;
598
599 $self->_seekb($s);
600 read FH, my $buf, $e-$s;
601
602 $D .= substr($buf, 0, $c, "");
603
604 $self->_seekb($s);
605 $self->_write_record($D);
606
607 return $buf;
608}
609
610# Like _twrite, but the data-pos-len triple may be repeated; you may
611# write several chunks. All the writing will be done in
612# one pass. Chunks SHALL be in ascending order and SHALL NOT overlap.
613sub _mtwrite {
614 my $self = shift;
615 my $unwritten = "";
616 my $delta = 0;
617
618 @_ % 3 == 0
619 or die "Arguments to _mtwrite did not come in groups of three";
620
621 while (@_) {
622 my ($data, $pos, $len) = splice @_, 0, 3;
623 my $end = $pos + $len; # The OLD end of the segment to be replaced
624 $data = $unwritten . $data;
625 $delta -= length($unwritten);
626 $unwritten = "";
627 $pos += $delta; # This is where the data goes now
628 my $dlen = length $data;
629 $self->_seekb($pos);
630 if ($len >= $dlen) { # the data will fit
631 $self->_write_record($data);
632 $delta += ($dlen - $len); # everything following moves down by this much
633 $data = ""; # All the data in the buffer has been written
634 } else { # won't fit
635 my $writable = substr($data, 0, $len - $delta, "");
636 $self->_write_record($writable);
637 $delta += ($dlen - $len); # everything following moves down by this much
638 }
639
640 # At this point we've written some but maybe not all of the data.
641 # There might be a gap to close up, or $data might still contain a
642 # bunch of unwritten data that didn't fit.
643 my $ndlen = length $data;
644 if ($delta == 0) {
645 $self->_write_record($data);
646 } elsif ($delta < 0) {
647 # upcopy (close up gap)
648 if (@_) {
649 $self->_upcopy($end, $end + $delta, $_[1] - $end);
650 } else {
651 $self->_upcopy($end, $end + $delta);
652 }
653 } else {
654 # downcopy (insert data that didn't fit; replace this data in memory
655 # with _later_ data that doesn't fit)
656 if (@_) {
657 $unwritten = $self->_downcopy($data, $end, $_[1] - $end);
658 } else {
2ded50a3 659 # Make the file longer to accommodate the last segment that doesn't
6ae23f41
JH
660 $unwritten = $self->_downcopy($data, $end);
661 }
662 }
663 }
664}
665
666# Copy block of data of length $len from position $spos to position $dpos
667# $dpos must be <= $spos
668#
669# If $len is undefined, go all the way to the end of the file
670# and then truncate it ($spos - $dpos bytes will be removed)
671sub _upcopy {
672 my $blocksize = 8192;
673 my ($self, $spos, $dpos, $len) = @_;
674 if ($dpos > $spos) {
675 die "source ($spos) was upstream of destination ($dpos) in _upcopy";
676 } elsif ($dpos == $spos) {
677 return;
678 }
679
680 while (! defined ($len) || $len > 0) {
681 my $readsize = ! defined($len) ? $blocksize
682 : $len > $blocksize ? $blocksize
683 : $len;
684
685 my $fh = $self->{fh};
686 $self->_seekb($spos);
86e5a81e 687 my $bytes_read = read $fh, my($data), $readsize;
6ae23f41
JH
688 $self->_seekb($dpos);
689 if ($data eq "") {
690 $self->_chop_file;
691 last;
692 }
693 $self->_write_record($data);
694 $spos += $bytes_read;
695 $dpos += $bytes_read;
696 $len -= $bytes_read if defined $len;
697 }
698}
699
700# Write $data into a block of length $len at position $pos,
701# moving everything in the block forwards to make room.
702# Instead of writing the last length($data) bytes from the block
703# (because there isn't room for them any longer) return them.
bc2f65e0
JH
704#
705# Undefined $len means 'until the end of the file'
6ae23f41
JH
706sub _downcopy {
707 my $blocksize = 8192;
708 my ($self, $data, $pos, $len) = @_;
709 my $fh = $self->{fh};
710
711 while (! defined $len || $len > 0) {
712 my $readsize = ! defined($len) ? $blocksize
713 : $len > $blocksize? $blocksize : $len;
714 $self->_seekb($pos);
86e5a81e 715 read $fh, my($old), $readsize;
bc2f65e0 716 my $last_read_was_short = length($old) < $readsize;
6ae23f41 717 $data .= $old;
bc2f65e0
JH
718 my $writable;
719 if ($last_read_was_short) {
720 # If last read was short, then $data now contains the entire rest
721 # of the file, so there's no need to write only one block of it
722 $writable = $data;
723 $data = "";
724 } else {
725 $writable = substr($data, 0, $readsize, "");
726 }
6ae23f41 727 last if $writable eq "";
bc2f65e0 728 $self->_seekb($pos);
6ae23f41 729 $self->_write_record($writable);
690c5ca7 730 last if $last_read_was_short && $data eq "";
6ae23f41
JH
731 $len -= $readsize if defined $len;
732 $pos += $readsize;
733 }
734 return $data;
735}
736
737# Adjust the object data structures following an '_mtwrite'
738# Arguments are
739# [$pos, $nrecs, @length] items
740# indicating that $nrecs records were removed at $recpos (a record offset)
741# and replaced with records of length @length...
742# Arguments guarantee that $recpos is strictly increasing.
743# No return value
744sub _oadjust {
745 my $self = shift;
746 my $delta = 0;
747 my $delta_recs = 0;
748 my $prev_end = -1;
749 my %newkeys;
750
751 for (@_) {
752 my ($pos, $nrecs, @data) = @$_;
753 $pos += $delta_recs;
754
755 # Adjust the offsets of the records after the previous batch up
756 # to the first new one of this batch
757 for my $i ($prev_end+2 .. $pos - 1) {
758 $self->{offsets}[$i] += $delta;
759 $newkey{$i} = $i + $delta_recs;
760 }
761
762 $prev_end = $pos + @data - 1; # last record moved on this pass
763
764 # Remove the offsets for the removed records;
765 # replace with the offsets for the inserted records
766 my @newoff = ($self->{offsets}[$pos] + $delta);
767 for my $i (0 .. $#data) {
768 my $newlen = length $data[$i];
769 push @newoff, $newoff[$i] + $newlen;
770 $delta += $newlen;
771 }
772
773 for my $i ($pos .. $pos+$nrecs-1) {
774 last if $i+1 > $#{$self->{offsets}};
775 my $oldlen = $self->{offsets}[$i+1] - $self->{offsets}[$i];
776 $delta -= $oldlen;
777 }
778
779# # also this data has changed, so update it in the cache
780# for (0 .. $#data) {
781# $self->{cache}->update($pos + $_, $data[$_]);
782# }
783# if ($delta_recs) {
784# my @oldkeys = grep $_ >= $pos + @data, $self->{cache}->ckeys;
785# my @newkeys = map $_ + $delta_recs, @oldkeys;
786# $self->{cache}->rekey(\@oldkeys, \@newkeys);
787# }
788
789 # replace old offsets with new
790 splice @{$self->{offsets}}, $pos, $nrecs+1, @newoff;
791 # What if we just spliced out the end of the offsets table?
792 # shouldn't we clear $self->{eof}? Test for this XXX BUG TODO
793
794 $delta_recs += @data - $nrecs; # net change in total number of records
795 }
796
797 # The trailing records at the very end of the file
798 if ($delta) {
799 for my $i ($prev_end+2 .. $#{$self->{offsets}}) {
800 $self->{offsets}[$i] += $delta;
801 }
802 }
803
804 # If we scrubbed out all known offsets, regenerate the trivial table
805 # that knows that the file does indeed start at 0.
806 $self->{offsets}[0] = 0 unless @{$self->{offsets}};
807 # If the file got longer, the offsets table is no longer complete
808 # $self->{eof} = 0 if $delta_recs > 0;
809
810 # Now there might be too much data in the cache, if we spliced out
811 # some short records and spliced in some long ones. If so, flush
812 # the cache.
813 $self->_cache_flush;
814}
815
b5aed31e
AMS
816# If a record does not already end with the appropriate terminator
817# string, append one.
818sub _fixrecs {
819 my $self = shift;
820 for (@_) {
27531ffb 821 $_ = "" unless defined $_;
b5aed31e
AMS
822 $_ .= $self->{recsep}
823 unless substr($_, - $self->{recseplen}) eq $self->{recsep};
824 }
825}
826
57c7bc08
AMS
827
828################################################################
829#
830# Basic read, write, and seek
831#
832
b5aed31e
AMS
833# seek to the beginning of record #$n
834# Assumes that the offsets table is already correctly populated
835#
836# Note that $n=-1 has a special meaning here: It means the start of
837# the last known record; this may or may not be the very last record
838# in the file, depending on whether the offsets table is fully populated.
839#
840sub _seek {
841 my ($self, $n) = @_;
842 my $o = $self->{offsets}[$n];
843 defined($o)
844 or confess("logic error: undefined offset for record $n");
845 seek $self->{fh}, $o, SEEK_SET
6ae23f41 846 or confess "Couldn't seek filehandle: $!"; # "Should never happen."
b5aed31e
AMS
847}
848
6ae23f41 849# seek to byte $b in the file
b5aed31e
AMS
850sub _seekb {
851 my ($self, $b) = @_;
852 seek $self->{fh}, $b, SEEK_SET
853 or die "Couldn't seek filehandle: $!"; # "Should never happen."
854}
855
856# populate the offsets table up to the beginning of record $n
857# return the offset of record $n
858sub _fill_offsets_to {
859 my ($self, $n) = @_;
27531ffb
JH
860
861 return $self->{offsets}[$n] if $self->{eof};
862
b5aed31e
AMS
863 my $fh = $self->{fh};
864 local *OFF = $self->{offsets};
865 my $rec;
866
867 until ($#OFF >= $n) {
b5aed31e
AMS
868 $self->_seek(-1); # tricky -- see comment at _seek
869 $rec = $self->_read_record;
870 if (defined $rec) {
6ae23f41 871 push @OFF, int(tell $fh); # Tels says that int() saves memory here
b5aed31e 872 } else {
27531ffb 873 $self->{eof} = 1;
b5aed31e
AMS
874 return; # It turns out there is no such record
875 }
876 }
877
878 # we have now read all the records up to record n-1,
879 # so we can return the offset of record n
6ae23f41
JH
880 $OFF[$n];
881}
882
883sub _fill_offsets {
884 my ($self) = @_;
885
886 my $fh = $self->{fh};
887 local *OFF = $self->{offsets};
888
889 $self->_seek(-1); # tricky -- see comment at _seek
890
891 # Tels says that inlining read_record() would make this loop
892 # five times faster. 20030508
893 while ( defined $self->_read_record()) {
894 # int() saves us memory here
895 push @OFF, int(tell $fh);
896 }
897
898 $self->{eof} = 1;
899 $#OFF;
b5aed31e
AMS
900}
901
902# assumes that $rec is already suitably terminated
903sub _write_record {
904 my ($self, $rec) = @_;
905 my $fh = $self->{fh};
bf919750 906 local $\ = "";
b5aed31e
AMS
907 print $fh $rec
908 or die "Couldn't write record: $!"; # "Should never happen."
27531ffb 909# $self->{_written} += length($rec);
b5aed31e
AMS
910}
911
912sub _read_record {
913 my $self = shift;
914 my $rec;
915 { local $/ = $self->{recsep};
916 my $fh = $self->{fh};
917 $rec = <$fh>;
918 }
27531ffb 919 return unless defined $rec;
29aee836 920 if (substr($rec, -$self->{recseplen}) ne $self->{recsep}) {
27531ffb
JH
921 # improperly terminated final record --- quietly fix it.
922# my $ac = substr($rec, -$self->{recseplen});
923# $ac =~ s/\n/\\n/g;
bf919750 924 $self->{sawlastrec} = 1;
27531ffb 925 unless ($self->{rdonly}) {
bf919750 926 local $\ = "";
27531ffb
JH
927 my $fh = $self->{fh};
928 print $fh $self->{recsep};
929 }
930 $rec .= $self->{recsep};
931 }
932# $self->{_read} += length($rec) if defined $rec;
b5aed31e
AMS
933 $rec;
934}
935
6fc0ea7e 936sub _rw_stats {
27531ffb 937 my $self = shift;
6fc0ea7e
JH
938 @{$self}{'_read', '_written'};
939}
940
57c7bc08
AMS
941################################################################
942#
943# Read cache management
944
6fc0ea7e
JH
945sub _cache_flush {
946 my ($self) = @_;
947 $self->{cache}->reduce_size_to($self->{memory} - $self->{deferred_s});
b5aed31e
AMS
948}
949
57c7bc08
AMS
950sub _cache_too_full {
951 my $self = shift;
6fc0ea7e 952 $self->{cache}->bytes + $self->{deferred_s} >= $self->{memory};
b5aed31e
AMS
953}
954
57c7bc08
AMS
955################################################################
956#
957# File custodial services
958#
959
960
b5aed31e
AMS
961# We have read to the end of the file and have the offsets table
962# entirely populated. Now we need to write a new record beyond
963# the end of the file. We prepare for this by writing
964# empty records into the file up to the position we want
51efdd02
AMS
965#
966# assumes that the offsets table already contains the offset of record $n,
967# if it exists, and extends to the end of the file if not.
b5aed31e
AMS
968sub _extend_file_to {
969 my ($self, $n) = @_;
970 $self->_seek(-1); # position after the end of the last record
971 my $pos = $self->{offsets}[-1];
972
973 # the offsets table has one entry more than the total number of records
6fc0ea7e 974 my $extras = $n - $#{$self->{offsets}};
b5aed31e
AMS
975
976 # Todo : just use $self->{recsep} x $extras here?
977 while ($extras-- > 0) {
978 $self->_write_record($self->{recsep});
6ae23f41 979 push @{$self->{offsets}}, int(tell $self->{fh});
b5aed31e
AMS
980 }
981}
982
983# Truncate the file at the current position
984sub _chop_file {
985 my $self = shift;
986 truncate $self->{fh}, tell($self->{fh});
987}
988
57c7bc08 989
b5aed31e
AMS
990# compute the size of a buffer suitable for moving
991# all the data in a file forward $n bytes
992# ($n may be negative)
993# The result should be at least $n.
994sub _bufsize {
995 my $n = shift;
6ae23f41 996 return 8192 if $n <= 0;
b5aed31e
AMS
997 my $b = $n & ~8191;
998 $b += 8192 if $n & 8191;
999 $b;
1000}
1001
57c7bc08
AMS
1002################################################################
1003#
1004# Miscellaneous public methods
1005#
1006
51efdd02
AMS
1007# Lock the file
1008sub flock {
1009 my ($self, $op) = @_;
1010 unless (@_ <= 3) {
1011 my $pack = ref $self;
1012 croak "Usage: $pack\->flock([OPERATION])";
1013 }
1014 my $fh = $self->{fh};
1015 $op = LOCK_EX unless defined $op;
6ae23f41
JH
1016 my $locked = flock $fh, $op;
1017
1018 if ($locked && ($op & (LOCK_EX | LOCK_SH))) {
1019 # If you're locking the file, then presumably it's because
1020 # there might have been a write access by another process.
1021 # In that case, the read cache contents and the offsets table
1022 # might be invalid, so discard them. 20030508
1023 $self->{offsets} = [0];
1024 $self->{cache}->empty;
1025 }
1026
1027 $locked;
51efdd02 1028}
b5aed31e 1029
0b28bc9a
AMS
1030# Get/set autochomp option
1031sub autochomp {
1032 my $self = shift;
1033 if (@_) {
1034 my $old = $self->{autochomp};
1035 $self->{autochomp} = shift;
1036 $old;
1037 } else {
1038 $self->{autochomp};
1039 }
1040}
1041
6ae23f41
JH
1042# Get offset table entries; returns offset of nth record
1043sub offset {
1044 my ($self, $n) = @_;
1045
1046 if ($#{$self->{offsets}} < $n) {
1047 return if $self->{eof}; # request for record beyond the end of file
1048 my $o = $self->_fill_offsets_to($n);
1049 # If it's still undefined, there is no such record, so return 'undef'
1050 return unless defined $o;
1051 }
1052
1053 $self->{offsets}[$n];
1054}
1055
1056sub discard_offsets {
1057 my $self = shift;
1058 $self->{offsets} = [0];
1059}
1060
57c7bc08
AMS
1061################################################################
1062#
1063# Matters related to deferred writing
1064#
1065
1066# Defer writes
1067sub defer {
1068 my $self = shift;
6fc0ea7e
JH
1069 $self->_stop_autodeferring;
1070 @{$self->{ad_history}} = ();
57c7bc08
AMS
1071 $self->{defer} = 1;
1072}
1073
b3fe5a4c
AMS
1074# Flush deferred writes
1075#
1076# This could be better optimized to write the file in one pass, instead
1077# of one pass per block of records. But that will require modifications
6ae23f41 1078# to _twrite, so I should have a good _twrite test suite first.
b3fe5a4c
AMS
1079sub flush {
1080 my $self = shift;
1081
1082 $self->_flush;
1083 $self->{defer} = 0;
1084}
1085
6ae23f41 1086sub _old_flush {
b3fe5a4c
AMS
1087 my $self = shift;
1088 my @writable = sort {$a<=>$b} (keys %{$self->{deferred}});
6ae23f41 1089
b3fe5a4c
AMS
1090 while (@writable) {
1091 # gather all consecutive records from the front of @writable
1092 my $first_rec = shift @writable;
1093 my $last_rec = $first_rec+1;
1094 ++$last_rec, shift @writable while @writable && $last_rec == $writable[0];
1095 --$last_rec;
1096 $self->_fill_offsets_to($last_rec);
1097 $self->_extend_file_to($last_rec);
1098 $self->_splice($first_rec, $last_rec-$first_rec+1,
1099 @{$self->{deferred}}{$first_rec .. $last_rec});
1100 }
1101
57c7bc08 1102 $self->_discard; # clear out defered-write-cache
b3fe5a4c
AMS
1103}
1104
6ae23f41
JH
1105sub _flush {
1106 my $self = shift;
1107 my @writable = sort {$a<=>$b} (keys %{$self->{deferred}});
1108 my @args;
1109 my @adjust;
1110
1111 while (@writable) {
1112 # gather all consecutive records from the front of @writable
1113 my $first_rec = shift @writable;
1114 my $last_rec = $first_rec+1;
1115 ++$last_rec, shift @writable while @writable && $last_rec == $writable[0];
1116 --$last_rec;
1117 my $end = $self->_fill_offsets_to($last_rec+1);
1118 if (not defined $end) {
1119 $self->_extend_file_to($last_rec);
1120 $end = $self->{offsets}[$last_rec];
1121 }
1122 my ($start) = $self->{offsets}[$first_rec];
1123 push @args,
1124 join("", @{$self->{deferred}}{$first_rec .. $last_rec}), # data
1125 $start, # position
1126 $end-$start; # length
1127 push @adjust, [$first_rec, # starting at this position...
1128 $last_rec-$first_rec+1, # this many records...
1129 # are replaced with these...
1130 @{$self->{deferred}}{$first_rec .. $last_rec},
1131 ];
1132 }
1133
1134 $self->_mtwrite(@args); # write multiple record groups
1135 $self->_discard; # clear out defered-write-cache
1136 $self->_oadjust(@adjust);
1137}
1138
57c7bc08 1139# Discard deferred writes and disable future deferred writes
b3fe5a4c
AMS
1140sub discard {
1141 my $self = shift;
57c7bc08 1142 $self->_discard;
b3fe5a4c
AMS
1143 $self->{defer} = 0;
1144}
1145
57c7bc08
AMS
1146# Discard deferred writes, but retain old deferred writing mode
1147sub _discard {
1148 my $self = shift;
6fc0ea7e
JH
1149 %{$self->{deferred}} = ();
1150 $self->{deferred_s} = 0;
1151 $self->{deferred_max} = -1;
1152 $self->{cache}->set_limit($self->{memory});
1153}
1154
1155# Deferred writing is enabled, either explicitly ($self->{defer})
1156# or automatically ($self->{autodeferring})
1157sub _is_deferring {
1158 my $self = shift;
1159 $self->{defer} || $self->{autodeferring};
1160}
1161
1162# The largest record number of any deferred record
1163sub _defer_max {
1164 my $self = shift;
1165 return $self->{deferred_max} if defined $self->{deferred_max};
1166 my $max = -1;
1167 for my $key (keys %{$self->{deferred}}) {
1168 $max = $key if $key > $max;
1169 }
1170 $self->{deferred_max} = $max;
1171 $max;
57c7bc08
AMS
1172}
1173
6fc0ea7e
JH
1174################################################################
1175#
1176# Matters related to autodeferment
1177#
1178
1179# Get/set autodefer option
1180sub autodefer {
1181 my $self = shift;
1182 if (@_) {
1183 my $old = $self->{autodefer};
1184 $self->{autodefer} = shift;
1185 if ($old) {
1186 $self->_stop_autodeferring;
1187 @{$self->{ad_history}} = ();
1188 }
1189 $old;
1190 } else {
1191 $self->{autodefer};
1192 }
1193}
1194
1195# The user is trying to store record #$n Record that in the history,
1196# and then enable (or disable) autodeferment if that seems useful.
1197# Note that it's OK for $n to be a non-number, as long as the function
1198# is prepared to deal with that. Nobody else looks at the ad_history.
1199#
1200# Now, what does the ad_history mean, and what is this function doing?
1201# Essentially, the idea is to enable autodeferring when we see that the
1202# user has made three consecutive STORE calls to three consecutive records.
1203# ("Three" is actually ->{autodefer_threshhold}.)
1204# A STORE call for record #$n inserts $n into the autodefer history,
1205# and if the history contains three consecutive records, we enable
1206# autodeferment. An ad_history of [X, Y] means that the most recent
1207# STOREs were for records X, X+1, ..., Y, in that order.
1208#
1209# Inserting a nonconsecutive number erases the history and starts over.
1210#
1211# Performing a special operation like SPLICE erases the history.
1212#
1213# There's one special case: CLEAR means that CLEAR was just called.
1214# In this case, we prime the history with [-2, -1] so that if the next
1215# write is for record 0, autodeferring goes on immediately. This is for
1216# the common special case of "@a = (...)".
1217#
1218sub _annotate_ad_history {
1219 my ($self, $n) = @_;
1220 return unless $self->{autodefer}; # feature is disabled
1221 return if $self->{defer}; # already in explicit defer mode
1222 return unless $self->{offsets}[-1] >= $self->{autodefer_filelen_threshhold};
1223
1224 local *H = $self->{ad_history};
1225 if ($n eq 'CLEAR') {
1226 @H = (-2, -1); # prime the history with fake records
1227 $self->_stop_autodeferring;
1228 } elsif ($n =~ /^\d+$/) {
1229 if (@H == 0) {
1230 @H = ($n, $n);
1231 } else { # @H == 2
1232 if ($H[1] == $n-1) { # another consecutive record
1233 $H[1]++;
1234 if ($H[1] - $H[0] + 1 >= $self->{autodefer_threshhold}) {
1235 $self->{autodeferring} = 1;
1236 }
1237 } else { # nonconsecutive- erase and start over
1238 @H = ($n, $n);
1239 $self->_stop_autodeferring;
1240 }
1241 }
1242 } else { # SPLICE or STORESIZE or some such
1243 @H = ();
1244 $self->_stop_autodeferring;
1245 }
1246}
1247
6ae23f41 1248# If autodeferring was enabled, cut it out and discard the history
6fc0ea7e
JH
1249sub _stop_autodeferring {
1250 my $self = shift;
1251 if ($self->{autodeferring}) {
1252 $self->_flush;
1253 }
1254 $self->{autodeferring} = 0;
1255}
1256
1257################################################################
1258
b3fe5a4c 1259
57c7bc08
AMS
1260# This is NOT a method. It is here for two reasons:
1261# 1. To factor a fairly complicated block out of the constructor
1262# 2. To provide access for the test suite, which need to be sure
1263# files are being written properly.
b3fe5a4c
AMS
1264sub _default_recsep {
1265 my $recsep = $/;
57c7bc08 1266 if ($^O eq 'MSWin32') { # Dos too?
b3fe5a4c
AMS
1267 # Windows users expect files to be terminated with \r\n
1268 # But $/ is set to \n instead
1269 # Note that this also transforms \n\n into \r\n\r\n.
1270 # That is a feature.
1271 $recsep =~ s/\n/\r\n/g;
1272 }
1273 $recsep;
1274}
1275
57c7bc08
AMS
1276# Utility function for _check_integrity
1277sub _ci_warn {
1278 my $msg = shift;
1279 $msg =~ s/\n/\\n/g;
1280 $msg =~ s/\r/\\r/g;
1281 print "# $msg\n";
1282}
1283
b5aed31e 1284# Given a file, make sure the cache is consistent with the
57c7bc08
AMS
1285# file contents and the internal data structures are consistent with
1286# each other. Returns true if everything checks out, false if not
1287#
1288# The $file argument is no longer used. It is retained for compatibility
1289# with the existing test suite.
b5aed31e
AMS
1290sub _check_integrity {
1291 my ($self, $file, $warn) = @_;
6fc0ea7e
JH
1292 my $rsl = $self->{recseplen};
1293 my $rs = $self->{recsep};
b5aed31e 1294 my $good = 1;
6fc0ea7e
JH
1295 local *_; # local $_ does not work here
1296 local $DIAGNOSTIC = 1;
1297
1298 if (not defined $rs) {
1299 _ci_warn("recsep is undef!");
1300 $good = 0;
1301 } elsif ($rs eq "") {
1302 _ci_warn("recsep is empty!");
1303 $good = 0;
1304 } elsif ($rsl != length $rs) {
1305 my $ln = length $rs;
1306 _ci_warn("recsep <$rs> has length $ln, should be $rsl");
1307 $good = 0;
1308 }
fa408a35 1309
836d9961 1310 if (not defined $self->{offsets}[0]) {
57c7bc08 1311 _ci_warn("offset 0 is missing!");
836d9961 1312 $good = 0;
bf919750 1313
836d9961 1314 } elsif ($self->{offsets}[0] != 0) {
57c7bc08 1315 _ci_warn("rec 0: offset <$self->{offsets}[0]> s/b 0!");
b5aed31e
AMS
1316 $good = 0;
1317 }
fa408a35 1318
57c7bc08 1319 my $cached = 0;
6fc0ea7e
JH
1320 {
1321 local *F = $self->{fh};
1322 seek F, 0, SEEK_SET;
1323 local $. = 0;
1324 local $/ = $rs;
1325
1326 while (<F>) {
1327 my $n = $. - 1;
1328 my $cached = $self->{cache}->_produce($n);
1329 my $offset = $self->{offsets}[$.];
1330 my $ao = tell F;
1331 if (defined $offset && $offset != $ao) {
1332 _ci_warn("rec $n: offset <$offset> actual <$ao>");
1333 $good = 0;
1334 }
1335 if (defined $cached && $_ ne $cached && ! $self->{deferred}{$n}) {
1336 $good = 0;
1337 _ci_warn("rec $n: cached <$cached> actual <$_>");
1338 }
1339 if (defined $cached && substr($cached, -$rsl) ne $rs) {
27531ffb 1340 $good = 0;
6fc0ea7e
JH
1341 _ci_warn("rec $n in the cache is missing the record separator");
1342 }
27531ffb
JH
1343 if (! defined $offset && $self->{eof}) {
1344 $good = 0;
1345 _ci_warn("The offset table was marked complete, but it is missing element $.");
1346 }
1347 }
1348 if (@{$self->{offsets}} > $.+1) {
1349 $good = 0;
1350 my $n = @{$self->{offsets}};
1351 _ci_warn("The offset table has $n items, but the file has only $.");
6fc0ea7e 1352 }
b5aed31e 1353
6fc0ea7e 1354 my $deferring = $self->_is_deferring;
bf919750 1355 for my $n ($self->{cache}->ckeys) {
6fc0ea7e
JH
1356 my $r = $self->{cache}->_produce($n);
1357 $cached += length($r);
1358 next if $n+1 <= $.; # checked this already
1359 _ci_warn("spurious caching of record $n");
b5aed31e
AMS
1360 $good = 0;
1361 }
6fc0ea7e
JH
1362 my $b = $self->{cache}->bytes;
1363 if ($cached != $b) {
1364 _ci_warn("cache size is $b, should be $cached");
b5aed31e
AMS
1365 $good = 0;
1366 }
1367 }
1368
bf919750 1369 # That cache has its own set of tests
6fc0ea7e
JH
1370 $good = 0 unless $self->{cache}->_check_integrity;
1371
57c7bc08
AMS
1372 # Now let's check the deferbuffer
1373 # Unless deferred writing is enabled, it should be empty
6fc0ea7e 1374 if (! $self->_is_deferring && %{$self->{deferred}}) {
57c7bc08
AMS
1375 _ci_warn("deferred writing disabled, but deferbuffer nonempty");
1376 $good = 0;
1377 }
1378
1379 # Any record in the deferbuffer should *not* be present in the readcache
1380 my $deferred_s = 0;
1381 while (my ($n, $r) = each %{$self->{deferred}}) {
1382 $deferred_s += length($r);
6fc0ea7e 1383 if (defined $self->{cache}->_produce($n)) {
57c7bc08
AMS
1384 _ci_warn("record $n is in the deferbuffer *and* the readcache");
1385 $good = 0;
1386 }
6fc0ea7e 1387 if (substr($r, -$rsl) ne $rs) {
57c7bc08
AMS
1388 _ci_warn("rec $n in the deferbuffer is missing the record separator");
1389 $good = 0;
1390 }
1391 }
1392
1393 # Total size of deferbuffer should match internal total
1394 if ($deferred_s != $self->{deferred_s}) {
1395 _ci_warn("buffer size is $self->{deferred_s}, should be $deferred_s");
1396 $good = 0;
1397 }
1398
1399 # Total size of deferbuffer should not exceed the specified limit
1400 if ($deferred_s > $self->{dw_size}) {
1401 _ci_warn("buffer size is $self->{deferred_s} which exceeds the limit of $self->{dw_size}");
1402 $good = 0;
1403 }
1404
1405 # Total size of cached data should not exceed the specified limit
1406 if ($deferred_s + $cached > $self->{memory}) {
1407 my $total = $deferred_s + $cached;
1408 _ci_warn("total stored data size is $total which exceeds the limit of $self->{memory}");
1409 $good = 0;
1410 }
1411
6fc0ea7e
JH
1412 # Stuff related to autodeferment
1413 if (!$self->{autodefer} && @{$self->{ad_history}}) {
1414 _ci_warn("autodefer is disabled, but ad_history is nonempty");
1415 $good = 0;
1416 }
1417 if ($self->{autodeferring} && $self->{defer}) {
1418 _ci_warn("both autodeferring and explicit deferring are active");
1419 $good = 0;
1420 }
1421 if (@{$self->{ad_history}} == 0) {
1422 # That's OK, no additional tests required
1423 } elsif (@{$self->{ad_history}} == 2) {
1424 my @non_number = grep !/^-?\d+$/, @{$self->{ad_history}};
1425 if (@non_number) {
1426 my $msg;
1427 { local $" = ')(';
1428 $msg = "ad_history contains non-numbers (@{$self->{ad_history}})";
1429 }
1430 _ci_warn($msg);
1431 $good = 0;
1432 } elsif ($self->{ad_history}[1] < $self->{ad_history}[0]) {
1433 _ci_warn("ad_history has nonsensical values @{$self->{ad_history}}");
1434 $good = 0;
1435 }
1436 } else {
1437 _ci_warn("ad_history has bad length <@{$self->{ad_history}}>");
1438 $good = 0;
1439 }
1440
b5aed31e
AMS
1441 $good;
1442}
1443
6fc0ea7e
JH
1444################################################################
1445#
1446# Tie::File::Cache
1447#
1448# Read cache
1449
1450package Tie::File::Cache;
1451$Tie::File::Cache::VERSION = $Tie::File::VERSION;
1452use Carp ':DEFAULT', 'confess';
1453
1454sub HEAP () { 0 }
1455sub HASH () { 1 }
1456sub MAX () { 2 }
1457sub BYTES() { 3 }
6ae23f41
JH
1458#sub STAT () { 4 } # Array with request statistics for each record
1459#sub MISS () { 5 } # Total number of cache misses
1460#sub REQ () { 6 } # Total number of cache requests
6fc0ea7e
JH
1461use strict 'vars';
1462
1463sub new {
1464 my ($pack, $max) = @_;
1465 local *_;
1466 croak "missing argument to ->new" unless defined $max;
1467 my $self = [];
1468 bless $self => $pack;
1469 @$self = (Tie::File::Heap->new($self), {}, $max, 0);
1470 $self;
1471}
1472
1473sub adj_limit {
1474 my ($self, $n) = @_;
1475 $self->[MAX] += $n;
1476}
1477
1478sub set_limit {
1479 my ($self, $n) = @_;
1480 $self->[MAX] = $n;
1481}
1482
1483# For internal use only
1484# Will be called by the heap structure to notify us that a certain
1485# piece of data has moved from one heap element to another.
1486# $k is the hash key of the item
1487# $n is the new index into the heap at which it is stored
1488# If $n is undefined, the item has been removed from the heap.
1489sub _heap_move {
1490 my ($self, $k, $n) = @_;
1491 if (defined $n) {
1492 $self->[HASH]{$k} = $n;
1493 } else {
6ae23f41 1494 delete $self->[HASH]{$k};
6fc0ea7e
JH
1495 }
1496}
1497
1498sub insert {
1499 my ($self, $key, $val) = @_;
1500 local *_;
1501 croak "missing argument to ->insert" unless defined $key;
1502 unless (defined $self->[MAX]) {
1503 confess "undefined max" ;
1504 }
1505 confess "undefined val" unless defined $val;
1506 return if length($val) > $self->[MAX];
6ae23f41
JH
1507
1508# if ($self->[STAT]) {
1509# $self->[STAT][$key] = 1;
1510# return;
1511# }
1512
6fc0ea7e
JH
1513 my $oldnode = $self->[HASH]{$key};
1514 if (defined $oldnode) {
1515 my $oldval = $self->[HEAP]->set_val($oldnode, $val);
1516 $self->[BYTES] -= length($oldval);
1517 } else {
1518 $self->[HEAP]->insert($key, $val);
1519 }
1520 $self->[BYTES] += length($val);
6ae23f41 1521 $self->flush if $self->[BYTES] > $self->[MAX];
6fc0ea7e
JH
1522}
1523
1524sub expire {
1525 my $self = shift;
1526 my $old_data = $self->[HEAP]->popheap;
1527 return unless defined $old_data;
1528 $self->[BYTES] -= length $old_data;
1529 $old_data;
1530}
1531
1532sub remove {
1533 my ($self, @keys) = @_;
1534 my @result;
6ae23f41
JH
1535
1536# if ($self->[STAT]) {
1537# for my $key (@keys) {
1538# $self->[STAT][$key] = 0;
1539# }
1540# return;
1541# }
1542
6fc0ea7e
JH
1543 for my $key (@keys) {
1544 next unless exists $self->[HASH]{$key};
1545 my $old_data = $self->[HEAP]->remove($self->[HASH]{$key});
1546 $self->[BYTES] -= length $old_data;
1547 push @result, $old_data;
1548 }
1549 @result;
1550}
1551
1552sub lookup {
1553 my ($self, $key) = @_;
1554 local *_;
1555 croak "missing argument to ->lookup" unless defined $key;
6ae23f41
JH
1556
1557# if ($self->[STAT]) {
1558# $self->[MISS]++ if $self->[STAT][$key]++ == 0;
1559# $self->[REQ]++;
1560# my $hit_rate = 1 - $self->[MISS] / $self->[REQ];
1561# # Do some testing to determine this threshhold
1562# $#$self = STAT - 1 if $hit_rate > 0.20;
1563# }
1564
6fc0ea7e
JH
1565 if (exists $self->[HASH]{$key}) {
1566 $self->[HEAP]->lookup($self->[HASH]{$key});
1567 } else {
1568 return;
1569 }
1570}
1571
1572# For internal use only
1573sub _produce {
1574 my ($self, $key) = @_;
1575 my $loc = $self->[HASH]{$key};
1576 return unless defined $loc;
1577 $self->[HEAP][$loc][2];
1578}
1579
1580# For internal use only
1581sub _promote {
1582 my ($self, $key) = @_;
1583 $self->[HEAP]->promote($self->[HASH]{$key});
1584}
1585
1586sub empty {
1587 my ($self) = @_;
1588 %{$self->[HASH]} = ();
1589 $self->[BYTES] = 0;
1590 $self->[HEAP]->empty;
6ae23f41
JH
1591# @{$self->[STAT]} = ();
1592# $self->[MISS] = 0;
1593# $self->[REQ] = 0;
6fc0ea7e
JH
1594}
1595
1596sub is_empty {
1597 my ($self) = @_;
1598 keys %{$self->[HASH]} == 0;
1599}
1600
1601sub update {
1602 my ($self, $key, $val) = @_;
1603 local *_;
1604 croak "missing argument to ->update" unless defined $key;
1605 if (length($val) > $self->[MAX]) {
6ae23f41 1606 my ($oldval) = $self->remove($key);
6fc0ea7e
JH
1607 $self->[BYTES] -= length($oldval) if defined $oldval;
1608 } elsif (exists $self->[HASH]{$key}) {
1609 my $oldval = $self->[HEAP]->set_val($self->[HASH]{$key}, $val);
1610 $self->[BYTES] += length($val);
1611 $self->[BYTES] -= length($oldval) if defined $oldval;
1612 } else {
1613 $self->[HEAP]->insert($key, $val);
1614 $self->[BYTES] += length($val);
1615 }
1616 $self->flush;
1617}
1618
1619sub rekey {
1620 my ($self, $okeys, $nkeys) = @_;
1621 local *_;
1622 my %map;
1623 @map{@$okeys} = @$nkeys;
1624 croak "missing argument to ->rekey" unless defined $nkeys;
1625 croak "length mismatch in ->rekey arguments" unless @$nkeys == @$okeys;
1626 my %adjusted; # map new keys to heap indices
1627 # You should be able to cut this to one loop TODO XXX
1628 for (0 .. $#$okeys) {
1629 $adjusted{$nkeys->[$_]} = delete $self->[HASH]{$okeys->[$_]};
1630 }
1631 while (my ($nk, $ix) = each %adjusted) {
1632 # @{$self->[HASH]}{keys %adjusted} = values %adjusted;
1633 $self->[HEAP]->rekey($ix, $nk);
1634 $self->[HASH]{$nk} = $ix;
1635 }
1636}
1637
bf919750 1638sub ckeys {
6fc0ea7e
JH
1639 my $self = shift;
1640 my @a = keys %{$self->[HASH]};
1641 @a;
1642}
1643
6ae23f41 1644# Return total amount of cached data
6fc0ea7e
JH
1645sub bytes {
1646 my $self = shift;
1647 $self->[BYTES];
1648}
1649
6ae23f41 1650# Expire oldest item from cache until cache size is smaller than $max
6fc0ea7e
JH
1651sub reduce_size_to {
1652 my ($self, $max) = @_;
6ae23f41
JH
1653 until ($self->[BYTES] <= $max) {
1654 # Note that Tie::File::Cache::expire has been inlined here
1655 my $old_data = $self->[HEAP]->popheap;
1656 return unless defined $old_data;
1657 $self->[BYTES] -= length $old_data;
6fc0ea7e
JH
1658 }
1659}
1660
6ae23f41
JH
1661# Why not just $self->reduce_size_to($self->[MAX])?
1662# Try this when things stabilize TODO XXX
1663# If the cache is too full, expire the oldest records
6fc0ea7e
JH
1664sub flush {
1665 my $self = shift;
6ae23f41 1666 $self->reduce_size_to($self->[MAX]) if $self->[BYTES] > $self->[MAX];
6fc0ea7e
JH
1667}
1668
1669# For internal use only
1670sub _produce_lru {
1671 my $self = shift;
1672 $self->[HEAP]->expire_order;
1673}
1674
bf919750
JH
1675BEGIN { *_ci_warn = \&Tie::File::_ci_warn }
1676
1677sub _check_integrity { # For CACHE
6fc0ea7e 1678 my $self = shift;
bf919750
JH
1679 my $good = 1;
1680
1681 # Test HEAP
1682 $self->[HEAP]->_check_integrity or $good = 0;
1683
1684 # Test HASH
1685 my $bytes = 0;
1686 for my $k (keys %{$self->[HASH]}) {
1687 if ($k ne '0' && $k !~ /^[1-9][0-9]*$/) {
1688 $good = 0;
1689 _ci_warn "Cache hash key <$k> is non-numeric";
1690 }
1691
1692 my $h = $self->[HASH]{$k};
1693 if (! defined $h) {
1694 $good = 0;
1695 _ci_warn "Heap index number for key $k is undefined";
1696 } elsif ($h == 0) {
1697 $good = 0;
1698 _ci_warn "Heap index number for key $k is zero";
1699 } else {
1700 my $j = $self->[HEAP][$h];
1701 if (! defined $j) {
1702 $good = 0;
1703 _ci_warn "Heap contents key $k (=> $h) are undefined";
1704 } else {
1705 $bytes += length($j->[2]);
1706 if ($k ne $j->[1]) {
1707 $good = 0;
1708 _ci_warn "Heap contents key $k (=> $h) is $j->[1], should be $k";
1709 }
1710 }
1711 }
1712 }
1713
1714 # Test BYTES
1715 if ($bytes != $self->[BYTES]) {
1716 $good = 0;
1717 _ci_warn "Total data in cache is $bytes, expected $self->[BYTES]";
1718 }
1719
1720 # Test MAX
1721 if ($bytes > $self->[MAX]) {
1722 $good = 0;
1723 _ci_warn "Total data in cache is $bytes, exceeds maximum $self->[MAX]";
1724 }
1725
1726 return $good;
6fc0ea7e
JH
1727}
1728
1729sub delink {
1730 my $self = shift;
1731 $self->[HEAP] = undef; # Bye bye heap
1732}
1733
1734################################################################
1735#
1736# Tie::File::Heap
1737#
1738# Heap data structure for use by cache LRU routines
1739
1740package Tie::File::Heap;
1741use Carp ':DEFAULT', 'confess';
1742$Tie::File::Heap::VERSION = $Tie::File::Cache::VERSION;
1743sub SEQ () { 0 };
1744sub KEY () { 1 };
1745sub DAT () { 2 };
1746
1747sub new {
1748 my ($pack, $cache) = @_;
1749 die "$pack: Parent cache object $cache does not support _heap_move method"
1750 unless eval { $cache->can('_heap_move') };
1751 my $self = [[0,$cache,0]];
1752 bless $self => $pack;
1753}
1754
1755# Allocate a new sequence number, larger than all previously allocated numbers
1756sub _nseq {
1757 my $self = shift;
1758 $self->[0][0]++;
1759}
1760
1761sub _cache {
1762 my $self = shift;
1763 $self->[0][1];
1764}
1765
1766sub _nelts {
1767 my $self = shift;
1768 $self->[0][2];
1769}
1770
1771sub _nelts_inc {
1772 my $self = shift;
1773 ++$self->[0][2];
1774}
1775
1776sub _nelts_dec {
1777 my $self = shift;
1778 --$self->[0][2];
1779}
1780
1781sub is_empty {
1782 my $self = shift;
1783 $self->_nelts == 0;
1784}
1785
1786sub empty {
1787 my $self = shift;
1788 $#$self = 0;
1789 $self->[0][2] = 0;
1790 $self->[0][0] = 0; # might as well reset the sequence numbers
1791}
1792
27531ffb 1793# notify the parent cache object that we moved something
6fc0ea7e
JH
1794sub _heap_move {
1795 my $self = shift;
1796 $self->_cache->_heap_move(@_);
1797}
1798
1799# Insert a piece of data into the heap with the indicated sequence number.
1800# The item with the smallest sequence number is always at the top.
1801# If no sequence number is specified, allocate a new one and insert the
1802# item at the bottom.
1803sub insert {
1804 my ($self, $key, $data, $seq) = @_;
1805 $seq = $self->_nseq unless defined $seq;
1806 $self->_insert_new([$seq, $key, $data]);
1807}
1808
1809# Insert a new, fresh item at the bottom of the heap
1810sub _insert_new {
1811 my ($self, $item) = @_;
1812 my $i = @$self;
1813 $i = int($i/2) until defined $self->[$i/2];
1814 $self->[$i] = $item;
27531ffb 1815 $self->[0][1]->_heap_move($self->[$i][KEY], $i);
6fc0ea7e
JH
1816 $self->_nelts_inc;
1817}
1818
1819# Insert [$data, $seq] pair at or below item $i in the heap.
1820# If $i is omitted, default to 1 (the top element.)
1821sub _insert {
1822 my ($self, $item, $i) = @_;
bf919750 1823# $self->_check_loc($i) if defined $i;
6fc0ea7e
JH
1824 $i = 1 unless defined $i;
1825 until (! defined $self->[$i]) {
1826 if ($self->[$i][SEQ] > $item->[SEQ]) { # inserted item is older
1827 ($self->[$i], $item) = ($item, $self->[$i]);
27531ffb 1828 $self->[0][1]->_heap_move($self->[$i][KEY], $i);
6fc0ea7e
JH
1829 }
1830 # If either is undefined, go that way. Otherwise, choose at random
1831 my $dir;
1832 $dir = 0 if !defined $self->[2*$i];
1833 $dir = 1 if !defined $self->[2*$i+1];
1834 $dir = int(rand(2)) unless defined $dir;
1835 $i = 2*$i + $dir;
1836 }
1837 $self->[$i] = $item;
27531ffb 1838 $self->[0][1]->_heap_move($self->[$i][KEY], $i);
6fc0ea7e
JH
1839 $self->_nelts_inc;
1840}
1841
1842# Remove the item at node $i from the heap, moving child items upwards.
1843# The item with the smallest sequence number is always at the top.
1844# Moving items upwards maintains this condition.
6ae23f41 1845# Return the removed item. Return undef if there was no item at node $i.
6fc0ea7e
JH
1846sub remove {
1847 my ($self, $i) = @_;
1848 $i = 1 unless defined $i;
1849 my $top = $self->[$i];
1850 return unless defined $top;
1851 while (1) {
1852 my $ii;
1853 my ($L, $R) = (2*$i, 2*$i+1);
1854
1855 # If either is undefined, go the other way.
1856 # Otherwise, go towards the smallest.
1857 last unless defined $self->[$L] || defined $self->[$R];
1858 $ii = $R if not defined $self->[$L];
1859 $ii = $L if not defined $self->[$R];
1860 unless (defined $ii) {
1861 $ii = $self->[$L][SEQ] < $self->[$R][SEQ] ? $L : $R;
1862 }
1863
1864 $self->[$i] = $self->[$ii]; # Promote child to fill vacated spot
27531ffb 1865 $self->[0][1]->_heap_move($self->[$i][KEY], $i);
6fc0ea7e
JH
1866 $i = $ii; # Fill new vacated spot
1867 }
27531ffb 1868 $self->[0][1]->_heap_move($top->[KEY], undef);
6fc0ea7e
JH
1869 undef $self->[$i];
1870 $self->_nelts_dec;
1871 return $top->[DAT];
1872}
1873
1874sub popheap {
1875 my $self = shift;
1876 $self->remove(1);
1877}
1878
1879# set the sequence number of the indicated item to a higher number
1880# than any other item in the heap, and bubble the item down to the
1881# bottom.
1882sub promote {
1883 my ($self, $n) = @_;
bf919750 1884# $self->_check_loc($n);
6fc0ea7e
JH
1885 $self->[$n][SEQ] = $self->_nseq;
1886 my $i = $n;
1887 while (1) {
1888 my ($L, $R) = (2*$i, 2*$i+1);
1889 my $dir;
1890 last unless defined $self->[$L] || defined $self->[$R];
1891 $dir = $R unless defined $self->[$L];
1892 $dir = $L unless defined $self->[$R];
1893 unless (defined $dir) {
1894 $dir = $self->[$L][SEQ] < $self->[$R][SEQ] ? $L : $R;
1895 }
1896 @{$self}[$i, $dir] = @{$self}[$dir, $i];
1897 for ($i, $dir) {
27531ffb 1898 $self->[0][1]->_heap_move($self->[$_][KEY], $_) if defined $self->[$_];
6fc0ea7e
JH
1899 }
1900 $i = $dir;
1901 }
1902}
1903
1904# Return item $n from the heap, promoting its LRU status
1905sub lookup {
1906 my ($self, $n) = @_;
bf919750 1907# $self->_check_loc($n);
6fc0ea7e
JH
1908 my $val = $self->[$n];
1909 $self->promote($n);
1910 $val->[DAT];
1911}
1912
1913
1914# Assign a new value for node $n, promoting it to the bottom of the heap
1915sub set_val {
1916 my ($self, $n, $val) = @_;
bf919750 1917# $self->_check_loc($n);
6fc0ea7e
JH
1918 my $oval = $self->[$n][DAT];
1919 $self->[$n][DAT] = $val;
1920 $self->promote($n);
1921 return $oval;
1922}
1923
2ded50a3 1924# The hash key has changed for an item;
6fc0ea7e
JH
1925# alter the heap's record of the hash key
1926sub rekey {
1927 my ($self, $n, $new_key) = @_;
bf919750 1928# $self->_check_loc($n);
6fc0ea7e
JH
1929 $self->[$n][KEY] = $new_key;
1930}
1931
1932sub _check_loc {
1933 my ($self, $n) = @_;
bf919750 1934 unless (1 || defined $self->[$n]) {
6fc0ea7e
JH
1935 confess "_check_loc($n) failed";
1936 }
1937}
1938
bf919750
JH
1939BEGIN { *_ci_warn = \&Tie::File::_ci_warn }
1940
6fc0ea7e
JH
1941sub _check_integrity {
1942 my $self = shift;
1943 my $good = 1;
bf919750
JH
1944 my %seq;
1945
6fc0ea7e 1946 unless (eval {$self->[0][1]->isa("Tie::File::Cache")}) {
bf919750 1947 _ci_warn "Element 0 of heap corrupt";
6fc0ea7e
JH
1948 $good = 0;
1949 }
1950 $good = 0 unless $self->_satisfies_heap_condition(1);
1951 for my $i (2 .. $#{$self}) {
1952 my $p = int($i/2); # index of parent node
1953 if (defined $self->[$i] && ! defined $self->[$p]) {
bf919750 1954 _ci_warn "Element $i of heap defined, but parent $p isn't";
6fc0ea7e
JH
1955 $good = 0;
1956 }
bf919750
JH
1957
1958 if (defined $self->[$i]) {
1959 if ($seq{$self->[$i][SEQ]}) {
1960 my $seq = $self->[$i][SEQ];
1961 _ci_warn "Nodes $i and $seq{$seq} both have SEQ=$seq";
1962 $good = 0;
1963 } else {
1964 $seq{$self->[$i][SEQ]} = $i;
1965 }
1966 }
6fc0ea7e 1967 }
bf919750 1968
6fc0ea7e
JH
1969 return $good;
1970}
1971
1972sub _satisfies_heap_condition {
1973 my $self = shift;
1974 my $n = shift || 1;
1975 my $good = 1;
1976 for (0, 1) {
1977 my $c = $n*2 + $_;
1978 next unless defined $self->[$c];
1979 if ($self->[$n][SEQ] >= $self->[$c]) {
bf919750 1980 _ci_warn "Node $n of heap does not predate node $c";
6fc0ea7e
JH
1981 $good = 0 ;
1982 }
1983 $good = 0 unless $self->_satisfies_heap_condition($c);
1984 }
1985 return $good;
1986}
1987
1988# Return a list of all the values, sorted by expiration order
1989sub expire_order {
1990 my $self = shift;
1991 my @nodes = sort {$a->[SEQ] <=> $b->[SEQ]} $self->_nodes;
1992 map { $_->[KEY] } @nodes;
1993}
1994
1995sub _nodes {
1996 my $self = shift;
1997 my $i = shift || 1;
1998 return unless defined $self->[$i];
1999 ($self->[$i], $self->_nodes($i*2), $self->_nodes($i*2+1));
2000}
2001
fa408a35
AMS
2002"Cogito, ergo sum."; # don't forget to return a true value from the file
2003
6ae23f41
JH
2004__END__
2005
b5aed31e
AMS
2006=head1 NAME
2007
2008Tie::File - Access the lines of a disk file via a Perl array
2009
2010=head1 SYNOPSIS
2011
c0504019 2012 # This file documents Tie::File version 0.98
6ae23f41 2013 use Tie::File;
b5aed31e
AMS
2014
2015 tie @array, 'Tie::File', filename or die ...;
2016
2017 $array[13] = 'blah'; # line 13 of the file is now 'blah'
2018 print $array[42]; # display line 42 of the file
2019
2020 $n_recs = @array; # how many records are in the file?
57c7bc08
AMS
2021 $#array -= 2; # chop two records off the end
2022
b5aed31e 2023
57c7bc08
AMS
2024 for (@array) {
2025 s/PERL/Perl/g; # Replace PERL with Perl everywhere in the file
2026 }
2027
2028 # These are just like regular push, pop, unshift, shift, and splice
2029 # Except that they modify the file in the way you would expect
51efdd02
AMS
2030
2031 push @array, new recs...;
2032 my $r1 = pop @array;
2033 unshift @array, new recs...;
6ae23f41 2034 my $r2 = shift @array;
b5aed31e
AMS
2035 @old_recs = splice @array, 3, 7, new recs...;
2036
2037 untie @array; # all finished
2038
57c7bc08 2039
b5aed31e
AMS
2040=head1 DESCRIPTION
2041
2042C<Tie::File> represents a regular text file as a Perl array. Each
2043element in the array corresponds to a record in the file. The first
2044line of the file is element 0 of the array; the second line is element
20451, and so on.
2046
2047The file is I<not> loaded into memory, so this will work even for
2048gigantic files.
2049
2050Changes to the array are reflected in the file immediately.
2051
57c7bc08 2052Lazy people and beginners may now stop reading the manual.
b3fe5a4c 2053
b5aed31e
AMS
2054=head2 C<recsep>
2055
2056What is a 'record'? By default, the meaning is the same as for the
2057C<E<lt>...E<gt>> operator: It's a string terminated by C<$/>, which is
6ae23f41 2058probably C<"\n">. (Minor exception: on DOS and Win32 systems, a
b3fe5a4c
AMS
2059'record' is a string terminated by C<"\r\n">.) You may change the
2060definition of "record" by supplying the C<recsep> option in the C<tie>
2061call:
b5aed31e
AMS
2062
2063 tie @array, 'Tie::File', $file, recsep => 'es';
2064
b3fe5a4c
AMS
2065This says that records are delimited by the string C<es>. If the file
2066contained the following data:
b5aed31e
AMS
2067
2068 Curse these pesky flies!\n
2069
27531ffb 2070then the C<@array> would appear to have four elements:
b5aed31e 2071
0b28bc9a
AMS
2072 "Curse th"
2073 "e p"
2074 "ky fli"
b5aed31e
AMS
2075 "!\n"
2076
2077An undefined value is not permitted as a record separator. Perl's
2078special "paragraph mode" semantics (E<agrave> la C<$/ = "">) are not
2079emulated.
2080
0b28bc9a 2081Records read from the tied array do not have the record separator
27531ffb 2082string on the end; this is to allow
0b28bc9a
AMS
2083
2084 $array[17] .= "extra";
2085
2086to work as expected.
2087
2088(See L<"autochomp">, below.) Records stored into the array will have
2089the record separator string appended before they are written to the
2090file, if they don't have one already. For example, if the record
2091separator string is C<"\n">, then the following two lines do exactly
2092the same thing:
b5aed31e
AMS
2093
2094 $array[17] = "Cherry pie";
2095 $array[17] = "Cherry pie\n";
2096
2097The result is that the contents of line 17 of the file will be
2098replaced with "Cherry pie"; a newline character will separate line 17
27531ffb 2099from line 18. This means that this code will do nothing:
b5aed31e
AMS
2100
2101 chomp $array[17];
2102
2103Because the C<chomp>ed value will have the separator reattached when
2104it is written back to the file. There is no way to create a file
2105whose trailing record separator string is missing.
2106
27531ffb
JH
2107Inserting records that I<contain> the record separator string is not
2108supported by this module. It will probably produce a reasonable
2109result, but what this result will be may change in a future version.
2110Use 'splice' to insert records or to replace one record with several.
b5aed31e 2111
0b28bc9a
AMS
2112=head2 C<autochomp>
2113
2114Normally, array elements have the record separator removed, so that if
2115the file contains the text
2116
2117 Gold
2118 Frankincense
2119 Myrrh
2120
57c7bc08
AMS
2121the tied array will appear to contain C<("Gold", "Frankincense",
2122"Myrrh")>. If you set C<autochomp> to a false value, the record
2123separator will not be removed. If the file above was tied with
0b28bc9a
AMS
2124
2125 tie @gifts, "Tie::File", $gifts, autochomp => 0;
2126
2127then the array C<@gifts> would appear to contain C<("Gold\n",
2128"Frankincense\n", "Myrrh\n")>, or (on Win32 systems) C<("Gold\r\n",
2129"Frankincense\r\n", "Myrrh\r\n")>.
2130
b5aed31e
AMS
2131=head2 C<mode>
2132
2133Normally, the specified file will be opened for read and write access,
2134and will be created if it does not exist. (That is, the flags
2135C<O_RDWR | O_CREAT> are supplied in the C<open> call.) If you want to
2136change this, you may supply alternative flags in the C<mode> option.
2137See L<Fcntl> for a listing of available flags.
2138For example:
2139
2140 # open the file if it exists, but fail if it does not exist
2141 use Fcntl 'O_RDWR';
2142 tie @array, 'Tie::File', $file, mode => O_RDWR;
2143
2144 # create the file if it does not exist
2145 use Fcntl 'O_RDWR', 'O_CREAT';
2146 tie @array, 'Tie::File', $file, mode => O_RDWR | O_CREAT;
2147
2148 # open an existing file in read-only mode
2149 use Fcntl 'O_RDONLY';
2150 tie @array, 'Tie::File', $file, mode => O_RDONLY;
2151
2152Opening the data file in write-only or append mode is not supported.
2153
b3fe5a4c
AMS
2154=head2 C<memory>
2155
57c7bc08
AMS
2156This is an upper limit on the amount of memory that C<Tie::File> will
2157consume at any time while managing the file. This is used for two
2158things: managing the I<read cache> and managing the I<deferred write
2159buffer>.
b5aed31e
AMS
2160
2161Records read in from the file are cached, to avoid having to re-read
2162them repeatedly. If you read the same record twice, the first time it
2163will be stored in memory, and the second time it will be fetched from
b3fe5a4c
AMS
2164the I<read cache>. The amount of data in the read cache will not
2165exceed the value you specified for C<memory>. If C<Tie::File> wants
2166to cache a new record, but the read cache is full, it will make room
2167by expiring the least-recently visited records from the read cache.
b5aed31e 2168
b3fe5a4c
AMS
2169The default memory limit is 2Mib. You can adjust the maximum read
2170cache size by supplying the C<memory> option. The argument is the
2171desired cache size, in bytes.
b5aed31e
AMS
2172
2173 # I have a lot of memory, so use a large cache to speed up access
b3fe5a4c 2174 tie @array, 'Tie::File', $file, memory => 20_000_000;
b5aed31e 2175
b3fe5a4c 2176Setting the memory limit to 0 will inhibit caching; records will be
b5aed31e
AMS
2177fetched from disk every time you examine them.
2178
27531ffb
JH
2179The C<memory> value is not an absolute or exact limit on the memory
2180used. C<Tie::File> objects contains some structures besides the read
2181cache and the deferred write buffer, whose sizes are not charged
6ae23f41
JH
2182against C<memory>.
2183
2184The cache itself consumes about 310 bytes per cached record, so if
2185your file has many short records, you may want to decrease the cache
2186memory limit, or else the cache overhead may exceed the size of the
2187cached data.
2188
27531ffb 2189
57c7bc08
AMS
2190=head2 C<dw_size>
2191
2192(This is an advanced feature. Skip this section on first reading.)
27531ffb 2193
57c7bc08
AMS
2194If you use deferred writing (See L<"Deferred Writing">, below) then
2195data you write into the array will not be written directly to the
2196file; instead, it will be saved in the I<deferred write buffer> to be
2197written out later. Data in the deferred write buffer is also charged
2198against the memory limit you set with the C<memory> option.
2199
2200You may set the C<dw_size> option to limit the amount of data that can
2201be saved in the deferred write buffer. This limit may not exceed the
2202total memory limit. For example, if you set C<dw_size> to 1000 and
2203C<memory> to 2500, that means that no more than 1000 bytes of deferred
2204writes will be saved up. The space available for the read cache will
2205vary, but it will always be at least 1500 bytes (if the deferred write
2206buffer is full) and it could grow as large as 2500 bytes (if the
2207deferred write buffer is empty.)
2208
2209If you don't specify a C<dw_size>, it defaults to the entire memory
2210limit.
2211
b5aed31e
AMS
2212=head2 Option Format
2213
2214C<-mode> is a synonym for C<mode>. C<-recsep> is a synonym for
b3fe5a4c 2215C<recsep>. C<-memory> is a synonym for C<memory>. You get the
b5aed31e
AMS
2216idea.
2217
2218=head1 Public Methods
2219
27531ffb 2220The C<tie> call returns an object, say C<$o>. You may call
b5aed31e
AMS
2221
2222 $rec = $o->FETCH($n);
2223 $o->STORE($n, $rec);
2224
b3fe5a4c
AMS
2225to fetch or store the record at line C<$n>, respectively; similarly
2226the other tied array methods. (See L<perltie> for details.) You may
2227also call the following methods on this object:
51efdd02
AMS
2228
2229=head2 C<flock>
2230
2231 $o->flock(MODE)
2232
2233will lock the tied file. C<MODE> has the same meaning as the second
2234argument to the Perl built-in C<flock> function; for example
2235C<LOCK_SH> or C<LOCK_EX | LOCK_NB>. (These constants are provided by
2236the C<use Fcntl ':flock'> declaration.)
2237
57c7bc08
AMS
2238C<MODE> is optional; the default is C<LOCK_EX>.
2239
6ae23f41
JH
2240C<Tie::File> maintains an internal table of the byte offset of each
2241record it has seen in the file.
2242
2243When you use C<flock> to lock the file, C<Tie::File> assumes that the
2244read cache is no longer trustworthy, because another process might
2245have modified the file since the last time it was read. Therefore, a
2246successful call to C<flock> discards the contents of the read cache
2247and the internal record offset table.
2248
57c7bc08
AMS
2249C<Tie::File> promises that the following sequence of operations will
2250be safe:
2251
2252 my $o = tie @array, "Tie::File", $filename;
2253 $o->flock;
2254
2255In particular, C<Tie::File> will I<not> read or write the file during
2256the C<tie> call. (Exception: Using C<mode =E<gt> O_TRUNC> will, of
2257course, erase the file during the C<tie> call. If you want to do this
2258safely, then open the file without C<O_TRUNC>, lock the file, and use
2259C<@array = ()>.)
51efdd02
AMS
2260
2261The best way to unlock a file is to discard the object and untie the
2262array. It is probably unsafe to unlock the file without also untying
2263it, because if you do, changes may remain unwritten inside the object.
2264That is why there is no shortcut for unlocking. If you really want to
2265unlock the file prematurely, you know what to do; if you don't know
2266what to do, then don't do it.
2267
2268All the usual warnings about file locking apply here. In particular,
2269note that file locking in Perl is B<advisory>, which means that
2270holding a lock will not prevent anyone else from reading, writing, or
2271erasing the file; it only prevents them from getting another lock at
2272the same time. Locks are analogous to green traffic lights: If you
2273have a green light, that does not prevent the idiot coming the other
2274way from plowing into you sideways; it merely guarantees to you that
2275the idiot does not also have a green light at the same time.
b5aed31e 2276
0b28bc9a
AMS
2277=head2 C<autochomp>
2278
2279 my $old_value = $o->autochomp(0); # disable autochomp option
2280 my $old_value = $o->autochomp(1); # enable autochomp option
2281
2282 my $ac = $o->autochomp(); # recover current value
2283
2284See L<"autochomp">, above.
2285
6fc0ea7e 2286=head2 C<defer>, C<flush>, C<discard>, and C<autodefer>
57c7bc08
AMS
2287
2288See L<"Deferred Writing">, below.
2289
6ae23f41
JH
2290=head2 C<offset>
2291
2292 $off = $o->offset($n);
2293
2294This method returns the byte offset of the start of the C<$n>th record
2295in the file. If there is no such record, it returns an undefined
2296value.
2297
0b28bc9a 2298=head1 Tying to an already-opened filehandle
fa408a35
AMS
2299
2300If C<$fh> is a filehandle, such as is returned by C<IO::File> or one
2301of the other C<IO> modules, you may use:
2302
2303 tie @array, 'Tie::File', $fh, ...;
2304
2305Similarly if you opened that handle C<FH> with regular C<open> or
2306C<sysopen>, you may use:
2307
2308 tie @array, 'Tie::File', \*FH, ...;
2309
2310Handles that were opened write-only won't work. Handles that were
57c7bc08
AMS
2311opened read-only will work as long as you don't try to modify the
2312array. Handles must be attached to seekable sources of data---that
27531ffb
JH
2313means no pipes or sockets. If C<Tie::File> can detect that you
2314supplied a non-seekable handle, the C<tie> call will throw an
2315exception. (On Unix systems, it can detect this.)
57c7bc08 2316
2a00e2a4
JH
2317Note that Tie::File will only close any filehandles that it opened
2318internally. If you passed it a filehandle as above, you "own" the
2319filehandle, and are responsible for closing it after you have untied
2320the @array.
2321
57c7bc08
AMS
2322=head1 Deferred Writing
2323
2324(This is an advanced feature. Skip this section on first reading.)
2325
2326Normally, modifying a C<Tie::File> array writes to the underlying file
2327immediately. Every assignment like C<$a[3] = ...> rewrites as much of
2328the file as is necessary; typically, everything from line 3 through
2329the end will need to be rewritten. This is the simplest and most
2330transparent behavior. Performance even for large files is reasonably
2331good.
2332
2333However, under some circumstances, this behavior may be excessively
2334slow. For example, suppose you have a million-record file, and you
2335want to do:
2336
2337 for (@FILE) {
2338 $_ = "> $_";
2339 }
2340
2341The first time through the loop, you will rewrite the entire file,
2342from line 0 through the end. The second time through the loop, you
2343will rewrite the entire file from line 1 through the end. The third
2344time through the loop, you will rewrite the entire file from line 2 to
2345the end. And so on.
2346
2347If the performance in such cases is unacceptable, you may defer the
2348actual writing, and then have it done all at once. The following loop
2349will perform much better for large files:
2350
2351 (tied @a)->defer;
2352 for (@a) {
2353 $_ = "> $_";
2354 }
2355 (tied @a)->flush;
2356
2357If C<Tie::File>'s memory limit is large enough, all the writing will
2358done in memory. Then, when you call C<-E<gt>flush>, the entire file
2359will be rewritten in a single pass.
2360
6fc0ea7e
JH
2361(Actually, the preceding discussion is something of a fib. You don't
2362need to enable deferred writing to get good performance for this
2363common case, because C<Tie::File> will do it for you automatically
3ecd7569 2364unless you specifically tell it not to. See L<"Autodeferring">,
6fc0ea7e
JH
2365below.)
2366
57c7bc08
AMS
2367Calling C<-E<gt>flush> returns the array to immediate-write mode. If
2368you wish to discard the deferred writes, you may call C<-E<gt>discard>
2369instead of C<-E<gt>flush>. Note that in some cases, some of the data
2370will have been written already, and it will be too late for
6fc0ea7e
JH
2371C<-E<gt>discard> to discard all the changes. Support for
2372C<-E<gt>discard> may be withdrawn in a future version of C<Tie::File>.
57c7bc08
AMS
2373
2374Deferred writes are cached in memory up to the limit specified by the
2375C<dw_size> option (see above). If the deferred-write buffer is full
2376and you try to write still more deferred data, the buffer will be
2377flushed. All buffered data will be written immediately, the buffer
2378will be emptied, and the now-empty space will be used for future
2379deferred writes.
2380
2381If the deferred-write buffer isn't yet full, but the total size of the
2382buffer and the read cache would exceed the C<memory> limit, the oldest
27531ffb 2383records will be expired from the read cache until the total size is
57c7bc08
AMS
2384under the limit.
2385
2386C<push>, C<pop>, C<shift>, C<unshift>, and C<splice> cannot be
2387deferred. When you perform one of these operations, any deferred data
2388is written to the file and the operation is performed immediately.
2389This may change in a future version.
2390
6fc0ea7e
JH
2391If you resize the array with deferred writing enabled, the file will
2392be resized immediately, but deferred records will not be written.
27531ffb
JH
2393This has a surprising consequence: C<@a = (...)> erases the file
2394immediately, but the writing of the actual data is deferred. This
2395might be a bug. If it is a bug, it will be fixed in a future version.
6fc0ea7e
JH
2396
2397=head2 Autodeferring
2398
2399C<Tie::File> tries to guess when deferred writing might be helpful,
27531ffb
JH
2400and to turn it on and off automatically.
2401
2402 for (@a) {
2403 $_ = "> $_";
2404 }
2405
2406In this example, only the first two assignments will be done
2407immediately; after this, all the changes to the file will be deferred
2408up to the user-specified memory limit.
6fc0ea7e
JH
2409
2410You should usually be able to ignore this and just use the module
2411without thinking about deferring. However, special applications may
2412require fine control over which writes are deferred, or may require
2413that all writes be immediate. To disable the autodeferment feature,
2414use
57c7bc08
AMS
2415
2416 (tied @o)->autodefer(0);
2417
6fc0ea7e
JH
2418or
2419
2420 tie @array, 'Tie::File', $file, autodefer => 0;
2421
fa408a35 2422
27531ffb
JH
2423Similarly, C<-E<gt>autodefer(1)> re-enables autodeferment, and
2424C<-E<gt>autodefer()> recovers the current value of the autodefer setting.
2425
b5aed31e 2426
6ae23f41 2427=head1 CONCURRENT ACCESS TO FILES
b5aed31e 2428
6ae23f41 2429Caching and deferred writing are inappropriate if you want the same
bc2f65e0
JH
2430file to be accessed simultaneously from more than one process. Other
2431optimizations performed internally by this module are also
2432incompatible with concurrent access. A future version of this module will
2433support a C<concurrent =E<gt> 1> option that enables safe concurrent access.
b3fe5a4c 2434
bc2f65e0
JH
2435Previous versions of this documentation suggested using C<memory
2436=E<gt> 0> for safe concurrent access. This was mistaken. Tie::File
c0504019 2437will not support safe concurrent access before version 0.96.
6ae23f41
JH
2438
2439=head1 CAVEATS
b3fe5a4c 2440
6ae23f41 2441(That's Latin for 'warnings'.)
b3fe5a4c 2442
6ae23f41 2443=over 4
6fc0ea7e 2444
27531ffb 2445=item *
b5aed31e 2446
6fc0ea7e 2447Reasonable effort was made to make this module efficient. Nevertheless,
b5aed31e 2448changing the size of a record in the middle of a large file will
b3fe5a4c
AMS
2449always be fairly slow, because everything after the new record must be
2450moved.
b5aed31e 2451
b3fe5a4c
AMS
2452=item *
2453
2454The behavior of tied arrays is not precisely the same as for regular
2455arrays. For example:
b5aed31e 2456
57c7bc08
AMS
2457 # This DOES print "How unusual!"
2458 undef $a[10]; print "How unusual!\n" if defined $a[10];
b3fe5a4c
AMS
2459
2460C<undef>-ing a C<Tie::File> array element just blanks out the
2461corresponding record in the file. When you read it back again, you'll
57c7bc08
AMS
2462get the empty string, so the supposedly-C<undef>'ed value will be
2463defined. Similarly, if you have C<autochomp> disabled, then
2464
2465 # This DOES print "How unusual!" if 'autochomp' is disabled
27531ffb 2466 undef $a[10];
57c7bc08
AMS
2467 print "How unusual!\n" if $a[10];
2468
2469Because when C<autochomp> is disabled, C<$a[10]> will read back as
2470C<"\n"> (or whatever the record separator string is.)
b5aed31e 2471
6fc0ea7e
JH
2472There are other minor differences, particularly regarding C<exists>
2473and C<delete>, but in general, the correspondence is extremely close.
b3fe5a4c
AMS
2474
2475=item *
2476
27531ffb
JH
2477I have supposed that since this module is concerned with file I/O,
2478almost all normal use of it will be heavily I/O bound. This means
2479that the time to maintain complicated data structures inside the
2480module will be dominated by the time to actually perform the I/O.
2481When there was an opportunity to spend CPU time to avoid doing I/O, I
6ae23f41 2482usually tried to take it.
b5aed31e 2483
57c7bc08 2484=item *
6fc0ea7e 2485
57c7bc08
AMS
2486You might be tempted to think that deferred writing is like
2487transactions, with C<flush> as C<commit> and C<discard> as
6fc0ea7e 2488C<rollback>, but it isn't, so don't.
57c7bc08 2489
6ae23f41
JH
2490=item *
2491
2492There is a large memory overhead for each record offset and for each
2493cache entry: about 310 bytes per cached data record, and about 21 bytes per offset table entry.
2494
2495The per-record overhead will limit the maximum number of records you
2496can access per file. Note that I<accessing> the length of the array
2497via C<$x = scalar @tied_file> accesses B<all> records and stores their
2498offsets. The same for C<foreach (@tied_file)>, even if you exit the
2499loop early.
2500
b3fe5a4c 2501=back
51efdd02 2502
57c7bc08
AMS
2503=head1 SUBCLASSING
2504
2505This version promises absolutely nothing about the internals, which
2506may change without notice. A future version of the module will have a
2507well-defined and stable subclassing API.
2508
b3fe5a4c 2509=head1 WHAT ABOUT C<DB_File>?
51efdd02 2510
27531ffb
JH
2511People sometimes point out that L<DB_File> will do something similar,
2512and ask why C<Tie::File> module is necessary.
b3fe5a4c 2513
27531ffb
JH
2514There are a number of reasons that you might prefer C<Tie::File>.
2515A list is available at C<http://perl.plover.com/TieFile/why-not-DB_File>.
b5aed31e
AMS
2516
2517=head1 AUTHOR
2518
2519Mark Jason Dominus
2520
2521To contact the author, send email to: C<mjd-perl-tiefile+@plover.com>
2522
2523To receive an announcement whenever a new version of this module is
2524released, send a blank email message to
2525C<mjd-perl-tiefile-subscribe@plover.com>.
2526
57c7bc08
AMS
2527The most recent version of this module, including documentation and
2528any news of importance, will be available at
2529
2530 http://perl.plover.com/TieFile/
2531
2532
b5aed31e
AMS
2533=head1 LICENSE
2534
c0504019 2535C<Tie::File> version 0.96 is copyright (C) 2003 Mark Jason Dominus.
7b6b3db1
JH
2536
2537This library is free software; you may redistribute it and/or modify
2538it under the same terms as Perl itself.
b5aed31e 2539
57c7bc08
AMS
2540These terms are your choice of any of (1) the Perl Artistic Licence,
2541or (2) version 2 of the GNU General Public License as published by the
7b6b3db1
JH
2542Free Software Foundation, or (3) any later version of the GNU General
2543Public License.
b5aed31e 2544
7b6b3db1 2545This library is distributed in the hope that it will be useful,
b5aed31e
AMS
2546but WITHOUT ANY WARRANTY; without even the implied warranty of
2547MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2548GNU General Public License for more details.
2549
2550You should have received a copy of the GNU General Public License
7b6b3db1 2551along with this library program; it should be in the file C<COPYING>.
8d9043d1
NC
2552If not, write to the Free Software Foundation, Inc., 51 Franklin Street,
2553Fifth Floor, Boston, MA 02110-1301, USA
b5aed31e
AMS
2554
2555For licensing inquiries, contact the author at:
2556
2557 Mark Jason Dominus
2558 255 S. Warnock St.
2559 Philadelphia, PA 19107
2560
2561=head1 WARRANTY
2562
c0504019 2563C<Tie::File> version 0.98 comes with ABSOLUTELY NO WARRANTY.
b5aed31e
AMS
2564For details, see the license.
2565
fa408a35
AMS
2566=head1 THANKS
2567
2568Gigantic thanks to Jarkko Hietaniemi, for agreeing to put this in the
2569core when I hadn't written it yet, and for generally being helpful,
2570supportive, and competent. (Usually the rule is "choose any one.")
2571Also big thanks to Abhijit Menon-Sen for all of the same things.
2572
57c7bc08
AMS
2573Special thanks to Craig Berry and Peter Prymmer (for VMS portability
2574help), Randy Kobes (for Win32 portability help), Clinton Pierce and
2575Autrijus Tang (for heroic eleventh-hour Win32 testing above and beyond
6fc0ea7e
JH
2576the call of duty), Michael G Schwern (for testing advice), and the
2577rest of the CPAN testers (for testing generally).
b5aed31e 2578
6ae23f41
JH
2579Special thanks to Tels for suggesting several speed and memory
2580optimizations.
2581
57c7bc08 2582Additional thanks to:
b3fe5a4c 2583Edward Avis /
6ae23f41 2584Mattia Barbon /
29aee836 2585Tom Christiansen /
fa408a35 2586Gerrit Haase /
29aee836 2587Gurusamy Sarathy /
6ae23f41 2588Jarkko Hietaniemi (again) /
b3fe5a4c 2589Nikola Knezevic /
6ae23f41 2590John Kominetz /
836d9961 2591Nick Ing-Simmons /
fa408a35
AMS
2592Tassilo von Parseval /
2593H. Dieter Pearcey /
b3fe5a4c 2594Slaven Rezic /
6ae23f41 2595Eric Roode /
6fc0ea7e 2596Peter Scott /
fa408a35 2597Peter Somu /
57c7bc08 2598Autrijus Tang (again) /
6ae23f41 2599Tels (again) /
c0504019
TR
2600Juerd Waalboer /
2601Todd Rinaldo
7b6b3db1 2602
fa408a35
AMS
2603=head1 TODO
2604
b5aed31e
AMS
2605More tests. (Stuff I didn't think of yet.)
2606
b5aed31e
AMS
2607Paragraph mode?
2608
6fc0ea7e 2609Fixed-length mode. Leave-blanks mode.
b5aed31e 2610
fa408a35
AMS
2611Maybe an autolocking mode?
2612
6ae23f41
JH
2613For many common uses of the module, the read cache is a liability.
2614For example, a program that inserts a single record, or that scans the
2615file once, will have a cache hit rate of zero. This suggests a major
2616optimization: The cache should be initially disabled. Here's a hybrid
2617approach: Initially, the cache is disabled, but the cache code
2618maintains statistics about how high the hit rate would be *if* it were
2619enabled. When it sees the hit rate get high enough, it enables
2620itself. The STAT comments in this code are the beginning of an
2621implementation of this.
2622
6fc0ea7e
JH
2623Record locking with fcntl()? Then the module might support an undo
2624log and get real transactions. What a tour de force that would be.
b3fe5a4c 2625
6ae23f41
JH
2626Keeping track of the highest cached record. This would allow reads-in-a-row
2627to skip the cache lookup faster (if reading from 1..N with empty cache at
2628start, the last cached value will be always N-1).
2629
27531ffb 2630More tests.
b3fe5a4c 2631
b5aed31e
AMS
2632=cut
2633