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