package DBM::Deep::File;
-use 5.6.0;
+use 5.006_000;
use strict;
-use warnings;
+use warnings FATAL => 'all';
use Fcntl qw( :DEFAULT :flock :seek );
-our $VERSION = '0.01';
+use constant DEBUG => 0;
+
+=head1 NAME
+
+DBM::Deep::File
+
+=head1 PURPOSE
+
+This is an internal-use-only object for L<DBM::Deep/>. It mediates the low-level
+interaction with the storage mechanism.
+
+Currently, the only storage mechanism supported is the file system.
+
+=head1 OVERVIEW
+
+This class provides an abstraction to the storage mechanism so that the Engine (the
+only class that uses this class) doesn't have to worry about that.
+
+=head1 METHODS
+
+=head2 new( \%args )
+
+=cut
sub new {
my $class = shift;
my ($args) = @_;
my $self = bless {
- audit_fh => undef,
- audit_file => undef,
autobless => 1,
- autoflush => undef,
+ autoflush => 1,
end => 0,
fh => undef,
file => undef,
file_offset => 0,
- locking => undef,
+ locking => 1,
locked => 0,
+#XXX Migrate this to the engine, where it really belongs.
filter_store_key => undef,
filter_store_value => undef,
filter_fetch_key => undef,
filter_fetch_value => undef,
-
- # These are values that are not expected to be passed in through
- # $args. They are here for documentation purposes.
- transaction_id => 0,
- transaction_offset => 0,
- transaction_audit => undef,
- base_db_obj => undef,
}, $class;
# Grab the parameters we want to use
$self->open unless $self->{fh};
- if ( $self->{audit_file} && !$self->{audit_fh} ) {
- my $flags = O_WRONLY | O_APPEND | O_CREAT;
-
- my $fh;
- sysopen( $fh, $self->{audit_file}, $flags )
- or die "Cannot open audit file '$self->{audit_file}' for read/write: $!";
-
- # Set the audit_fh to autoflush
- my $old = select $fh;
- $|=1;
- select $old;
-
- $self->{audit_fh} = $fh;
- }
-
-
return $self;
}
-sub set_db {
- my $self = shift;
+=head2 open()
- unless ( $self->{base_db_obj} ) {
- $self->{base_db_obj} = shift;
- Scalar::Util::weaken( $self->{base_db_obj} );
- }
+This method opens the filehandle for the filename in C< file >.
- return;
-}
+There is no return value.
+
+=cut
sub open {
my $self = shift;
# Adding O_BINARY should remove the need for the binmode below. However,
# I'm not going to remove it because I don't have the Win32 chops to be
# absolutely certain everything will be ok.
- my $flags = O_RDWR | O_CREAT | O_BINARY;
+ my $flags = O_CREAT | O_BINARY;
+
+ if ( !-e $self->{file} || -w _ ) {
+ $flags |= O_RDWR;
+ }
+ else {
+ $flags |= O_RDONLY;
+ }
my $fh;
sysopen( $fh, $self->{file}, $flags )
return 1;
}
+=head2 close()
+
+If the filehandle is opened, this will close it.
+
+There is no return value.
+
+=cut
+
sub close {
my $self = shift;
return 1;
}
+=head2 size()
+
+This will return the size of the DB. If file_offset is set, this will take that into account.
+
+=cut
+
+sub size {
+ my $self = shift;
+
+ return 0 unless $self->{fh};
+ return( (-s $self->{fh}) - $self->{file_offset} );
+}
+
+=head2 set_inode()
+
+This will set the inode value of the underlying file object.
+
+This is only needed to handle some obscure Win32 bugs. It reqlly shouldn't be needed outside
+this object.
+
+There is no return value.
+
+=cut
+
sub set_inode {
my $self = shift;
- unless ( $self->{inode} ) {
+ unless ( defined $self->{inode} ) {
my @stats = stat($self->{fh});
$self->{inode} = $stats[1];
$self->{end} = $stats[7];
return 1;
}
+=head2 print_at( $offset, @data )
+
+This takes an optional offset and some data to print.
+
+C< $offset >, if defined, will be used to seek into the file. If file_offset is set, it will be used
+as the zero location. If it is undefined, no seeking will occur. Then, C< @data > will be printed to
+the current location.
+
+There is no return value.
+
+=cut
+
sub print_at {
my $self = shift;
my $loc = shift;
- local ($/,$\);
+ local ($,,$\);
my $fh = $self->{fh};
if ( defined $loc ) {
seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
}
- print( $fh @_ );
+ if ( DEBUG ) {
+ my $caller = join ':', (caller)[0,2];
+ my $len = length( join '', @_ );
+ warn "($caller) print_at( " . (defined $loc ? $loc : '<undef>') . ", $len )\n";
+ }
+
+ print( $fh @_ ) or die "Internal Error (print_at($loc)): $!\n";
return 1;
}
+=head2 read_at( $offset, $length )
+
+This takes an optional offset and a length.
+
+C< $offset >, if defined, will be used to seek into the file. If file_offset is set, it will be used
+as the zero location. If it is undefined, no seeking will occur. Then, C< $length > bytes will be
+read from the current location.
+
+The data read will be returned.
+
+=cut
+
sub read_at {
my $self = shift;
my ($loc, $size) = @_;
- local ($/,$\);
-
my $fh = $self->{fh};
if ( defined $loc ) {
seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
}
+ if ( DEBUG ) {
+ my $caller = join ':', (caller)[0,2];
+ warn "($caller) read_at( " . (defined $loc ? $loc : '<undef>') . ", $size )\n";
+ }
+
my $buffer;
read( $fh, $buffer, $size);
return $buffer;
}
-sub increment_pointer {
- my $self = shift;
- my ($size) = @_;
+=head2 DESTROY
- if ( defined $size ) {
- seek( $self->{fh}, $size, SEEK_CUR );
- }
+When the ::File object goes out of scope, it will be closed.
- return 1;
-}
+=cut
sub DESTROY {
my $self = shift;
return;
}
+=head2 request_space( $size )
+
+This takes a size and adds that much space to the DBM.
+
+This returns the offset for the new location.
+
+=cut
+
sub request_space {
my $self = shift;
my ($size) = @_;
return $loc;
}
-#sub release_space {
-# my $self = shift;
-# my ($size, $loc) = @_;
-#
-# local($/,$\);
-#
-# my $next_loc = 0;
-#
-# my $fh = $self->{fh};
-# seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
-# print( $fh SIG_FREE
-# . pack($self->{long_pack}, $size )
-# . pack($self->{long_pack}, $next_loc )
-# );
-#
-# return;
-#}
-
-##
-# If db locking is set, flock() the db file. If called multiple
-# times before unlock(), then the same number of unlocks() must
-# be called before the lock is released.
-##
-sub lock {
- my $self = shift;
- my ($obj, $type) = @_;
- $type = LOCK_EX unless defined $type;
+=head2 flush()
- if (!defined($self->{fh})) { return; }
+This flushes the filehandle. This takes no parameters and returns nothing.
- if ($self->{locking}) {
- if (!$self->{locked}) {
- flock($self->{fh}, $type);
+=cut
- # refresh end counter in case file has changed size
- my @stats = stat($self->{fh});
- $self->{end} = $stats[7];
+sub flush {
+ my $self = shift;
- # double-check file inode, in case another process
- # has optimize()d our file while we were waiting.
- if ($stats[1] != $self->{inode}) {
- $self->close;
- $self->open;
+ # Flush the filehandle
+ my $old_fh = select $self->{fh};
+ my $old_af = $|; $| = 1; $| = $old_af;
+ select $old_fh;
- #XXX This needs work
- $obj->{engine}->setup_fh( $obj );
+ return 1;
+}
- flock($self->{fh}, $type); # re-lock
+=head2 is_writable()
- # This may not be necessary after re-opening
- $self->{end} = (stat($self->{fh}))[7]; # re-end
- }
- }
- $self->{locked}++;
+This takes no parameters. It returns a boolean saying if this filehandle is
+writable.
- return 1;
- }
+Taken from L<http://www.perlmonks.org/?node_id=691054/>.
- return;
-}
+=cut
-##
-# If db locking is set, unlock the db file. See note in lock()
-# regarding calling lock() multiple times.
-##
-sub unlock {
+sub is_writable {
my $self = shift;
- if (!defined($self->{fh})) { return; }
-
- if ($self->{locking} && $self->{locked} > 0) {
- $self->{locked}--;
- if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); }
-
- return 1;
- }
-
- return;
+ my $fh = $self->{fh};
+ return unless defined $fh;
+ return unless defined fileno $fh;
+ local $\ = ''; # just in case
+ no warnings; # temporarily disable warnings
+ local $^W; # temporarily disable warnings
+ return print $fh '';
}
-sub set_transaction_offset {
- my $self = shift;
- $self->{transaction_offset} = shift;
-}
+=head2 copy_stats( $target_filename )
-sub audit {
- my $self = shift;
- my ($string) = @_;
+This will take the stats for the current filehandle and apply them to
+C< $target_filename >. The stats copied are:
- if ( my $afh = $self->{audit_fh} ) {
- flock( $afh, LOCK_EX );
+=over 4
- if ( $string =~ /^#/ ) {
- print( $afh "$string " . localtime(time) . "\n" );
- }
- else {
- print( $afh "$string # " . localtime(time) . "\n" );
- }
+=item * Onwer UID and GID
- flock( $afh, LOCK_UN );
- }
+=item * Permissions
- if ( $self->{transaction_audit} ) {
- push @{$self->{transaction_audit}}, $string;
- }
+=back
- return 1;
-}
+=cut
-sub begin_transaction {
+sub copy_stats {
my $self = shift;
+ my ($temp_filename) = @_;
+
+ my @stats = stat( $self->{fh} );
+ my $perms = $stats[2] & 07777;
+ my $uid = $stats[4];
+ my $gid = $stats[5];
+ chown( $uid, $gid, $temp_filename );
+ chmod( $perms, $temp_filename );
+}
- my $fh = $self->{fh};
+=head1 LOCKING
- $self->lock;
+This is where the actual locking of the storage medium is performed.
+Nested locking is supported.
- my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
- my ($next, @trans) = unpack( 'C C C C', $buffer );
+B<NOTE>: It is unclear what will happen if a read lock is taken, then
+a write lock is taken as a nested lock, then the write lock is released.
- $self->{transaction_id} = ++$next;
+Currently, the only locking method supported is flock(1). This is a
+whole-file lock. In the future, more granular locking may be supported.
+The API for that is unclear right now.
- die if $trans[-1] != 0;
+The following methods manage the locking status. In all cases, they take
+a L<DBM::Deep/> object and returns nothing.
- for ( my $i = 0; $i <= $#trans; $i++ ) {
- next if $trans[$i] != 0;
- $trans[$i] = $next;
- last;
- }
+=over 4
- $self->print_at(
- $self->{transaction_offset},
- pack( 'C C C C', $next, @trans),
- );
+=item * lock_exclusive( $obj )
- $self->unlock;
+Take a lock usable for writing.
- $self->{transaction_audit} = [];
+=item * lock_shared( $obj )
- return $self->{transaction_id};
-}
+Take a lock usable for reading.
-sub end_transaction {
- my $self = shift;
+=item * unlock( $obj )
- my $fh = $self->{fh};
+Releases the last lock taken. If this is the outermost lock, then the
+object is actually unlocked.
+
+=back
- $self->lock;
+=cut
- my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
- my ($next, @trans) = unpack( 'C C C C', $buffer );
+sub lock_exclusive {
+ my $self = shift;
+ my ($obj) = @_;
+ return $self->_lock( $obj, LOCK_EX );
+}
- @trans = grep { $_ != $self->{transaction_id} } @trans;
+sub lock_shared {
+ my $self = shift;
+ my ($obj) = @_;
+ return $self->_lock( $obj, LOCK_SH );
+}
- $self->print_at(
- $self->{transaction_offset},
- pack( 'C C C C', $next, @trans),
- );
+sub _lock {
+ my $self = shift;
+ my ($obj, $type) = @_;
- #XXX Need to free the space used by the current transaction
+ $type = LOCK_EX unless defined $type;
- $self->unlock;
+ #XXX This is a temporary fix for Win32 and autovivification. It
+ # needs to improve somehow. -RobK, 2008-03-09
+ if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
+ $type = LOCK_EX;
+ }
- $self->{transaction_id} = 0;
- $self->{transaction_audit} = undef;
+ if (!defined($self->{fh})) { return; }
-# $self->{base_db_obj}->optimize;
-# $self->{inode} = undef;
-# $self->set_inode;
+ #XXX This either needs to allow for upgrading a shared lock to an
+ # exclusive lock or something else with autovivification.
+ # -RobK, 2008-03-09
+ if ($self->{locking}) {
+ if (!$self->{locked}) {
+ flock($self->{fh}, $type);
- return 1;
-}
+ # refresh end counter in case file has changed size
+ my @stats = stat($self->{fh});
+ $self->{end} = $stats[7];
-sub current_transactions {
- my $self = shift;
+ # double-check file inode, in case another process
+ # has optimize()d our file while we were waiting.
+ if (defined($self->{inode}) && $stats[1] != $self->{inode}) {
+ $self->close;
+ $self->open;
- my $fh = $self->{fh};
+ #XXX This needs work
+ $obj->{engine}->setup_fh( $obj );
- $self->lock;
+ flock($self->{fh}, $type); # re-lock
- my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
- my ($next, @trans) = unpack( 'C C C C', $buffer );
+ # This may not be necessary after re-opening
+ $self->{end} = (stat($self->{fh}))[7]; # re-end
+ }
+ }
+ $self->{locked}++;
- $self->unlock;
+ return 1;
+ }
- return grep { $_ && $_ != $self->{transaction_id} } @trans;
+ return;
}
-sub transaction_id { return $_[0]->{transaction_id} }
-
-sub commit_transaction {
+sub unlock {
my $self = shift;
- my @audit = @{$self->{transaction_audit}};
+ if (!defined($self->{fh})) { return; }
- $self->end_transaction;
+ if ($self->{locking} && $self->{locked} > 0) {
+ $self->{locked}--;
- {
- my $db = $self->{base_db_obj};
- for ( @audit ) {
- eval "$_;";
- warn "$_: $@\n" if $@;
+ if (!$self->{locked}) {
+ flock($self->{fh}, LOCK_UN);
+ return 1;
}
+
+ return;
}
- return 1;
+ return;
}
1;
__END__
-
projects / dbsrgits/DBM-Deep.git / blobdiff