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 ( defined $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(":",map{$_||''}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 ##
 196 # If db locking is set, flock() the db file.  If called multiple
 197 # times before unlock(), then the same number of unlocks() must
 198 # be called before the lock is released.
 199 ##
 200 sub lock {
 201     my $self = shift;
 202     my ($obj, $type) = @_;
 203
 204     #XXX This may not always be the correct thing to do
 205     $obj = $self->{base_db_obj} unless defined $obj;
 206
 207     $type = LOCK_EX unless defined $type;
 208
 209     if (!defined($self->{fh})) { return; }
 210
 211     if ($self->{locking}) {
 212         if (!$self->{locked}) {
 213             flock($self->{fh}, $type);
 214
 215             # refresh end counter in case file has changed size
 216             my @stats = stat($self->{fh});
 217             $self->{end} = $stats[7];
 218
 219             # double-check file inode, in case another process
 220             # has optimize()d our file while we were waiting.
 221             if (defined($self->{inode}) && $stats[1] != $self->{inode}) {
 222                 $self->close;
 223                 $self->open;
 224
 225                 #XXX This needs work
 226                 $obj->{engine}->setup_fh( $obj );
 227
 228                 flock($self->{fh}, $type); # re-lock
 229
 230                 # This may not be necessary after re-opening
 231                 $self->{end} = (stat($self->{fh}))[7]; # re-end
 232             }
 233         }
 234         $self->{locked}++;
 235
 236         return 1;
 237     }
 238
 239     return;
 240 }
 241
 242 ##
 243 # If db locking is set, unlock the db file.  See note in lock()
 244 # regarding calling lock() multiple times.
 245 ##
 246 sub unlock {
 247     my $self = shift;
 248
 249     if (!defined($self->{fh})) { return; }
 250
 251     if ($self->{locking} && $self->{locked} > 0) {
 252         $self->{locked}--;
 253         if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); }
 254
 255         return 1;
 256     }
 257
 258     return;
 259 }
 260
 261 sub flush {
 262     my $self = shift;
 263
 264     # Flush the filehandle
 265     my $old_fh = select $self->{fh};
 266     my $old_af = $|; $| = 1; $| = $old_af;
 267     select $old_fh;
 268
 269     return 1;
 270 }
 271
 272 sub set_transaction_offset {
 273     my $self = shift;
 274     $self->{transaction_offset} = shift;
 275 }
 276
 277 sub audit {
 278     my $self = shift;
 279     my ($string) = @_;
 280
 281     if ( my $afh = $self->{audit_fh} ) {
 282         flock( $afh, LOCK_EX );
 283
 284         if ( $string =~ /^#/ ) {
 285             print( $afh "$string " . localtime(time) . "\n" );
 286         }
 287         else {
 288             print( $afh "$string # " . localtime(time) . "\n" );
 289         }
 290
 291         flock( $afh, LOCK_UN );
 292     }
 293
 294     if ( $self->{transaction_audit} ) {
 295         push @{$self->{transaction_audit}}, $string;
 296     }
 297
 298     return 1;
 299 }
 300
 301 sub begin_transaction {
 302     my $self = shift;
 303
 304     my $fh = $self->{fh};
 305
 306     $self->lock;
 307
 308     my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
 309     my ($next, @trans) = unpack( 'C C C C C C C C C C C C C C C C', $buffer );
 310
 311     $self->{transaction_id} = ++$next;
 312
 313     die if $trans[-1] != 0;
 314
 315     for ( my $i = 0; $i <= $#trans; $i++ ) {
 316         next if $trans[$i] != 0;
 317         $trans[$i] = $next;
 318         last;
 319     }
 320
 321     $self->print_at(
 322         $self->{transaction_offset},
 323         pack( 'C C C C C C C C C C C C C C C C', $next, @trans),
 324     );
 325
 326     $self->unlock;
 327
 328     $self->{transaction_audit} = [];
 329
 330     return $self->{transaction_id};
 331 }
 332
 333 sub end_transaction {
 334     my $self = shift;
 335
 336     my $fh = $self->{fh};
 337
 338     $self->lock;
 339
 340     my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
 341     my ($next, @trans) = unpack( 'C C C C C C C C C C C C C C C C', $buffer );
 342
 343     @trans = grep { $_ != $self->{transaction_id} } @trans;
 344
 345     $self->print_at(
 346         $self->{transaction_offset},
 347         pack( 'C C C C C C C C C C C C C C C C', $next, @trans),
 348     );
 349
 350     #XXX Need to free the space used by the current transaction
 351
 352     $self->unlock;
 353
 354     $self->{transaction_id} = 0;
 355     $self->{transaction_audit} = undef;
 356
 357 #    $self->{base_db_obj}->optimize;
 358 #    $self->{inode} = undef;
 359 #    $self->set_inode;
 360
 361     return 1;
 362 }
 363
 364 sub current_transactions {
 365     my $self = shift;
 366
 367     my $fh = $self->{fh};
 368
 369     $self->lock;
 370
 371     my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
 372     my ($next, @trans) = unpack( 'C C C C C C C C C C C C C C C C', $buffer );
 373
 374     $self->unlock;
 375
 376     return grep { $_ && $_ != $self->{transaction_id} } @trans;
 377 }
 378
 379 sub transaction_id { return $_[0]->{transaction_id} }
 380
 381 sub commit_transaction {
 382     my $self = shift;
 383
 384     my @audit = @{$self->{transaction_audit}};
 385
 386     $self->end_transaction;
 387
 388     {
 389         my $db = $self->{base_db_obj};
 390         for ( @audit ) {
 391             eval "$_;";
 392             warn "$_: $@\n" if $@;
 393         }
 394     }
 395
 396     return 1;
 397 }
 398
 399 1;
 400 __END__
 401