lib/DBM/Deep/File.pm

   1 package DBM::Deep::File;
   2
   3 use 5.6.0;
   4
   5 use strict;
   6 use warnings;
   7
   8 use Fcntl qw( :DEFAULT :flock :seek );
   9
  10 our $VERSION = '0.01';
  11
  12 sub new {
  13     my $class = shift;
  14     my ($args) = @_;
  15
  16     my $self = bless {
  17         autobless          => undef,
  18         autoflush          => undef,
  19         end                => 0,
  20         fh                 => undef,
  21         file               => undef,
  22         file_offset        => 0,
  23         locking            => undef,
  24         locked             => 0,
  25         filter_store_key   => undef,
  26         filter_store_value => undef,
  27         filter_fetch_key   => undef,
  28         filter_fetch_value => undef,
  29
  30         transaction_id        => 0,
  31         transaction_offset    => 0,
  32     }, $class;
  33
  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};
  38     }
  39
  40     if ( $self->{fh} && !$self->{file_offset} ) {
  41         $self->{file_offset} = tell( $self->{fh} );
  42     }
  43
  44     $self->open unless $self->{fh};
  45
  46     return $self;
  47 }
  48
  49 sub open {
  50     my $self = shift;
  51
  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;
  56
  57     my $fh;
  58     sysopen( $fh, $self->{file}, $flags )
  59         or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n";
  60     $self->{fh} = $fh;
  61
  62     # Even though we use O_BINARY, better be safe than sorry.
  63     binmode $fh;
  64
  65     if ($self->{autoflush}) {
  66         my $old = select $fh;
  67         $|=1;
  68         select $old;
  69     }
  70
  71     return 1;
  72 }
  73
  74 sub close {
  75     my $self = shift;
  76
  77     if ( $self->{fh} ) {
  78         close $self->{fh};
  79         $self->{fh} = undef;
  80     }
  81
  82     return 1;
  83 }
  84
  85 sub DESTROY {
  86     my $self = shift;
  87     return unless $self;
  88
  89     $self->close;
  90
  91     return;
  92 }
  93
  94 ##
  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.
  98 ##
  99 sub lock {
 100     my $self = shift;
 101     my ($obj, $type) = @_;
 102     $type = LOCK_EX unless defined $type;
 103
 104     if (!defined($self->{fh})) { return; }
 105
 106     if ($self->{locking}) {
 107         if (!$self->{locked}) {
 108             flock($self->{fh}, $type);
 109
 110             # refresh end counter in case file has changed size
 111             my @stats = stat($self->{fh});
 112             $self->{end} = $stats[7];
 113
 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}) {
 117                 $self->close;
 118                 $self->open;
 119
 120                 #XXX This needs work
 121                 $obj->{engine}->setup_fh( $obj );
 122
 123                 flock($self->{fh}, $type); # re-lock
 124
 125                 # This may not be necessary after re-opening
 126                 $self->{end} = (stat($self->{fh}))[7]; # re-end
 127             }
 128         }
 129         $self->{locked}++;
 130
 131         return 1;
 132     }
 133
 134     return;
 135 }
 136
 137 ##
 138 # If db locking is set, unlock the db file.  See note in lock()
 139 # regarding calling lock() multiple times.
 140 ##
 141 sub unlock {
 142     my $self = shift;
 143
 144     if (!defined($self->{fh})) { return; }
 145
 146     if ($self->{locking} && $self->{locked} > 0) {
 147         $self->{locked}--;
 148         if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); }
 149
 150         return 1;
 151     }
 152
 153     return;
 154 }
 155
 156 sub set_transaction_offset {
 157     my $self = shift;
 158     $self->{transaction_offset} = shift;
 159 }
 160
 161 sub begin_transaction {
 162     my $self = shift;
 163
 164     my $fh = $self->{fh};
 165
 166     $self->lock;
 167
 168     seek( $fh, $self->{transaction_offset}, SEEK_SET );
 169     my $buffer;
 170     read( $fh, $buffer, 4 );
 171     $buffer = unpack( 'N', $buffer );
 172
 173     for ( 1 .. 32 ) {
 174         next if $buffer & (1 << ($_ - 1));
 175         $self->{transaction_id} = $_;
 176         $buffer |= (1 << $_-1 );
 177         last;
 178     }
 179
 180     seek( $fh, $self->{transaction_offset}, SEEK_SET );
 181     print( $fh pack( 'N', $buffer ) );
 182
 183     $self->unlock;
 184
 185     return $self->{transaction_id};
 186 }
 187
 188 sub end_transaction {
 189     my $self = shift;
 190
 191     my $fh = $self->{fh};
 192
 193     $self->lock;
 194
 195     seek( $fh, $self->{transaction_offset}, SEEK_SET );
 196     my $buffer;
 197     read( $fh, $buffer, 4 );
 198     $buffer = unpack( 'N', $buffer );
 199
 200     # Unset $self->{transaction_id} bit
 201
 202     seek( $fh, $self->{transaction_offset}, SEEK_SET );
 203     print( $fh pack( 'N', $buffer ) );
 204
 205     $self->unlock;
 206
 207     $self->{transaction_id} = 0;
 208 }
 209
 210 sub current_transactions {
 211     my $self = shift;
 212
 213     my $fh = $self->{fh};
 214
 215     $self->lock;
 216
 217     seek( $fh, $self->{transaction_offset}, SEEK_SET );
 218     my $buffer;
 219     read( $fh, $buffer, 4 );
 220     $buffer = unpack( 'N', $buffer );
 221
 222     $self->unlock;
 223
 224     my @transactions;
 225     for ( 1 .. 32 ) {
 226         if ( $buffer & (1 << ($_ - 1)) ) {
 227             push @transactions, $_;
 228         }
 229     }
 230
 231     return grep { $_ != $self->{transaction_id} } @transactions;
 232 }
 233
 234 sub transaction_id { return $_[0]->{transaction_id} }
 235
 236 #sub commit {
 237 #}
 238
 239 1;
 240 __END__
 241