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 B<NOTE>: This function isn't used internally anywhere.
 136
 137 =cut
 138
 139 sub size {
 140     my $self = shift;
 141
 142     return 0 unless $self->{fh};
 143     return( (-s $self->{fh}) - $self->{file_offset} );
 144 }
 145
 146 =head2 set_inode()
 147
 148 This will set the inode value of the underlying file object.
 149
 150 This is only needed to handle some obscure Win32 bugs. It reqlly shouldn't be
 151 needed outside this object.
 152
 153 There is no return value.
 154
 155 =cut
 156
 157 sub set_inode {
 158     my $self = shift;
 159
 160     unless ( defined $self->{inode} ) {
 161         my @stats = stat($self->{fh});
 162         $self->{inode} = $stats[1];
 163         $self->{end} = $stats[7];
 164     }
 165
 166     return 1;
 167 }
 168
 169 =head2 print_at( $offset, @data )
 170
 171 This takes an optional offset and some data to print.
 172
 173 C< $offset >, if defined, will be used to seek into the file. If file_offset is
 174 set, it will be used as the zero location. If it is undefined, no seeking will
 175 occur. Then, C< @data > will be printed to the current location.
 176
 177 There is no return value.
 178
 179 =cut
 180
 181 sub print_at {
 182     my $self = shift;
 183     my $loc  = shift;
 184
 185     local ($,,$\);
 186
 187     my $fh = $self->{fh};
 188     if ( defined $loc ) {
 189         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
 190     }
 191
 192     if ( DEBUG ) {
 193         my $caller = join ':', (caller)[0,2];
 194         my $len = length( join '', @_ );
 195         warn "($caller) print_at( " . (defined $loc ? $loc : '<undef>') . ", $len )\n";
 196     }
 197
 198     print( $fh @_ ) or die "Internal Error (print_at($loc)): $!\n";
 199
 200     return 1;
 201 }
 202
 203 =head2 read_at( $offset, $length )
 204
 205 This takes an optional offset and a length.
 206
 207 C< $offset >, if defined, will be used to seek into the file. If file_offset is
 208 set, it will be used as the zero location. If it is undefined, no seeking will
 209 occur. Then, C< $length > bytes will be read from the current location.
 210
 211 The data read will be returned.
 212
 213 =cut
 214
 215 sub read_at {
 216     my $self = shift;
 217     my ($loc, $size) = @_;
 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__