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