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     local ($/,$\);
 218
 219     my $fh = $self->{fh};
 220     if ( defined $loc ) {
 221         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
 222     }
 223
 224     if ( DEBUG ) {
 225         my $caller = join ':', (caller)[0,2];
 226         warn "($caller) read_at( " . (defined $loc ? $loc : '<undef>') . ", $size )\n";
 227     }
 228
 229     my $buffer;
 230     read( $fh, $buffer, $size);
 231
 232     return $buffer;
 233 }
 234
 235 =head2 DESTROY
 236
 237 When the ::Storage::File object goes out of scope, it will be closed.
 238
 239 =cut
 240
 241 sub DESTROY {
 242     my $self = shift;
 243     return unless $self;
 244
 245     $self->close;
 246
 247     return;
 248 }
 249
 250 =head2 request_space( $size )
 251
 252 This takes a size and adds that much space to the DBM.
 253
 254 This returns the offset for the new location.
 255
 256 =cut
 257
 258 sub request_space {
 259     my $self = shift;
 260     my ($size) = @_;
 261
 262     #XXX Do I need to reset $self->{end} here? I need a testcase
 263     my $loc = $self->{end};
 264     $self->{end} += $size;
 265
 266     return $loc;
 267 }
 268
 269 =head2 copy_stats( $target_filename )
 270
 271 This will take the stats for the current filehandle and apply them to
 272 C< $target_filename >. The stats copied are:
 273
 274 =over 4
 275
 276 =item * Onwer UID and GID
 277
 278 =item * Permissions
 279
 280 =back
 281
 282 =cut
 283
 284 sub copy_stats {
 285     my $self = shift;
 286     my ($temp_filename) = @_;
 287
 288     my @stats = stat( $self->{fh} );
 289     my $perms = $stats[2] & 07777;
 290     my $uid = $stats[4];
 291     my $gid = $stats[5];
 292     chown( $uid, $gid, $temp_filename );
 293     chmod( $perms, $temp_filename );
 294 }
 295
 296 sub flush {
 297     my $self = shift;
 298
 299     # Flush the filehandle
 300     my $old_fh = select $self->{fh};
 301     my $old_af = $|; $| = 1; $| = $old_af;
 302     select $old_fh;
 303
 304     return 1;
 305 }
 306
 307 sub is_writable {
 308     my $self = shift;
 309
 310     my $fh = $self->{fh};
 311     return unless defined $fh;
 312     return unless defined fileno $fh;
 313     local $\ = '';  # just in case
 314     no warnings;    # temporarily disable warnings
 315     local $^W;      # temporarily disable warnings
 316     return print $fh '';
 317 }
 318
 319 sub lock_exclusive {
 320     my $self = shift;
 321     my ($obj) = @_;
 322     return $self->_lock( $obj, LOCK_EX );
 323 }
 324
 325 sub lock_shared {
 326     my $self = shift;
 327     my ($obj) = @_;
 328     return $self->_lock( $obj, LOCK_SH );
 329 }
 330
 331 sub _lock {
 332     my $self = shift;
 333     my ($obj, $type) = @_;
 334
 335     $type = LOCK_EX unless defined $type;
 336
 337     #XXX This is a temporary fix for Win32 and autovivification. It
 338     # needs to improve somehow. -RobK, 2008-03-09
 339     if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
 340         $type = LOCK_EX;
 341     }
 342
 343     if (!defined($self->{fh})) { return; }
 344
 345     #XXX This either needs to allow for upgrading a shared lock to an
 346     # exclusive lock or something else with autovivification.
 347     # -RobK, 2008-03-09
 348     if ($self->{locking}) {
 349         if (!$self->{locked}) {
 350             flock($self->{fh}, $type);
 351
 352             # refresh end counter in case file has changed size
 353             my @stats = stat($self->{fh});
 354             $self->{end} = $stats[7];
 355
 356             # double-check file inode, in case another process
 357             # has optimize()d our file while we were waiting.
 358             if (defined($self->{inode}) && $stats[1] != $self->{inode}) {
 359                 $self->close;
 360                 $self->open;
 361
 362                 #XXX This needs work
 363                 $obj->{engine}->setup( $obj );
 364
 365                 flock($self->{fh}, $type); # re-lock
 366
 367                 # This may not be necessary after re-opening
 368                 $self->{end} = (stat($self->{fh}))[7]; # re-end
 369             }
 370         }
 371         $self->{locked}++;
 372
 373         return 1;
 374     }
 375
 376     return;
 377 }
 378
 379 sub unlock {
 380     my $self = shift;
 381
 382     if (!defined($self->{fh})) { return; }
 383
 384     if ($self->{locking} && $self->{locked} > 0) {
 385         $self->{locked}--;
 386
 387         if (!$self->{locked}) {
 388             flock($self->{fh}, LOCK_UN);
 389             return 1;
 390         }
 391
 392         return;
 393     }
 394
 395     return;
 396 }
 397
 398 1;
 399 __END__