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         audit_fh           => undef,
  18         audit_file         => undef,
  19         autobless          => 1,
  20         autoflush          => undef,
  21         end                => 0,
  22         fh                 => undef,
  23         file               => undef,
  24         file_offset        => 0,
  25         locking            => undef,
  26         locked             => 0,
  27         filter_store_key   => undef,
  28         filter_store_value => undef,
  29         filter_fetch_key   => undef,
  30         filter_fetch_value => undef,
  31
  32         # These are values that are not expected to be passed in through
  33         # $args. They are here for documentation purposes.
  34         transaction_id     => 0,
  35         transaction_offset => 0,
  36         base_db_obj        => undef,
  37     }, $class;
  38
  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};
  43     }
  44
  45     if ( $self->{fh} && !$self->{file_offset} ) {
  46         $self->{file_offset} = tell( $self->{fh} );
  47     }
  48
  49     $self->open unless $self->{fh};
  50
  51     if ( $self->{audit_file} && !$self->{audit_fh} ) {
  52         my $flags = O_WRONLY | O_APPEND | O_CREAT;
  53
  54         my $fh;
  55         sysopen( $fh, $self->{audit_file}, $flags )
  56             or die "Cannot open audit file '$self->{audit_file}' for read/write: $!";
  57
  58         # Set the audit_fh to autoflush
  59         my $old = select $fh;
  60         $|=1;
  61         select $old;
  62
  63         $self->{audit_fh} = $fh;
  64     }
  65
  66
  67     return $self;
  68 }
  69
  70 sub set_db {
  71     unless ( $_[0]{base_db_obj} ) {
  72         $_[0]{base_db_obj} = $_[1];
  73         Scalar::Util::weaken( $_[0]{base_db_obj} );
  74     }
  75 }
  76
  77 sub open {
  78     my $self = shift;
  79
  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;
  84
  85     my $fh;
  86     sysopen( $fh, $self->{file}, $flags )
  87         or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n";
  88     $self->{fh} = $fh;
  89
  90     # Even though we use O_BINARY, better be safe than sorry.
  91     binmode $fh;
  92
  93     if ($self->{autoflush}) {
  94         my $old = select $fh;
  95         $|=1;
  96         select $old;
  97     }
  98
  99     return 1;
 100 }
 101
 102 sub close {
 103     my $self = shift;
 104
 105     if ( $self->{fh} ) {
 106         close $self->{fh};
 107         $self->{fh} = undef;
 108     }
 109
 110     return 1;
 111 }
 112
 113 sub DESTROY {
 114     my $self = shift;
 115     return unless $self;
 116
 117     $self->close;
 118
 119     return;
 120 }
 121
 122 ##
 123 # If db locking is set, flock() the db file.  If called multiple
 124 # times before unlock(), then the same number of unlocks() must
 125 # be called before the lock is released.
 126 ##
 127 sub lock {
 128     my $self = shift;
 129     my ($obj, $type) = @_;
 130     $type = LOCK_EX unless defined $type;
 131
 132     if (!defined($self->{fh})) { return; }
 133
 134     if ($self->{locking}) {
 135         if (!$self->{locked}) {
 136             flock($self->{fh}, $type);
 137
 138             # refresh end counter in case file has changed size
 139             my @stats = stat($self->{fh});
 140             $self->{end} = $stats[7];
 141
 142             # double-check file inode, in case another process
 143             # has optimize()d our file while we were waiting.
 144             if ($stats[1] != $self->{inode}) {
 145                 $self->close;
 146                 $self->open;
 147
 148                 #XXX This needs work
 149                 $obj->{engine}->setup_fh( $obj );
 150
 151                 flock($self->{fh}, $type); # re-lock
 152
 153                 # This may not be necessary after re-opening
 154                 $self->{end} = (stat($self->{fh}))[7]; # re-end
 155             }
 156         }
 157         $self->{locked}++;
 158
 159         return 1;
 160     }
 161
 162     return;
 163 }
 164
 165 ##
 166 # If db locking is set, unlock the db file.  See note in lock()
 167 # regarding calling lock() multiple times.
 168 ##
 169 sub unlock {
 170     my $self = shift;
 171
 172     if (!defined($self->{fh})) { return; }
 173
 174     if ($self->{locking} && $self->{locked} > 0) {
 175         $self->{locked}--;
 176         if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); }
 177
 178         return 1;
 179     }
 180
 181     return;
 182 }
 183
 184 sub set_transaction_offset {
 185     my $self = shift;
 186     $self->{transaction_offset} = shift;
 187 }
 188
 189 sub begin_transaction {
 190     my $self = shift;
 191
 192     my $fh = $self->{fh};
 193
 194     $self->lock;
 195
 196     seek( $fh, $self->{transaction_offset}, SEEK_SET );
 197     my $buffer;
 198     read( $fh, $buffer, 4 );
 199     $buffer = unpack( 'N', $buffer );
 200
 201     for ( 1 .. 32 ) {
 202         next if $buffer & (1 << ($_ - 1));
 203         $self->{transaction_id} = $_;
 204         $buffer |= (1 << $_-1 );
 205         last;
 206     }
 207
 208     seek( $fh, $self->{transaction_offset}, SEEK_SET );
 209     print( $fh pack( 'N', $buffer ) );
 210
 211     $self->unlock;
 212
 213     return $self->{transaction_id};
 214 }
 215
 216 sub end_transaction {
 217     my $self = shift;
 218
 219     my $fh = $self->{fh};
 220
 221     $self->lock;
 222
 223     seek( $fh, $self->{transaction_offset}, SEEK_SET );
 224     my $buffer;
 225     read( $fh, $buffer, 4 );
 226     $buffer = unpack( 'N', $buffer );
 227
 228     # Unset $self->{transaction_id} bit
 229
 230     seek( $fh, $self->{transaction_offset}, SEEK_SET );
 231     print( $fh pack( 'N', $buffer ) );
 232
 233     $self->unlock;
 234
 235     $self->{transaction_id} = 0;
 236 }
 237
 238 sub current_transactions {
 239     my $self = shift;
 240
 241     my $fh = $self->{fh};
 242
 243     $self->lock;
 244
 245     seek( $fh, $self->{transaction_offset}, SEEK_SET );
 246     my $buffer;
 247     read( $fh, $buffer, 4 );
 248     $buffer = unpack( 'N', $buffer );
 249
 250     $self->unlock;
 251
 252     my @transactions;
 253     for ( 1 .. 32 ) {
 254         if ( $buffer & (1 << ($_ - 1)) ) {
 255             push @transactions, $_;
 256         }
 257     }
 258
 259     return grep { $_ != $self->{transaction_id} } @transactions;
 260 }
 261
 262 sub transaction_id { return $_[0]->{transaction_id} }
 263
 264 #sub commit {
 265 #}
 266
 267 1;
 268 __END__
 269