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