my $args = $class->_get_args( @_ );
my $self;
- ##
- # Check for SQL storage
- ##
if (exists $args->{dbi}) {
eval {
require DBIx::Abstract;
}; if ( $@ ) {
- DBM::Deep->_throw_error('DBIx::Abstract not installed. You cannot use the SQL mode.');
+ __PACKAGE__->_throw_error('DBIx::Abstract not installed. You cannot use the SQL mode.');
}
unless (UNIVERSAL::isa($args->{dbi}, 'DBIx::Abstract')) {
$args->{dbi} = DBIx::Abstract->connect($args->{dbi});
if (defined $args->{id}) {
unless ($args->{id} =~ /^\d+$/ && $args->{id} > 0) {
- DBM::Deep->_throw_error('Invalid SQL record id');
+ __PACKAGE__->_throw_error('Invalid SQL record id');
}
my $util = {dbi => $args->{dbi}};
bless $util, 'DBM::Deep::SQL::Util';
engine => undef,
}, $class;
- $args->{engine} = DBM::Deep::Engine::File->new( { %{$args}, obj => $self } )
- unless exists $args->{engine};
+ unless ( exists $args->{engine} ) {
+ my $class = exists $args->{dbi}
+ ? 'DBM::Deep::Engine::DBI'
+ : 'DBM::Deep::Engine::File';
+
+ $args->{engine} = $class->new({
+ %{$args},
+ obj => $self,
+ });
+ }
# Grab the parameters we want to use
foreach my $param ( keys %$self ) {
}
eval {
- local $SIG{'__DIE__'};
+ local $SIG{'__DIE__'};
- $self->lock_exclusive;
- $self->_engine->setup( $self );
- $self->unlock;
+ $self->lock_exclusive;
+ $self->_engine->setup( $self );
+ $self->unlock;
}; if ( $@ ) {
- my $e = $@;
- eval { local $SIG{'__DIE__'}; $self->unlock; };
- die $e;
+ my $e = $@;
+ eval { local $SIG{'__DIE__'}; $self->unlock; };
+ die $e;
}
return $self;
if ( $r eq 'ARRAY' ) {
$tied = tied(@$value);
}
- # This assumes hash or array only. This is a bad assumption moving
- # forward. -RobK, 2008-05-27
- else {
+ elsif ( $r eq 'HASH' ) {
$tied = tied(%$value);
}
+ else {
+ __PACKAGE__->_throw_error( "Unknown type for '$value'" );
+ }
- if ( eval { local $SIG{__DIE__}; $tied->isa( 'DBM::Deep' ) } ) {
+ if ( eval { local $SIG{__DIE__}; $tied->isa( __PACKAGE__ ) } ) {
${$spot} = $tied->_repr;
$tied->_copy_node( ${$spot} );
}
}
my $c = Scalar::Util::blessed( $value );
- if ( defined $c && !$c->isa( 'DBM::Deep') ) {
+ if ( defined $c && !$c->isa( __PACKAGE__ ) ) {
${$spot} = bless ${$spot}, $c
}
}
return $r if 'HASH' eq $r;
return $r if 'ARRAY' eq $r;
- DBM::Deep->_throw_error(
+ __PACKAGE__->_throw_error(
"Storage of references of type '$r' is not supported."
);
}
my $type = $self->_check_legality( $struct );
if ( !$type ) {
- DBM::Deep->_throw_error( "Cannot import a scalar" );
+ __PACKAGE__->_throw_error( "Cannot import a scalar" );
}
if ( substr( $type, 0, 1 ) ne $self->_type ) {
- DBM::Deep->_throw_error(
+ __PACKAGE__->_throw_error(
"Cannot import " . ('HASH' eq $type ? 'a hash' : 'an array')
. " into " . ('HASH' eq $type ? 'an array' : 'a hash')
);
#XXX Should we use tempfile() here instead of a hard-coded name?
my $temp_filename = $self->_engine->storage->{file} . '.tmp';
- my $db_temp = DBM::Deep->new(
+ my $db_temp = __PACKAGE__->new(
file => $temp_filename,
type => $self->_type,
##
my $self = shift->_get_self;
- return DBM::Deep->new(
+ return __PACKAGE__->new(
type => $self->_type,
base_offset => $self->_base_offset,
staleness => $self->_staleness,
$value = $self->_engine->storage->{filter_store_value}->( $value );
}
- $self->_engine->write_value( $self, $key, $value);
+ $self->_engine->write_value( $self, $key, $value );
$self->unlock;
$self->lock_shared;
- my $result = $self->_engine->read_value( $self, $key);
+ my $result = $self->_engine->read_value( $self, $key );
$self->unlock;
=over 4
-=item * C<DBM::Deep-E<gt>TYPE_HASH>
+=item * C<<DBM::Deep->TYPE_HASH>>
-=item * C<DBM::Deep-E<gt>TYPE_ARRAY>.
+=item * C<<DBM::Deep->TYPE_ARRAY>>
=back
This only takes effect when beginning a new file. This is an optional
-parameter, and defaults to C<DBM::Deep-E<gt>TYPE_HASH>.
+parameter, and defaults to C<<DBM::Deep->TYPE_HASH>>.
=item * locking
As with hashes, you can treat any DBM::Deep object like a normal Perl array
reference. This includes inserting, removing and manipulating elements,
and the C<push()>, C<pop()>, C<shift()>, C<unshift()> and C<splice()> functions.
-The object must have first been created using type C<DBM::Deep-E<gt>TYPE_ARRAY>,
+The object must have first been created using type C<<DBM::Deep->TYPE_ARRAY>>,
or simply be a nested array reference inside a hash. Example:
my $db = DBM::Deep->new(
push @$db, "bar", "baz";
unshift @$db, "bah";
- my $last_elem = pop @$db; # baz
- my $first_elem = shift @$db; # bah
- my $second_elem = $db->[1]; # bar
+ my $last_elem = pop @$db; # baz
+ my $first_elem = shift @$db; # bah
+ my $second_elem = $db->[1]; # bar
my $num_elements = scalar @$db;
by specifying the 'pack_size' parameter when constructing the file.
DBM::Deep->new(
- filename => $filename,
+ file => $filename,
pack_size => 'large',
);
instead of 32-bit longs. After setting these values your DB files have a
theoretical maximum size of 16 XB (exabytes).
-You can also use C<pack_size =E<gt> 'small'> in order to use 16-bit file
+You can also use C<<pack_size => 'small'>> in order to use 16-bit file
offsets.
B<Note:> Changing these values will B<NOT> work for existing database files.
=head2 External references and transactions
-If you do C<my $x = $db-E<gt>{foo};>, then start a transaction, $x will be
+If you do C<<my $x = $db->{foo};>>, then start a transaction, $x will be
referencing the database from outside the transaction. A fix for this (and other
issues with how external references into the database) is being looked into. This
is the skipped set of tests in t/39_singletons.t and a related issue is the focus
--- /dev/null
+package DBM::Deep::Engine::DBI;
+
+use 5.006_000;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base 'DBM::Deep::Engine';
+
+sub read_value {
+ my $self = shift;
+ my ($obj, $key) = @_;
+}
+
+sub get_classname {
+ my $self = shift;
+ my ($obj) = @_;
+}
+
+sub make_reference {
+ my $self = shift;
+ my ($obj, $old_key, $new_key) = @_;
+}
+
+sub key_exists {
+ my $self = shift;
+ my ($obj, $key) = @_;
+}
+
+sub delete_key {
+ my $self = shift;
+ my ($obj, $key) = @_;
+}
+
+sub write_value {
+ my $self = shift;
+ my ($obj, $key, $value) = @_;
+
+ my $r = Scalar::Util::reftype( $value ) || '';
+ {
+ last if $r eq '';
+ last if $r eq 'HASH';
+ last if $r eq 'ARRAY';
+
+ DBM::Deep->_throw_error(
+ "Storage of references of type '$r' is not supported."
+ );
+ }
+
+ # Load the reference entry
+ # Determine if the row was deleted under us
+ #
+
+ my ($type);
+ if ( $r eq 'ARRAY' || $r eq 'HASH' ) {
+ my $tmpvar;
+ if ( $r eq 'ARRAY' ) {
+ $tmpvar = tied @$value;
+ } elsif ( $r eq 'HASH' ) {
+ $tmpvar = tied %$value;
+ }
+
+ if ( $tmpvar ) {
+ my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
+
+ unless ( $is_dbm_deep ) {
+ DBM::Deep->_throw_error( "Cannot store something that is tied." );
+ }
+
+ unless ( $tmpvar->_engine->storage == $self->storage ) {
+ DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
+ }
+
+ # Load $tmpvar's sector
+
+ # First, verify if we're storing the same thing to this spot. If we
+ # are, then this should be a no-op. -EJS, 2008-05-19
+
+ # See whether or not we are storing ourselves to ourself.
+ # Write the sector as data in this reference (keyed by $key)
+ $value_sector->increment_refcount;
+
+ return 1;
+ }
+
+ $type = substr( $r, 0, 1 );
+ }
+ else {
+ if ( tied($value) ) {
+ DBM::Deep->_throw_error( "Cannot store something that is tied." );
+ }
+ }
+
+ # This code is to make sure we write all the values in the $value to the
+ # disk and to make sure all changes to $value after the assignment are
+ # reflected on disk. This may be counter-intuitive at first, but it is
+ # correct dwimmery.
+ # NOTE - simply tying $value won't perform a STORE on each value. Hence,
+ # the copy to a temp value.
+ if ( $r eq 'ARRAY' ) {
+ my @temp = @$value;
+ tie @$value, 'DBM::Deep', {
+ base_offset => $value_sector->offset,
+ staleness => $value_sector->staleness,
+ storage => $self->storage,
+ engine => $self,
+ };
+ @$value = @temp;
+ bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
+ }
+ elsif ( $r eq 'HASH' ) {
+ my %temp = %$value;
+ tie %$value, 'DBM::Deep', {
+ base_offset => $value_sector->offset,
+ staleness => $value_sector->staleness,
+ storage => $self->storage,
+ engine => $self,
+ };
+
+ %$value = %temp;
+ bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
+ }
+
+ return 1;
+}
+
+sub setup {
+ my $self = shift;
+ my ($obj) = @_;
+}
+
+sub begin_work {
+ my $self = shift;
+ my ($obj) = @_;
+}
+
+sub rollback {
+ my $self = shift;
+ my ($obj) = @_;
+}
+
+sub commit {
+ my $self = shift;
+ my ($obj) = @_;
+}
+
+
+1;
+__END__
use base qw( DBM::Deep::Engine );
-# Never import symbols into our namespace. We are a class, not a library.
use Scalar::Util ();
-use DBM::Deep::Storage::File ();
-
-use DBM::Deep::Engine::Sector::Data ();
-use DBM::Deep::Engine::Sector::BucketList ();
-use DBM::Deep::Engine::Sector::Index ();
-use DBM::Deep::Engine::Sector::Null ();
-use DBM::Deep::Engine::Sector::Reference ();
-use DBM::Deep::Engine::Sector::Scalar ();
use DBM::Deep::Null ();
+use DBM::Deep::Sector::File ();
+use DBM::Deep::Storage::File ();
my $STALE_SIZE = 2;
my ($obj, $key) = @_;
# This will be a Reference sector
- my $sector = $self->_load_sector( $obj->_base_offset )
+ my $sector = DBM::Deep::Sector::File->load( $self, $obj->_base_offset )
or return;
if ( $sector->staleness != $obj->_staleness ) {
});
unless ( $value_sector ) {
- $value_sector = DBM::Deep::Engine::Sector::Null->new({
+ $value_sector = DBM::Deep::Sector::File::Null->new({
engine => $self,
data => undef,
});
my ($obj) = @_;
# This will be a Reference sector
- my $sector = $self->_load_sector( $obj->_base_offset )
+ my $sector = DBM::Deep::Sector::File->load( $self, $obj->_base_offset )
or DBM::Deep->_throw_error( "How did get_classname fail (no sector for '$obj')?!" );
if ( $sector->staleness != $obj->_staleness ) {
my ($obj, $old_key, $new_key) = @_;
# This will be a Reference sector
- my $sector = $self->_load_sector( $obj->_base_offset )
+ my $sector = DBM::Deep::Sector::File->load( $self, $obj->_base_offset )
or DBM::Deep->_throw_error( "How did make_reference fail (no sector for '$obj')?!" );
if ( $sector->staleness != $obj->_staleness ) {
});
unless ( $value_sector ) {
- $value_sector = DBM::Deep::Engine::Sector::Null->new({
+ $value_sector = DBM::Deep::Sector::File::Null->new({
engine => $self,
data => undef,
});
});
}
- if ( $value_sector->isa( 'DBM::Deep::Engine::Sector::Reference' ) ) {
+ if ( $value_sector->isa( 'DBM::Deep::Sector::File::Reference' ) ) {
$sector->write_data({
key => $new_key,
key_md5 => $self->_apply_digest( $new_key ),
my ($obj, $key) = @_;
# This will be a Reference sector
- my $sector = $self->_load_sector( $obj->_base_offset )
+ my $sector = DBM::Deep::Sector::File->load( $self, $obj->_base_offset )
or return '';
if ( $sector->staleness != $obj->_staleness ) {
my $self = shift;
my ($obj, $key) = @_;
- my $sector = $self->_load_sector( $obj->_base_offset )
+ my $sector = DBM::Deep::Sector::File->load( $self, $obj->_base_offset )
or return;
if ( $sector->staleness != $obj->_staleness ) {
}
# This will be a Reference sector
- my $sector = $self->_load_sector( $obj->_base_offset )
+ my $sector = DBM::Deep::Sector::File->load( $self, $obj->_base_offset )
or DBM::Deep->_throw_error( "Cannot write to a deleted spot in DBM::Deep." );
if ( $sector->staleness != $obj->_staleness ) {
my ($class, $type);
if ( !defined $value ) {
- $class = 'DBM::Deep::Engine::Sector::Null';
+ $class = 'DBM::Deep::Sector::File::Null';
}
elsif ( $r eq 'ARRAY' || $r eq 'HASH' ) {
my $tmpvar;
DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
}
- # First, verify if we're storing the same thing to this spot. If we are, then
- # this should be a no-op. -EJS, 2008-05-19
+ # First, verify if we're storing the same thing to this spot. If we
+ # are, then this should be a no-op. -EJS, 2008-05-19
my $loc = $sector->get_data_location_for({
key_md5 => $self->_apply_digest( $key ),
allow_head => 1,
}
#XXX Can this use $loc?
- my $value_sector = $self->_load_sector( $tmpvar->_base_offset );
+ my $value_sector = DBM::Deep::Sector::File->load( $self, $tmpvar->_base_offset );
$sector->write_data({
key => $key,
key_md5 => $self->_apply_digest( $key ),
return 1;
}
- $class = 'DBM::Deep::Engine::Sector::Reference';
+ $class = 'DBM::Deep::Sector::File::Reference';
$type = substr( $r, 0, 1 );
}
else {
if ( tied($value) ) {
DBM::Deep->_throw_error( "Cannot store something that is tied." );
}
- $class = 'DBM::Deep::Engine::Sector::Scalar';
+ $class = 'DBM::Deep::Sector::File::Scalar';
}
- # Create this after loading the reference sector in case something bad happens.
- # This way, we won't allocate value sector(s) needlessly.
+ # Create this after loading the reference sector in case something bad
+ # happens. This way, we won't allocate value sector(s) needlessly.
my $value_sector = $class->new({
engine => $self,
data => $value,
value => $value_sector,
});
- # This code is to make sure we write all the values in the $value to the disk
- # and to make sure all changes to $value after the assignment are reflected
- # on disk. This may be counter-intuitive at first, but it is correct dwimmery.
- # NOTE - simply tying $value won't perform a STORE on each value. Hence, the
- # copy to a temp value.
+ # This code is to make sure we write all the values in the $value to the
+ # disk and to make sure all changes to $value after the assignment are
+ # reflected on disk. This may be counter-intuitive at first, but it is
+ # correct dwimmery.
+ # NOTE - simply tying $value won't perform a STORE on each value. Hence,
+ # the copy to a temp value.
if ( $r eq 'ARRAY' ) {
my @temp = @$value;
tie @$value, 'DBM::Deep', {
$self->_write_file_header;
# 1) Create Array/Hash entry
- my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
+ my $initial_reference = DBM::Deep::Sector::File::Reference->new({
engine => $self,
type => $obj->_type,
});
# Reading from an existing file
else {
$obj->{base_offset} = $bytes_read;
- my $initial_reference = DBM::Deep::Engine::Sector::Reference->new({
+ my $initial_reference = DBM::Deep::Sector::File::Reference->new({
engine => $self,
offset => $obj->_base_offset,
});
$self->storage->print_at( $read_loc, pack( $StP{$self->byte_size}, 0 ) );
if ( $data_loc > 1 ) {
- $self->_load_sector( $data_loc )->free;
+ DBM::Deep::Sector::File->load( $self, $data_loc )->free;
}
}
);
if ( $head_loc > 1 ) {
- $self->_load_sector( $head_loc )->free;
+ DBM::Deep::Sector::File->load( $self, $head_loc )->free;
}
}
}
}
-=head2 _load_sector( $offset )
-
-This will instantiate and return the sector object that represents the data found
-at $offset.
-
-=cut
-
-sub _load_sector {
- my $self = shift;
- my ($offset) = @_;
-
- # Add a catch for offset of 0 or 1
- return if !$offset || $offset <= 1;
-
- my $type = $self->storage->read_at( $offset, 1 );
- return if $type eq chr(0);
-
- if ( $type eq $self->SIG_ARRAY || $type eq $self->SIG_HASH ) {
- return DBM::Deep::Engine::Sector::Reference->new({
- engine => $self,
- type => $type,
- offset => $offset,
- });
- }
- # XXX Don't we need key_md5 here?
- elsif ( $type eq $self->SIG_BLIST ) {
- return DBM::Deep::Engine::Sector::BucketList->new({
- engine => $self,
- type => $type,
- offset => $offset,
- });
- }
- elsif ( $type eq $self->SIG_INDEX ) {
- return DBM::Deep::Engine::Sector::Index->new({
- engine => $self,
- type => $type,
- offset => $offset,
- });
- }
- elsif ( $type eq $self->SIG_NULL ) {
- return DBM::Deep::Engine::Sector::Null->new({
- engine => $self,
- type => $type,
- offset => $offset,
- });
- }
- elsif ( $type eq $self->SIG_DATA ) {
- return DBM::Deep::Engine::Sector::Scalar->new({
- engine => $self,
- type => $type,
- offset => $offset,
- });
- }
- # This was deleted from under us, so just return and let the caller figure it out.
- elsif ( $type eq $self->SIG_FREE ) {
- return;
- }
-
- DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" );
-}
-
=head2 _apply_digest( @stuff )
This will apply the digest methd (default to Digest::MD5::md5) to the arguments
my %sizes = (
'D' => $self->data_sector_size,
- 'B' => DBM::Deep::Engine::Sector::BucketList->new({engine=>$self,offset=>1})->size,
- 'I' => DBM::Deep::Engine::Sector::Index->new({engine=>$self,offset=>1})->size,
+ 'B' => DBM::Deep::Sector::File::BucketList->new({engine=>$self,offset=>1})->size,
+ 'I' => DBM::Deep::Sector::File::Index->new({engine=>$self,offset=>1})->size,
);
my $return = "";
SECTOR:
while ( $spot < $self->storage->{end} ) {
# Read each sector in order.
- my $sector = $self->_load_sector( $spot );
+ my $sector = DBM::Deep::Sector::File->load( $self, $spot );
if ( !$sector ) {
# Find it in the free-sectors that were found already
foreach my $type ( keys %sectors ) {
use strict;
use warnings FATAL => 'all';
-my $STALE_SIZE = 2;
-
-# Please refer to the pack() documentation for further information
-my %StP = (
- 1 => 'C', # Unsigned char value (no order needed as it's just one byte)
- 2 => 'n', # Unsigned short in "network" (big-endian) order
- 4 => 'N', # Unsigned long in "network" (big-endian) order
- 8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
-);
-
-sub new {
- my $self = bless $_[1], $_[0];
- Scalar::Util::weaken( $self->{engine} );
- $self->_init;
- return $self;
-}
-
-#sub _init {}
-#sub clone { DBM::Deep->_throw_error( "Must be implemented in the child class" ); }
-
-sub engine { $_[0]{engine} }
-sub offset { $_[0]{offset} }
-sub type { $_[0]{type} }
-
-sub base_size {
- my $self = shift;
- return $self->engine->SIG_SIZE + $STALE_SIZE;
-}
-
-sub free {
- my $self = shift;
-
- my $e = $self->engine;
-
- $e->storage->print_at( $self->offset, $e->SIG_FREE );
- # Skip staleness counter
- $e->storage->print_at( $self->offset + $self->base_size,
- chr(0) x ($self->size - $self->base_size),
- );
-
- my $free_meth = $self->free_meth;
- $e->$free_meth( $self->offset, $self->size );
-
- return;
-}
-
1;
__END__
+
+new({
+ engine =>
+ type =>
+ offset =>
+})
+ _init( $args )
+staleness
+get_data_for({
+ key_md5 =>
+ allow_head =>
+})
+get_data_location_for({
+ key_md5 =>
+ allow_head =>
+})
+write_data({
+ key =>
+ key_md5 =>
+ value => $value_sector,
+})
+size
+get_classname
+delete_key({
+ key_md5 =>
+ allow_head =>
+})
+get_refcount
my $self = shift;
my ($loc) = @_;
- my $sector = $self->{engine}->_load_sector( $loc )
+ my $sector = DBM::Deep::Sector::File->load( $self->{engine}, $loc )
or return;
- if ( $sector->isa( 'DBM::Deep::Engine::Sector::Index' ) ) {
+ if ( $sector->isa( 'DBM::Deep::Sector::File::Index' ) ) {
return DBM::Deep::Iterator::Index->new({
iterator => $self,
sector => $sector,
});
}
- elsif ( $sector->isa( 'DBM::Deep::Engine::Sector::BucketList' ) ) {
+ elsif ( $sector->isa( 'DBM::Deep::Sector::File::BucketList' ) ) {
return DBM::Deep::Iterator::BucketList->new({
iterator => $self,
sector => $sector,
unless ( @$crumbs ) {
# This will be a Reference sector
- my $sector = $e->_load_sector( $self->{base_offset} )
+ my $sector = DBM::Deep::Sector::File->load( $e, $self->{base_offset} )
# If no sector is found, this must have been deleted from under us.
or return;
-# This was copied from MARCEL's Class::Null. However, I couldn't use it because
-# I need an undef value, not an implementation of the Null Class pattern.
package DBM::Deep::Null;
use 5.006_000;
my $obj = $tobj->_get_self();
my $vt;
$val = '' unless (defined $val);
- if (ref $val)
- {
+ if (ref $val) {
my $done = 0;
- unless ($obj->{'serialize'})
- {
- if ($val =~ /HASH/)
- {
+ unless ($obj->{'serialize'}) {
+ if ($val =~ /HASH/) {
my $id = $obj->_create('hash');
my $ta = $obj->_tiehash($id);
$dval = $ta;
- foreach my $k (keys %$val)
- {
+ foreach my $k (keys %$val) {
$ta->{$k} = $val->{$k};
}
$vt = 'hash';
$val = $id;
$done = 1;
}
- elsif ($val =~ /ARRAY/)
- {
+ elsif ($val =~ /ARRAY/) {
my $id = $obj->_create('array');
my $ta = $obj->_tiearray($id);
$dval = $ta;
- foreach my $i (0..$#{$val})
- {
+ foreach my $i (0..$#{$val}) {
$ta->[$i] = $val->[$i];
}
$vt = 'array';
$done = 1;
}
}
- unless ($done)
- {
+ unless ($done) {
my $data = nfreeze($val);
$val = $obj->_create('value_data', {
'data' => $data,
$vt = 'data';
}
}
- elsif (length($val) > 255)
- {
+ elsif (length($val) > 255) {
$val = $obj->_create('value_data', {
'data' => $val,
});
$vt = 'text';
}
- else
- {
+ else {
$vt = 'value';
}
my $hcode = md5_base64($k);
},
);
my $create = 1;
- if (scalar @$c)
- {
- if ($c->[0]->[0] eq 'value')
- {
+ if (scalar @$c) {
+ if ($c->[0]->[0] eq 'value') {
$create = 0;
$obj->_update(
'table' => 'rec_hash_item',
},
);
}
- else
- {
+ else {
$obj->_delete($k);
}
}
- if ($create)
- {
+ if ($create) {
my $kt;
- if (length($k) > 255)
- {
+ if (length($k) > 255) {
$k = $obj->_create('value_text', {
'data' => $k,
});
$kt = 'text';
}
- else
- {
+ else {
$kt = 'value';
}
$obj->_create('hash_item', {
--- /dev/null
+package DBM::Deep::Sector;
+
+use 5.006_000;
+
+use strict;
+use warnings FATAL => 'all';
+
+use Scalar::Util ();
+
+sub new {
+ my $self = bless $_[1], $_[0];
+ Scalar::Util::weaken( $self->{engine} );
+ $self->_init;
+ return $self;
+}
+
+sub _init {}
+sub clone { die "clone must be implemented in a child class" }
+
+sub engine { $_[0]{engine} }
+sub offset { $_[0]{offset} }
+sub type { $_[0]{type} }
+
+sub load { die "load must be implemented in a child class" }
+
+1;
+__END__
--- /dev/null
+package DBM::Deep::Sector::File;
+
+use 5.006_000;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base qw( DBM::Deep::Sector );
+
+use DBM::Deep::Sector::File::Reference;
+use DBM::Deep::Sector::File::BucketList;
+use DBM::Deep::Sector::File::Index;
+use DBM::Deep::Sector::File::Null;
+use DBM::Deep::Sector::File::Scalar;
+
+my $STALE_SIZE = 2;
+
+sub base_size {
+ my $self = shift;
+ return $self->engine->SIG_SIZE + $STALE_SIZE;
+}
+
+sub free_meth { die "free_meth must be implemented in a child class" }
+
+sub free {
+ my $self = shift;
+
+ my $e = $self->engine;
+
+ $e->storage->print_at( $self->offset, $e->SIG_FREE );
+ # Skip staleness counter
+ $e->storage->print_at( $self->offset + $self->base_size,
+ chr(0) x ($self->size - $self->base_size),
+ );
+
+ my $free_meth = $self->free_meth;
+ $e->$free_meth( $self->offset, $self->size );
+
+ return;
+}
+
+=head2 load( $offset )
+
+This will instantiate and return the sector object that represents the data
+found at $offset.
+
+=cut
+
+sub load {
+ my $self = shift;
+ my ($engine, $offset) = @_;
+
+ # Add a catch for offset of 0 or 1
+ return if !$offset || $offset <= 1;
+
+ my $type = $engine->storage->read_at( $offset, 1 );
+ return if $type eq chr(0);
+
+ if ( $type eq $engine->SIG_ARRAY || $type eq $engine->SIG_HASH ) {
+ return DBM::Deep::Sector::File::Reference->new({
+ engine => $engine,
+ type => $type,
+ offset => $offset,
+ });
+ }
+ # XXX Don't we need key_md5 here?
+ elsif ( $type eq $engine->SIG_BLIST ) {
+ return DBM::Deep::Sector::File::BucketList->new({
+ engine => $engine,
+ type => $type,
+ offset => $offset,
+ });
+ }
+ elsif ( $type eq $engine->SIG_INDEX ) {
+ return DBM::Deep::Sector::File::Index->new({
+ engine => $engine,
+ type => $type,
+ offset => $offset,
+ });
+ }
+ elsif ( $type eq $engine->SIG_NULL ) {
+ return DBM::Deep::Sector::File::Null->new({
+ engine => $engine,
+ type => $type,
+ offset => $offset,
+ });
+ }
+ elsif ( $type eq $engine->SIG_DATA ) {
+ return DBM::Deep::Sector::File::Scalar->new({
+ engine => $engine,
+ type => $type,
+ offset => $offset,
+ });
+ }
+ # This was deleted from under us, so just return and let the caller figure it out.
+ elsif ( $type eq $engine->SIG_FREE ) {
+ return;
+ }
+
+ DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" );
+}
+
+1;
+__END__
-package DBM::Deep::Engine::Sector::BucketList;
+package DBM::Deep::Sector::File::BucketList;
use 5.006_000;
use strict;
use warnings FATAL => 'all';
-use base qw( DBM::Deep::Engine::Sector );
+use base qw( DBM::Deep::Sector::File );
my $STALE_SIZE = 2;
# Delete the keysector
my $l = unpack( $StP{$e->byte_size}, substr( $rest, $e->hash_size, $e->byte_size ) );
- my $s = $e->_load_sector( $l ); $s->free if $s;
+ my $s = DBM::Deep::Sector::File->load( $e, $l ); $s->free if $s;
# Delete the HEAD sector
$l = unpack( $StP{$e->byte_size},
$e->byte_size,
),
);
- $s = $e->_load_sector( $l ); $s->free if $s;
+ $s = DBM::Deep::Sector::File->load( $e, $l ); $s->free if $s;
foreach my $txn ( 0 .. $e->num_txns - 2 ) {
my $l = unpack( $StP{$e->byte_size},
$e->byte_size,
),
);
- my $s = $e->_load_sector( $l ); $s->free if $s;
+ my $s = DBM::Deep::Sector::File->load( $e, $l ); $s->free if $s;
}
}
$engine->add_entry( $args->{trans_id}, $spot );
unless ($self->{found}) {
- my $key_sector = DBM::Deep::Engine::Sector::Scalar->new({
+ my $key_sector = DBM::Deep::Sector::File::Scalar->new({
engine => $engine,
data => $args->{key},
});
$key_sector->free;
- my $data_sector = $self->engine->_load_sector( $location );
+ my $data_sector = DBM::Deep::Sector::File->load( $self->engine, $location );
my $data = $data_sector->data({ export => 1 });
$data_sector->free;
my $location = $self->get_data_location_for({
allow_head => $args->{allow_head},
});
- return $self->engine->_load_sector( $location );
+ return DBM::Deep::Sector::File->load( $self->engine, $location );
}
sub get_key_for {
$location = unpack( $StP{$self->engine->byte_size}, $location );
DBM::Deep->_throw_error( "get_key_for: No location?" ) unless $location;
- return $self->engine->_load_sector( $location );
+ return DBM::Deep::Sector::File->load( $self->engine, $location );
}
1;
-package DBM::Deep::Engine::Sector::Data;
+package DBM::Deep::Sector::File::Data;
use 5.006_000;
use strict;
use warnings FATAL => 'all';
-use base qw( DBM::Deep::Engine::Sector );
+use base qw( DBM::Deep::Sector::File );
# This is in bytes
sub size { $_[0]{engine}->data_sector_size }
-package DBM::Deep::Engine::Sector::Index;
+package DBM::Deep::Sector::File::Index;
-use base qw( DBM::Deep::Engine::Sector );
+use base qw( DBM::Deep::Sector::File );
my $STALE_SIZE = 2;
for my $i ( 0 .. $e->hash_chars - 1 ) {
my $l = $self->get_entry( $i ) or next;
- $e->_load_sector( $l )->free;
+ DBM::Deep::Sector::File->load( $e, $l )->free;
}
$self->SUPER::free();
-package DBM::Deep::Engine::Sector::Null;
+package DBM::Deep::Sector::File::Null;
use 5.006_000;
use strict;
use warnings FATAL => 'all';
-use base qw( DBM::Deep::Engine::Sector::Data );
+use base qw( DBM::Deep::Sector::File::Data );
my $STALE_SIZE = 2;
-package DBM::Deep::Engine::Sector::Reference;
+package DBM::Deep::Sector::File::Reference;
use 5.006_000;
use strict;
use warnings FATAL => 'all';
-use base qw( DBM::Deep::Engine::Sector::Data );
+use base qw( DBM::Deep::Sector::File::Data );
my $STALE_SIZE = 2;
my $class_offset = 0;
if ( defined $classname ) {
- my $class_sector = DBM::Deep::Engine::Sector::Scalar->new({
+ my $class_sector = DBM::Deep::Sector::File::Scalar->new({
engine => $e,
data => $classname,
});
my $location = $self->get_data_location_for( $args )
or return;
- return $self->engine->_load_sector( $location );
+ return DBM::Deep::Sector::File->load( $self->engine, $location );
}
sub write_data {
my $location = $blist->get_data_location_for({
allow_head => 0,
});
- my $old_value = $location && $self->engine->_load_sector( $location );
+ my $old_value = $location && DBM::Deep::Sector::File->load( $self->engine, $location );
my @trans_ids = $self->engine->get_running_txn_ids;
unless ( $blist_loc ) {
return unless $args->{create};
- my $blist = DBM::Deep::Engine::Sector::BucketList->new({
+ my $blist = DBM::Deep::Sector::File::BucketList->new({
engine => $engine,
key_md5 => $args->{key_md5},
});
return $blist;
}
- my $sector = $engine->_load_sector( $blist_loc )
+ my $sector = DBM::Deep::Sector::File->load( $engine, $blist_loc )
or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
my $i = 0;
my $last_sector = undef;
- while ( $sector->isa( 'DBM::Deep::Engine::Sector::Index' ) ) {
+ while ( $sector->isa( 'DBM::Deep::Sector::File::Index' ) ) {
$blist_loc = $sector->get_entry( ord( substr( $args->{key_md5}, $i++, 1 ) ) );
$last_sector = $sector;
if ( $blist_loc ) {
- $sector = $engine->_load_sector( $blist_loc )
+ $sector = DBM::Deep::Sector::File->load( $engine, $blist_loc )
or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
}
else {
DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" )
unless $last_sector;
- my $blist = DBM::Deep::Engine::Sector::BucketList->new({
+ my $blist = DBM::Deep::Sector::File::BucketList->new({
engine => $engine,
key_md5 => $args->{key_md5},
});
if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) {{
my $redo;
- my $new_index = DBM::Deep::Engine::Sector::Index->new({
+ my $new_index = DBM::Deep::Sector::File::Index->new({
engine => $engine,
});
# XXX This is inefficient
my $blist = $blist_cache{$idx}
- ||= DBM::Deep::Engine::Sector::BucketList->new({
+ ||= DBM::Deep::Sector::File::BucketList->new({
engine => $engine,
});
++$i, ++$redo;
} else {
my $blist = $blist_cache{$idx}
- ||= DBM::Deep::Engine::Sector::BucketList->new({
+ ||= DBM::Deep::Sector::File::BucketList->new({
engine => $engine,
});
$blist->write_md5({
key => $args->{key},
key_md5 => $args->{key_md5},
- value => DBM::Deep::Engine::Sector::Null->new({
+ value => DBM::Deep::Sector::File::Null->new({
engine => $engine,
data => undef,
}),
});
}
# my $blist = $blist_cache{$idx}
-# ||= DBM::Deep::Engine::Sector::BucketList->new({
+# ||= DBM::Deep::Sector::File::BucketList->new({
# engine => $engine,
# });
#
# $blist->write_md5({
# key => $args->{key},
# key_md5 => $args->{key_md5},
-# value => DBM::Deep::Engine::Sector::Null->new({
+# value => DBM::Deep::Sector::File::Null->new({
# engine => $engine,
# data => undef,
# }),
return unless $class_offset;
- return $self->engine->_load_sector( $class_offset )->data;
+ return DBM::Deep::Sector::File->load( $self->engine, $class_offset )->data;
}
sub data {
delete $self->engine->cache->{ $self->offset };
my $blist_loc = $self->get_blist_loc;
- $self->engine->_load_sector( $blist_loc )->free if $blist_loc;
+ DBM::Deep::Sector::File->load( $self->engine, $blist_loc )->free if $blist_loc;
my $class_loc = $self->get_class_offset;
- $self->engine->_load_sector( $class_loc )->free if $class_loc;
+ DBM::Deep::Sector::File->load( $self->engine, $class_loc )->free if $class_loc;
$self->SUPER::free();
}
-package DBM::Deep::Engine::Sector::Scalar;
+package DBM::Deep::Sector::File::Scalar;
use 5.006_000;
use strict;
use warnings FATAL => 'all';
-use base qw( DBM::Deep::Engine::Sector::Data );
+use base qw( DBM::Deep::Sector::File::Data );
my $STALE_SIZE = 2;
$self->SUPER::free();
if ( $chain_loc ) {
- $self->engine->_load_sector( $chain_loc )->free;
+ DBM::Deep::Sector::File->load( $self->engine, $chain_loc )->free;
}
return;
last unless $chain_loc;
- $self = $self->engine->_load_sector( $chain_loc );
+ $self = DBM::Deep::Sector::File->load( $self->engine, $chain_loc );
}
return $data;
--- /dev/null
+package DBM::Deep::Storage;
+
+use 5.006_000;
+
+use strict;
+use warnings FATAL => 'all';
+
+=head2 flush()
+
+This flushes the filehandle. This takes no parameters and returns nothing.
+
+=cut
+
+sub flush { die "flush must be implemented in a child class" }
+
+=head2 is_writable()
+
+This takes no parameters. It returns a boolean saying if this filehandle is
+writable.
+
+Taken from L<http://www.perlmonks.org/?node_id=691054/>.
+
+=cut
+
+sub is_writable { die "is_writable must be implemented in a child class" }
+
+=head1 LOCKING
+
+This is where the actual locking of the storage medium is performed.
+Nested locking is supported.
+
+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.
+
+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.
+
+The following methods manage the locking status. In all cases, they take
+a L<DBM::Deep/> object and returns nothing.
+
+=over 4
+
+=item * lock_exclusive( $obj )
+
+Take a lock usable for writing.
+
+=item * lock_shared( $obj )
+
+Take a lock usable for reading.
+
+=item * unlock( $obj )
+
+Releases the last lock taken. If this is the outermost lock, then the
+object is actually unlocked.
+
+=back
+
+=cut
+
+sub lock_exclusive { die "lock_exclusive must be implemented in a child class" }
+sub lock_shared { die "lock_shared must be implemented in a child class" }
+sub unlock { die "unlock must be implemented in a child class" }
+
+1;
+__END__
--- /dev/null
+package DBM::Deep::Storage::DBI;
+
+use 5.006_000;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base 'DBM::Deep::Storage';
+
+sub is_writable {
+ my $self = shift;
+ return 1;
+}
+
+sub lock_exclusive {
+ my $self = shift;
+}
+
+sub lock_shared {
+ my $self = shift;
+}
+
+sub unlock {
+ my $self = shift;
+}
+
+1;
+__END__
use constant DEBUG => 0;
+use base 'DBM::Deep::Storage';
+
=head1 NAME
DBM::Deep::Storage::File
return $loc;
}
-=head2 flush()
-
-This flushes the filehandle. This takes no parameters and returns nothing.
-
-=cut
-
-sub flush {
- my $self = shift;
-
- # Flush the filehandle
- my $old_fh = select $self->{fh};
- my $old_af = $|; $| = 1; $| = $old_af;
- select $old_fh;
-
- return 1;
-}
-
-=head2 is_writable()
-
-This takes no parameters. It returns a boolean saying if this filehandle is
-writable.
-
-Taken from L<http://www.perlmonks.org/?node_id=691054/>.
-
-=cut
-
-sub is_writable {
- my $self = shift;
-
- 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 '';
-}
-
=head2 copy_stats( $target_filename )
This will take the stats for the current filehandle and apply them to
chmod( $perms, $temp_filename );
}
-=head1 LOCKING
-
-This is where the actual locking of the storage medium is performed.
-Nested locking is supported.
-
-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.
-
-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.
-
-The following methods manage the locking status. In all cases, they take
-a L<DBM::Deep/> object and returns nothing.
-
-=over 4
-
-=item * lock_exclusive( $obj )
-
-Take a lock usable for writing.
-
-=item * lock_shared( $obj )
-
-Take a lock usable for reading.
+sub flush {
+ my $self = shift;
-=item * unlock( $obj )
+ # Flush the filehandle
+ my $old_fh = select $self->{fh};
+ my $old_af = $|; $| = 1; $| = $old_af;
+ select $old_fh;
-Releases the last lock taken. If this is the outermost lock, then the
-object is actually unlocked.
+ return 1;
+}
-=back
+sub is_writable {
+ my $self = shift;
-=cut
+ 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 lock_exclusive {
my $self = shift;
projects / dbsrgits/DBM-Deep.git / commitdiff