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