my $args = $class->_get_args( @_ );
my $self;
-=pod
- if (exists $args->{dbi}) {
- eval {
- require DBIx::Abstract;
- }; if ( $@ ) {
- __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) {
- __PACKAGE__->_throw_error('Invalid SQL record id');
- }
- my $util = {dbi => $args->{dbi}};
- bless $util, 'DBM::Deep::SQL::Util';
- my $q = $util->_select(
- table => 'rec_item',
- fields => 'item_type',
- where => {id => $args->{id}},
- );
- if ($q->[0]->[0] eq 'array') {
- $args->{type} = TYPE_ARRAY;
- }
- elsif ($q->[0]->[0] eq 'hash') {
- $args->{type} = TYPE_HASH;
- }
- else {
- DBM::Deep->_throw_error('Unknown SQL record id');
- }
- }
- else {
- my $util = {dbi => $args->{dbi}};
- bless $util, 'DBM::Deep::SQL::Util';
- if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
- $args->{id} = $util->_create('array');
- }
- else {
- $args->{id} = $util->_create('hash');
- }
- }
-
- if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
- $class = 'DBM::Deep::SQL::Array';
- require DBM::Deep::SQL::Array;
- tie @$self, $class, %$args;
- if ($args->{prefetch}) {
- (tied(@$self))->_prefetch();
- }
- return bless $self, $class;
- }
- else {
- $class = 'DBM::Deep::SQL::Hash';
- require DBM::Deep::SQL::Hash;
- tie %$self, $class, %$args;
- if ($args->{prefetch}) {
- (tied(%$self))->_prefetch();
- }
- return bless $self, $class;
- }
- }
-=cut
-
- ##
- # Check if we want a tied hash or array.
- ##
if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
$class = 'DBM::Deep::Array';
require DBM::Deep::Array;
return $value_sector->data;
}
-=pod
sub get_classname {
my $self = shift;
my ($obj) = @_;
+
+ return;
}
+=pod
sub make_reference {
my $self = shift;
my ($obj, $old_key, $new_key) = @_;
my ($args) = @_;
my $self = bless {
- breadcrumbs => [],
engine => $args->{engine},
base_offset => $args->{base_offset},
}, $class;
Scalar::Util::weaken( $self->{engine} );
+ $self->reset;
+
return $self;
}
=cut
-sub reset { $_[0]{breadcrumbs} = []; return }
-
-=head2 get_sector_iterator( $loc )
-
-This takes a location. It will load the sector for $loc, then instantiate the
-right iteartor type for it.
-
-This returns the sector iterator.
-
-=cut
-
-sub get_sector_iterator { die "get_sector_iterator must be implemented in a child class" }
+sub reset { die "reset must be implemented in a child class" }
=head2 get_next_key( $obj )
use base qw( DBM::Deep::Iterator );
+sub reset {
+ my $self = shift;
+
+ eval { $self->{sth}->finish; };
+ delete $self->{sth};
+
+ return;
+}
+
+sub get_next_key {
+ my $self = shift;
+ my ($obj) = @_;
+
+ unless ( exists $self->{sth} ) {
+ $self->{sth} = $self->{engine}->storage->{dbh}->prepare(
+ "SELECT `key` FROM datas WHERE ref_id = ? ORDER BY RAND()",
+ );
+ $self->{sth}->execute( $self->{base_offset} );
+ }
+
+ my ($key) = $self->{sth}->fetchrow_array;
+ return $key;
+}
+
1;
__END__
use DBM::Deep::Iterator::File::BucketList ();
use DBM::Deep::Iterator::File::Index ();
+sub reset { $_[0]{breadcrumbs} = []; return }
+
sub get_sector_iterator {
my $self = shift;
my ($loc) = @_;
or return;
if ( $sector->isa( 'DBM::Deep::Sector::File::Index' ) ) {
- return DBM::Deep::Iterator::Index->new({
+ return DBM::Deep::Iterator::File::Index->new({
iterator => $self,
sector => $sector,
});
}
elsif ( $sector->isa( 'DBM::Deep::Sector::File::BucketList' ) ) {
- return DBM::Deep::Iterator::BucketList->new({
+ return DBM::Deep::Iterator::File::BucketList->new({
iterator => $self,
sector => $sector,
});
redo FIND_NEXT_KEY;
}
- if ( $iterator->isa( 'DBM::Deep::Iterator::Index' ) ) {
+ if ( $iterator->isa( 'DBM::Deep::Iterator::File::Index' ) ) {
# If we don't have any more, it will be caught at the
# prior check.
if ( my $next = $iterator->get_next_iterator ) {
redo FIND_NEXT_KEY;
}
- unless ( $iterator->isa( 'DBM::Deep::Iterator::BucketList' ) ) {
+ unless ( $iterator->isa( 'DBM::Deep::Iterator::File::BucketList' ) ) {
DBM::Deep->_throw_error(
"Should have a bucketlist iterator here - instead have $iterator"
);
});
}
elsif ( $type eq 'datas' ) {
- return DBM::Deep::Sector::DBI::Scalar->new({
+ my $sector = DBM::Deep::Sector::DBI::Scalar->new({
engine => $engine,
offset => $offset,
});
+
+ if ( $sector->{data_type} eq 'R' ) {
+ return $self->load(
+ $engine, $sector->{offset}, 'refs',
+ );
+ }
+
+ return $sector;
}
DBM::Deep->_throw_error( "'$offset': Don't know what to do with type '$type'" );
my $self = shift;
my ($args) = @_;
- $self->engine->storage->write_to(
- datas => $args->{value}{offset},
- ref_id => $self->offset,
- data_type => 'S',
- key => $args->{key},
- value => $args->{value}{data},
- class => $args->{value}{class},
- );
+ if ( ( $args->{value}->type || 'S' ) eq 'S' ) {
+ $self->engine->storage->write_to(
+ datas => $args->{value}{offset},
+ ref_id => $self->offset,
+ data_type => 'S',
+ key => $args->{key},
+ value => $args->{value}{data},
+ class => $args->{value}{class},
+ );
+ }
+ else {
+ $self->engine->storage->write_to(
+ datas => $args->{value}{offset},
+ ref_id => $self->offset,
+ data_type => 'R',
+ key => $args->{key},
+ value => $args->{value}{offset},
+ class => $args->{value}{class},
+ );
+ }
$args->{value}->reload;
}
my $data;
if ( $old_value ) {
- $data = $old_value->data;
+ $data = $old_value->data({ export => 1 });
$old_value->free;
}
return $data;
}
+sub get_classname {
+ my $self = shift;
+ return;
+}
+
+sub data {
+ my $self = shift;
+ my ($args) = @_;
+ $args ||= {};
+
+ my $obj = DBM::Deep->new({
+ type => $self->type,
+ base_offset => $self->offset,
+# staleness => $self->staleness,
+ storage => $self->engine->storage,
+ engine => $self->engine,
+ });
+
+ if ( $self->engine->storage->{autobless} ) {
+ my $classname = $self->get_classname;
+ if ( defined $classname ) {
+ bless $obj, $classname;
+ }
+ }
+
+ # We're not exporting, so just return.
+ unless ( $args->{export} ) {
+ return $obj;
+ }
+
+ # We shouldn't export if this is still referred to.
+ if ( $self->get_refcount > 1 ) {
+ return $obj;
+ }
+
+ return $obj->export;
+}
+
+sub free {
+ my $self = shift;
+
+ # We're not ready to be removed yet.
+ if ( $self->decrement_refcount > 0 ) {
+ return;
+ }
+
+ $self->engine->storage->delete_from(
+ 'datas', { ref_id => $self->offset },
+ );
+
+ $self->engine->storage->delete_from(
+ 'datas', { value => $self->offset, data_type => 'R' },
+ );
+
+ $self->SUPER::free( @_ );
+}
+
+sub increment_refcount {
+ return 1;
+}
+
+sub decrement_refcount {
+ return 0;
+}
+
+sub get_refcount {
+ return 1;
+}
+
+sub write_refcount {
+ my $self = shift;
+ my ($num) = @_;
+}
+
1;
__END__
my $self = shift;
my ($table, $id, %args) = @_;
- if ( $id ) {
- $self->{dbh}->do(
- "DELETE FROM $table WHERE id = $id",
- );
- }
-
my @keys = keys %args;
my $sql =
- "INSERT INTO $table ( `id`, "
+ "REPLACE INTO $table ( `id`, "
. join( ',', map { "`$_`" } @keys )
. ") VALUES ("
. join( ',', ('?') x (@keys + 1) )
. ")";
- warn $sql. $/;
- no warnings;
- warn "@args{@keys}\n";
+#warn $sql. $/;
+#no warnings;
+#warn "@args{@keys}\n";
$self->{dbh}->do( $sql, undef, $id, @args{@keys} );
return $self->{dbh}{mysql_insertid};
sub delete_from {
my $self = shift;
- my ($table, $id) = @_;
+ my ($table, $cond) = @_;
+
+ $cond = { id => $cond } unless ref $cond;
+
+ my @keys = keys %$cond;
+ my $where = join ' AND ', map { "`$_` = ?" } @keys;
$self->{dbh}->do(
- "DELETE FROM $table WHERE id = ?", undef, $id,
+ "DELETE FROM $table WHERE $where", undef, @{$cond}{@keys},
);
}
#
# Q: How do we make sure that the iterator is unique? Is it supposed to be?
-=pod
##
# count keys
##
throws_ok {
$db->exists(undef);
} qr/Cannot use an undefined hash key/, "EXISTS fails on an undefined key";
-=cut
}
done_testing;
use strict;
-use Test::More tests => 41;
+use Test::More;
use Test::Deep;
use t::common qw( new_dbm );
sub new_dbm {
my @args = @_;
my ($fh, $filename) = new_fh();
- my @extra_args = (
- [ file => $filename ],
- );
+
+ my @reset_funcs;
+ my @extra_args;
+
+ unless ( $ENV{NO_TEST_FILE} ) {
+ push @reset_funcs, undef;
+ push @extra_args, (
+ [ file => $filename ],
+ );
+ }
# eval { require DBD::SQLite; };
# unless ( $@ ) {
# }
if ( $ENV{TEST_MYSQL_DSN} ) {
+ push @reset_funcs, sub {
+ my $dbh = DBI->connect(
+ "dbi:mysql:$ENV{TEST_MYSQL_DSN}",
+ $ENV{TEST_MYSQL_USER},
+ $ENV{TEST_MYSQL_PASS},
+ );
+ my $sql = do {
+ my $filename = 'etc/mysql_tables.sql';
+ open my $fh, '<', $filename
+ or die "Cannot open '$filename' for reading: $!\n";
+ local $/;
+ <$fh>
+ };
+ foreach my $line ( split ';', $sql ) {
+ $dbh->do( "$line" ) if $line =~ /\S/;
+ }
+ };
push @extra_args, [
dbi => {
dsn => "dbi:mysql:$ENV{TEST_MYSQL_DSN}",
return sub {
return unless @extra_args;
my @these_args = @{ shift @extra_args };
+ if ( my $reset = shift @reset_funcs ) {
+ $reset->();
+ }
return sub {
DBM::Deep->new(
@these_args, @args, @_,
projects / dbsrgits/DBM-Deep.git / commitdiff