lib/DBM/Deep/File.pm

   1 package DBM::Deep::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::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 (the
  26 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 needed outside
 146 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 set, it will be used
 169 as the zero location. If it is undefined, no seeking will occur. Then, C< @data > will be printed to
 170 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 set, it will be used
 203 as the zero location. If it is undefined, no seeking will occur. Then, C< $length > bytes will be
 204 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     my $fh = $self->{fh};
 215     if ( defined $loc ) {
 216         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
 217     }
 218
 219     if ( DEBUG ) {
 220         my $caller = join ':', (caller)[0,2];
 221         warn "($caller) read_at( " . (defined $loc ? $loc : '<undef>') . ", $size )\n";
 222     }
 223
 224     my $buffer;
 225     read( $fh, $buffer, $size);
 226
 227     return $buffer;
 228 }
 229
 230 =head2 DESTROY
 231
 232 When the ::File object goes out of scope, it will be closed.
 233
 234 =cut
 235
 236 sub DESTROY {
 237     my $self = shift;
 238     return unless $self;
 239
 240     $self->close;
 241
 242     return;
 243 }
 244
 245 =head2 request_space( $size )
 246
 247 This takes a size and adds that much space to the DBM.
 248
 249 This returns the offset for the new location.
 250
 251 =cut
 252
 253 sub request_space {
 254     my $self = shift;
 255     my ($size) = @_;
 256
 257     #XXX Do I need to reset $self->{end} here? I need a testcase
 258     my $loc = $self->{end};
 259     $self->{end} += $size;
 260
 261     return $loc;
 262 }
 263
 264 =head2 flush()
 265
 266 This flushes the filehandle. This takes no parameters and returns nothing.
 267
 268 =cut
 269
 270 sub flush {
 271     my $self = shift;
 272
 273     # Flush the filehandle
 274     my $old_fh = select $self->{fh};
 275     my $old_af = $|; $| = 1; $| = $old_af;
 276     select $old_fh;
 277
 278     return 1;
 279 }
 280
 281 =head2 is_writable()
 282
 283 This takes no parameters. It returns a boolean saying if this filehandle is
 284 writable.
 285
 286 Taken from L<http://www.perlmonks.org/?node_id=691054/>.
 287
 288 =cut
 289
 290 sub is_writable {
 291     my $self = shift;
 292
 293     my $fh = $self->{fh};
 294     return unless defined $fh;
 295     return unless defined fileno $fh;
 296     local $\ = '';  # just in case
 297     no warnings;    # temporarily disable warnings
 298     local $^W;      # temporarily disable warnings
 299     return print $fh '';
 300 }
 301
 302 =head2 copy_stats( $target_filename )
 303
 304 This will take the stats for the current filehandle and apply them to
 305 C< $target_filename >. The stats copied are:
 306
 307 =over 4
 308
 309 =item * Onwer UID and GID
 310
 311 =item * Permissions
 312
 313 =back
 314
 315 =cut
 316
 317 sub copy_stats {
 318     my $self = shift;
 319     my ($temp_filename) = @_;
 320
 321     my @stats = stat( $self->{fh} );
 322     my $perms = $stats[2] & 07777;
 323     my $uid = $stats[4];
 324     my $gid = $stats[5];
 325     chown( $uid, $gid, $temp_filename );
 326     chmod( $perms, $temp_filename );
 327 }
 328
 329 =head1 LOCKING
 330
 331 This is where the actual locking of the storage medium is performed.
 332 Nested locking is supported.
 333
 334 B<NOTE>: It is unclear what will happen if a read lock is taken, then
 335 a write lock is taken as a nested lock, then the write lock is released.
 336
 337 Currently, the only locking method supported is flock(1). This is a
 338 whole-file lock. In the future, more granular locking may be supported.
 339 The API for that is unclear right now.
 340
 341 The following methods manage the locking status. In all cases, they take
 342 a L<DBM::Deep/> object and returns nothing.
 343
 344 =over 4
 345
 346 =item * lock_exclusive( $obj )
 347
 348 Take a lock usable for writing.
 349
 350 =item * lock_shared( $obj )
 351
 352 Take a lock usable for reading.
 353
 354 =item * unlock( $obj )
 355
 356 Releases the last lock taken. If this is the outermost lock, then the
 357 object is actually unlocked.
 358
 359 =back
 360
 361 =cut
 362
 363 sub lock_exclusive {
 364     my $self = shift;
 365     my ($obj) = @_;
 366     return $self->_lock( $obj, LOCK_EX );
 367 }
 368
 369 sub lock_shared {
 370     my $self = shift;
 371     my ($obj) = @_;
 372     return $self->_lock( $obj, LOCK_SH );
 373 }
 374
 375 sub _lock {
 376     my $self = shift;
 377     my ($obj, $type) = @_;
 378
 379     $type = LOCK_EX unless defined $type;
 380
 381     #XXX This is a temporary fix for Win32 and autovivification. It
 382     # needs to improve somehow. -RobK, 2008-03-09
 383     if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
 384         $type = LOCK_EX;
 385     }
 386
 387     if (!defined($self->{fh})) { return; }
 388
 389     #XXX This either needs to allow for upgrading a shared lock to an
 390     # exclusive lock or something else with autovivification.
 391     # -RobK, 2008-03-09
 392     if ($self->{locking}) {
 393         if (!$self->{locked}) {
 394             flock($self->{fh}, $type);
 395
 396             # refresh end counter in case file has changed size
 397             my @stats = stat($self->{fh});
 398             $self->{end} = $stats[7];
 399
 400             # double-check file inode, in case another process
 401             # has optimize()d our file while we were waiting.
 402             if (defined($self->{inode}) && $stats[1] != $self->{inode}) {
 403                 $self->close;
 404                 $self->open;
 405
 406                 #XXX This needs work
 407                 $obj->{engine}->setup_fh( $obj );
 408
 409                 flock($self->{fh}, $type); # re-lock
 410
 411                 # This may not be necessary after re-opening
 412                 $self->{end} = (stat($self->{fh}))[7]; # re-end
 413             }
 414         }
 415         $self->{locked}++;
 416
 417         return 1;
 418     }
 419
 420     return;
 421 }
 422
 423 sub unlock {
 424     my $self = shift;
 425
 426     if (!defined($self->{fh})) { return; }
 427
 428     if ($self->{locking} && $self->{locked} > 0) {
 429         $self->{locked}--;
 430
 431         if (!$self->{locked}) {
 432             flock($self->{fh}, LOCK_UN);
 433             return 1;
 434         }
 435
 436         return;
 437     }
 438
 439     return;
 440 }
 441
 442 1;
 443 __END__