lib/DBM/Deep/Storage/File.pm

   1 package DBM::Deep::Storage::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 => 0;
  11
  12 use base 'DBM::Deep::Storage';
  13
  14 =head1 NAME
  15
  16 DBM::Deep::Storage::File
  17
  18 =head1 PURPOSE
  19
  20 This is an internal-use-only object for L<DBM::Deep>. It mediates the low-level
  21 interaction with the storage mechanism.
  22
  23 Currently, the only storage mechanism supported is the file system.
  24
  25 =head1 OVERVIEW
  26
  27 This class provides an abstraction to the storage mechanism so that the Engine
  28 (the only class that uses this class) doesn't have to worry about that.
  29
  30 =head1 METHODS
  31
  32 =head2 new( \%args )
  33
  34 =cut
  35
  36 sub new {
  37     my $class = shift;
  38     my ($args) = @_;
  39
  40     my $self = bless {
  41         autobless          => 1,
  42         autoflush          => 1,
  43         end                => 0,
  44         fh                 => undef,
  45         file               => undef,
  46         file_offset        => 0,
  47         locking            => 1,
  48         locked             => 0,
  49 #XXX Migrate this to the engine, where it really belongs.
  50         filter_store_key   => undef,
  51         filter_store_value => undef,
  52         filter_fetch_key   => undef,
  53         filter_fetch_value => undef,
  54     }, $class;
  55
  56     # Grab the parameters we want to use
  57     foreach my $param ( keys %$self ) {
  58         next unless exists $args->{$param};
  59         $self->{$param} = $args->{$param};
  60     }
  61
  62     if ( $self->{fh} && !$self->{file_offset} ) {
  63         $self->{file_offset} = tell( $self->{fh} );
  64     }
  65
  66     $self->open unless $self->{fh};
  67
  68     return $self;
  69 }
  70
  71 =head2 open()
  72
  73 This method opens the filehandle for the filename in C< file >.
  74
  75 There is no return value.
  76
  77 =cut
  78
  79 # TODO: What happens if we ->open when we already have a $fh?
  80 sub open {
  81     my $self = shift;
  82
  83     # Adding O_BINARY should remove the need for the binmode below. However,
  84     # I'm not going to remove it because I don't have the Win32 chops to be
  85     # absolutely certain everything will be ok.
  86     my $flags = O_CREAT | O_BINARY;
  87
  88     if ( !-e $self->{file} || -w _ ) {
  89       $flags |= O_RDWR;
  90     }
  91     else {
  92       $flags |= O_RDONLY;
  93     }
  94
  95     my $fh;
  96     sysopen( $fh, $self->{file}, $flags )
  97         or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n";
  98     $self->{fh} = $fh;
  99
 100     # Even though we use O_BINARY, better be safe than sorry.
 101     binmode $fh;
 102
 103     if ($self->{autoflush}) {
 104         my $old = select $fh;
 105         $|=1;
 106         select $old;
 107     }
 108
 109     return 1;
 110 }
 111
 112 =head2 close()
 113
 114 If the filehandle is opened, this will close it.
 115
 116 There is no return value.
 117
 118 =cut
 119
 120 sub close {
 121     my $self = shift;
 122
 123     if ( $self->{fh} ) {
 124         close $self->{fh};
 125         $self->{fh} = undef;
 126     }
 127
 128     return 1;
 129 }
 130
 131 =head2 size()
 132
 133 This will return the size of the DB. If file_offset is set, this will take that into account.
 134
 135 =cut
 136
 137 sub size {
 138     my $self = shift;
 139
 140     return 0 unless $self->{fh};
 141     return( (-s $self->{fh}) - $self->{file_offset} );
 142 }
 143
 144 =head2 set_inode()
 145
 146 This will set the inode value of the underlying file object.
 147
 148 This is only needed to handle some obscure Win32 bugs. It reqlly shouldn't be
 149 needed outside this object.
 150
 151 There is no return value.
 152
 153 =cut
 154
 155 sub set_inode {
 156     my $self = shift;
 157
 158     unless ( defined $self->{inode} ) {
 159         my @stats = stat($self->{fh});
 160         $self->{inode} = $stats[1];
 161         $self->{end} = $stats[7];
 162     }
 163
 164     return 1;
 165 }
 166
 167 =head2 print_at( $offset, @data )
 168
 169 This takes an optional offset and some data to print.
 170
 171 C< $offset >, if defined, will be used to seek into the file. If file_offset is
 172 set, it will be used as the zero location. If it is undefined, no seeking will
 173 occur. Then, C< @data > will be printed to the current location.
 174
 175 There is no return value.
 176
 177 =cut
 178
 179 sub print_at {
 180     my $self = shift;
 181     my $loc  = shift;
 182
 183     local ($,,$\);
 184
 185     my $fh = $self->{fh};
 186     if ( defined $loc ) {
 187         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
 188     }
 189
 190     if ( DEBUG ) {
 191         my $caller = join ':', (caller)[0,2];
 192         my $len = length( join '', @_ );
 193         warn "($caller) print_at( " . (defined $loc ? $loc : '<undef>') . ", $len )\n";
 194     }
 195
 196     print( $fh @_ ) or die "Internal Error (print_at($loc)): $!\n";
 197
 198     return 1;
 199 }
 200
 201 =head2 read_at( $offset, $length )
 202
 203 This takes an optional offset and a length.
 204
 205 C< $offset >, if defined, will be used to seek into the file. If file_offset is
 206 set, it will be used as the zero location. If it is undefined, no seeking will
 207 occur. Then, C< $length > bytes will be read from the current location.
 208
 209 The data read will be returned.
 210
 211 =cut
 212
 213 sub read_at {
 214     my $self = shift;
 215     my ($loc, $size) = @_;
 216
 217     my $fh = $self->{fh};
 218     if ( defined $loc ) {
 219         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
 220     }
 221
 222     if ( DEBUG ) {
 223         my $caller = join ':', (caller)[0,2];
 224         warn "($caller) read_at( " . (defined $loc ? $loc : '<undef>') . ", $size )\n";
 225     }
 226
 227     my $buffer;
 228     read( $fh, $buffer, $size);
 229
 230     return $buffer;
 231 }
 232
 233 =head2 DESTROY
 234
 235 When the ::Storage::File object goes out of scope, it will be closed.
 236
 237 =cut
 238
 239 sub DESTROY {
 240     my $self = shift;
 241     return unless $self;
 242
 243     $self->close;
 244
 245     return;
 246 }
 247
 248 =head2 request_space( $size )
 249
 250 This takes a size and adds that much space to the DBM.
 251
 252 This returns the offset for the new location.
 253
 254 =cut
 255
 256 sub request_space {
 257     my $self = shift;
 258     my ($size) = @_;
 259
 260     #XXX Do I need to reset $self->{end} here? I need a testcase
 261     my $loc = $self->{end};
 262     $self->{end} += $size;
 263
 264     return $loc;
 265 }
 266
 267 =head2 copy_stats( $target_filename )
 268
 269 This will take the stats for the current filehandle and apply them to
 270 C< $target_filename >. The stats copied are:
 271
 272 =over 4
 273
 274 =item * Onwer UID and GID
 275
 276 =item * Permissions
 277
 278 =back
 279
 280 =cut
 281
 282 sub copy_stats {
 283     my $self = shift;
 284     my ($temp_filename) = @_;
 285
 286     my @stats = stat( $self->{fh} );
 287     my $perms = $stats[2] & 07777;
 288     my $uid = $stats[4];
 289     my $gid = $stats[5];
 290     chown( $uid, $gid, $temp_filename );
 291     chmod( $perms, $temp_filename );
 292 }
 293
 294 sub flush {
 295     my $self = shift;
 296
 297     # Flush the filehandle
 298     my $old_fh = select $self->{fh};
 299     my $old_af = $|; $| = 1; $| = $old_af;
 300     select $old_fh;
 301
 302     return 1;
 303 }
 304
 305 sub is_writable {
 306     my $self = shift;
 307
 308     my $fh = $self->{fh};
 309     return unless defined $fh;
 310     return unless defined fileno $fh;
 311     local $\ = '';  # just in case
 312     no warnings;    # temporarily disable warnings
 313     local $^W;      # temporarily disable warnings
 314     return print $fh '';
 315 }
 316
 317 sub lock_exclusive {
 318     my $self = shift;
 319     my ($obj) = @_;
 320     return $self->_lock( $obj, LOCK_EX );
 321 }
 322
 323 sub lock_shared {
 324     my $self = shift;
 325     my ($obj) = @_;
 326     return $self->_lock( $obj, LOCK_SH );
 327 }
 328
 329 sub _lock {
 330     my $self = shift;
 331     my ($obj, $type) = @_;
 332
 333     $type = LOCK_EX unless defined $type;
 334
 335     #XXX This is a temporary fix for Win32 and autovivification. It
 336     # needs to improve somehow. -RobK, 2008-03-09
 337     if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
 338         $type = LOCK_EX;
 339     }
 340
 341     if (!defined($self->{fh})) { return; }
 342
 343     #XXX This either needs to allow for upgrading a shared lock to an
 344     # exclusive lock or something else with autovivification.
 345     # -RobK, 2008-03-09
 346     if ($self->{locking}) {
 347         if (!$self->{locked}) {
 348             flock($self->{fh}, $type);
 349
 350             # refresh end counter in case file has changed size
 351             my @stats = stat($self->{fh});
 352             $self->{end} = $stats[7];
 353
 354             # double-check file inode, in case another process
 355             # has optimize()d our file while we were waiting.
 356             if (defined($self->{inode}) && $stats[1] != $self->{inode}) {
 357                 $self->close;
 358                 $self->open;
 359
 360                 #XXX This needs work
 361                 $obj->{engine}->setup( $obj );
 362
 363                 flock($self->{fh}, $type); # re-lock
 364
 365                 # This may not be necessary after re-opening
 366                 $self->{end} = (stat($self->{fh}))[7]; # re-end
 367             }
 368         }
 369         $self->{locked}++;
 370
 371         return 1;
 372     }
 373
 374     return;
 375 }
 376
 377 sub unlock {
 378     my $self = shift;
 379
 380     if (!defined($self->{fh})) { return; }
 381
 382     if ($self->{locking} && $self->{locked} > 0) {
 383         $self->{locked}--;
 384
 385         if (!$self->{locked}) {
 386             flock($self->{fh}, LOCK_UN);
 387             return 1;
 388         }
 389
 390         return;
 391     }
 392
 393     return;
 394 }
 395
 396 1;
 397 __END__