1 package DBM::Deep::File;
8 use Fcntl qw( :DEFAULT :flock :seek );
10 our $VERSION = '0.01';
27 filter_store_key => undef,
28 filter_store_value => undef,
29 filter_fetch_key => undef,
30 filter_fetch_value => undef,
32 # These are values that are not expected to be passed in through
33 # $args. They are here for documentation purposes.
35 transaction_offset => 0,
40 # Grab the parameters we want to use
41 foreach my $param ( keys %$self ) {
42 next unless exists $args->{$param};
43 $self->{$param} = $args->{$param};
46 if ( $self->{fh} && !$self->{file_offset} ) {
47 $self->{file_offset} = tell( $self->{fh} );
50 $self->open unless $self->{fh};
52 if ( $self->{audit_file} && !$self->{audit_fh} ) {
53 my $flags = O_WRONLY | O_APPEND | O_CREAT;
56 sysopen( $fh, $self->{audit_file}, $flags )
57 or die "Cannot open audit file '$self->{audit_file}' for read/write: $!";
59 # Set the audit_fh to autoflush
64 $self->{audit_fh} = $fh;
73 unless ( $self->{base_db_obj} ) {
74 $self->{base_db_obj} = shift;
75 Scalar::Util::weaken( $self->{base_db_obj} );
84 # Adding O_BINARY does remove the need for the binmode below. However,
85 # I'm not going to remove it because I don't have the Win32 chops to be
86 # absolutely certain everything will be ok.
87 my $flags = O_RDWR | O_CREAT | O_BINARY;
90 sysopen( $fh, $self->{file}, $flags )
91 or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n";
94 # Even though we use O_BINARY, better be safe than sorry.
97 if ($self->{autoflush}) {
120 unless ( $self->{inode} ) {
121 my @stats = stat($self->{fh});
122 $self->{inode} = $stats[1];
123 $self->{end} = $stats[7];
135 my $fh = $self->{fh};
136 if ( defined $loc ) {
137 seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
147 my ($loc, $size) = @_;
151 my $fh = $self->{fh};
152 if ( defined $loc ) {
153 seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
157 read( $fh, $buffer, $size);
162 sub increment_pointer {
166 if ( defined $size ) {
167 seek( $self->{fh}, $size, SEEK_CUR );
186 #XXX Do I need to reset $self->{end} here? I need a testcase
187 my $loc = $self->{end};
188 $self->{end} += $size;
195 # my ($size, $loc) = @_;
201 # my $fh = $self->{fh};
202 # seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
203 # print( $fh SIG_FREE
204 # . pack($self->{long_pack}, $size )
205 # . pack($self->{long_pack}, $next_loc )
212 # If db locking is set, flock() the db file. If called multiple
213 # times before unlock(), then the same number of unlocks() must
214 # be called before the lock is released.
218 my ($obj, $type) = @_;
219 $type = LOCK_EX unless defined $type;
221 if (!defined($self->{fh})) { return; }
223 if ($self->{locking}) {
224 if (!$self->{locked}) {
225 flock($self->{fh}, $type);
227 # refresh end counter in case file has changed size
228 my @stats = stat($self->{fh});
229 $self->{end} = $stats[7];
231 # double-check file inode, in case another process
232 # has optimize()d our file while we were waiting.
233 if ($stats[1] != $self->{inode}) {
238 $obj->{engine}->setup_fh( $obj );
240 flock($self->{fh}, $type); # re-lock
242 # This may not be necessary after re-opening
243 $self->{end} = (stat($self->{fh}))[7]; # re-end
255 # If db locking is set, unlock the db file. See note in lock()
256 # regarding calling lock() multiple times.
261 if (!defined($self->{fh})) { return; }
263 if ($self->{locking} && $self->{locked} > 0) {
265 if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); }
273 sub set_transaction_offset {
275 $self->{transaction_offset} = shift;
282 if ( my $afh = $self->{audit_fh} ) {
283 flock( $afh, LOCK_EX );
285 if ( $string =~ /^#/ ) {
286 print( $afh "$string " . localtime(time) . "\n" );
289 print( $afh "$string # " . localtime(time) . "\n" );
292 flock( $afh, LOCK_UN );
295 if ( $self->{trans_audit} ) {
296 push @{$self->{trans_audit}}, $string;
302 sub begin_transaction {
305 my $fh = $self->{fh};
309 seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
311 read( $fh, $buffer, 4 );
312 $buffer = unpack( 'N', $buffer );
315 next if $buffer & (1 << ($_ - 1));
316 $self->{transaction_id} = $_;
317 $buffer |= (1 << $_-1 );
321 seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
322 print( $fh pack( 'N', $buffer ) );
326 $self->{trans_audit} = [];
328 return $self->{transaction_id};
331 sub end_transaction {
334 my $fh = $self->{fh};
338 seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
340 read( $fh, $buffer, 4 );
341 $buffer = unpack( 'N', $buffer );
343 # Unset $self->{transaction_id} bit
344 $buffer ^= (1 << $self->{transaction_id}-1);
346 seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
347 print( $fh pack( 'N', $buffer ) );
351 $self->{transaction_id} = 0;
352 $self->{trans_audit} = undef;
357 sub current_transactions {
360 my $fh = $self->{fh};
364 seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
366 read( $fh, $buffer, 4 );
367 $buffer = unpack( 'N', $buffer );
373 if ( $buffer & (1 << ($_ - 1)) ) {
374 push @transactions, $_;
378 return grep { $_ != $self->{transaction_id} } @transactions;
381 sub transaction_id { return $_[0]->{transaction_id} }
383 sub commit_transaction {
386 my @audit = @{$self->{trans_audit}};
388 $self->end_transaction;
391 my $db = $self->{base_db_obj};
394 warn "$_: $@\n" if $@;