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 audit {
 190     my $self = shift;
 191
 192     if ( my $afh = $self->{audit_fh} ) {
 193         my ($string) = @_;
 194
 195         flock( $afh, LOCK_EX );
 196
 197         if ( $string =~ /^#/ ) {
 198             print( $afh "$string " . localtime(time) . "\n" );
 199         }
 200         else {
 201             print( $afh "$string # " . localtime(time) . "\n" );
 202         }
 203
 204         flock( $afh, LOCK_UN );
 205     }
 206
 207     return 1;
 208 }
 209
 210 sub begin_transaction {
 211     my $self = shift;
 212
 213     my $fh = $self->{fh};
 214
 215     $self->lock;
 216
 217     seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
 218     my $buffer;
 219     read( $fh, $buffer, 4 );
 220     $buffer = unpack( 'N', $buffer );
 221
 222     for ( 1 .. 32 ) {
 223         next if $buffer & (1 << ($_ - 1));
 224         $self->{transaction_id} = $_;
 225         $buffer |= (1 << $_-1 );
 226         last;
 227     }
 228
 229     seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
 230     print( $fh pack( 'N', $buffer ) );
 231
 232     $self->unlock;
 233
 234     return $self->{transaction_id};
 235 }
 236
 237 sub end_transaction {
 238     my $self = shift;
 239
 240     my $fh = $self->{fh};
 241
 242     $self->lock;
 243
 244     seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
 245     my $buffer;
 246     read( $fh, $buffer, 4 );
 247     $buffer = unpack( 'N', $buffer );
 248
 249     # Unset $self->{transaction_id} bit
 250
 251     seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
 252     print( $fh pack( 'N', $buffer ) );
 253
 254     $self->unlock;
 255
 256     $self->{transaction_id} = 0;
 257 }
 258
 259 sub current_transactions {
 260     my $self = shift;
 261
 262     my $fh = $self->{fh};
 263
 264     $self->lock;
 265
 266     seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
 267     my $buffer;
 268     read( $fh, $buffer, 4 );
 269     $buffer = unpack( 'N', $buffer );
 270
 271     $self->unlock;
 272
 273     my @transactions;
 274     for ( 1 .. 32 ) {
 275         if ( $buffer & (1 << ($_ - 1)) ) {
 276             push @transactions, $_;
 277         }
 278     }
 279
 280     return grep { $_ != $self->{transaction_id} } @transactions;
 281 }
 282
 283 sub transaction_id { return $_[0]->{transaction_id} }
 284
 285 #sub commit {
 286 #}
 287
 288 1;
 289 __END__
 290