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 print_at {
 114     my $self = shift;
 115     my $loc  = shift;
 116
 117     local ($/,$\);
 118
 119     my $fh = $self->{fh};
 120     seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
 121     print( $fh @_ );
 122
 123     return 1;
 124 }
 125
 126 sub DESTROY {
 127     my $self = shift;
 128     return unless $self;
 129
 130     $self->close;
 131
 132     return;
 133 }
 134
 135 sub request_space {
 136     my $self = shift;
 137     my ($size) = @_;
 138
 139     my $loc = $self->{end};
 140     $self->{end} += $size;
 141
 142     return $loc;
 143 }
 144
 145 #sub release_space {
 146 #    my $self = shift;
 147 #    my ($size, $loc) = @_;
 148 #
 149 #    local($/,$\);
 150 #
 151 #    my $next_loc = 0;
 152 #
 153 #    my $fh = $self->{fh};
 154 #    seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
 155 #    print( $fh SIG_FREE
 156 #        . pack($self->{long_pack}, $size )
 157 #        . pack($self->{long_pack}, $next_loc )
 158 #    );
 159 #
 160 #    return;
 161 #}
 162
 163 ##
 164 # If db locking is set, flock() the db file.  If called multiple
 165 # times before unlock(), then the same number of unlocks() must
 166 # be called before the lock is released.
 167 ##
 168 sub lock {
 169     my $self = shift;
 170     my ($obj, $type) = @_;
 171     $type = LOCK_EX unless defined $type;
 172
 173     if (!defined($self->{fh})) { return; }
 174
 175     if ($self->{locking}) {
 176         if (!$self->{locked}) {
 177             flock($self->{fh}, $type);
 178
 179             # refresh end counter in case file has changed size
 180             my @stats = stat($self->{fh});
 181             $self->{end} = $stats[7];
 182
 183             # double-check file inode, in case another process
 184             # has optimize()d our file while we were waiting.
 185             if ($stats[1] != $self->{inode}) {
 186                 $self->close;
 187                 $self->open;
 188
 189                 #XXX This needs work
 190                 $obj->{engine}->setup_fh( $obj );
 191
 192                 flock($self->{fh}, $type); # re-lock
 193
 194                 # This may not be necessary after re-opening
 195                 $self->{end} = (stat($self->{fh}))[7]; # re-end
 196             }
 197         }
 198         $self->{locked}++;
 199
 200         return 1;
 201     }
 202
 203     return;
 204 }
 205
 206 ##
 207 # If db locking is set, unlock the db file.  See note in lock()
 208 # regarding calling lock() multiple times.
 209 ##
 210 sub unlock {
 211     my $self = shift;
 212
 213     if (!defined($self->{fh})) { return; }
 214
 215     if ($self->{locking} && $self->{locked} > 0) {
 216         $self->{locked}--;
 217         if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); }
 218
 219         return 1;
 220     }
 221
 222     return;
 223 }
 224
 225 sub set_transaction_offset {
 226     my $self = shift;
 227     $self->{transaction_offset} = shift;
 228 }
 229
 230 sub audit {
 231     my $self = shift;
 232
 233     if ( my $afh = $self->{audit_fh} ) {
 234         my ($string) = @_;
 235
 236         flock( $afh, LOCK_EX );
 237
 238         if ( $string =~ /^#/ ) {
 239             print( $afh "$string " . localtime(time) . "\n" );
 240         }
 241         else {
 242             print( $afh "$string # " . localtime(time) . "\n" );
 243         }
 244
 245         flock( $afh, LOCK_UN );
 246     }
 247
 248     return 1;
 249 }
 250
 251 sub begin_transaction {
 252     my $self = shift;
 253
 254     my $fh = $self->{fh};
 255
 256     $self->lock;
 257
 258     seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
 259     my $buffer;
 260     read( $fh, $buffer, 4 );
 261     $buffer = unpack( 'N', $buffer );
 262
 263     for ( 1 .. 32 ) {
 264         next if $buffer & (1 << ($_ - 1));
 265         $self->{transaction_id} = $_;
 266         $buffer |= (1 << $_-1 );
 267         last;
 268     }
 269
 270     seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
 271     print( $fh pack( 'N', $buffer ) );
 272
 273     $self->unlock;
 274
 275     return $self->{transaction_id};
 276 }
 277
 278 sub end_transaction {
 279     my $self = shift;
 280
 281     my $fh = $self->{fh};
 282
 283     $self->lock;
 284
 285     seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
 286     my $buffer;
 287     read( $fh, $buffer, 4 );
 288     $buffer = unpack( 'N', $buffer );
 289
 290     # Unset $self->{transaction_id} bit
 291
 292     seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
 293     print( $fh pack( 'N', $buffer ) );
 294
 295     $self->unlock;
 296
 297     $self->{transaction_id} = 0;
 298 }
 299
 300 sub current_transactions {
 301     my $self = shift;
 302
 303     my $fh = $self->{fh};
 304
 305     $self->lock;
 306
 307     seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
 308     my $buffer;
 309     read( $fh, $buffer, 4 );
 310     $buffer = unpack( 'N', $buffer );
 311
 312     $self->unlock;
 313
 314     my @transactions;
 315     for ( 1 .. 32 ) {
 316         if ( $buffer & (1 << ($_ - 1)) ) {
 317             push @transactions, $_;
 318         }
 319     }
 320
 321     return grep { $_ != $self->{transaction_id} } @transactions;
 322 }
 323
 324 sub transaction_id { return $_[0]->{transaction_id} }
 325
 326 #sub commit {
 327 #}
 328
 329 1;
 330 __END__
 331