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