From: Rob Kinyon Date: Sat, 26 Dec 2009 01:35:40 +0000 (-0500) Subject: Fixed a bug with DBI iterators and made the tets self-bootstrapping and added the... X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=350896ee7e5b32e5f965e84f445df47113573a72;p=dbsrgits%2FDBM-Deep.git Fixed a bug with DBI iterators and made the tets self-bootstrapping and added the NO_TEST_FILE option to the test runs and fixed a mistake in testplans. --- diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index 94c296f..bf507fc 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -57,73 +57,6 @@ sub new { 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; diff --git a/lib/DBM/Deep/Engine/DBI.pm b/lib/DBM/Deep/Engine/DBI.pm index 7d28615..c00227a 100644 --- a/lib/DBM/Deep/Engine/DBI.pm +++ b/lib/DBM/Deep/Engine/DBI.pm @@ -96,12 +96,14 @@ sub read_value { 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) = @_; diff --git a/lib/DBM/Deep/Iterator.pm b/lib/DBM/Deep/Iterator.pm index 4dfe3e0..1082983 100644 --- a/lib/DBM/Deep/Iterator.pm +++ b/lib/DBM/Deep/Iterator.pm @@ -43,13 +43,14 @@ sub new { my ($args) = @_; my $self = bless { - breadcrumbs => [], engine => $args->{engine}, base_offset => $args->{base_offset}, }, $class; Scalar::Util::weaken( $self->{engine} ); + $self->reset; + return $self; } @@ -63,18 +64,7 @@ This method returns nothing. =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 ) diff --git a/lib/DBM/Deep/Iterator/DBI.pm b/lib/DBM/Deep/Iterator/DBI.pm index 3b8f1c8..31ec7b8 100644 --- a/lib/DBM/Deep/Iterator/DBI.pm +++ b/lib/DBM/Deep/Iterator/DBI.pm @@ -5,5 +5,29 @@ use warnings FATAL => 'all'; 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__ diff --git a/lib/DBM/Deep/Iterator/File.pm b/lib/DBM/Deep/Iterator/File.pm index d2d5437..b38ed94 100644 --- a/lib/DBM/Deep/Iterator/File.pm +++ b/lib/DBM/Deep/Iterator/File.pm @@ -8,6 +8,8 @@ use base qw( DBM::Deep::Iterator ); 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) = @_; @@ -16,13 +18,13 @@ sub get_sector_iterator { 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, }); @@ -69,7 +71,7 @@ sub get_next_key { 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 ) { @@ -78,7 +80,7 @@ sub get_next_key { 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" ); diff --git a/lib/DBM/Deep/Sector/DBI.pm b/lib/DBM/Deep/Sector/DBI.pm index ed00cbf..8b0765d 100644 --- a/lib/DBM/Deep/Sector/DBI.pm +++ b/lib/DBM/Deep/Sector/DBI.pm @@ -37,10 +37,18 @@ sub load { }); } 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'" ); diff --git a/lib/DBM/Deep/Sector/DBI/Reference.pm b/lib/DBM/Deep/Sector/DBI/Reference.pm index e6a0ccc..d224760 100644 --- a/lib/DBM/Deep/Sector/DBI/Reference.pm +++ b/lib/DBM/Deep/Sector/DBI/Reference.pm @@ -54,14 +54,26 @@ sub write_data { 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; } @@ -76,12 +88,86 @@ sub delete_key { 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__ diff --git a/lib/DBM/Deep/Storage/DBI.pm b/lib/DBM/Deep/Storage/DBI.pm index b86f809..da5c89e 100644 --- a/lib/DBM/Deep/Storage/DBI.pm +++ b/lib/DBM/Deep/Storage/DBI.pm @@ -98,22 +98,16 @@ sub write_to { 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}; @@ -121,10 +115,15 @@ sub write_to { 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}, ); } diff --git a/t/02_hash.t b/t/02_hash.t index 039e134..a317fa3 100644 --- a/t/02_hash.t +++ b/t/02_hash.t @@ -50,7 +50,6 @@ while ( my $dbm_maker = $dbm_factory->() ) { # # Q: How do we make sure that the iterator is unique? Is it supposed to be? -=pod ## # count keys ## @@ -174,7 +173,6 @@ while ( my $dbm_maker = $dbm_factory->() ) { throws_ok { $db->exists(undef); } qr/Cannot use an undefined hash key/, "EXISTS fails on an undefined key"; -=cut } done_testing; diff --git a/t/41_transaction_multilevel.t b/t/41_transaction_multilevel.t index 338a1cd..b392144 100644 --- a/t/41_transaction_multilevel.t +++ b/t/41_transaction_multilevel.t @@ -1,5 +1,5 @@ use strict; -use Test::More tests => 41; +use Test::More; use Test::Deep; use t::common qw( new_dbm ); diff --git a/t/common.pm b/t/common.pm index 1d47d04..f34c900 100644 --- a/t/common.pm +++ b/t/common.pm @@ -29,9 +29,16 @@ sub new_fh { 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 ( $@ ) { @@ -40,6 +47,23 @@ sub new_dbm { # } 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}", @@ -52,6 +76,9 @@ sub new_dbm { 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, @_,