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 our $VERSION = q(0.99_03);
   9
  10 use Fcntl qw( :DEFAULT :flock :seek );
  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         transaction_audit  => undef,
  37         base_db_obj        => undef,
  38     }, $class;
  39
  40     # Grab the parameters we want to use
  41     foreach my $param ( keys %$self ) {
  42         next unless exists $args->{$param};
  43         $self->{$param} = $args->{$param};
  44     }
  45
  46     if ( $self->{fh} && !$self->{file_offset} ) {
  47         $self->{file_offset} = tell( $self->{fh} );
  48     }
  49
  50     $self->open unless $self->{fh};
  51
  52     if ( $self->{audit_file} && !$self->{audit_fh} ) {
  53         my $flags = O_WRONLY | O_APPEND | O_CREAT;
  54
  55         my $fh;
  56         sysopen( $fh, $self->{audit_file}, $flags )
  57             or die "Cannot open audit file '$self->{audit_file}' for read/write: $!";
  58
  59         # Set the audit_fh to autoflush
  60         my $old = select $fh;
  61         $|=1;
  62         select $old;
  63
  64         $self->{audit_fh} = $fh;
  65     }
  66
  67
  68     return $self;
  69 }
  70
  71 sub set_db {
  72     my $self = shift;
  73
  74     unless ( $self->{base_db_obj} ) {
  75         $self->{base_db_obj} = shift;
  76         Scalar::Util::weaken( $self->{base_db_obj} );
  77     }
  78
  79     return;
  80 }
  81
  82 sub open {
  83     my $self = shift;
  84
  85     # Adding O_BINARY should remove the need for the binmode below. However,
  86     # I'm not going to remove it because I don't have the Win32 chops to be
  87     # absolutely certain everything will be ok.
  88     my $flags = O_RDWR | O_CREAT | O_BINARY;
  89
  90     my $fh;
  91     sysopen( $fh, $self->{file}, $flags )
  92         or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n";
  93     $self->{fh} = $fh;
  94
  95     # Even though we use O_BINARY, better be safe than sorry.
  96     binmode $fh;
  97
  98     if ($self->{autoflush}) {
  99         my $old = select $fh;
 100         $|=1;
 101         select $old;
 102     }
 103
 104     return 1;
 105 }
 106
 107 sub close {
 108     my $self = shift;
 109
 110     if ( $self->{fh} ) {
 111         close $self->{fh};
 112         $self->{fh} = undef;
 113     }
 114
 115     return 1;
 116 }
 117
 118 sub set_inode {
 119     my $self = shift;
 120
 121     unless ( $self->{inode} ) {
 122         my @stats = stat($self->{fh});
 123         $self->{inode} = $stats[1];
 124         $self->{end} = $stats[7];
 125     }
 126
 127     return 1;
 128 }
 129
 130 sub print_at {
 131     my $self = shift;
 132     my $loc  = shift;
 133
 134     local ($/,$\);
 135
 136     my $fh = $self->{fh};
 137     if ( defined $loc ) {
 138         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
 139     }
 140
 141     print( $fh @_ );
 142
 143     return 1;
 144 }
 145
 146 sub read_at {
 147     my $self = shift;
 148     my ($loc, $size) = @_;
 149     print join(":",caller) . " - read_at(@{[$loc || 'undef']}, $size)\n" if $::DEBUG;
 150
 151     local ($/,$\);
 152
 153     my $fh = $self->{fh};
 154     if ( defined $loc ) {
 155         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
 156     }
 157
 158     my $buffer;
 159     read( $fh, $buffer, $size);
 160
 161     return $buffer;
 162 }
 163
 164 sub increment_pointer {
 165     my $self = shift;
 166     my ($size) = @_;
 167
 168     if ( defined $size ) {
 169         seek( $self->{fh}, $size, SEEK_CUR );
 170     }
 171
 172     return 1;
 173 }
 174
 175 sub DESTROY {
 176     my $self = shift;
 177     return unless $self;
 178
 179     $self->close;
 180
 181     return;
 182 }
 183
 184 sub request_space {
 185     my $self = shift;
 186     my ($size) = @_;
 187
 188     #XXX Do I need to reset $self->{end} here? I need a testcase
 189     my $loc = $self->{end};
 190     $self->{end} += $size;
 191
 192     return $loc;
 193 }
 194
 195 #sub release_space {
 196 #    my $self = shift;
 197 #    my ($size, $loc) = @_;
 198 #
 199 #    local($/,$\);
 200 #
 201 #    my $next_loc = 0;
 202 #
 203 #    my $fh = $self->{fh};
 204 #    seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
 205 #    print( $fh SIG_FREE
 206 #        . pack($self->{long_pack}, $size )
 207 #        . pack($self->{long_pack}, $next_loc )
 208 #    );
 209 #
 210 #    return;
 211 #}
 212
 213 ##
 214 # If db locking is set, flock() the db file.  If called multiple
 215 # times before unlock(), then the same number of unlocks() must
 216 # be called before the lock is released.
 217 ##
 218 sub lock {
 219     my $self = shift;
 220     my ($obj, $type) = @_;
 221
 222     #XXX This may not always be the correct thing to do
 223     $obj = $self->{base_db_obj} unless defined $obj;
 224
 225     $type = LOCK_EX unless defined $type;
 226
 227     if (!defined($self->{fh})) { return; }
 228
 229     if ($self->{locking}) {
 230         if (!$self->{locked}) {
 231             flock($self->{fh}, $type);
 232
 233             # refresh end counter in case file has changed size
 234             my @stats = stat($self->{fh});
 235             $self->{end} = $stats[7];
 236
 237             # double-check file inode, in case another process
 238             # has optimize()d our file while we were waiting.
 239             if ($stats[1] != $self->{inode}) {
 240                 $self->close;
 241                 $self->open;
 242
 243                 #XXX This needs work
 244                 $obj->{engine}->setup_fh( $obj );
 245
 246                 flock($self->{fh}, $type); # re-lock
 247
 248                 # This may not be necessary after re-opening
 249                 $self->{end} = (stat($self->{fh}))[7]; # re-end
 250             }
 251         }
 252         $self->{locked}++;
 253
 254         return 1;
 255     }
 256
 257     return;
 258 }
 259
 260 ##
 261 # If db locking is set, unlock the db file.  See note in lock()
 262 # regarding calling lock() multiple times.
 263 ##
 264 sub unlock {
 265     my $self = shift;
 266
 267     if (!defined($self->{fh})) { return; }
 268
 269     if ($self->{locking} && $self->{locked} > 0) {
 270         $self->{locked}--;
 271         if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); }
 272
 273         return 1;
 274     }
 275
 276     return;
 277 }
 278
 279 sub set_transaction_offset {
 280     my $self = shift;
 281     $self->{transaction_offset} = shift;
 282 }
 283
 284 sub audit {
 285     my $self = shift;
 286     my ($string) = @_;
 287
 288     if ( my $afh = $self->{audit_fh} ) {
 289         flock( $afh, LOCK_EX );
 290
 291         if ( $string =~ /^#/ ) {
 292             print( $afh "$string " . localtime(time) . "\n" );
 293         }
 294         else {
 295             print( $afh "$string # " . localtime(time) . "\n" );
 296         }
 297
 298         flock( $afh, LOCK_UN );
 299     }
 300
 301     if ( $self->{transaction_audit} ) {
 302         push @{$self->{transaction_audit}}, $string;
 303     }
 304
 305     return 1;
 306 }
 307
 308 sub begin_transaction {
 309     my $self = shift;
 310
 311     my $fh = $self->{fh};
 312
 313     $self->lock;
 314
 315     my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
 316     my ($next, @trans) = unpack( 'C C C C C C C C C C C C C C C C', $buffer );
 317
 318     $self->{transaction_id} = ++$next;
 319
 320     die if $trans[-1] != 0;
 321
 322     for ( my $i = 0; $i <= $#trans; $i++ ) {
 323         next if $trans[$i] != 0;
 324         $trans[$i] = $next;
 325         last;
 326     }
 327
 328     $self->print_at(
 329         $self->{transaction_offset},
 330         pack( 'C C C C C C C C C C C C C C C C', $next, @trans),
 331     );
 332
 333     $self->unlock;
 334
 335     $self->{transaction_audit} = [];
 336
 337     return $self->{transaction_id};
 338 }
 339
 340 sub end_transaction {
 341     my $self = shift;
 342
 343     my $fh = $self->{fh};
 344
 345     $self->lock;
 346
 347     my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
 348     my ($next, @trans) = unpack( 'C C C C C C C C C C C C C C C C', $buffer );
 349
 350     @trans = grep { $_ != $self->{transaction_id} } @trans;
 351
 352     $self->print_at(
 353         $self->{transaction_offset},
 354         pack( 'C C C C C C C C C C C C C C C C', $next, @trans),
 355     );
 356
 357     #XXX Need to free the space used by the current transaction
 358
 359     $self->unlock;
 360
 361     $self->{transaction_id} = 0;
 362     $self->{transaction_audit} = undef;
 363
 364 #    $self->{base_db_obj}->optimize;
 365 #    $self->{inode} = undef;
 366 #    $self->set_inode;
 367
 368     return 1;
 369 }
 370
 371 sub current_transactions {
 372     my $self = shift;
 373
 374     my $fh = $self->{fh};
 375
 376     $self->lock;
 377
 378     my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
 379     my ($next, @trans) = unpack( 'C C C C C C C C C C C C C C C C', $buffer );
 380
 381     $self->unlock;
 382
 383     return grep { $_ && $_ != $self->{transaction_id} } @trans;
 384 }
 385
 386 sub transaction_id { return $_[0]->{transaction_id} }
 387
 388 sub commit_transaction {
 389     my $self = shift;
 390
 391     my @audit = @{$self->{transaction_audit}};
 392
 393     $self->end_transaction;
 394
 395     {
 396         my $db = $self->{base_db_obj};
 397         for ( @audit ) {
 398             eval "$_;";
 399             warn "$_: $@\n" if $@;
 400         }
 401     }
 402
 403     return 1;
 404 }
 405
 406 1;
 407 __END__
 408