META.yml
lib/DBM/Deep.pm
lib/DBM/Deep/Engine.pm
+lib/DBM/Deep/File.pm
lib/DBM/Deep/Array.pm
lib/DBM/Deep/Hash.pm
t/01_basic.t
# modify it under the same terms as Perl itself.
##
+use 5.6.0;
+
use strict;
+use warnings;
use Fcntl qw( :DEFAULT :flock :seek );
use Digest::MD5 ();
use Scalar::Util ();
use DBM::Deep::Engine;
+use DBM::Deep::File;
use vars qw( $VERSION );
$VERSION = q(0.99_01);
my $class = shift;
my ($args) = @_;
+ $args->{fileobj} = DBM::Deep::File->new( $args )
+ unless exists $args->{fileobj};
+
+ # locking implicitly enables autoflush
+ if ($args->{locking}) { $args->{autoflush} = 1; }
+
# These are the defaults to be optionally overridden below
my $self = bless {
type => TYPE_HASH,
engine => DBM::Deep::Engine->new( $args ),
base_offset => undef,
+ fileobj => undef,
}, $class;
# Grab the parameters we want to use
$self->{$param} = $args->{$param};
}
- # locking implicitly enables autoflush
- if ($args->{locking}) { $args->{autoflush} = 1; }
-
- $self->{root} = exists $args->{root}
- ? $args->{root}
- : DBM::Deep::_::Root->new( $args );
-
$self->{engine}->setup_fh( $self );
return $self;
if (!defined($self->_fh)) { return; }
- if ($self->_root->{locking}) {
- if (!$self->_root->{locked}) {
+ if ($self->_fileobj->{locking}) {
+ if (!$self->_fileobj->{locked}) {
flock($self->_fh, $type);
# refresh end counter in case file has changed size
my @stats = stat($self->_fh);
- $self->_root->{end} = $stats[7];
+ $self->_fileobj->{end} = $stats[7];
# double-check file inode, in case another process
# has optimize()d our file while we were waiting.
- if ($stats[1] != $self->_root->{inode}) {
- $self->{engine}->close_fh( $self );
+ if ($stats[1] != $self->_fileobj->{inode}) {
+ $self->_fileobj->close;
+ $self->_fileobj->open;
$self->{engine}->setup_fh( $self );
flock($self->_fh, $type); # re-lock
# This may not be necessary after re-opening
- $self->_root->{end} = (stat($self->_fh))[7]; # re-end
+ $self->_fileobj->{end} = (stat($self->_fh))[7]; # re-end
}
}
- $self->_root->{locked}++;
+ $self->_fileobj->{locked}++;
return 1;
}
if (!defined($self->_fh)) { return; }
- if ($self->_root->{locking} && $self->_root->{locked} > 0) {
- $self->_root->{locked}--;
- if (!$self->_root->{locked}) { flock($self->_fh, LOCK_UN); }
+ if ($self->_fileobj->{locking} && $self->_fileobj->{locked} > 0) {
+ $self->_fileobj->{locked}--;
+ if (!$self->_fileobj->{locked}) { flock($self->_fh, LOCK_UN); }
return 1;
}
my $self = shift->_get_self;
#XXX Need to create a new test for this
-# if ($self->_root->{links} > 1) {
+# if ($self->_fileobj->{links} > 1) {
# $self->_throw_error("Cannot optimize: reference count is greater than 1");
# }
my $db_temp = DBM::Deep->new(
- file => $self->_root->{file} . '.tmp',
+ file => $self->_fileobj->{file} . '.tmp',
type => $self->_type
);
my $perms = $stats[2] & 07777;
my $uid = $stats[4];
my $gid = $stats[5];
- chown( $uid, $gid, $self->_root->{file} . '.tmp' );
- chmod( $perms, $self->_root->{file} . '.tmp' );
+ chown( $uid, $gid, $self->_fileobj->{file} . '.tmp' );
+ chmod( $perms, $self->_fileobj->{file} . '.tmp' );
# q.v. perlport for more information on this variable
if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
# with a soft copy.
##
$self->unlock();
- $self->{engine}->close_fh( $self );
+ $self->_fileobj->close;
}
- if (!rename $self->_root->{file} . '.tmp', $self->_root->{file}) {
- unlink $self->_root->{file} . '.tmp';
+ if (!rename $self->_fileobj->{file} . '.tmp', $self->_fileobj->{file}) {
+ unlink $self->_fileobj->{file} . '.tmp';
$self->unlock();
$self->_throw_error("Optimize failed: Cannot copy temp file over original: $!");
}
$self->unlock();
- $self->{engine}->close_fh( $self );
+ $self->_fileobj->close;
+ $self->_fileobj->open;
$self->{engine}->setup_fh( $self );
return 1;
return DBM::Deep->new(
type => $self->_type,
base_offset => $self->_base_offset,
- root => $self->_root
+ fileobj => $self->_fileobj,
);
}
my $func = shift;
if ( $is_legal_filter{$type} ) {
- $self->_root->{"filter_$type"} = $func;
+ $self->_fileobj->{"filter_$type"} = $func;
return 1;
}
# Accessor methods
##
-sub _root {
+sub _fileobj {
##
# Get access to the root structure
##
my $self = $_[0]->_get_self;
- return $self->{root};
+ return $self->{fileobj};
}
sub _type {
# Get access to the raw fh
##
my $self = $_[0]->_get_self;
- return $self->_root->{fh};
+ return $self->_fileobj->{fh};
}
##
# User may be storing a hash, in which case we do not want it run
# through the filtering system
- if ( !ref($value) && $self->_root->{filter_store_value} ) {
- $value = $self->_root->{filter_store_value}->( $value );
+ if ( !ref($value) && $self->_fileobj->{filter_store_value} ) {
+ $value = $self->_fileobj->{filter_store_value}->( $value );
}
##
# Filters only apply to scalar values, so the ref check is making
# sure the fetched bucket is a scalar, not a child hash or array.
- return ($result && !ref($result) && $self->_root->{filter_fetch_value})
- ? $self->_root->{filter_fetch_value}->($result)
+ return ($result && !ref($result) && $self->_fileobj->{filter_fetch_value})
+ ? $self->_fileobj->{filter_fetch_value}->($result)
: $result;
}
##
my $value = $self->{engine}->get_bucket_value($self, $tag, $md5 );
- if (defined $value && !ref($value) && $self->_root->{filter_fetch_value}) {
- $value = $self->_root->{filter_fetch_value}->($value);
+ if (defined $value && !ref($value) && $self->_fileobj->{filter_fetch_value}) {
+ $value = $self->_fileobj->{filter_fetch_value}->($value);
}
my $result = $self->{engine}->delete_bucket( $self, $tag, $md5 );
my $fh = $self->_fh;
- seek($fh, $self->_base_offset + $self->_root->{file_offset}, SEEK_SET);
+ seek($fh, $self->_base_offset + $self->_fileobj->{file_offset}, SEEK_SET);
if (eof $fh) {
$self->unlock();
return;
sub exists { (shift)->EXISTS( @_ ) }
sub clear { (shift)->CLEAR( @_ ) }
-package DBM::Deep::_::Root;
-
-sub new {
- my $class = shift;
- my ($args) = @_;
-
- my $self = bless {
- autobless => undef,
- autoflush => undef,
- end => 0,
- fh => undef,
- file => undef,
- file_offset => 0,
- locking => undef,
- locked => 0,
- filter_store_key => undef,
- filter_store_value => undef,
- filter_fetch_key => undef,
- filter_fetch_value => undef,
- }, $class;
-
- # Grab the parameters we want to use
- foreach my $param ( keys %$self ) {
- next unless exists $args->{$param};
- $self->{$param} = $args->{$param};
- }
-
- if ( $self->{fh} && !$self->{file_offset} ) {
- $self->{file_offset} = tell( $self->{fh} );
- }
-
- return $self;
-}
-
-sub DESTROY {
- my $self = shift;
- return unless $self;
-
- close $self->{fh} if $self->{fh};
-
- return;
-}
-
1;
__END__
This method can be called on the root level of the datbase, or any child
hashes or arrays. All levels share a I<root> structure, which contains things
like the filehandle, a reference counter, and all the options specified
-when you created the object. You can get access to this root structure by
-calling the C<root()> method.
+when you created the object. You can get access to this file object by
+calling the C<_fileobj()> method.
- my $root = $db->_root();
+ my $file_obj = $db->_fileobj();
This is useful for changing options after the object has already been created,
such as enabling/disabling locking. You can also store your own temporary user
package DBM::Deep::Array;
+use 5.6.0;
+
use strict;
+use warnings;
# This is to allow DBM::Deep::Array to handle negative indices on
# its own. Otherwise, Perl would intercept the call to negative
# indices for us. This was causing bugs for negative index handling.
-use vars qw( $NEGATIVE_INDICES );
-$NEGATIVE_INDICES = 1;
+our $NEGATIVE_INDICES = 1;
use base 'DBM::Deep';
return 1;
}
sub TIEARRAY {
-##
-# Tied array constructor method, called by Perl's tie() function.
-##
my $class = shift;
my $args = $class->_get_args( @_ );
}
sub FETCHSIZE {
- ##
- # Return the length of the array
- ##
my $self = shift->_get_self;
$self->lock( $self->LOCK_SH );
- my $SAVE_FILTER = $self->_root->{filter_fetch_value};
- $self->_root->{filter_fetch_value} = undef;
+ my $SAVE_FILTER = $self->_fileobj->{filter_fetch_value};
+ $self->_fileobj->{filter_fetch_value} = undef;
my $packed_size = $self->FETCH('length');
- $self->_root->{filter_fetch_value} = $SAVE_FILTER;
+ $self->_fileobj->{filter_fetch_value} = $SAVE_FILTER;
$self->unlock;
}
sub STORESIZE {
- ##
- # Set the length of the array
- ##
my $self = shift->_get_self;
my ($new_length) = @_;
$self->lock( $self->LOCK_EX );
- my $SAVE_FILTER = $self->_root->{filter_store_value};
- $self->_root->{filter_store_value} = undef;
+ my $SAVE_FILTER = $self->_fileobj->{filter_store_value};
+ $self->_fileobj->{filter_store_value} = undef;
my $result = $self->STORE('length', pack($self->{engine}{long_pack}, $new_length));
- $self->_root->{filter_store_value} = $SAVE_FILTER;
+ $self->_fileobj->{filter_store_value} = $SAVE_FILTER;
$self->unlock;
}
sub POP {
- ##
- # Remove and return the last element on the array
- ##
my $self = shift->_get_self;
$self->lock( $self->LOCK_EX );
}
sub PUSH {
- ##
- # Add new element(s) to the end of the array
- ##
my $self = shift->_get_self;
$self->lock( $self->LOCK_EX );
}
sub SHIFT {
- ##
- # Remove and return first element on the array.
- # Shift over remaining elements to take up space.
- ##
my $self = shift->_get_self;
$self->lock( $self->LOCK_EX );
if ($length) {
my $content = $self->FETCH( 0 );
- ##
- # Shift elements over and remove last one.
- ##
for (my $i = 0; $i < $length - 1; $i++) {
$self->STORE( $i, $self->FETCH($i + 1) );
}
}
sub UNSHIFT {
- ##
- # Insert new element(s) at beginning of array.
- # Shift over other elements to make space.
- ##
my $self = shift->_get_self;
my @new_elements = @_;
}
sub SPLICE {
- ##
- # Splices section of array with optional new section.
- # Returns deleted section, or last element deleted in scalar context.
- ##
my $self = shift->_get_self;
$self->lock( $self->LOCK_EX );
return wantarray ? @old_elements : $old_elements[-1];
}
-#XXX We don't need to define it, yet.
-#XXX It will be useful, though, when we split out HASH and ARRAY
+# We don't need to define it, yet.
+# It will be useful, though, when we split out HASH and ARRAY
sub EXTEND {
##
# Perl will call EXTEND() when the array is likely to grow.
- # We don't care, but include it for compatibility.
+ # We don't care, but include it because it gets called at times.
##
}
package DBM::Deep::Engine;
+use 5.6.0;
+
use strict;
+use warnings;
use Fcntl qw( :DEFAULT :flock :seek );
# Setup file and tag signatures. These should never change.
##
sub SIG_FILE () { 'DPDB' }
+sub SIG_HEADER () { 'h' }
sub SIG_INTERNAL () { 'i' }
sub SIG_HASH () { 'H' }
sub SIG_ARRAY () { 'A' }
# reindex overrun.
##
max_buckets => 16,
+
+ fileobj => undef,
}, $class;
if ( defined $args->{pack_size} ) {
return $self;
}
+sub _fileobj { return $_[0]{fileobj} }
+sub _fh { return $_[0]->_fileobj->{fh} }
+
sub calculate_sizes {
my $self = shift;
sub write_file_header {
my $self = shift;
- my ($obj) = @_;
+# my ($obj) = @_;
- my $fh = $obj->_fh;
+ my $fh = $self->_fh;
my $loc = $self->_request_space(
- $obj, length( SIG_FILE ) + 12,
+ undef, length( SIG_FILE ) + 21,
);
- seek($fh, $loc + $obj->_root->{file_offset}, SEEK_SET);
+ seek($fh, $loc + $self->_fileobj->{file_offset}, SEEK_SET);
print( $fh
SIG_FILE,
- pack('S', 1),
+ SIG_HEADER,
+ pack('N', 1), # header version
+ pack('N', 12), # header size
+ pack('N', 0), # file version
pack('S', $self->{long_size}),
pack('A', $self->{long_pack}),
pack('S', $self->{data_size}),
my $fh = $obj->_fh;
- seek($fh, 0 + $obj->_root->{file_offset}, SEEK_SET);
+ seek($fh, 0 + $obj->_fileobj->{file_offset}, SEEK_SET);
my $buffer;
- my $bytes_read = read(
- $fh, $buffer, length(SIG_FILE) + 12,
+ my $bytes_read = read( $fh, $buffer, length(SIG_FILE) + 9 );
+
+ return unless $bytes_read;
+
+ my ($file_signature, $sig_header, $header_version, $size) = unpack(
+ 'A4 A N N', $buffer
);
- if ( $bytes_read ) {
- my ($signature, $version, @values) = unpack( 'A4 S S A S A S', $buffer );
- unless ($signature eq SIG_FILE) {
- $self->close_fh( $obj );
- $obj->_throw_error("Signature not found -- file is not a Deep DB");
- }
+ unless ( $file_signature eq SIG_FILE ) {
+ $self->{fileobj}->close;
+ $obj->_throw_error( "Signature not found -- file is not a Deep DB" );
+ }
- if ( @values < 5 || grep { !defined } @values ) {
- die "DBM::Deep: Corrupted file - bad header\n";
- }
+ unless ( $sig_header eq SIG_HEADER ) {
+ $self->{fileobj}->close;
+ $obj->_throw_error( "Old file version found." );
+ }
- #XXX Add warnings if values weren't set right
- @{$self}{qw( long_size long_pack data_size data_pack max_buckets )} = @values;
+ my $buffer2;
+ $bytes_read += read( $fh, $buffer2, $size );
+ my ($file_version, @values) = unpack( 'N S A S A S', $buffer2 );
+ if ( @values < 5 || grep { !defined } @values ) {
+ $self->{fileobj}->close;
+ $obj->_throw_error("Corrupted file - bad header");
}
+ #XXX Add warnings if values weren't set right
+ @{$self}{qw(long_size long_pack data_size data_pack max_buckets)} = @values;
+
return $bytes_read;
}
-sub setup_fh {
+sub get_file_version {
my $self = shift;
my ($obj) = @_;
- $self->open( $obj ) if !defined $obj->_fh;
+ my $fh = $obj->_fh;
+
+ seek( $fh, 13 + $obj->_fileobj->{file_offset}, SEEK_SET );
+ my $buffer;
+ my $bytes_read = read( $fh, $buffer, 4 );
+ unless ( $bytes_read == 4 ) {
+ $obj->_throw_error( "Cannot read file version" );
+ }
+
+ return unpack( 'N', $buffer );
+}
+
+sub write_file_version {
+ my $self = shift;
+ my ($obj, $new_version) = @_;
+
+ my $fh = $obj->_fh;
+
+ seek( $fh, 13 + $obj->_fileobj->{file_offset}, SEEK_SET );
+ print( $fh pack( 'N', $new_version ) );
+
+ return;
+}
+
+sub setup_fh {
+ my $self = shift;
+ my ($obj) = @_;
my $fh = $obj->_fh;
flock $fh, LOCK_EX;
}
#XXX We have to make sure we don't mess up when autoflush isn't turned on
- unless ( $obj->_root->{inode} ) {
+ unless ( $obj->_fileobj->{inode} ) {
my @stats = stat($obj->_fh);
- $obj->_root->{inode} = $stats[1];
- $obj->_root->{end} = $stats[7];
+ $obj->_fileobj->{inode} = $stats[1];
+ $obj->_fileobj->{end} = $stats[7];
}
flock $fh, LOCK_UN;
return 1;
}
-sub open {
- ##
- # Open a fh to the database, create if nonexistent.
- # Make sure file signature matches DBM::Deep spec.
- ##
- my $self = shift;
- my ($obj) = @_;
-
- # Theoretically, adding O_BINARY should remove the need for the binmode
- # Of course, testing it is going to be ... interesting.
- my $flags = O_RDWR | O_CREAT | O_BINARY;
-
- my $fh;
- my $filename = $obj->_root->{file};
- sysopen( $fh, $filename, $flags )
- or $obj->_throw_error("Cannot sysopen file '$filename': $!");
- $obj->_root->{fh} = $fh;
-
- # Even though we use O_BINARY, better be safe than sorry.
- binmode $fh;
-
- if ($obj->_root->{autoflush}) {
- my $old = select $fh;
- $|=1;
- select $old;
- }
-
- return 1;
-}
-
-sub close_fh {
- my $self = shift;
- my ($obj) = @_;
-
- if ( my $fh = $obj->_root->{fh} ) {
- close $fh;
- }
- $obj->_root->{fh} = undef;
-
- return 1;
-}
-
sub tag_size {
my $self = shift;
my ($size) = @_;
my $fh = $obj->_fh;
if ( defined $offset ) {
- seek($fh, $offset + $obj->_root->{file_offset}, SEEK_SET);
+ seek($fh, $offset + $obj->_fileobj->{file_offset}, SEEK_SET);
}
print( $fh $sig . pack($self->{data_pack}, $size) . $content );
my $fh = $obj->_fh;
- seek($fh, $offset + $obj->_root->{file_offset}, SEEK_SET);
+ seek($fh, $offset + $obj->_fileobj->{file_offset}, SEEK_SET);
#XXX I'm not sure this check will work if autoflush isn't enabled ...
return if eof $fh;
my $len = SIG_SIZE + $self->{data_size}
+ $self->{data_size} + length( $key );
- if ( $is_dbm_deep && $value->_root eq $obj->_root ) {
+ if ( $is_dbm_deep && $value->_fileobj eq $obj->_fileobj ) {
return $len + $self->{long_size};
}
my $r = Scalar::Util::reftype( $value ) || '';
- if ( $obj->_root->{autobless} ) {
+ if ( $obj->_fileobj->{autobless} ) {
# This is for the bit saying whether or not this thing is blessed.
$len += 1;
}
# if autobless is enabled, must also take into consideration
# the class name as it is stored after the key.
- if ( $obj->_root->{autobless} ) {
+ if ( $obj->_fileobj->{autobless} ) {
my $c = Scalar::Util::blessed($value);
if ( defined $c && !$is_dbm_deep ) {
$len += $self->{data_size} + length($c);
my $location = 0;
my $result = 2;
- my $root = $obj->_root;
+ my $root = $obj->_fileobj;
my $fh = $obj->_fh;
my $actual_length = $self->_length_needed( $obj, $value, $plain_key );
my ($obj, $location, $key, $value) = @_;
my $fh = $obj->_fh;
- my $root = $obj->_root;
+ my $root = $obj->_fileobj;
my $dbm_deep_obj = _get_dbm_object( $value );
- if ( $dbm_deep_obj && $dbm_deep_obj->_root ne $obj->_root ) {
+ if ( $dbm_deep_obj && $dbm_deep_obj->_fileobj ne $obj->_fileobj ) {
$obj->_throw_error( "Cannot cross-reference. Use export() instead" );
}
my %x = %$value;
tie %$value, 'DBM::Deep', {
base_offset => $location,
- root => $root,
+ fileobj => $root,
};
%$value = %x;
}
my @x = @$value;
tie @$value, 'DBM::Deep', {
base_offset => $location,
- root => $root,
+ fileobj => $root,
};
@$value = @x;
}
my ($obj, $md5, $tag) = @_;
my $fh = $obj->_fh;
- my $root = $obj->_root;
+ my $root = $obj->_fileobj;
my $loc = $self->_request_space(
$obj, $self->tag_size( $self->{index_size} ),
# Found match -- seek to offset and read signature
##
my $signature;
- seek($fh, $subloc + $obj->_root->{file_offset}, SEEK_SET);
+ seek($fh, $subloc + $obj->_fileobj->{file_offset}, SEEK_SET);
read( $fh, $signature, SIG_SIZE);
##
my $new_obj = DBM::Deep->new({
type => $signature,
base_offset => $subloc,
- root => $obj->_root,
+ fileobj => $obj->_fileobj,
});
- if ($new_obj->_root->{autobless}) {
+ if ($new_obj->_fileobj->{autobless}) {
##
# Skip over value and plain key to see if object needs
# to be re-blessed
##
# Otherwise return actual value
##
- elsif ($signature eq SIG_DATA) {
+ elsif ( $signature eq SIG_DATA ) {
my $size;
read( $fh, $size, $self->{data_size});
$size = unpack($self->{data_pack}, $size);
#XXX This needs _release_space()
if ( $subloc ) {
my $fh = $obj->_fh;
- seek($fh, $tag->{offset} + $offset + $obj->_root->{file_offset}, SEEK_SET);
+ seek($fh, $tag->{offset} + $offset + $obj->_fileobj->{file_offset}, SEEK_SET);
print( $fh substr($tag->{content}, $offset + $self->{bucket_size} ) );
print( $fh chr(0) x $self->{bucket_size} );
);
my $fh = $obj->_fh;
- seek($fh, $ref_loc + $obj->_root->{file_offset}, SEEK_SET);
+ seek($fh, $ref_loc + $obj->_fileobj->{file_offset}, SEEK_SET);
print( $fh pack($self->{long_pack}, $loc) );
$tag = $self->write_tag(
}
# Seek to bucket location and skip over signature
elsif ($obj->{return_next}) {
- seek($fh, $subloc + $obj->_root->{file_offset}, SEEK_SET);
+ seek($fh, $subloc + $obj->_fileobj->{file_offset}, SEEK_SET);
# Skip over value to get to plain key
my $sig;
my $self = shift;
my ($obj, $size) = @_;
- my $loc = $obj->_root->{end};
- $obj->_root->{end} += $size;
+ my $loc = $self->_fileobj->{end};
+ $self->_fileobj->{end} += $size;
return $loc;
}
my $next_loc = 0;
my $fh = $obj->_fh;
- seek( $fh, $loc + $obj->_root->{file_offset}, SEEK_SET );
+ seek( $fh, $loc + $obj->_fileobj->{file_offset}, SEEK_SET );
print( $fh SIG_FREE
. pack($self->{long_pack}, $size )
. pack($self->{long_pack}, $next_loc )
my ($obj, $spot, $amount, $unpack) = @_;
my $fh = $obj->_fh;
- seek( $fh, $spot + $obj->_root->{file_offset}, SEEK_SET );
+ seek( $fh, $spot + $obj->_fileobj->{file_offset}, SEEK_SET );
my $buffer;
my $bytes_read = read( $fh, $buffer, $amount );
--- /dev/null
+package DBM::Deep::File;
+
+use 5.6.0;
+
+use strict;
+use warnings;
+
+use Fcntl qw( :DEFAULT :flock :seek );
+
+our $VERSION = '0.01';
+
+sub new {
+ my $class = shift;
+ my ($args) = @_;
+
+ my $self = bless {
+ autobless => undef,
+ autoflush => undef,
+ end => 0,
+ fh => undef,
+ file => undef,
+ file_offset => 0,
+ locking => undef,
+ locked => 0,
+ filter_store_key => undef,
+ filter_store_value => undef,
+ filter_fetch_key => undef,
+ filter_fetch_value => undef,
+ }, $class;
+
+ # Grab the parameters we want to use
+ foreach my $param ( keys %$self ) {
+ next unless exists $args->{$param};
+ $self->{$param} = $args->{$param};
+ }
+
+ if ( $self->{fh} && !$self->{file_offset} ) {
+ $self->{file_offset} = tell( $self->{fh} );
+ }
+
+ $self->open unless $self->{fh};
+
+ return $self;
+}
+
+sub open {
+ my $self = shift;
+
+ # Adding O_BINARY does 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 $fh;
+ sysopen( $fh, $self->{file}, $flags )
+ or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n";
+ $self->{fh} = $fh;
+
+ # Even though we use O_BINARY, better be safe than sorry.
+ binmode $fh;
+
+ if ($self->{autoflush}) {
+ my $old = select $fh;
+ $|=1;
+ select $old;
+ }
+
+ return 1;
+}
+
+sub close {
+ my $self = shift;
+
+ if ( $self->{fh} ) {
+ close $self->{fh};
+ $self->{fh} = undef;
+ }
+
+ return 1;
+}
+
+sub DESTROY {
+ my $self = shift;
+ return unless $self;
+
+ $self->close;
+
+ return;
+}
+
+1;
+__END__
+
package DBM::Deep::Hash;
+use 5.6.0;
+
use strict;
+use warnings;
use base 'DBM::Deep';
sub FETCH {
my $self = shift->_get_self;
- my $key = ($self->_root->{filter_store_key})
- ? $self->_root->{filter_store_key}->($_[0])
+ my $key = ($self->_fileobj->{filter_store_key})
+ ? $self->_fileobj->{filter_store_key}->($_[0])
: $_[0];
return $self->SUPER::FETCH( $key );
sub STORE {
my $self = shift->_get_self;
- my $key = ($self->_root->{filter_store_key})
- ? $self->_root->{filter_store_key}->($_[0])
+ my $key = ($self->_fileobj->{filter_store_key})
+ ? $self->_fileobj->{filter_store_key}->($_[0])
: $_[0];
my $value = $_[1];
sub EXISTS {
my $self = shift->_get_self;
- my $key = ($self->_root->{filter_store_key})
- ? $self->_root->{filter_store_key}->($_[0])
+ my $key = ($self->_fileobj->{filter_store_key})
+ ? $self->_fileobj->{filter_store_key}->($_[0])
: $_[0];
return $self->SUPER::EXISTS( $key );
sub DELETE {
my $self = shift->_get_self;
- my $key = ($self->_root->{filter_store_key})
- ? $self->_root->{filter_store_key}->($_[0])
+ my $key = ($self->_fileobj->{filter_store_key})
+ ? $self->_fileobj->{filter_store_key}->($_[0])
: $_[0];
return $self->SUPER::DELETE( $key );
$self->unlock();
- return ($result && $self->_root->{filter_fetch_key})
- ? $self->_root->{filter_fetch_key}->($result)
+ return ($result && $self->_fileobj->{filter_fetch_key})
+ ? $self->_fileobj->{filter_fetch_key}->($result)
: $result;
}
##
my $self = shift->_get_self;
- my $prev_key = ($self->_root->{filter_store_key})
- ? $self->_root->{filter_store_key}->($_[0])
+ my $prev_key = ($self->_fileobj->{filter_store_key})
+ ? $self->_fileobj->{filter_store_key}->($_[0])
: $_[0];
my $prev_md5 = $self->{engine}{digest}->($prev_key);
$self->unlock();
- return ($result && $self->_root->{filter_fetch_key})
- ? $self->_root->{filter_fetch_key}->($result)
+ return ($result && $self->_fileobj->{filter_fetch_key})
+ ? $self->_fileobj->{filter_fetch_key}->($result)
: $result;
}
close FH;
throws_ok {
DBM::Deep->new( $filename );
-} qr/DBM::Deep: Corrupted file - bad header/, "Fail if there's a bad header";
+} qr/DBM::Deep: Old file version found/, "Fail if there's a bad header";
{
my ($fh, $filename) = new_fh();
# Testing to verify that the close() will occur if open is called on an open DB.
#XXX WOW is this hacky ...
-$db->_get_self->{engine}->open( $db->_get_self );
+$db->_get_self->_fileobj->open;
is( $db->{key1}, "value1", "Value still set after re-open" );
throws_ok {
file => $filename,
locking => 1,
);
- $db->_get_self->{engine}->close_fh( $db->_get_self );
- ok( !$db->lock );
+ $db->_get_self->_fileobj->close( $db->_get_self );
+ ok( !$db->lock, "Calling lock() on a closed database returns false" );
}
{
locking => 1,
);
$db->lock;
- $db->_get_self->{engine}->close_fh( $db->_get_self );
- ok( !$db->unlock );
+ $db->_get_self->_fileobj->close( $db->_get_self );
+ ok( !$db->unlock, "Calling unlock() on a closed database returns false" );
}
ok( !$db->exists( 'foo' ), "foo doesn't exist" );
my $db_obj = $db->_get_self;
- ok( $db_obj->_root->{inode}, "The inode has been set" );
+ ok( $db_obj->_fileobj->{inode}, "The inode has been set" );
close($fh);
}
$db->{x} = 'z';
is( $db->{x}, 'z' );
$db->rollback;
-is( $db->{x}, 'y' );
+TODO: {
+ local $TODO = "Haven't written transaction code yet";
+ is( $db->{x}, 'y' );
+}
+
+# Add a commit test (using fork) - we don't have to use fork initially. Since
+# the transaction is in the Engine object and each new() provides a new Engine
+# object, we're cool.
+
+# Should the transaction be in the Root and not the Engine? How would that
+# work?
+
+__END__
+
+Plan for transactions:
+* In a normal world, every key's version is set to 0. 0 is the indication that
+ this value isn't part of a transaction.
+* When a transaction is started, it is assigned the next transaction number.
+ The engine handles the transaction, not the DBM::Deep object.
+* While the transaction is running, all mutations occur in parallel, not
+ overwriting the original. They are assigned the transaction number.
+* How is a parallel mutation handled? It needs to be handled in the file
+ because we don't who's going to access what from where?
+ - Well, everything has to go through the same Engine object.
+ - Two processes may never access the same transaction.
+ - If a process in the middle of a transaction dies, the transaction is
+ considered void and will be reaped during the next optimize().
+ - So, in theory, by storing the fact that -this- file offset is involved
+ in a transaction should be able to be stored in memory.
+ -
-# Add a commit test using fork
+* Every operation is now transaction-aware
+* If a transaction is in effect against the file, everyone ELSE has to be
+ aware of it and respect it
+* Every key now has a transaction number associated with it
+* Every operation only operates against the key with the appropriate
+ transaction number
+* In the case of %$db = (), there will need to be a 0th level to tell you
+ which $db to go to.
+* Transaction #0 is the HEAD.
+* Upon commit, your version of reality is overlaid upon the HEAD.
+* Upon rollback, your version of reality disappears.
+* Upon process termination, an attempt is made to rollback any pending
+ transaction(s). If ABEND, it's your responsability to optimize().
+* The exact actions for each tie-method will have to be mapped out.
projects / dbsrgits/DBM-Deep.git / commitdiff