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,
39 # Grab the parameters we want to use
40 foreach my $param ( keys %$self ) {
41 next unless exists $args->{$param};
42 $self->{$param} = $args->{$param};
45 if ( $self->{fh} && !$self->{file_offset} ) {
46 $self->{file_offset} = tell( $self->{fh} );
49 $self->open unless $self->{fh};
51 if ( $self->{audit_file} && !$self->{audit_fh} ) {
52 my $flags = O_WRONLY | O_APPEND | O_CREAT;
55 sysopen( $fh, $self->{audit_file}, $flags )
56 or die "Cannot open audit file '$self->{audit_file}' for read/write: $!";
58 # Set the audit_fh to autoflush
63 $self->{audit_fh} = $fh;
71 unless ( $_[0]{base_db_obj} ) {
72 $_[0]{base_db_obj} = $_[1];
73 Scalar::Util::weaken( $_[0]{base_db_obj} );
80 # Adding O_BINARY does remove the need for the binmode below. However,
81 # I'm not going to remove it because I don't have the Win32 chops to be
82 # absolutely certain everything will be ok.
83 my $flags = O_RDWR | O_CREAT | O_BINARY;
86 sysopen( $fh, $self->{file}, $flags )
87 or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n";
90 # Even though we use O_BINARY, better be safe than sorry.
93 if ($self->{autoflush}) {
119 my $fh = $self->{fh};
120 seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
139 my $loc = $self->{end};
140 $self->{end} += $size;
147 # my ($size, $loc) = @_;
153 # my $fh = $self->{fh};
154 # seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
155 # print( $fh SIG_FREE
156 # . pack($self->{long_pack}, $size )
157 # . pack($self->{long_pack}, $next_loc )
164 # If db locking is set, flock() the db file. If called multiple
165 # times before unlock(), then the same number of unlocks() must
166 # be called before the lock is released.
170 my ($obj, $type) = @_;
171 $type = LOCK_EX unless defined $type;
173 if (!defined($self->{fh})) { return; }
175 if ($self->{locking}) {
176 if (!$self->{locked}) {
177 flock($self->{fh}, $type);
179 # refresh end counter in case file has changed size
180 my @stats = stat($self->{fh});
181 $self->{end} = $stats[7];
183 # double-check file inode, in case another process
184 # has optimize()d our file while we were waiting.
185 if ($stats[1] != $self->{inode}) {
190 $obj->{engine}->setup_fh( $obj );
192 flock($self->{fh}, $type); # re-lock
194 # This may not be necessary after re-opening
195 $self->{end} = (stat($self->{fh}))[7]; # re-end
207 # If db locking is set, unlock the db file. See note in lock()
208 # regarding calling lock() multiple times.
213 if (!defined($self->{fh})) { return; }
215 if ($self->{locking} && $self->{locked} > 0) {
217 if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); }
225 sub set_transaction_offset {
227 $self->{transaction_offset} = shift;
233 if ( my $afh = $self->{audit_fh} ) {
236 flock( $afh, LOCK_EX );
238 if ( $string =~ /^#/ ) {
239 print( $afh "$string " . localtime(time) . "\n" );
242 print( $afh "$string # " . localtime(time) . "\n" );
245 flock( $afh, LOCK_UN );
251 sub begin_transaction {
254 my $fh = $self->{fh};
258 seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
260 read( $fh, $buffer, 4 );
261 $buffer = unpack( 'N', $buffer );
264 next if $buffer & (1 << ($_ - 1));
265 $self->{transaction_id} = $_;
266 $buffer |= (1 << $_-1 );
270 seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
271 print( $fh pack( 'N', $buffer ) );
275 return $self->{transaction_id};
278 sub end_transaction {
281 my $fh = $self->{fh};
285 seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
287 read( $fh, $buffer, 4 );
288 $buffer = unpack( 'N', $buffer );
290 # Unset $self->{transaction_id} bit
292 seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
293 print( $fh pack( 'N', $buffer ) );
297 $self->{transaction_id} = 0;
300 sub current_transactions {
303 my $fh = $self->{fh};
307 seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
309 read( $fh, $buffer, 4 );
310 $buffer = unpack( 'N', $buffer );
316 if ( $buffer & (1 << ($_ - 1)) ) {
317 push @transactions, $_;
321 return grep { $_ != $self->{transaction_id} } @transactions;
324 sub transaction_id { return $_[0]->{transaction_id} }