lib/DBM/Deep/File.pm

   1 package DBM::Deep::File;
   2
   3 use 5.006_000;
   4
   5 use strict;
   6 use warnings FATAL => 'all';
   7
   8 use Fcntl qw( :DEFAULT :flock :seek );
   9
  10 use constant DEBUG => 1;
  11
  12 sub new {
  13     my $class = shift;
  14     my ($args) = @_;
  15
  16     my $self = bless {
  17         autobless          => 1,
  18         autoflush          => 1,
  19         end                => 0,
  20         fh                 => undef,
  21         file               => undef,
  22         file_offset        => 0,
  23         locking            => 1,
  24         locked             => 0,
  25 #XXX Migrate this to the engine, where it really belongs.
  26         filter_store_key   => undef,
  27         filter_store_value => undef,
  28         filter_fetch_key   => undef,
  29         filter_fetch_value => undef,
  30     }, $class;
  31
  32     # Grab the parameters we want to use
  33     foreach my $param ( keys %$self ) {
  34         next unless exists $args->{$param};
  35         $self->{$param} = $args->{$param};
  36     }
  37
  38     if ( $self->{fh} && !$self->{file_offset} ) {
  39         $self->{file_offset} = tell( $self->{fh} );
  40     }
  41
  42     $self->open unless $self->{fh};
  43
  44     return $self;
  45 }
  46
  47 sub open {
  48     my $self = shift;
  49
  50     # Adding O_BINARY should remove the need for the binmode below. However,
  51     # I'm not going to remove it because I don't have the Win32 chops to be
  52     # absolutely certain everything will be ok.
  53     my $flags = O_CREAT | O_BINARY;
  54
  55     if ( !-e $self->{file} || -w _ ) {
  56       $flags |= O_RDWR;
  57     }
  58     else {
  59       $flags |= O_RDONLY;
  60     }
  61
  62     my $fh;
  63     sysopen( $fh, $self->{file}, $flags )
  64         or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n";
  65     $self->{fh} = $fh;
  66
  67     # Even though we use O_BINARY, better be safe than sorry.
  68     binmode $fh;
  69
  70     if ($self->{autoflush}) {
  71         my $old = select $fh;
  72         $|=1;
  73         select $old;
  74     }
  75
  76     return 1;
  77 }
  78
  79 sub close {
  80     my $self = shift;
  81
  82     if ( $self->{fh} ) {
  83         close $self->{fh};
  84         $self->{fh} = undef;
  85     }
  86
  87     return 1;
  88 }
  89
  90 sub size {
  91     my $self = shift;
  92
  93     return 0 unless $self->{fh};
  94     return -s $self->{fh};
  95 }
  96
  97 sub set_inode {
  98     my $self = shift;
  99
 100     unless ( defined $self->{inode} ) {
 101         my @stats = stat($self->{fh});
 102         $self->{inode} = $stats[1];
 103         $self->{end} = $stats[7];
 104     }
 105
 106     return 1;
 107 }
 108
 109 sub print_at {
 110     my $self = shift;
 111     my $loc  = shift;
 112
 113     warn "print_at called\n";
 114     local ($/,$\);
 115
 116     my $fh = $self->{fh};
 117     if ( defined $loc ) {
 118         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
 119     }
 120
 121     if ( DEBUG ) {
 122         my $caller = join ':', (caller)[0,2];
 123         my $len = length( join '', @_ );
 124         warn "($caller) print_at( " . (defined $loc ? $loc : '<undef>') . ", $len )\n";
 125     }
 126
 127     print( $fh @_ ) or die "Internal Error (print_at($loc)): $!\n";
 128
 129     return 1;
 130 }
 131
 132 sub read_at {
 133     my $self = shift;
 134     my ($loc, $size) = @_;
 135
 136     local ($/,$\);
 137
 138     my $fh = $self->{fh};
 139     if ( defined $loc ) {
 140         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
 141     }
 142
 143     if ( DEBUG ) {
 144         my $caller = join ':', (caller)[0,2];
 145         warn "($caller) read_at( " . (defined $loc ? $loc : '<undef>') . ", $size )\n";
 146     }
 147
 148     my $buffer;
 149     read( $fh, $buffer, $size);
 150
 151     return $buffer;
 152 }
 153
 154 sub DESTROY {
 155     my $self = shift;
 156     return unless $self;
 157
 158     $self->close;
 159
 160     return;
 161 }
 162
 163 sub request_space {
 164     my $self = shift;
 165     my ($size) = @_;
 166
 167     #XXX Do I need to reset $self->{end} here? I need a testcase
 168     my $loc = $self->{end};
 169     $self->{end} += $size;
 170
 171     return $loc;
 172 }
 173
 174 ##
 175 # If db locking is set, flock() the db file.  If called multiple
 176 # times before unlock(), then the same number of unlocks() must
 177 # be called before the lock is released.
 178 ##
 179 sub lock_exclusive {
 180     my $self = shift;
 181     my ($obj) = @_;
 182     return $self->lock( $obj, LOCK_EX );
 183 }
 184
 185 sub lock_shared {
 186     my $self = shift;
 187     my ($obj) = @_;
 188     return $self->lock( $obj, LOCK_SH );
 189 }
 190
 191 sub lock {
 192     my $self = shift;
 193     my ($obj, $type) = @_;
 194
 195     $type = LOCK_EX unless defined $type;
 196
 197     #XXX This is a temporary fix for Win32 and autovivification. It
 198     # needs to improve somehow. -RobK, 2008-03-09
 199     if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
 200         $type = LOCK_EX;
 201     }
 202
 203     if (!defined($self->{fh})) { return; }
 204
 205     #XXX This either needs to allow for upgrading a shared lock to an
 206     # exclusive lock or something else with autovivification.
 207     # -RobK, 2008-03-09
 208     if ($self->{locking}) {
 209         if (!$self->{locked}) {
 210             flock($self->{fh}, $type);
 211
 212             # refresh end counter in case file has changed size
 213             my @stats = stat($self->{fh});
 214             $self->{end} = $stats[7];
 215
 216             # double-check file inode, in case another process
 217             # has optimize()d our file while we were waiting.
 218             if (defined($self->{inode}) && $stats[1] != $self->{inode}) {
 219                 $self->close;
 220                 $self->open;
 221
 222                 #XXX This needs work
 223                 $obj->{engine}->setup_fh( $obj );
 224
 225                 flock($self->{fh}, $type); # re-lock
 226
 227                 # This may not be necessary after re-opening
 228                 $self->{end} = (stat($self->{fh}))[7]; # re-end
 229             }
 230         }
 231         $self->{locked}++;
 232
 233         return 1;
 234     }
 235
 236     return;
 237 }
 238
 239 ##
 240 # If db locking is set, unlock the db file.  See note in lock()
 241 # regarding calling lock() multiple times.
 242 ##
 243 sub unlock {
 244     my $self = shift;
 245
 246     if (!defined($self->{fh})) { return; }
 247
 248     if ($self->{locking} && $self->{locked} > 0) {
 249         $self->{locked}--;
 250
 251         if (!$self->{locked}) {
 252             flock($self->{fh}, LOCK_UN);
 253             return 1;
 254         }
 255
 256         return;
 257     }
 258
 259     return;
 260 }
 261
 262 sub flush {
 263     my $self = shift;
 264
 265     # Flush the filehandle
 266     my $old_fh = select $self->{fh};
 267     my $old_af = $|; $| = 1; $| = $old_af;
 268     select $old_fh;
 269
 270     return 1;
 271 }
 272
 273 # Taken from http://www.perlmonks.org/?node_id=691054
 274 sub is_writable {
 275     my $self = shift;
 276
 277     my $fh = $self->{fh};
 278     return unless defined $fh;
 279     return unless defined fileno $fh;
 280     local $\ = '';  # just in case
 281     no warnings;    # temporarily disable warnings
 282     local $^W;      # temporarily disable warnings
 283     return print $fh '';
 284 }
 285
 286 sub copy_stats {
 287     my $self = shift;
 288     my ($temp_filename) = @_;
 289
 290     my @stats = stat( $self->{fh} );
 291     my $perms = $stats[2] & 07777;
 292     my $uid = $stats[4];
 293     my $gid = $stats[5];
 294     chown( $uid, $gid, $temp_filename );
 295     chmod( $perms, $temp_filename );
 296 }
 297
 298 1;
 299 __END__