lib/DBM/Deep/File.pm

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