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