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         autobless          => 1,
  18         autoflush          => undef,
  19         end                => 0,
  20         fh                 => undef,
  21         file               => undef,
  22         file_offset        => 0,
  23         locking            => undef,
  24         locked             => 0,
  25         filter_store_key   => undef,
  26         filter_store_value => undef,
  27         filter_fetch_key   => undef,
  28         filter_fetch_value => undef,
  29     }, $class;
  30
  31     # Grab the parameters we want to use
  32     foreach my $param ( keys %$self ) {
  33         next unless exists $args->{$param};
  34         $self->{$param} = $args->{$param};
  35     }
  36
  37     if ( $self->{fh} && !$self->{file_offset} ) {
  38         $self->{file_offset} = tell( $self->{fh} );
  39     }
  40
  41     $self->open unless $self->{fh};
  42
  43     return $self;
  44 }
  45
  46 sub open {
  47     my $self = shift;
  48
  49     # Adding O_BINARY should remove the need for the binmode below. However,
  50     # I'm not going to remove it because I don't have the Win32 chops to be
  51     # absolutely certain everything will be ok.
  52     my $flags = O_RDWR | O_CREAT | O_BINARY;
  53
  54     my $fh;
  55     sysopen( $fh, $self->{file}, $flags )
  56         or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n";
  57     $self->{fh} = $fh;
  58
  59     # Even though we use O_BINARY, better be safe than sorry.
  60     binmode $fh;
  61
  62     if ($self->{autoflush}) {
  63         my $old = select $fh;
  64         $|=1;
  65         select $old;
  66     }
  67
  68     return 1;
  69 }
  70
  71 sub close {
  72     my $self = shift;
  73
  74     if ( $self->{fh} ) {
  75         close $self->{fh};
  76         $self->{fh} = undef;
  77     }
  78
  79     return 1;
  80 }
  81
  82 sub set_inode {
  83     my $self = shift;
  84
  85     unless ( defined $self->{inode} ) {
  86         my @stats = stat($self->{fh});
  87         $self->{inode} = $stats[1];
  88         $self->{end} = $stats[7];
  89     }
  90
  91     return 1;
  92 }
  93
  94 sub print_at {
  95     my $self = shift;
  96     my $loc  = shift;
  97
  98     local ($/,$\);
  99
 100     my $fh = $self->{fh};
 101     if ( defined $loc ) {
 102         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
 103     }
 104
 105     print( $fh @_ );
 106
 107     return 1;
 108 }
 109
 110 sub read_at {
 111     my $self = shift;
 112     my ($loc, $size) = @_;
 113     print join(":",map{$_||''}caller) . " - read_at(@{[$loc || 'undef']}, $size)\n" if $::DEBUG;
 114
 115     local ($/,$\);
 116
 117     my $fh = $self->{fh};
 118     if ( defined $loc ) {
 119         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
 120     }
 121
 122     my $buffer;
 123     read( $fh, $buffer, $size);
 124
 125     return $buffer;
 126 }
 127
 128 sub DESTROY {
 129     my $self = shift;
 130     return unless $self;
 131
 132     $self->close;
 133
 134     return;
 135 }
 136
 137 sub request_space {
 138     my $self = shift;
 139     my ($size) = @_;
 140
 141     #XXX Do I need to reset $self->{end} here? I need a testcase
 142     my $loc = $self->{end};
 143     $self->{end} += $size;
 144
 145     return $loc;
 146 }
 147
 148 ##
 149 # If db locking is set, flock() the db file.  If called multiple
 150 # times before unlock(), then the same number of unlocks() must
 151 # be called before the lock is released.
 152 ##
 153 sub lock {
 154     my $self = shift;
 155     my ($obj, $type) = @_;
 156
 157     $type = LOCK_EX unless defined $type;
 158
 159     if (!defined($self->{fh})) { return; }
 160
 161     if ($self->{locking}) {
 162         if (!$self->{locked}) {
 163             flock($self->{fh}, $type);
 164
 165             # refresh end counter in case file has changed size
 166             my @stats = stat($self->{fh});
 167             $self->{end} = $stats[7];
 168
 169             # double-check file inode, in case another process
 170             # has optimize()d our file while we were waiting.
 171             if (defined($self->{inode}) && $stats[1] != $self->{inode}) {
 172                 $self->close;
 173                 $self->open;
 174
 175                 #XXX This needs work
 176                 $obj->{engine}->setup_fh( $obj );
 177
 178                 flock($self->{fh}, $type); # re-lock
 179
 180                 # This may not be necessary after re-opening
 181                 $self->{end} = (stat($self->{fh}))[7]; # re-end
 182             }
 183         }
 184         $self->{locked}++;
 185
 186         return 1;
 187     }
 188
 189     return;
 190 }
 191
 192 ##
 193 # If db locking is set, unlock the db file.  See note in lock()
 194 # regarding calling lock() multiple times.
 195 ##
 196 sub unlock {
 197     my $self = shift;
 198
 199     if (!defined($self->{fh})) { return; }
 200
 201     if ($self->{locking} && $self->{locked} > 0) {
 202         $self->{locked}--;
 203         if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); }
 204
 205         return 1;
 206     }
 207
 208     return;
 209 }
 210
 211 sub flush {
 212     my $self = shift;
 213
 214     # Flush the filehandle
 215     my $old_fh = select $self->{fh};
 216     my $old_af = $|; $| = 1; $| = $old_af;
 217     select $old_fh;
 218
 219     return 1;
 220 }
 221
 222 1;
 223 __END__