1 package DBM::Deep::File;
8 use Fcntl qw( :DEFAULT :flock :seek );
10 our $VERSION = '0.01';
25 filter_store_key => undef,
26 filter_store_value => undef,
27 filter_fetch_key => undef,
28 filter_fetch_value => undef,
31 transaction_offset => 0,
34 # Grab the parameters we want to use
35 foreach my $param ( keys %$self ) {
36 next unless exists $args->{$param};
37 $self->{$param} = $args->{$param};
40 if ( $self->{fh} && !$self->{file_offset} ) {
41 $self->{file_offset} = tell( $self->{fh} );
44 $self->open unless $self->{fh};
52 # Adding O_BINARY does remove the need for the binmode below. However,
53 # I'm not going to remove it because I don't have the Win32 chops to be
54 # absolutely certain everything will be ok.
55 my $flags = O_RDWR | O_CREAT | O_BINARY;
58 sysopen( $fh, $self->{file}, $flags )
59 or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n";
62 # Even though we use O_BINARY, better be safe than sorry.
65 if ($self->{autoflush}) {
95 # If db locking is set, flock() the db file. If called multiple
96 # times before unlock(), then the same number of unlocks() must
97 # be called before the lock is released.
101 my ($obj, $type) = @_;
102 $type = LOCK_EX unless defined $type;
104 if (!defined($self->{fh})) { return; }
106 if ($self->{locking}) {
107 if (!$self->{locked}) {
108 flock($self->{fh}, $type);
110 # refresh end counter in case file has changed size
111 my @stats = stat($self->{fh});
112 $self->{end} = $stats[7];
114 # double-check file inode, in case another process
115 # has optimize()d our file while we were waiting.
116 if ($stats[1] != $self->{inode}) {
121 $obj->{engine}->setup_fh( $obj );
123 flock($self->{fh}, $type); # re-lock
125 # This may not be necessary after re-opening
126 $self->{end} = (stat($self->{fh}))[7]; # re-end
138 # If db locking is set, unlock the db file. See note in lock()
139 # regarding calling lock() multiple times.
144 if (!defined($self->{fh})) { return; }
146 if ($self->{locking} && $self->{locked} > 0) {
148 if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); }
156 sub set_transaction_offset {
158 $self->{transaction_offset} = shift;
161 sub begin_transaction {
164 my $fh = $self->{fh};
168 seek( $fh, $self->{transaction_offset}, SEEK_SET );
170 read( $fh, $buffer, 4 );
171 $buffer = unpack( 'N', $buffer );
174 next if $buffer & (1 << ($_ - 1));
175 $self->{transaction_id} = $_;
176 $buffer |= (1 << $_-1 );
180 seek( $fh, $self->{transaction_offset}, SEEK_SET );
181 print( $fh pack( 'N', $buffer ) );
185 return $self->{transaction_id};
188 sub end_transaction {
191 my $fh = $self->{fh};
195 seek( $fh, $self->{transaction_offset}, SEEK_SET );
197 read( $fh, $buffer, 4 );
198 $buffer = unpack( 'N', $buffer );
200 # Unset $self->{transaction_id} bit
202 seek( $fh, $self->{transaction_offset}, SEEK_SET );
203 print( $fh pack( 'N', $buffer ) );
207 $self->{transaction_id} = 0;
210 sub current_transactions {
213 my $fh = $self->{fh};
217 seek( $fh, $self->{transaction_offset}, SEEK_SET );
219 read( $fh, $buffer, 4 );
220 $buffer = unpack( 'N', $buffer );
226 if ( $buffer & (1 << ($_ - 1)) ) {
227 push @transactions, $_;
231 return grep { $_ != $self->{transaction_id} } @transactions;
234 sub transaction_id { return $_[0]->{transaction_id} }