Skip to content

Instantly share code, notes, and snippets.

@markpasc

markpasc/dod-release-05-to-trunk-changes.diff

Created November 17, 2008 18:56
Show Gist options
  • Save markpasc/25861 to your computer and use it in GitHub Desktop.
Save markpasc/25861 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
dod-release-05-to-trunk-changes.diff
Index: t/11-sql.t
===================================================================
--- t/11-sql.t (.../tags/release-0.05) (revision 528)
+++ t/11-sql.t (.../trunk) (revision 528)
@@ -3,7 +3,7 @@
use strict;
use Data::ObjectDriver::SQL;
-use Test::More tests => 58;
+use Test::More tests => 67;
my $stmt = ns();
ok($stmt, 'Created SQL object');
@@ -212,4 +212,48 @@
LIMIT 2
SQL
+# DISTINCT
+$stmt = ns();
+$stmt->add_select(foo => 'foo');
+$stmt->from([ qw(baz) ]);
+is($stmt->as_sql, "SELECT foo\nFROM baz\n", "DISTINCT is absent by default");
+$stmt->distinct(1);
+is($stmt->as_sql, "SELECT DISTINCT foo\nFROM baz\n", "we can turn on DISTINCT");
+
+# index hint
+$stmt = ns();
+$stmt->add_select(foo => 'foo');
+$stmt->from([ qw(baz) ]);
+is($stmt->as_sql, "SELECT foo\nFROM baz\n", "index hint is absent by default");
+$stmt->add_index_hint('baz' => { type => 'USE', list => ['index_hint']});
+is($stmt->as_sql, "SELECT foo\nFROM baz USE INDEX (index_hint)\n", "we can turn on USE INDEX");
+
+# index hint with joins
+$stmt->joins([]);
+$stmt->from([]);
+$stmt->add_join(baz => { type => 'inner', table => 'baz',
+ condition => 'baz.baz_id = foo.baz_id' });
+is($stmt->as_sql, "SELECT foo\nFROM baz USE INDEX (index_hint) INNER JOIN baz ON baz.baz_id = foo.baz_id\n", 'USE INDEX with JOIN');
+$stmt->from([]);
+$stmt->joins([]);
+$stmt->add_join(baz => [
+ { type => 'inner', table => 'baz b1',
+ condition => 'baz.baz_id = b1.baz_id AND b1.quux_id = 1' },
+ { type => 'left', table => 'baz b2',
+ condition => 'baz.baz_id = b2.baz_id AND b2.quux_id = 2' },
+ ]);
+is($stmt->as_sql, "SELECT foo\nFROM baz USE INDEX (index_hint) INNER JOIN baz b1 ON baz.baz_id = b1.baz_id AND b1.quux_id = 1 LEFT JOIN baz b2 ON baz.baz_id = b2.baz_id AND b2.quux_id = 2\n", 'USE INDEX with JOINs');
+
+$stmt = ns();
+$stmt->add_select(foo => 'foo');
+$stmt->from([ qw(baz) ]);
+$stmt->comment("mycomment");
+is($stmt->as_sql, "SELECT foo\nFROM baz\n-- mycomment");
+
+$stmt->comment("\nbad\n\nmycomment");
+is($stmt->as_sql, "SELECT foo\nFROM baz\n-- bad", "correctly untainted");
+
+$stmt->comment("G\\G");
+is($stmt->as_sql, "SELECT foo\nFROM baz\n-- G", "correctly untainted");
+
sub ns { Data::ObjectDriver::SQL->new }
Index: t/09-resultset.t
===================================================================
--- t/09-resultset.t (.../tags/release-0.05) (revision 0)
+++ t/09-resultset.t (.../trunk) (revision 528)
@@ -0,0 +1,149 @@
+# $Id: 01-col-inheritance.t 989 2005-09-23 19:58:01Z btrott $
+
+use strict;
+
+use lib 't/lib';
+
+require 't/lib/db-common.pl';
+
+$Data::ObjectDriver::DEBUG = 0;
+use Test::More;
+unless (eval { require DBD::SQLite }) {
+ plan skip_all => 'Tests require DBD::SQLite';
+}
+plan tests => 47;
+
+setup_dbs({
+ global => [ qw( wines ) ],
+});
+
+use Wine;
+use Storable;
+
+my $wine = Wine->new;
+$wine->name("Saumur Champigny, Le Grand Clos 2001");
+$wine->rating(4);
+
+## generate some binary data (SQL_BLOB / MEDIUMBLOB)
+my $glouglou = { tanin => "beaucoup", caudalies => "4" };
+$wine->binchar("xxx\0yyy");
+$wine->content(Storable::nfreeze($glouglou));
+ok($wine->save, 'Object saved successfully');
+
+my $iter;
+
+$iter = Data::ObjectDriver::Iterator->new(sub {});
+my $wine_id = $wine->id;
+undef $wine;
+$wine = Wine->lookup($wine_id);
+
+ok $wine;
+is_deeply Storable::thaw($wine->content), $glouglou;
+SKIP: {
+ skip "Please upgrade to DBD::SQLite 1.11", 1
+ if $DBD::SQLite::VERSION < 1.11;
+ is $wine->binchar, "xxx\0yyy";
+};
+
+Wine->bulk_insert(['name', 'rating'], [['Caymus', 4], ['Thunderbird', 1], ['Stags Leap', 3]]);
+
+
+{
+ my $result = Wine->result({});
+
+ my $objs = $result->slice(0, 100);
+ is @$objs, 4;
+
+ my $rs = $result->slice(0, 2);
+ is @$rs, 3;
+ for my $r (@$rs) {
+ isa_ok $r, 'Wine';
+ }
+}
+
+$wine = undef;
+my ($result) = Wine->result({name => 'Caymus'});
+ok! $result->is_finished;
+$wine = $result->next;
+ok $wine, 'Found Caymus';
+is $wine->name, 'Caymus';
+ok ! $result->next; #sets is_finished()
+ok $result->is_finished;
+
+# testing iterator
+my ($iterator) = $result->iterator([$wine]);
+ok(! $iterator->is_finished );
+$wine = $iterator->next;
+ok $wine, 'Found Caymus';
+is $wine->name, 'Caymus';
+ok( ! $iterator->next );
+ok( $iterator->is_finished );
+
+# testing bug in iterator, adding a limit where there was one before shouldn't invalidate results
+($iterator) = $result->iterator([$wine]);
+$iterator->add_limit(1);
+ok(! $iterator->is_finished );
+$wine = $iterator->next;
+ok $wine, 'Found Caymus';
+is $wine->name, 'Caymus';
+ok ! $iterator->next;
+ok $iterator->is_finished;
+
+
+($result) = Wine->result({}, { sort => 'name', direction => 'ascend' });
+($iterator) = $result->iterator( [ $result->next, $result->next ] );
+$iterator->add_limit(1);
+ok! $iterator->is_finished ;
+$wine = $iterator->next;
+ok $wine, 'Found Caymus';
+is $wine->name, 'Caymus';
+ok ! $iterator->next;
+ok $iterator->is_finished;
+
+
+# raising the limit should trigger a new search
+($result) = Wine->result({}, { sort => 'name', direction => 'ascend' });
+($iterator) = $result->iterator( [ $result->next, $result->next ] );
+$iterator->add_limit(9999);
+ok! $iterator->is_finished;
+$wine = $iterator->next;
+ok $wine, 'Found Caymus';
+is $wine->name, 'Caymus';
+ok $iterator->next, 'more to go';
+ok ! $iterator->is_finished, "we're not finished";
+
+
+# testing limit in args
+($result) = Wine->result({}, { limit => 2, sort => 'name', direction => 'ascend' });
+ok! $result->is_finished ;
+$wine = $result->next;
+is $wine->name, 'Caymus';
+$wine = $result->next;
+is $wine->name, 'Saumur Champigny, Le Grand Clos 2001';
+ok ! $result->next;
+ok $result->is_finished;
+
+# raising the limit should trigger a new search
+($result) = Wine->result({}, { limit => 2, sort => 'name', direction => 'ascend' });
+$result->add_limit(3);
+is $result->next->name, 'Caymus';
+is $result->next->name, 'Saumur Champigny, Le Grand Clos 2001';
+is $result->next->name, 'Stags Leap';
+
+# test slice again with _results_loaded
+$result->rewind;
+{
+ my $rs = $result->slice(0, 2);
+ for my $r (@$rs) {
+ isa_ok $r, 'Wine';
+ }
+
+ my $objs;
+ $objs = $result->slice(0, 100);
+ is @$objs, 3;
+
+ $objs = $result->slice(5, 10);
+ is @$objs, 0;
+}
+
+teardown_dbs(qw( global ));
Index: t/34-both.t
===================================================================
--- t/34-both.t (.../tags/release-0.05) (revision 528)
+++ t/34-both.t (.../trunk) (revision 528)
@@ -18,7 +18,7 @@
}
}
-plan tests => 46;
+plan tests => 86;
use Recipe;
use Ingredient;
@@ -32,6 +32,7 @@
## Install some deflate/inflate in the Cache driver.
{
no warnings 'once';
+ no warnings 'redefine';
*Data::ObjectDriver::Driver::Cache::Cache::deflate = sub {
$_[1]->deflate;
};
@@ -114,15 +115,24 @@
ok !$i4->{__cached};
is $i4->name, 'Flour';
+## verify it's in the cache
+my $key = $i4->driver->cache_key(ref($i4), $i4->primary_key);
+my $data = $i4->driver->get_from_cache($key);
+ok $data;
+is $data->{columns}{id}, $i3->id, "it's in the cache";
## Delete it from the cache, so that the next test is actually accurate.
-my $driver = Ingredient->driver;
-$driver->remove_from_cache($driver->cache_key('Ingredient', $i4->primary_key));
+$i4->uncache_object;
+ok ! $i4->driver->get_from_cache($key), "It's been purged from the cache";
## Now look up the ingredients again. Milk and Eggs should already be cached,
## and doing the search should now cache Flour.
@is = Ingredient->search({ recipe_id => $recipe->recipe_id });
is scalar(@is), 3;
+## this is still working if we add a comment
+@is = Ingredient->search({ recipe_id => $recipe->recipe_id }, { comment => "mytest" });
+is scalar(@is), 3;
+
## Flour should now be cached.
$i4 = Ingredient->lookup([ $recipe->recipe_id, $i3->id ]);
ok $i4->{__cached};
@@ -176,4 +186,6 @@
ok $replaced->{__cached};
is $replaced->title, 'Cup Cake';
+require 't/txn-common.pl';
+
teardown_dbs(qw( global cluster1 cluster2 ));
Index: t/04-clone.t
===================================================================
--- t/04-clone.t (.../tags/release-0.05) (revision 528)
+++ t/04-clone.t (.../trunk) (revision 528)
@@ -18,7 +18,7 @@
}
}
-plan tests => 26;
+plan tests => 29;
use Wine;
use Recipe;
@@ -68,6 +68,10 @@
ok !defined $clone->id, 'Basic clone has no id';
ok $clone->save, 'Basic clone could be saved';
+ is $clone->name, 'Cul de Veau à la Sauge';
+ is $clone->is_changed('name'), '', "This is documentation ;-)";
+ $clone->refresh;
+ is $clone->name, 'Cul de Veau à la Sauge';
ok defined $clone->id, 'Basic clone has an id after saving';
isnt $w->id, $clone->id, q(Basic clone's id differs from original's id);
}
Index: t/35-multiplexed.t
===================================================================
--- t/35-multiplexed.t (.../tags/release-0.05) (revision 528)
+++ t/35-multiplexed.t (.../trunk) (revision 528)
@@ -11,7 +11,7 @@
unless (eval { require DBD::SQLite }) {
plan skip_all => 'Tests require DBD::SQLite';
}
-plan tests => 26;
+plan tests => 42;
setup_dbs({
global1 => [ qw( ingredient2recipe ) ],
@@ -60,6 +60,54 @@
is $ok, 1, "Record is removed from $driver backend database";
}
+## check transactions
+$obj = Ingredient2Recipe->new;
+$obj->ingredient_id(10);
+$obj->recipe_id(50);
+$obj->insert;
+
+Data::ObjectDriver::BaseObject->begin_work();
+$obj->value1("will be rolled back");
+$obj->update;
+Data::ObjectDriver::BaseObject->rollback();
+$obj->refresh;
+is $obj->value1, undef, "properly rolled back";
+_check_object($obj);
+
+Data::ObjectDriver::BaseObject->begin_work();
+$obj->value1("commit");
+$obj->update;
+Data::ObjectDriver::BaseObject->commit();
+$obj->refresh;
+is $obj->value1, "commit", "yay";
+_check_object($obj);
+
+## if something goes wrong writing the second partition we roll back
+## the first one
+## set up a trap:
+my $second_driver = Ingredient2Recipe->driver->drivers->[-1];
+my $dbh = $second_driver->dbh;
+my $sth = $dbh->prepare("insert into ingredient2recipe (ingredient_id, recipe_id, value1) values (199, 199, 'tada')");
+$sth->execute;
+$sth->finish;
+
+Data::ObjectDriver::BaseObject->begin_work();
+$obj = Ingredient2Recipe->new;
+$obj->ingredient_id(199);
+$obj->recipe_id(199);
+$obj->value1("test");
+eval { $obj->insert;};
+ok $@, "rollback";
+if ($@) {
+ Data::ObjectDriver::BaseObject->rollback();
+}
+else {
+ Data::ObjectDriver::BaseObject->commit();
+}
+# since on_lookup use the first driver this should be undef
+my $void = Ingredient2Recipe->lookup(199);
+is $void, undef, "rolled back";
+
## Object remove()
$obj = Ingredient2Recipe->new;
$obj->ingredient_id(4);
Index: t/schemas/ingredient2recipe.sql
===================================================================
--- t/schemas/ingredient2recipe.sql (.../tags/release-0.05) (revision 528)
+++ t/schemas/ingredient2recipe.sql (.../trunk) (revision 528)
@@ -1,5 +1,6 @@
CREATE TABLE ingredient2recipe (
ingredient_id INTEGER NOT NULL,
recipe_id INTEGER NOT NULL,
+ value1 VARCHAR(255),
PRIMARY KEY (recipe_id, ingredient_id)
)
Index: t/05-deflate.t
===================================================================
--- t/05-deflate.t (.../tags/release-0.05) (revision 528)
+++ t/05-deflate.t (.../trunk) (revision 528)
@@ -42,6 +42,7 @@
## Install some deflate/inflate in the Cache driver.
{
no warnings 'once';
+ no warnings 'redefine';
*Data::ObjectDriver::Driver::Cache::Cache::deflate = sub {
$_[1]->deflate;
};
Index: t/31-cached.t
===================================================================
--- t/31-cached.t (.../tags/release-0.05) (revision 528)
+++ t/31-cached.t (.../trunk) (revision 528)
@@ -16,7 +16,7 @@
plan skip_all => 'Tests require Cache::Memory';
}
}
-plan tests => 62;
+plan tests => 100;
setup_dbs({
global => [ qw( recipes ingredients ) ],
@@ -151,6 +151,23 @@
is($ingredient->remove, 1, 'Ingredient removed successfully');
is($ingredient2->remove, 1, 'Ingredient removed successfully');
+
+## demonstration that we have a problem with caching and transaction
+{
+ # ingredient3 should already be hot in the cache anyway
+ Data::ObjectDriver::BaseObject->begin_work;
+ $ingredient3->quantity(300); # originally was 100
+ $ingredient3->save;
+
+ my $same = Ingredient->lookup($ingredient3->primary_key);
+ is $same->quantity, 300;
+
+ Data::ObjectDriver::BaseObject->rollback;
+
+ $same = Ingredient->lookup($ingredient3->primary_key);
+ is $same->quantity, 100;
+}
+
# let's remove ingredient3 with Class methods
eval {
Ingredient->remove({ name => 'Chocolate Chips' }, { nofetch => 1 });
@@ -160,8 +177,9 @@
is(Ingredient->remove({ name => 'Chocolate Chips' }), 1, "Removed with class method");
ok(! Ingredient->lookup(1), "really deleted");
-
is($recipe->remove, 1, 'Recipe removed successfully');
is($recipe2->remove, 1, 'Recipe removed successfully');
+require 't/txn-common.pl';
+
teardown_dbs(qw( global ));
Index: t/10-resultset-peek.t
===================================================================
--- t/10-resultset-peek.t (.../tags/release-0.05) (revision 0)
+++ t/10-resultset-peek.t (.../trunk) (revision 528)
@@ -0,0 +1,150 @@
+# $Id: 01-col-inheritance.t 989 2005-09-23 19:58:01Z btrott $
+
+# this is about the same test as t/09-resultset.t, but with lots of peek_next'ing
+# going on, to test that new method
+
+use strict;
+
+use lib 't/lib';
+
+require 't/lib/db-common.pl';
+
+$Data::ObjectDriver::DEBUG = 0;
+use Test::More;
+unless (eval { require DBD::SQLite }) {
+ plan skip_all => 'Tests require DBD::SQLite';
+}
+plan tests => 65;
+
+setup_dbs({
+ global => [ qw( wines ) ],
+});
+
+use Wine;
+use Storable;
+
+my $wine = Wine->new;
+$wine->name("Saumur Champigny, Le Grand Clos 2001");
+$wine->rating(4);
+
+## generate some binary data (SQL_BLOB / MEDIUMBLOB)
+my $glouglou = { tanin => "beaucoup", caudalies => "4" };
+$wine->binchar("xxx\0yyy");
+$wine->content(Storable::nfreeze($glouglou));
+ok($wine->save, 'Object saved successfully');
+
+my $iter;
+
+$iter = Data::ObjectDriver::Iterator->new(sub {});
+my $wine_id = $wine->id;
+undef $wine;
+$wine = Wine->lookup($wine_id);
+
+ok $wine;
+is_deeply Storable::thaw($wine->content), $glouglou;
+SKIP: {
+ skip "Please upgrade to DBD::SQLite 1.11", 1
+ if $DBD::SQLite::VERSION < 1.11;
+ is $wine->binchar, "xxx\0yyy";
+};
+
+Wine->bulk_insert(['name', 'rating'], [['Caymus', 4], ['Thunderbird', 1], ['Stags Leap', 3]]);
+
+$wine = undef;
+my ($result) = Wine->result({name => 'Caymus'});
+is $result->peek_next->name, 'Caymus', 'before we start, peek_next says the first one is Caymus';
+ok! $result->is_finished;
+$wine = $result->next;
+ok $wine, 'Found Caymus';
+is $wine->name, 'Caymus';
+ok ! $result->peek_next, "we're at the end of the set";
+ok ! $result->next; #sets is_finished()
+ok ! $result->peek_next, "we're *still* at the end of the set";
+ok $result->is_finished;
+
+# testing iterator
+my ($iterator) = $result->iterator([$wine]);
+is $iterator->peek_next->name, 'Caymus', 'before we start, peek_next says the first one is Caymus';
+ok(! $iterator->is_finished );
+$wine = $iterator->next;
+ok $wine, 'Found Caymus';
+is $wine->name, 'Caymus';
+ok ! $iterator->peek_next, "we're at the end of the set";
+ok( ! $iterator->next );
+ok ! $iterator->peek_next, "we're *still* at the end of the set";
+ok( $iterator->is_finished );
+
+# testing bug in iterator, adding a limit where there was one before shouldn't invalidate results
+($iterator) = $result->iterator([$wine]);
+is $iterator->peek_next->name, 'Caymus', 'before we start, peek_next says the first one is Caymus';
+$iterator->add_limit(1);
+is $iterator->peek_next->name, 'Caymus', 'after adding limit, peek_next says the first one is Caymus';
+ok(! $iterator->is_finished );
+$wine = $iterator->next;
+ok $wine, 'Found Caymus';
+is $wine->name, 'Caymus';
+ok ! $iterator->peek_next, "we're at the end of the set";
+ok ! $iterator->next;
+ok ! $iterator->peek_next, "we're *still* at the end of the set";
+ok $iterator->is_finished;
+
+
+($result) = Wine->result({}, { sort => 'name', direction => 'ascend' });
+($iterator) = $result->iterator( [ $result->next, $result->next ] );
+is $iterator->peek_next->name, 'Caymus', 'before we start, peek_next says the first one is Caymus';
+$iterator->add_limit(1);
+is $iterator->peek_next->name, 'Caymus', 'after adding limit, peek_next says the first one is Caymus';
+ok! $iterator->is_finished ;
+$wine = $iterator->next;
+ok $wine, 'Found Caymus';
+is $wine->name, 'Caymus';
+ok ! $iterator->peek_next, "we're at the end of the set";
+ok ! $iterator->next;
+ok ! $iterator->peek_next, "we're *still* at the end of the set";
+ok $iterator->is_finished;
+
+
+# raising the limit should trigger a new search
+($result) = Wine->result({}, { sort => 'name', direction => 'ascend' });
+($iterator) = $result->iterator( [ $result->next, $result->next ] );
+is $iterator->peek_next->name, 'Caymus', 'before we start, peek_next says the first one is Caymus';
+$iterator->add_limit(9999);
+is $iterator->peek_next->name, 'Caymus', 'after adding limit, peek_next says the first one is Caymus';
+ok! $iterator->is_finished;
+$wine = $iterator->next;
+ok $wine, 'Found Caymus';
+is $wine->name, 'Caymus';
+ok $iterator->peek_next, "more to go";
+ok $iterator->next, 'more to go';
+ok ! $iterator->peek_next, "that was the last one, there are no more";
+ok ! $iterator->is_finished, "we're not finished";
+ok ! $iterator->next; #sets is_finished()
+ok ! $iterator->peek_next, "that was the last one, there are no more";
+ok $iterator->is_finished, "now we are finished";
+
+
+# testing limit in args
+($result) = Wine->result({}, { limit => 2, sort => 'name', direction => 'ascend' });
+is $result->peek_next->name, 'Caymus', 'before we start, peek_next says the first one is Caymus';
+ok! $result->is_finished ;
+$wine = $result->next;
+is $wine->name, 'Caymus';
+is $result->peek_next->name, 'Saumur Champigny, Le Grand Clos 2001', 'the next one will be Saumur';
+$wine = $result->next;
+is $wine->name, 'Saumur Champigny, Le Grand Clos 2001';
+ok ! $result->peek_next, "Saumur was the last one";
+ok ! $result->next;
+ok $result->is_finished;
+ok ! $result->peek_next, "Saumur was really the last one";
+
+# raising the limit should trigger a new search
+($result) = Wine->result({}, { limit => 2, sort => 'name', direction => 'ascend' });
+$result->add_limit(3);
+is $result->next->name, 'Caymus';
+is $result->peek_next->name, 'Saumur Champigny, Le Grand Clos 2001', 'the next one will be Saumur';
+is $result->next->name, 'Saumur Champigny, Le Grand Clos 2001';
+is $result->peek_next->name, 'Stags Leap', 'the next one will be Stags Leap';
+is $result->next->name, 'Stags Leap';
+ok ! $result->peek_next, "Stags Leap was the last one";
+
+teardown_dbs(qw( global ));
Index: t/98-perl_critic.t
===================================================================
--- t/98-perl_critic.t (.../tags/release-0.05) (revision 528)
+++ t/98-perl_critic.t (.../trunk) (revision 528)
@@ -1,6 +1,9 @@
use Test::More;
-eval 'use Test::Perl::Critic';
+eval {
+ require Test::Perl::Critic;
+ Test::Perl::Critic->import( -exclude => ['ProhibitNoStrict'] );
+};
plan skip_all => 'Test::Perl::Critic required to criticise code' if $@;
all_critic_ok();
Index: t/02-basic.t
===================================================================
--- t/02-basic.t (.../tags/release-0.05) (revision 528)
+++ t/02-basic.t (.../trunk) (revision 528)
@@ -19,7 +19,7 @@
}
}
-plan tests => 58;
+plan tests => 67;
use Wine;
use Recipe;
@@ -196,6 +196,7 @@
# emulate a driver which doesn't support REPLACE INTO
{
+ no warnings 'redefine';
local *Data::ObjectDriver::Driver::DBD::SQLite::can_replace = sub { 0 };
$r->title('replaced');
$r->recipe_id("lamer");
@@ -244,5 +245,35 @@
is (Wine->remove({}, { nofetch => 1 }), '0E0', 'removing all bad wine');
}
-#teardown_dbs(qw( global ));
+# different utilities
+{
+ my $w1 = Wine->new;
+ $w1->name("Chateau la pompe");
+ $w1->insert;
+ my $w3 = Wine->new;
+ $w3->name("different");
+ $w3->insert;
+
+ my $w2 = Wine->lookup($w1->id);
+ ok $w1->is_same($w1);
+ ok $w2->is_same($w1);
+ ok $w1->is_same($w2);
+ ok !$w1->is_same($w3);
+ ok !$w3->is_same($w2);
+
+ like $w1->pk_str, qr/\d+/;
+}
+
+# Test the new flag for persistent store insertion
+{
+ my $w = Wine->new(name => 'flag test', rating=> 4);
+ ok !$w->object_is_stored, "this object needs to be saved!";
+ $w->save;
+ ok $w->object_is_stored, "this object is no saved";
+ my $w2 = Wine->lookup( $w->id );
+ ok $w2->object_is_stored, "an object fetched from the database is by definition NOT ephemeral";
+}
+
+teardown_dbs(qw( global ));
+
Index: t/32-partitioned.t
===================================================================
--- t/32-partitioned.t (.../tags/release-0.05) (revision 528)
+++ t/32-partitioned.t (.../trunk) (revision 528)
@@ -10,7 +10,7 @@
unless (eval { require DBD::SQLite }) {
plan skip_all => 'Tests require DBD::SQLite';
}
-plan tests => 52;
+plan tests => 88;
setup_dbs({
global => [ qw( recipes ) ],
@@ -48,6 +48,7 @@
ok(!$iter->(), 'Iterator gave us only one recipe');
is(ref $tmp, 'Recipe', 'Iterator gave us a recipe');
is($tmp->title, 'My Banana Milkshake', 'Title is My Banana Milkshake');
+$iter->end();
my $ingredient = Ingredient->new;
$ingredient->recipe_id($recipe->recipe_id);
@@ -72,6 +73,7 @@
ok(!$iter->(), 'Iterator gave us only one ingredient');
is(ref $tmp, 'Ingredient', 'Iterator gave us an ingredient');
is($tmp->name, 'Vanilla Ice Cream', 'Name is Vanilla Ice Cream');
+$iter->end();
my $ingredient2 = Ingredient->new;
$ingredient2->recipe_id($recipe->recipe_id);
@@ -121,4 +123,6 @@
is $recipe->remove, 1, 'Recipe removed successfully';
is $recipe2->remove, 1, 'Recipe removed successfully';
+require 't/txn-common.pl';
+
teardown_dbs(qw( global cluster1 cluster2 ));
Index: t/lib/partitioned/Recipe.pm
===================================================================
--- t/lib/partitioned/Recipe.pm (.../tags/release-0.05) (revision 528)
+++ t/lib/partitioned/Recipe.pm (.../trunk) (revision 528)
@@ -12,16 +12,22 @@
primary_key => 'recipe_id',
driver => Data::ObjectDriver::Driver::DBI->new(
dsn => 'dbi:SQLite:dbname=global.db',
+ reuse_dbh => 1,
),
});
+my %drivers;
__PACKAGE__->has_partitions(
number => 2,
get_driver => sub {
- return Data::ObjectDriver::Driver::DBI->new(
- dsn => 'dbi:SQLite:dbname=cluster' . shift() . '.db',
- @_,
- ),
+ my $cluster = shift;
+ my $driver = $drivers{$cluster} ||=
+ Data::ObjectDriver::Driver::DBI->new(
+ dsn => 'dbi:SQLite:dbname=cluster' . $cluster . '.db',
+ reuse_dbh => 1,
+ @_,
+ );
+ return $driver;
},
);
Index: t/lib/cached/Recipe.pm
===================================================================
--- t/lib/cached/Recipe.pm (.../tags/release-0.05) (revision 528)
+++ t/lib/cached/Recipe.pm (.../trunk) (revision 528)
@@ -12,6 +12,7 @@
primary_key => 'recipe_id',
driver => Data::ObjectDriver::Driver::DBI->new(
dsn => 'dbi:SQLite:dbname=global.db',
+ reuse_dbh => 1,
),
});
Index: t/lib/cached/Ingredient.pm
===================================================================
--- t/lib/cached/Ingredient.pm (.../tags/release-0.05) (revision 528)
+++ t/lib/cached/Ingredient.pm (.../trunk) (revision 528)
@@ -6,8 +6,7 @@
use Carp ();
use Data::ObjectDriver::Driver::DBI;
-use Data::ObjectDriver::Driver::Cache::Cache;
-use Cache::Memory;
+use Data::ObjectDriver::Driver::Cache::RAM;
our %IDs;
@@ -15,11 +14,11 @@
columns => [ 'id', 'recipe_id', 'name', 'quantity' ],
datasource => 'ingredients',
primary_key => [ 'recipe_id', 'id' ],
- driver => Data::ObjectDriver::Driver::Cache::Cache->new(
- cache => Cache::Memory->new,
+ driver => Data::ObjectDriver::Driver::Cache::RAM->new(
fallback => Data::ObjectDriver::Driver::DBI->new(
dsn => 'dbi:SQLite:dbname=global.db',
pk_generator => \&generate_pk,
+ reuse_dbh => 1,
),
pk_generator => \&generate_pk,
),
Index: t/lib/both/Recipe.pm
===================================================================
--- t/lib/both/Recipe.pm (.../tags/release-0.05) (revision 528)
+++ t/lib/both/Recipe.pm (.../trunk) (revision 528)
@@ -16,17 +16,23 @@
cache => Cache::Memory->new,
fallback => Data::ObjectDriver::Driver::DBI->new(
dsn => 'dbi:SQLite:dbname=global.db',
+ reuse_dbh => 1,
),
),
});
+my %drivers;
__PACKAGE__->has_partitions(
number => 2,
get_driver => sub {
- return Data::ObjectDriver::Driver::DBI->new(
- dsn => 'dbi:SQLite:dbname=cluster' . shift() . '.db',
- @_,
- ),
+ my $cluster = shift;
+ my $driver = $drivers{$cluster} ||=
+ Data::ObjectDriver::Driver::DBI->new(
+ dsn => 'dbi:SQLite:dbname=cluster' . $cluster . '.db',
+ reuse_dbh => 1,
+ @_,
+ );
+ return $driver;
},
);
Index: t/lib/multiplexed/Ingredient2Recipe.pm
===================================================================
--- t/lib/multiplexed/Ingredient2Recipe.pm (.../tags/release-0.05) (revision 528)
+++ t/lib/multiplexed/Ingredient2Recipe.pm (.../trunk) (revision 528)
@@ -16,7 +16,7 @@
);
__PACKAGE__->install_properties({
- columns => [ 'recipe_id', 'ingredient_id' ],
+ columns => [ 'recipe_id', 'ingredient_id', "value1" ],
datasource => 'ingredient2recipe',
primary_key => 'recipe_id', ## should match lookup XXX could we auto generate it ?
driver => Data::ObjectDriver::Driver::Multiplexer->new(
Index: t/txn-common.pl
===================================================================
--- t/txn-common.pl (.../tags/release-0.05) (revision 0)
+++ t/txn-common.pl (.../trunk) (revision 528)
@@ -0,0 +1,139 @@
+# $Id: db-common.pl 58 2006-05-04 00:04:10Z sky $
+
+use strict;
+use Test::More;
+
+diag "executing common tests";
+use Data::ObjectDriver::BaseObject;
+
+## testing basic rollback
+{
+ Data::ObjectDriver::BaseObject->begin_work;
+
+ my $recipe = Recipe->new;
+ $recipe->title('gratin dauphinois');
+ ok($recipe->save, 'Object saved successfully');
+ ok(my $recipe_id = $recipe->recipe_id, 'Recipe has an ID');
+ is($recipe->title, 'gratin dauphinois', 'Title is set');
+
+ my $ingredient = Ingredient->new;
+ $ingredient->recipe_id($recipe->recipe_id);
+ $ingredient->name('cheese');
+ $ingredient->quantity(10);
+ ok($ingredient->save, 'Ingredient saved successfully');
+ ok(my $ingredient_pk = $ingredient->primary_key, 'Ingredient has an ID');
+ ok($ingredient->id, 'ID is defined');
+ is($ingredient->name, 'cheese', 'got a name for the ingredient');
+
+ #use YAML; warn Dump (Data::ObjectDriver::BaseObject->txn_debug);
+ Data::ObjectDriver::BaseObject->rollback;
+
+ ## check that we don't have a trace of all the good stuff we cooked
+ is(Recipe->lookup($recipe_id), undef, "no trace of object");
+ is(eval { Ingredient->lookup($ingredient_pk) }, undef, "no trace of object");
+ is(Recipe->lookup_multi([ $recipe_id ])->[0], undef);
+}
+
+## testing basic commit
+{
+ Data::ObjectDriver::BaseObject->begin_work;
+
+ my $recipe = Recipe->new;
+ $recipe->title('gratin dauphinois');
+ ok($recipe->save, 'Object saved successfully');
+ ok(my $recipe_id = $recipe->recipe_id, 'Recipe has an ID');
+ is($recipe->title, 'gratin dauphinois', 'Title is set');
+
+ my $ingredient = Ingredient->new;
+ $ingredient->recipe_id($recipe->recipe_id);
+ $ingredient->name('cheese');
+ $ingredient->quantity(10);
+ ok($ingredient->save, 'Ingredient saved successfully');
+ ok(my $ingredient_pk = $ingredient->primary_key, 'Ingredient has an ID');
+ ok($ingredient->id, 'ID is defined');
+ is($ingredient->name, 'cheese', 'got a name for the ingredient');
+
+ Data::ObjectDriver::BaseObject->commit;
+
+ ## check that we don't have a trace of all the good stuff we cooked
+ ok(Recipe->lookup($recipe_id), "still here");
+ ok(Ingredient->lookup($ingredient_pk), "still here");
+ ok defined Recipe->lookup_multi([ $recipe_id ])->[0];
+
+ ## and now test a rollback of a remove
+ Data::ObjectDriver::BaseObject->begin_work;
+ $ingredient->remove;
+ Data::ObjectDriver::BaseObject->rollback;
+ ok(Ingredient->lookup($ingredient_pk), "still here");
+
+ ## finally let's delete it
+ Data::ObjectDriver::BaseObject->begin_work;
+ $ingredient->remove;
+ Data::ObjectDriver::BaseObject->commit;
+ ok(! Ingredient->lookup($ingredient_pk), "finally deleted");
+}
+
+## nested transactions
+{
+ ## if there is no transaction active this will just warn
+ is( Data::ObjectDriver::BaseObject->txn_active, 0);
+ diag "will warn";
+ Data::ObjectDriver::BaseObject->commit;
+ is( Data::ObjectDriver::BaseObject->txn_active, 0);
+
+ ## do a commit in the end
+ Data::ObjectDriver::BaseObject->begin_work;
+ is( Data::ObjectDriver::BaseObject->txn_active, 1);
+
+ my $recipe = Recipe->new;
+ $recipe->title('lasagnes');
+ ok($recipe->save, 'Object saved successfully');
+ diag $recipe->recipe_id;
+
+ diag "will warn";
+ Data::ObjectDriver::BaseObject->begin_work;
+ Data::ObjectDriver::BaseObject->begin_work;
+ is( Data::ObjectDriver::BaseObject->txn_active, 3);
+
+
+ my $ingredient = Ingredient->new;
+ $ingredient->recipe_id($recipe->recipe_id);
+ $ingredient->name("pasta");
+ ok $ingredient->insert;
+
+ Data::ObjectDriver::BaseObject->rollback;
+ Data::ObjectDriver::BaseObject->commit;
+ Data::ObjectDriver::BaseObject->commit;
+ is( Data::ObjectDriver::BaseObject->txn_active, 0);
+
+ $recipe = Recipe->lookup($recipe->primary_key);
+ $ingredient = Ingredient->lookup($ingredient->primary_key);
+ ok $recipe, "got committed";
+ ok $ingredient, "got committed";
+ is $ingredient->name, "pasta";
+
+ ## now test the same thing with a rollback in the end
+ Data::ObjectDriver::BaseObject->begin_work;
+
+ $recipe = Recipe->new;
+ $recipe->title('lasagnes');
+ ok($recipe->save, 'Object saved successfully');
+
+ diag "will warn";
+ Data::ObjectDriver::BaseObject->begin_work;
+
+ $ingredient = Ingredient->new;
+ $ingredient->recipe_id($recipe->recipe_id);
+ $ingredient->name("more layers");
+ ok $ingredient->insert;
+
+ Data::ObjectDriver::BaseObject->commit;
+ Data::ObjectDriver::BaseObject->rollback;
+
+ $recipe = Recipe->lookup($recipe->primary_key);
+ $ingredient = eval { Ingredient->lookup($ingredient->primary_key) };
+ ok ! $recipe, "rollback";
+ ok ! $ingredient, "rollback";
+}
+
+1;
Property changes on: t/txn-common.pl
___________________________________________________________________
Name: svn:executable
+ *
Index: t/12-windows.t
===================================================================
--- t/12-windows.t (.../tags/release-0.05) (revision 0)
+++ t/12-windows.t (.../trunk) (revision 528)
@@ -0,0 +1,104 @@
+# $Id$
+
+use strict;
+
+use Data::Dumper;
+use lib 't/lib';
+use lib 't/lib/cached';
+
+require 't/lib/db-common.pl';
+
+use Test::More;
+use Test::Exception;
+use Scalar::Util;
+BEGIN {
+ unless (eval { require DBD::SQLite }) {
+ plan skip_all => 'Tests require DBD::SQLite';
+ }
+ unless (eval { require Cache::Memory }) {
+ plan skip_all => 'Tests require Cache::Memory';
+ }
+}
+
+plan tests => 19;
+
+use Recipe;
+use Ingredient;
+
+setup_dbs({
+ global => [ qw( recipes ingredients ) ],
+});
+
+my $r = Recipe->new;
+$r->title("Spaghetti");
+$r->save;
+
+my $i = Ingredient->new;
+$i->name("Oregano");
+$i->recipe_id($r->recipe_id);
+ok( $i->save, "Saved first ingredient" );
+
+$i = Ingredient->new;
+$i->name("Salt");
+$i->recipe_id($r->recipe_id);
+ok( $i->save, "Saved second ingredient" );
+
+$i = Ingredient->new;
+$i->name("Onion");
+$i->recipe_id($r->recipe_id);
+ok( $i->save, "Saved third ingredient" );
+
+my $load_count = 0;
+my $trigger = sub { $load_count++ };
+Ingredient->add_trigger( 'post_load', $trigger );
+
+$load_count = 0;
+Ingredient->driver->clear_cache;
+my $iter = Ingredient->search();
+$iter->end;
+is( $load_count, 3, "Default behavior: load all objects with plain search method" );
+
+$load_count = 0;
+Ingredient->driver->clear_cache;
+$iter = Ingredient->search( undef, { window_size => 1 });
+$i = $iter->();
+$iter->end;
+is( $load_count, 1, "1 ingredient loaded when window size = 1" );
+
+$load_count = 0;
+Ingredient->driver->clear_cache;
+$iter = Ingredient->search( undef, { window_size => 2 });
+$i = $iter->();
+$iter->end;
+is( $load_count, 2, "2 ingredients loaded" );
+
+$load_count = 0;
+Ingredient->driver->clear_cache;
+$iter = Ingredient->search( undef, { window_size => 1, sort => "name", direction => "asc" });
+my $i1 = $iter->();
+ok($i1, "First row from windowed select returned");
+is( $i1->name, "Onion", "Name is 'Onion'" );
+my $i2 = $iter->();
+ok( $i2, "Second row from windowed select returned");
+is( $i2->name, "Oregano", "Name is 'Oregano'" );
+ok( $iter->(), "Third row from windowed select returned" );
+ok( ! $iter->(), "No more rows, which is okay" );
+is( $load_count, 3, "3 objects loaded");
+$iter->end;
+
+$load_count = 0;
+Ingredient->driver->clear_cache;
+$iter = Ingredient->search( undef, { window_size => 5, limit => 2, sort => "name", direction => "asc" });
+$i1 = $iter->();
+ok($i1, "First row from windowed select returned");
+is( $i1->name, "Onion", "Name is 'Onion'" );
+$i2 = $iter->();
+ok( $i2, "Second row from windowed select returned");
+is( $i2->name, "Oregano", "Name is 'Oregano'" );
+ok( !$iter->(), "No third row; limit argument respected" );
+is( $load_count, 2, "2 objects loaded; limit argument respected");
+$iter->end;
+
+teardown_dbs(qw( global ));
+
+print Dumper( Data::ObjectDriver->profiler->query_log ) if $ENV{DOD_PROFILE};
Property changes on: t/12-windows.t
___________________________________________________________________
Name: svn:keywords
+ Id Revision
Index: lib/Data/ObjectDriver/ResultSet.pm
===================================================================
--- lib/Data/ObjectDriver/ResultSet.pm (.../tags/release-0.05) (revision 528)
+++ lib/Data/ObjectDriver/ResultSet.pm (.../trunk) (revision 528)
@@ -7,6 +7,7 @@
use strict;
use base qw( Class::Accessor::Fast );
+use List::Util qw(min);
## Public/_Private Accessors
@@ -91,6 +92,7 @@
my $cur_terms = $self->_terms || {};
my $filter_terms = $self->_filter_terms || {};
foreach my $k (keys %$terms) {
+ $self->_results_loaded(0) unless $cur_terms->{$k};
$cur_terms->{$k} = $terms->{$k};
$filter_terms->{$k} = 1 if $self->_results_loaded;
}
@@ -107,10 +109,12 @@
foreach my $k (keys %$args) {
my $val = $args->{$k};
- # If we get a limit arg that is bigger than our existing limit, then
+ # If we get a limit arg that is bigger than our existing limit (and
+ # we *have* an existing limit), then
# make sure we force a requery. Same for any filter arguments.
# Same for offset arg that is smaller than existing one.
- if ((($k eq 'limit') and (($cur_args->{'limit'}||0) < $val)) or
+ if ((($k eq 'limit') and
+ ( exists $cur_args->{'limit'} && defined $cur_args->{'limit'} && ($cur_args->{'limit'}||0) < $val)) or
(($k eq 'offset') and (($cur_args->{'offset'}||0) > $val)) or
($k eq 'filters')) {
$self->_results_loaded(0);
@@ -136,7 +140,9 @@
if ref $term_names ne 'ARRAY';
foreach my $n (@$term_names) {
- delete $terms->{$n};
+ if (delete $terms->{$n}) {
+ $self->_results_loaded(0);
+ }
}
}
@@ -211,6 +217,23 @@
}
}
+# look at next() without incrementing the cursor
+# like if you just want to see what's coming down the road at you
+sub peek_next {
+ my $self = shift;
+
+ return if $self->is_finished;
+
+ # Load the results and return an object
+ my $results = $self->_load_results;
+
+ my $obj = $results->[$self->_cursor + 1];
+
+ return $obj;
+}
+
+
+
sub prev {
my $self = shift;
@@ -239,13 +262,14 @@
sub slice {
my $self = shift;
my ($start, $end) = @_;
- my $limit = $end - $start;
# Do we already have results?
if ($self->_results) {
- return @{ $self->_results }[$start, $end];
+ return [ @{ $self->_results }[$start..min($self->count-1, $end)] ];
}
+ my $limit = $end - $start + 1;
+
$self->add_offset($start);
$self->add_limit($limit);
@@ -254,6 +278,21 @@
return $r;
}
+sub all {
+ my $self = shift;
+
+ return unless $self->count;
+
+ my @obj;
+ push @obj, $self->first;
+ while (my $obj = $self->next) {
+ push @obj, $obj;
+ }
+
+ $self->rewind;
+ return @obj;
+}
+
sub count {
my $self = shift;
@@ -415,6 +454,12 @@
return \@r;
}
+sub rewind {
+ my $self = shift;
+ $self->is_finished(0);
+ $self->_cursor(-1);
+ return $self;
+}
1;
__END__
@@ -739,6 +784,39 @@
$obj = $res->next;
+=head2 peek_next
+
+Retrieve the next item in the resultset WITHOUT advancing the cursor.
+
+Arguments:
+
+=over 4
+
+=item I<none>
+
+=back
+
+; Return value
+: The next object or undef if past the end of the result set
+
+; Notes
+: Calling this method will force a DB query. All subsequent calls to I<curr> will return this object
+
+; Example
+
+ while ($bottle = $res->next){
+
+ if ($bottle->type eq 'Bud Light'
+ && $res->peek_next->type eq 'Chimay'){
+
+ $bottle->pass; #don't spoil my palate
+
+ }else{
+ $bottle->drink;
+ }
+ }
+
+
=head2 prev
Retrieve the previous item in the result set
@@ -859,6 +937,10 @@
Set this and you'll see $Data::ObjectDriver::DEBUG output when
I go to get the results.
+=head2 rewind
+
+Move back to the start of the iterator for this instance of results of a query.
+
=head2 first
Returns the first object in the result set.
Index: lib/Data/ObjectDriver/SQL.pm
===================================================================
--- lib/Data/ObjectDriver/SQL.pm (.../tags/release-0.05) (revision 528)
+++ lib/Data/ObjectDriver/SQL.pm (.../trunk) (revision 528)
@@ -6,12 +6,18 @@
use base qw( Class::Accessor::Fast );
-__PACKAGE__->mk_accessors(qw( select select_map select_map_reverse from joins where bind limit offset group order having where_values column_mutator ));
+__PACKAGE__->mk_accessors(qw(
+ select distinct select_map select_map_reverse
+ from joins where bind limit offset group order
+ having where_values column_mutator index_hint
+ comment
+));
sub new {
my $class = shift;
my $stmt = $class->SUPER::new(@_);
$stmt->select([]);
+ $stmt->distinct(0);
$stmt->select_map({});
$stmt->select_map_reverse({});
$stmt->bind([]);
@@ -20,6 +26,7 @@
$stmt->where_values({});
$stmt->having([]);
$stmt->joins([]);
+ $stmt->index_hint({});
$stmt;
}
@@ -41,22 +48,34 @@
};
}
+sub add_index_hint {
+ my $stmt = shift;
+ my($table, $hint) = @_;
+ $stmt->index_hint->{$table} = {
+ type => $hint->{type} || 'USE',
+ list => ref($hint->{list}) eq 'ARRAY' ? $hint->{list} : [ $hint->{list} ],
+ };
+}
+
sub as_sql {
my $stmt = shift;
my $sql = '';
if (@{ $stmt->select }) {
$sql .= 'SELECT ';
+ $sql .= 'DISTINCT ' if $stmt->distinct;
$sql .= join(', ', map {
my $alias = $stmt->select_map->{$_};
$alias && /(?:^|\.)\Q$alias\E$/ ? $_ : "$_ $alias";
} @{ $stmt->select }) . "\n";
}
$sql .= 'FROM ';
+
## Add any explicit JOIN statements before the non-joined tables.
if ($stmt->joins && @{ $stmt->joins }) {
my $initial_table_written = 0;
for my $j (@{ $stmt->joins }) {
my($table, $joins) = map { $j->{$_} } qw( table joins );
+ $table = $stmt->_add_index_hint($table); ## index hint handling
$sql .= $table unless $initial_table_written++;
for my $join (@{ $j->{joins} }) {
$sql .= ' ' .
@@ -66,7 +85,12 @@
}
$sql .= ', ' if @{ $stmt->from };
}
- $sql .= join(', ', @{ $stmt->from }) . "\n";
+
+ if ($stmt->from && @{ $stmt->from }) {
+ $sql .= join ', ', map { $stmt->_add_index_hint($_) } @{ $stmt->from };
+ }
+
+ $sql .= "\n";
$sql .= $stmt->as_sql_where;
$sql .= $stmt->as_aggregate('group');
@@ -74,7 +98,11 @@
$sql .= $stmt->as_aggregate('order');
$sql .= $stmt->as_limit;
- $sql;
+ my $comment = $stmt->comment;
+ if ($comment && $comment =~ /([ 0-9a-zA-Z.:;()_#&,]+)/) {
+ $sql .= "-- $1" if $1;
+ }
+ return $sql;
}
sub as_limit {
@@ -233,6 +261,19 @@
($term, \@bind, $col);
}
+sub _add_index_hint {
+ my $stmt = shift;
+ my ($tbl_name) = @_;
+ my $hint = $stmt->index_hint->{$tbl_name};
+ return $tbl_name unless $hint && ref($hint) eq 'HASH';
+ if ($hint->{list} && @{ $hint->{list} }) {
+ return $tbl_name . ' ' . uc($hint->{type} || 'USE') . ' INDEX (' .
+ join (',', @{ $hint->{list} }) .
+ ')';
+ }
+ return $tbl_name;
+}
+
1;
__END__
@@ -276,6 +317,10 @@
The database columns to select in a C<SELECT> query.
+=head2 C<distinct> (boolean)
+
+Whether the C<SELECT> query should return DISTINCT rows only.
+
=head2 C<select_map> (hashref)
The map of database column names to object fields in a C<SELECT> query. Use
@@ -401,6 +446,10 @@
Note you can set a single ordering field, or use an arrayref containing
multiple ordering fields.
+=head2 C<$sql-E<gt>comment([ $comment ])>
+
+Returns or sets a simple comment to the SQL statement
+
=head1 USAGE
=head2 C<Data::ObjectDriver::SQL-E<gt>new()>
@@ -421,6 +470,10 @@
C<JOIN> table references for the statement. The structure for the set of joins
are as described for the C<joins> attribute member above.
+=head2 C<$sql-E<gt>add_index_hint($table, $index)>
+
+Specifies a particular index to use for a particular table.
+
=head2 C<$sql-E<gt>add_where($column, $value)>
Adds a condition on the value of the database column C<$column> to the
@@ -518,6 +571,23 @@
HAVING> clause. The expression compares C<$column> using C<$value>, which can
be any of the structures described above for the C<add_where()> method.
+=head2 C<$sql-E<gt>add_index_hint($table, \@hints)>
+
+Addes the index hint into a C<SELECT> query. The structure for the set of
+C<\@hints> are arrayref of hashrefs containing these members:
+
+=over 4
+
+=item * C<type> (scalar)
+
+The name of the type. "USE", "IGNORE or "FORCE".
+
+=item * C<list> (arrayref)
+
+The list of name of indexes which to use.
+
+=back
+
=head2 C<$sql-E<gt>as_sql()>
Returns the SQL fully representing the SQL statement C<$sql>.
Index: lib/Data/ObjectDriver/Driver/DBD.pm
===================================================================
--- lib/Data/ObjectDriver/Driver/DBD.pm (.../tags/release-0.05) (revision 528)
+++ lib/Data/ObjectDriver/Driver/DBD.pm (.../trunk) (revision 528)
@@ -10,6 +10,7 @@
my($name) = @_;
die "No Driver" unless $name;
my $subclass = join '::', $class, $name;
+ no strict 'refs';
unless (defined ${"${subclass}::"}) {
eval "use $subclass"; ## no critic
die $@ if $@;
@@ -40,6 +41,9 @@
sub sql_class { 'Data::ObjectDriver::SQL' }
+# Some drivers have problems with prepared caches
+sub force_no_prepared_cache { 0 };
+
1;
__END__
Index: lib/Data/ObjectDriver/Driver/Partition.pm
===================================================================
--- lib/Data/ObjectDriver/Driver/Partition.pm (.../tags/release-0.05) (revision 528)
+++ lib/Data/ObjectDriver/Driver/Partition.pm (.../trunk) (revision 528)
@@ -3,6 +3,7 @@
package Data::ObjectDriver::Driver::Partition;
use strict;
use warnings;
+use Carp();
use base qw( Data::ObjectDriver Class::Accessor::Fast );
@@ -13,18 +14,21 @@
$driver->SUPER::init(@_);
my %param = @_;
$driver->get_driver($param{get_driver});
+ $driver->{__working_drivers} = [];
$driver;
}
sub lookup {
my $driver = shift;
my($class, $id) = @_;
+ return unless $id;
$driver->get_driver->($id)->lookup($class, $id);
}
sub lookup_multi {
my $driver = shift;
my($class, $ids) = @_;
+ return [] unless @$ids;
$driver->get_driver->($ids->[0])->lookup_multi($class, $ids);
}
@@ -55,9 +59,56 @@
} else {
$d = $driver->get_driver->(@rest);
}
+
+ if ( $driver->txn_active ) {
+ $driver->add_working_driver($d);
+ }
$d->$meth($obj, @rest);
}
+sub add_working_driver {
+ my $driver = shift;
+ my $part_driver = shift;
+ if (! $part_driver->txn_active) {
+ $part_driver->begin_work;
+ push @{$driver->{__working_drivers}}, $part_driver;
+ }
+}
+
+sub commit {
+ my $driver = shift;
+
+ ## if the driver has its own internal txn_active flag
+ ## off, we don't bother ending. Maybe we already did
+ return unless $driver->txn_active;
+
+ $driver->SUPER::commit(@_);
+ _end_txn($driver, 'commit', @_);
+}
+
+sub rollback {
+ my $driver = shift;
+
+ ## if the driver has its own internal txn_active flag
+ ## off, we don't bother ending. Maybe we already did
+ return unless $driver->txn_active;
+
+ $driver->SUPER::rollback(@_);
+ _end_txn($driver, 'rollback', @_);
+}
+
+sub _end_txn {
+ my ($driver, $method) = @_;
+
+ my $wd = $driver->{__working_drivers};
+ $driver->{__working_drivers} = [];
+
+ for my $part_driver (@{ $wd || [] }) {
+ $part_driver->$method;
+ }
+}
+
+
1;
__END__
Index: lib/Data/ObjectDriver/Driver/Multiplexer.pm
===================================================================
--- lib/Data/ObjectDriver/Driver/Multiplexer.pm (.../tags/release-0.05) (revision 528)
+++ lib/Data/ObjectDriver/Driver/Multiplexer.pm (.../trunk) (revision 528)
@@ -93,9 +93,10 @@
my($meth, $obj, @args) = @_;
my $orig_obj = Storable::dclone($obj);
my $ret;
+
## We want to be sure to have the initial and final state of the object
## strictly identical as if we made only one call on $obj
- ## (Perhaps it's a bit overkill ? playing with 'changed_cols' may suffice)
+ ## (Perhaps it's a bit overkill ? playing with 'changed_cols' may do the trick)
for my $sub_driver (@{ $driver->drivers }) {
$obj = Storable::dclone($orig_obj);
$ret = $sub_driver->$meth($obj, @args);
@@ -103,15 +104,33 @@
return $ret;
}
-## Nobody should ask a dbh for us directly, if someone does, this
-## is probably to change handler properties (transaction). So
-## we assume that only the on_lookup is important (I said it was experimental..)
-sub get_dbh {
+sub begin_work {
my $driver = shift;
- my $subdriver = $driver->on_lookup;
- return $subdriver->get_dbh(@_);
+ $driver->SUPER::begin_work(@_);
+ for my $sub_driver (@{ $driver->drivers }) {
+ $sub_driver->begin_work;
+ }
}
+sub commit {
+ my $driver = shift;
+ $driver->SUPER::commit(@_);
+ $driver->_end_txn('commit', @_);
+}
+
+sub rollback {
+ my $driver = shift;
+ $driver->SUPER::rollback(@_);
+ $driver->_end_txn('rollback', @_);
+}
+
+sub _end_txn {
+ my ($driver, $method) = @_;
+ for my $sub_driver (@{ $driver->drivers }) {
+ $sub_driver->$method;
+ }
+}
+
1;
__END__
Index: lib/Data/ObjectDriver/Driver/BaseCache.pm
===================================================================
--- lib/Data/ObjectDriver/Driver/BaseCache.pm (.../tags/release-0.05) (revision 528)
+++ lib/Data/ObjectDriver/Driver/BaseCache.pm (.../trunk) (revision 528)
@@ -9,7 +9,7 @@
use Carp ();
-__PACKAGE__->mk_accessors(qw( cache fallback ));
+__PACKAGE__->mk_accessors(qw( cache fallback txn_buffer));
__PACKAGE__->mk_classdata(qw( Disabled ));
sub deflate { $_[1] }
@@ -29,9 +29,45 @@
or Carp::croak("cache is required");
$driver->fallback($param{fallback})
or Carp::croak("fallback is required");
+ $driver->txn_buffer([]);
$driver;
}
+sub begin_work {
+ my $driver = shift;
+ my $rv = $driver->fallback->begin_work(@_);
+ $driver->SUPER::begin_work(@_);
+ return $rv;
+}
+
+sub commit {
+ my $driver = shift;
+ return unless $driver->txn_active;
+
+ my $rv = $driver->fallback->commit(@_);
+
+ $driver->debug(sprintf("%14s", "COMMIT(" . scalar(@{$driver->txn_buffer}) . ")") . ": driver=$driver");
+ while (my $cb = shift @{$driver->txn_buffer}) {
+ $cb->();
+ }
+ $driver->SUPER::commit(@_);
+
+ return $rv;
+}
+
+sub rollback {
+ my $driver = shift;
+ return unless $driver->txn_active;
+ my $rv = $driver->fallback->rollback(@_);
+
+ $driver->debug(sprintf("%14s", "ROLLBACK(" . scalar(@{$driver->txn_buffer}) . ")") . ": driver=$driver");
+ $driver->txn_buffer([]);
+
+ $driver->SUPER::rollback(@_);
+
+ return $rv;
+}
+
sub cache_object {
my $driver = shift;
my($obj) = @_;
@@ -40,10 +76,12 @@
## If it's already cached in this layer, assume it's already cached in
## all layers below this, as well.
unless (exists $obj->{__cached} && $obj->{__cached}{ref $driver}) {
- $driver->add_to_cache(
+ $driver->modify_cache(sub {
+ $driver->add_to_cache(
$driver->cache_key(ref($obj), $obj->primary_key),
$driver->deflate($obj)
);
+ });
$driver->fallback->cache_object($obj);
}
}
@@ -53,7 +91,7 @@
my($class, $id) = @_;
return unless defined $id;
return $driver->fallback->lookup($class, $id)
- if $driver->Disabled;
+ if $driver->Disabled or $driver->txn_active;
my $key = $driver->cache_key($class, $id);
my $obj = $driver->get_from_cache($key);
if ($obj) {
@@ -83,7 +121,7 @@
my $driver = shift;
my($class, $ids) = @_;
return $driver->fallback->lookup_multi($class, $ids)
- if $driver->Disabled;
+ if $driver->Disabled or $driver->txn_active;
my %id2key = map { $_ => $driver->cache_key($class, $_) } grep { defined } @$ids;
my $got = $driver->get_multi_from_cache(values %id2key);
@@ -149,14 +187,35 @@
local $args->{fetchonly} = $class->primary_key_tuple;
## Disable triggers for this load. We don't want the post_load trigger
## being called twice.
- $args->{no_triggers} = 1;
+ local $args->{no_triggers} = 1;
my @objs = $driver->fallback->search($class, $terms, $args);
- ## Load all of the objects using a lookup_multi, which is fast from
- ## cache.
- my $objs = $driver->lookup_multi($class, [ map { $_->primary_key } @objs ]);
+ my $windowed = (!wantarray) && $args->{window_size};
- $driver->list_or_iterator($objs);
+ if ( $windowed ) {
+ my @window;
+ my $window_size = $args->{window_size};
+ my $iter = sub {
+ my $d = $driver;
+ while ( (!@window) && @objs ) {
+ my $objs = $driver->lookup_multi(
+ $class,
+ [ map { $_->primary_key }
+ splice( @objs, 0, $window_size ) ]
+ );
+ # A small possibility exists that we may fetch
+ # some IDs here that no longer exist; grep these out
+ @window = grep { defined $_ } @$objs if $objs;
+ }
+ return @window ? shift @window : undef;
+ };
+ return Data::ObjectDriver::Iterator->new($iter, sub { @objs = (); @window = () });
+ } else {
+ ## Load all of the objects using a lookup_multi, which is fast from
+ ## cache.
+ my $objs = $driver->lookup_multi($class, [ map { $_->primary_key } @objs ]);
+ return $driver->list_or_iterator($objs);
+ }
}
sub update {
@@ -166,7 +225,9 @@
if $driver->Disabled;
my $ret = $driver->fallback->update($obj);
my $key = $driver->cache_key(ref($obj), $obj->primary_key);
- $driver->update_cache($key, $driver->deflate($obj));
+ $driver->modify_cache(sub {
+ $driver->update_cache($key, $driver->deflate($obj));
+ });
return $ret;
}
@@ -181,7 +242,9 @@
my $ret = $driver->fallback->replace($obj);
if ($has_pk) {
my $key = $driver->cache_key(ref($obj), $obj->primary_key);
- $driver->update_cache($key, $driver->deflate($obj));
+ $driver->modify_cache(sub {
+ $driver->update_cache($key, $driver->deflate($obj));
+ });
}
return $ret;
}
@@ -199,11 +262,22 @@
Carp::croak("nofetch option isn't compatible with a cache driver");
}
if (ref $obj) {
- $driver->remove_from_cache($driver->cache_key(ref($obj), $obj->primary_key));
+ $driver->uncache_object($obj);
}
$driver->fallback->remove(@_);
}
+sub uncache_object {
+ my $driver = shift;
+ my($obj) = @_;
+ my $key = $driver->cache_key(ref($obj), $obj->primary_key);
+ return $driver->modify_cache(sub {
+ delete $obj->{__cached};
+ $driver->remove_from_cache($key);
+ $driver->fallback->uncache_object($obj);
+ });
+}
+
sub cache_key {
my $driver = shift;
my($class, $id) = @_;
@@ -217,6 +291,18 @@
return $key;
}
+# if we're operating within a transaction then we need to buffer CRUD
+# and only commit to the cache upon commit
+sub modify_cache {
+ my ($driver, $cb) = @_;
+
+ unless ($driver->txn_active) {
+ return $cb->();
+ }
+ $driver->debug(sprintf("%14s", "BUFFER(1)") . ": driver=$driver");
+ push @{$driver->txn_buffer} => $cb;
+}
+
sub DESTROY { }
sub AUTOLOAD {
Index: lib/Data/ObjectDriver/Driver/DBD/SQLite.pm
===================================================================
--- lib/Data/ObjectDriver/Driver/DBD/SQLite.pm (.../tags/release-0.05) (revision 528)
+++ lib/Data/ObjectDriver/Driver/DBD/SQLite.pm (.../trunk) (revision 528)
@@ -56,7 +56,10 @@
return 1;
}
+# TODO this should check the version
+sub force_no_prepared_cache { 1 };
+
1;
=pod
Index: lib/Data/ObjectDriver/Driver/DBI.pm
===================================================================
--- lib/Data/ObjectDriver/Driver/DBI.pm (.../tags/release-0.05) (revision 528)
+++ lib/Data/ObjectDriver/Driver/DBI.pm (.../trunk) (revision 528)
@@ -13,8 +13,10 @@
use Data::ObjectDriver::Driver::DBD;
use Data::ObjectDriver::Iterator;
-__PACKAGE__->mk_accessors(qw( dsn username password connect_options dbh get_dbh dbd prefix ));
+__PACKAGE__->mk_accessors(qw( dsn username password connect_options dbh get_dbh dbd prefix reuse_dbh force_no_prepared_cache));
+our $FORCE_NO_PREPARED_CACHE = 0;
+
sub init {
my $driver = shift;
my %param = @_;
@@ -45,21 +47,45 @@
}
}
+# Some versions of SQLite require the undefing to finalise properly
+sub _close_sth {
+ my $sth = shift;
+ $sth->finish;
+ undef $sth;
+}
+
+# Some versions of SQLite have problems with prepared caching due to finalisation order
+sub _prepare_cached {
+ my $driver = shift;
+ my $dbh = shift;
+ my $sql = shift;
+ return ($FORCE_NO_PREPARED_CACHE || $driver->force_no_prepared_cache || $driver->dbd->force_no_prepared_cache)? $dbh->prepare($sql) : $dbh->prepare_cached($sql);
+}
+
+my %Handles;
sub init_db {
my $driver = shift;
my $dbh;
- eval {
- $dbh = DBI->connect($driver->dsn, $driver->username, $driver->password,
- { RaiseError => 1, PrintError => 0, AutoCommit => 1,
- %{$driver->connect_options || {}} })
- or Carp::croak("Connection error: " . $DBI::errstr);
- };
- if ($@) {
- Carp::croak($@);
+ if ($driver->reuse_dbh) {
+ $dbh = $Handles{$driver->dsn};
}
+ unless ($dbh) {
+ eval {
+ $dbh = DBI->connect($driver->dsn, $driver->username, $driver->password,
+ { RaiseError => 1, PrintError => 0, AutoCommit => 1,
+ %{$driver->connect_options || {}} })
+ or Carp::croak("Connection error: " . $DBI::errstr);
+ };
+ if ($@) {
+ Carp::croak($@);
+ }
+ }
+ if ($driver->reuse_dbh) {
+ $Handles{$driver->dsn} = $dbh;
+ }
$driver->dbd->init_dbh($dbh);
$driver->{__dbh_init_by_driver} = 1;
- $dbh;
+ return $dbh;
}
sub rw_handle {
@@ -88,7 +114,7 @@
my $rec = {};
my $sth = $driver->fetch($rec, $obj, $terms, $args);
$sth->fetch;
- $sth->finish;
+ _close_sth($sth);
$driver->end_query($sth);
return $rec;
}
@@ -98,8 +124,8 @@
my($rec, $class, $orig_terms, $orig_args) = @_;
## Use (shallow) duplicates so the pre_search trigger can modify them.
- my $terms = defined $orig_terms ? ( ref $orig_terms eq 'ARRAY' ? [ @$orig_terms ] : { %$orig_terms } ) : undef;
- my $args = defined $orig_args ? { %$orig_args } : undef;
+ my $terms = defined $orig_terms ? ( ref $orig_terms eq 'ARRAY' ? [ @$orig_terms ] : { %$orig_terms } ) : {};
+ my $args = defined $orig_args ? { %$orig_args } : {};
$class->call_trigger('pre_search', $terms, $args);
my $stmt = $driver->prepare_statement($class, $terms, $args);
@@ -114,7 +140,7 @@
$sql .= "\nFOR UPDATE" if $orig_args->{for_update};
my $dbh = $driver->r_handle($class->properties->{db});
$driver->start_query($sql, $stmt->{bind});
- my $sth = $orig_args->{no_cached_prepare} ? $dbh->prepare($sql) : $dbh->prepare_cached($sql);
+ my $sth = $orig_args->{no_cached_prepare} ? $dbh->prepare($sql) : $driver->_prepare_cached($dbh, $sql);
$sth->execute(@{ $stmt->{bind} });
$sth->bind_columns(undef, @bind);
@@ -142,7 +168,7 @@
my $d = $driver;
unless ($sth->fetch) {
- $sth->finish;
+ _close_sth($sth);
$driver->end_query($sth);
return;
}
@@ -151,12 +177,10 @@
$obj->set_values_internal($rec);
## Don't need a duplicate as there's no previous version in memory
## to preserve.
+ $obj->{__is_stored} = 1;
$obj->call_trigger('post_load') unless $args->{no_triggers};
$obj;
};
- my $iterator = Data::ObjectDriver::Iterator->new(
- $iter, sub { $sth->finish; $driver->end_query($sth) },
- );
if (wantarray) {
my @objs = ();
@@ -166,6 +190,9 @@
}
return @objs;
} else {
+ my $iterator = Data::ObjectDriver::Iterator->new(
+ $iter, sub { _close_sth($sth); $driver->end_query($sth) },
+ );
return $iterator;
}
return;
@@ -186,7 +213,7 @@
return [] unless @$ids;
my @got;
## If it's a single-column PK, assume it's in one partition, and
- ## use an OR search.
+ ## use an OR search. FIXME: can we instead check for partitioning?
unless (ref($ids->[0])) {
my $terms = $class->primary_key_to_terms([ $ids ]);
my @sqlgot = $driver->search($class, $terms, { is_pk => 1 });
@@ -194,7 +221,7 @@
@got = map { defined $_ ? $hgot{$_} : undef } @$ids;
} else {
for my $id (@$ids) {
- push @got, $class->driver->lookup($class, $id);
+ push @got, eval{ $class->driver->lookup($class, $id) };
}
}
\@got;
@@ -206,16 +233,16 @@
my $dbh = $driver->r_handle;
$driver->start_query($sql, $bind);
- my $sth = $dbh->prepare_cached($sql);
+ my $sth = $driver->_prepare_cached($dbh, $sql);
$sth->execute(@$bind);
$sth->bind_columns(undef, \my($val));
unless ($sth->fetch) {
- $sth->finish;
+ _close_sth($sth);
$driver->end_query($sth);
return;
}
- $sth->finish;
+ _close_sth($sth);
$driver->end_query($sth);
return $val;
@@ -237,6 +264,7 @@
my $terms = $obj->primary_key_to_terms;
my $class = ref $obj;
+ $terms ||= {};
$class->call_trigger('pre_search', $terms);
my $tbl = $driver->table_for($obj);
@@ -245,10 +273,10 @@
$sql .= $stmt->as_sql_where;
my $dbh = $driver->r_handle($obj->properties->{db});
$driver->start_query($sql, $stmt->{bind});
- my $sth = $dbh->prepare_cached($sql);
+ my $sth = $driver->_prepare_cached($dbh, $sql);
$sth->execute(@{ $stmt->{bind} });
my $exists = $sth->fetch;
- $sth->finish;
+ _close_sth($sth);
$driver->end_query($sth);
return $exists;
@@ -257,8 +285,9 @@
sub replace {
my $driver = shift;
if ($driver->dbd->can_replace) {
- $driver->_insert_or_replace(@_, { replace => 1 });
- } else {
+ return $driver->_insert_or_replace(@_, { replace => 1 });
+ }
+ if (! $driver->txn_active) {
$driver->begin_work;
eval {
$driver->remove(@_);
@@ -269,7 +298,10 @@
Carp::croak("REPLACE transaction error $driver: $@");
}
$driver->commit;
+ return;
}
+ $driver->remove(@_);
+ $driver->insert(@_);
}
sub insert {
@@ -321,7 +353,7 @@
'VALUES (' . join(', ', ('?') x @$cols) . ')' . "\n";
my $dbh = $driver->rw_handle($obj->properties->{db});
$driver->start_query($sql, $obj->{column_values});
- my $sth = $dbh->prepare_cached($sql);
+ my $sth = $driver->_prepare_cached($dbh, $sql);
my $i = 1;
my $col_defs = $obj->properties->{column_defs};
for my $col (@$cols) {
@@ -330,8 +362,9 @@
my $attr = $dbd->bind_param_attributes($type, $obj, $col);
$sth->bind_param($i++, $val, $attr);
}
- $sth->execute;
- $sth->finish;
+ eval { $sth->execute };
+ die "Failed to execute $sql with ".join(", ",@$cols).": $@" if $@;
+ _close_sth($sth);
$driver->end_query($sth);
## Now, if we didn't have an object ID, we need to grab the
@@ -349,12 +382,14 @@
$obj->call_trigger('post_save', $orig_obj);
$obj->call_trigger('post_insert', $orig_obj);
+ $orig_obj->{__is_stored} = 1;
$orig_obj->{changed_cols} = {};
1;
}
sub update {
my $driver = shift;
+
my($orig_obj, $terms) = @_;
## Use a duplicate so the pre_save trigger can modify it.
@@ -387,7 +422,7 @@
my $dbh = $driver->rw_handle($obj->properties->{db});
$driver->start_query($sql, $obj->{column_values});
- my $sth = $dbh->prepare_cached($sql);
+ my $sth = $driver->_prepare_cached($dbh, $sql);
my $i = 1;
my $col_defs = $obj->properties->{column_defs};
for my $col (@changed_cols) {
@@ -403,7 +438,7 @@
}
my $rows = $sth->execute;
- $sth->finish;
+ _close_sth($sth);
$driver->end_query($sth);
$obj->call_trigger('post_save', $orig_obj);
@@ -448,13 +483,14 @@
$sql .= $stmt->as_sql_where;
my $dbh = $driver->rw_handle($obj->properties->{db});
$driver->start_query($sql, $stmt->{bind});
- my $sth = $dbh->prepare_cached($sql);
+ my $sth = $driver->_prepare_cached($dbh, $sql);
my $result = $sth->execute(@{ $stmt->{bind} });
- $sth->finish;
+ _close_sth($sth);
$driver->end_query($sth);
$obj->call_trigger('post_remove', $orig_obj);
+ $orig_obj->{__is_stored} = 1;
return $result;
}
@@ -482,9 +518,9 @@
my $dbh = $driver->rw_handle($class->properties->{db});
$driver->start_query($sql, $stmt->{bind});
- my $sth = $dbh->prepare_cached($sql);
+ my $sth = $driver->_prepare_cached($dbh, $sql);
my $result = $sth->execute(@{ $stmt->{bind} });
- $sth->finish;
+ _close_sth($sth);
$driver->end_query($sth);
return $result;
}
@@ -523,19 +559,29 @@
sub begin_work {
my $driver = shift;
+
+ return if $driver->txn_active;
+
my $dbh = $driver->dbh;
+
unless ($dbh) {
$driver->{__delete_dbh_after_txn} = 1;
$dbh = $driver->rw_handle;
$driver->dbh($dbh);
}
- eval {
- $dbh->begin_work;
- };
- if ($@) {
- $driver->rollback;
- Carp::croak("Begin work failed for driver $driver: $@");
+
+ if ($dbh->{AutoCommit}) {
+ eval {
+ $dbh->begin_work;
+ };
+ if (my $err = $@) {
+ $driver->rollback;
+ Carp::croak("Begin work failed for driver $driver: $err");
+ }
}
+ ## if for some reason AutoCommit was 0 but txn_active was false,
+ ## then we set it to true now
+ $driver->txn_active(1);
}
sub commit { shift->_end_txn('commit') }
@@ -544,11 +590,21 @@
sub _end_txn {
my $driver = shift;
my($action) = @_;
- my $dbh = $driver->dbh
- or Carp::croak("$action called without a stored handle--begin_work?");
- eval { $dbh->$action() };
- if ($@) {
- Carp::croak("$action failed for driver $driver: $@");
+
+ ## if the driver has its own internal txn_active flag
+ ## off, we don't bother ending. Maybe we already did
+ if ($driver->txn_active) {
+ $driver->txn_active(0);
+
+ my $dbh = $driver->dbh
+ or Carp::croak("$action called without a stored handle--begin_work?");
+
+ unless ($dbh->{AutoCommit}) {
+ eval { $dbh->$action() };
+ if ($@) {
+ Carp::croak("$action failed for driver $driver: $@");
+ }
+ }
}
if ($driver->{__delete_dbh_after_txn}) {
$driver->dbh(undef);
@@ -629,8 +685,9 @@
$stmt->order(\@order);
}
}
- $stmt->limit($args->{limit}) if $args->{limit};
- $stmt->offset($args->{offset}) if $args->{offset};
+ $stmt->limit( $args->{limit} ) if $args->{limit};
+ $stmt->offset( $args->{offset} ) if $args->{offset};
+ $stmt->comment( $args->{comment} ) if $args->{comment};
if (my $terms = $args->{having}) {
for my $col (keys %$terms) {
Index: lib/Data/ObjectDriver/BaseObject.pm
===================================================================
--- lib/Data/ObjectDriver/BaseObject.pm (.../tags/release-0.05) (revision 528)
+++ lib/Data/ObjectDriver/BaseObject.pm (.../trunk) (revision 528)
@@ -5,7 +5,7 @@
use warnings;
our $HasWeaken;
-eval "use Scalar::Util qw(weaken)";
+eval q{ use Scalar::Util qw(weaken) }; ## no critic
$HasWeaken = !$@;
use Carp ();
@@ -16,6 +16,10 @@
use Data::ObjectDriver::ResultSet;
+## Global Transaction variables
+our @WorkingDrivers;
+our $TransactionLevel = 0;
+
sub install_properties {
my $class = shift;
my($props) = @_;
@@ -269,6 +273,27 @@
\%terms;
}
+sub is_same {
+ my($obj, $other) = @_;
+
+ my @a;
+ for my $o ($obj, $other) {
+ push @a, [ map { $o->$_() } @{ $o->primary_key_tuple }];
+ }
+ return is_same_array( @a );
+}
+
+sub object_is_stored {
+ my $obj = shift;
+ return $obj->{__is_stored} ? 1 : 0;
+}
+sub pk_str {
+ my ($obj) = @_;
+ my $pk = $obj->primary_key;
+ return $pk unless ref ($pk) eq 'ARRAY';
+ return join (":", @$pk);
+}
+
sub has_primary_key {
my $obj = shift;
return unless @{$obj->primary_key_tuple};
@@ -300,7 +325,7 @@
my $values = shift;
for my $col (keys %$values) {
unless ( $obj->has_column($col) ) {
- Carp::croak("You tried to set inexistent column $col to value $values->{$col} on " . ref($obj));
+ Carp::croak("You tried to set non-existent column $col to value $values->{$col} on " . ref($obj));
}
$obj->$col($values->{$col});
}
@@ -468,24 +493,43 @@
my $class = shift;
my($terms, $args) = @_;
my $driver = $class->driver;
- my @objs = $driver->search($class, $terms, $args);
+ if (wantarray) {
+ my @objs = $driver->search($class, $terms, $args);
- ## Don't attempt to cache objects where the caller specified fetchonly,
- ## because they won't be complete.
- ## Also skip this step if we don't get any objects back from the search
- if (!$args->{fetchonly} || !@objs) {
- for my $obj (@objs) {
- $driver->cache_object($obj) if $obj;
+ ## Don't attempt to cache objects where the caller specified fetchonly,
+ ## because they won't be complete.
+ ## Also skip this step if we don't get any objects back from the search
+ if (!$args->{fetchonly} || !@objs) {
+ for my $obj (@objs) {
+ $driver->cache_object($obj) if $obj;
+ }
}
+ return @objs;
+ } else {
+ my $iter = $driver->search($class, $terms, $args);
+ return $iter if $args->{fetchonly};
+
+ my $caching_iter = sub {
+ my $d = $driver;
+
+ my $o = $iter->();
+ unless ($o) {
+ $iter->end;
+ return;
+ }
+ $driver->cache_object($o);
+ return $o;
+ };
+ return Data::ObjectDriver::Iterator->new($caching_iter, sub { $iter->end });
}
- $driver->list_or_iterator(\@objs);
}
-sub remove { shift->_proxy('remove', @_) }
-sub update { shift->_proxy('update', @_) }
-sub insert { shift->_proxy('insert', @_) }
-sub replace { shift->_proxy('replace', @_) }
-sub fetch_data { shift->_proxy('fetch_data', @_) }
+sub remove { shift->_proxy( 'remove', @_ ) }
+sub update { shift->_proxy( 'update', @_ ) }
+sub insert { shift->_proxy( 'insert', @_ ) }
+sub replace { shift->_proxy( 'replace', @_ ) }
+sub fetch_data { shift->_proxy( 'fetch_data', @_ ) }
+sub uncache_object { shift->_proxy( 'uncache_object', @_ ) }
sub refresh {
my $obj = shift;
@@ -496,12 +540,72 @@
return 1;
}
+## NOTE: I wonder if it could be useful to BaseObject superclass
+## to override the global transaction flag. If so, I'd add methods
+## to manipulate this flag and the working drivers. -- Yann
sub _proxy {
my $obj = shift;
my($meth, @args) = @_;
- $obj->driver->$meth($obj, @args);
+ my $driver = $obj->driver;
+ ## faster than $obj->txn_active && ! $driver->txn_active but see note.
+ if ($TransactionLevel && ! $driver->txn_active) {
+ $driver->begin_work;
+ push @WorkingDrivers, $driver;
+ }
+ $driver->$meth($obj, @args);
}
+sub txn_active { $TransactionLevel }
+
+sub begin_work {
+ my $class = shift;
+ if ($TransactionLevel > 0) {
+ warn __PACKAGE__ . ": one ore more transaction already active: $TransactionLevel";
+ }
+ $TransactionLevel++;
+}
+
+sub commit {
+ my $class = shift;
+ $class->_end_txn('commit');
+}
+
+sub rollback {
+ my $class = shift;
+ $class->_end_txn('rollback');
+}
+
+sub _end_txn {
+ my $class = shift;
+ my $meth = shift;
+
+ ## Ignore nested transactions
+ if ($TransactionLevel > 1) {
+ $TransactionLevel--;
+ return;
+ }
+
+ if (! $TransactionLevel) {
+ warn __PACKAGE__ . ": no transaction active, ignored $meth";
+ return;
+ }
+ my @wd = @WorkingDrivers;
+ $TransactionLevel--;
+ @WorkingDrivers = ();
+
+ for my $driver (@wd) {
+ $driver->$meth;
+ }
+}
+
+sub txn_debug {
+ my $class = shift;
+ return {
+ txn => $TransactionLevel,
+ drivers => \@WorkingDrivers,
+ };
+}
+
sub deflate { { columns => shift->column_values } }
sub inflate {
@@ -930,10 +1034,31 @@
Returns the I<names> of the primary key fields of C<Class> objects.
+=head2 C<$obj-E<gt>is_same($other_obj)>
+
+Do a primary key check on C<$obj> and $<other_obj> and returns true only if they
+are identical.
+
+=head2 C<$obj-E<gt>object_is_stored()>
+
+Returns true if the object hasn't been stored in the database yet.
+This is particularily useful in triggers where you can then determine
+if the object is being INSERTED or just UPDATED.
+
+=head2 C<$obj-E<gt>pk_str()>
+
+returns the primay key has a printable string.
+
=head2 C<$obj-E<gt>has_primary_key()>
Returns whether the given object has values for all of its primary key fields.
+=head2 C<$obj-E<gt>uncache_object()>
+
+If you use a Cache driver, returned object will be automatically cached as a result
+of common retrieve operations. In some rare cases you may want the cache to be cleared
+explicitely, and this method provides you with a way to do it.
+
=head2 C<$obj-E<gt>primary_key_to_terms([$id])>
Returns C<$obj>'s primary key as a hashref of values keyed on column names,
@@ -1053,6 +1178,41 @@
object in the class I<Class>. That is, undoes the operation C<$deflated =
$obj-E<gt>deflate()> by returning a new object equivalent to C<$obj>.
+=head1 TRANSACTION SUPPORT AND METHODS
+
+=head2 Introduction
+
+When dealing with the methods on this class, the transactions are global,
+i.e: applied to all drivers. You can still enable transactions per driver
+if you directly use the driver API.
+
+=head2 C<Class-E<gt>begin_work>
+
+This enable transactions globally for all drivers until the next L<rollback>
+or L<commit> call on the class.
+
+If begin_work is called while a transaction is still active (nested transaction)
+then the two transactions are merged. So inner transactions are ignored and
+a warning will be emitted.
+
+=head2 C<Class-E<gt>rollback>
+
+This rollbacks all the transactions since the last begin work, and exits
+from the active transaction state.
+
+=head2 C<Class-E<gt>commit>
+
+Commits the transactions, and exits from the active transaction state.
+
+=head2 C<Class-E<gt>txn_debug>
+
+Just return the value of the global flag and the current working drivers
+in a hashref.
+
+=head2 C<Class-E<gt>txn_active>
+
+Returns true if a transaction is already active.
+
=head1 DIAGNOSTICS
=over 4
Index: lib/Data/ObjectDriver.pm
===================================================================
--- lib/Data/ObjectDriver.pm (.../tags/release-0.05) (revision 528)
+++ lib/Data/ObjectDriver.pm (.../trunk) (revision 528)
@@ -8,7 +8,7 @@
use base qw( Class::Accessor::Fast );
use Data::ObjectDriver::Iterator;
-__PACKAGE__->mk_accessors(qw( pk_generator ));
+__PACKAGE__->mk_accessors(qw( pk_generator txn_active ));
our $VERSION = '0.05';
our $DEBUG = $ENV{DOD_DEBUG} || 0;
@@ -38,6 +38,7 @@
my $driver = shift;
my %param = @_;
$driver->pk_generator($param{pk_generator});
+ $driver->txn_active(0);
$driver;
}
@@ -56,6 +57,29 @@
sub end_query { }
+sub begin_work {
+ my $driver = shift;
+ $driver->txn_active(1);
+ $driver->debug(sprintf("%14s", "BEGIN_WORK") . ": driver=$driver");
+}
+
+sub commit {
+ my $driver = shift;
+ _end_txn($driver, 'commit');
+}
+
+sub rollback {
+ my $driver = shift;
+ _end_txn($driver, 'rollback');
+}
+
+sub _end_txn {
+ my $driver = shift;
+ my $method = shift;
+ $driver->txn_active(0);
+ $driver->debug(sprintf("%14s", uc($method)) . ": driver=$driver");
+}
+
sub debug {
my $driver = shift;
return unless $DEBUG;
@@ -106,6 +130,7 @@
}
sub cache_object { }
+sub uncache_object { }
1;
__END__
@@ -396,6 +421,23 @@
If set to a true value, the I<SELECT> statement generated will include a
I<FOR UPDATE> clause.
+=item * comment
+
+A sql comment to watermark the SQL query.
+
+=item * window_size
+
+Used when requesting an iterator for the search method and selecting
+a large result set or a result set of unknown size. In such a case,
+no LIMIT clause is assigned, which can load all available objects into
+memory. Specifying C<window_size> will load objects in manageable chunks.
+This will also cause any caching driver to be bypassed for issuing
+the search itself. Objects are still placed into the cache upon load.
+
+This attribute is ignored when the search method is invoked in an array
+context, or if a C<limit> attribute is also specified that is smaller than
+the C<window_size>.
+
=back
=head2 Class->search(\@terms [, \%options ])
@@ -571,6 +613,89 @@
Then see the documentation for I<Data::ObjectDriver::Profiler> to see the
methods on that class.
+
+=head1 TRANSACTIONS
+
+
+Transactions are supported by Data::ObjectDriver's default drivers. So each
+Driver is capable to deal with transactional state independently. Additionally
+<Data::ObjectDriver::BaseObject> class know how to turn transactions switch on
+for all objects.
+
+In the case of a global transaction all drivers used during this time are put
+in a transactional state until the end of the transaction.
+
+=head2 Example
+
+ ## start a transaction
+ Data::ObjectDriver::BaseObject->begin_work;
+
+ $recipe = Recipe->new;
+ $recipe->title('lasagnes');
+ $recipe->save;
+
+ my $ingredient = Ingredient->new;
+ $ingredient->recipe_id($recipe->recipe_id);
+ $ingredient->name("more layers");
+ $ingredient->insert;
+ $ingredient->remove;
+
+ if ($you_are_sure) {
+ Data::ObjectDriver::BaseObject->commit;
+ }
+ else {
+ ## erase all trace of the above
+ Data::ObjectDriver::BaseObject->rollback;
+ }
+
+=head2 Driver implementation
+
+Drivers have to implement the following methods:
+
+=over 4
+
+=item * begin_work to initialize a transaction
+
+=item * rollback
+
+=item * commmit
+
+=back
+
+=head2 Nested transactions
+
+Are not supported and will result in warnings and the inner transactions
+to be ignored. Be sure to B<end> each transaction and not to let et long
+running transaction open (i.e you should execute a rollback or commit for
+each open begin_work).
+
+=head2 Transactions and DBI
+
+In order to make transactions work properly you have to make sure that
+the C<$dbh> for each DBI drivers are shared among drivers using the same
+database (basically dsn).
+
+One way of doing that is to define a get_dbh() subref in each DBI driver
+to return the same dbh if the dsn and attributes of the connection are
+identical.
+
+The other way is to use the new configuration flag on the DBI driver that
+has been added specifically for this purpose: C<reuse_dbh>.
+
+ ## example coming from the test suite
+ __PACKAGE__->install_properties({
+ columns => [ 'recipe_id', 'partition_id', 'title' ],
+ datasource => 'recipes',
+ primary_key => 'recipe_id',
+ driver => Data::ObjectDriver::Driver::Cache::Cache->new(
+ cache => Cache::Memory->new,
+ fallback => Data::ObjectDriver::Driver::DBI->new(
+ dsn => 'dbi:SQLite:dbname=global.db',
+ reuse_dbh => 1, ## be sure that the corresponding dbh is shared
+ ),
+ ),
+ });
+
=head1 EXAMPLES
=head2 A Partitioned, Caching Driver
Index: Changes
===================================================================
--- Changes (.../tags/release-0.05) (revision 528)
+++ Changes (.../trunk) (revision 528)
@@ -2,6 +2,31 @@
Revision history for Data::ObjectDriver
+0.06
+ - Added peek_next() method to ResultSet, q.v.
+ - Localized creation of D::OD::Iterator object. Thanks to Hirotaka Ogawa
+ for the patch.
+ - Fixed compilation error with Perl 5.10. Thanks to smpeters for the patch.
+ - Added a new $object->uncache_object as a mirror of cache_object(), which
+ purge one object from the cache layer, for the cases where you want a
+ manual control over it.
+ - Added a "distinct" method to D::OD::SQL that forces the DISTINCT keyword
+ in the generated SQL statement. Thanks to John Berthels for the patch.
+ - Added a "window_size" argument for the search() method of the caching
+ layer to constrain the number of objects loaded from the database for
+ large or unbounded searches.
+ - Added a "comment" argument to search parameter allowing the SQL
+ queries to be watermarked with SQL comments.
+ - Added a "object_is_stored" method on DOD objects, which returns true until
+ the object has been saved in the persistent store.
+ - Added a "pk_str" method on base objects has a nice shortcut for printing
+ the primary key of an object.
+ - Added a "reuse_dbh" option to D::OD::D::DBI, if enabled it caches and reuses
+ $dbh using the dsn as the key.
+ - Exposed the transaction mechanism built in the drivers at the object levels:
+ D::OD::BO->begin_work now starts a global transaction across all drivers
+ ending with a rollback or a commit on the same class.
+
0.05 2008.02.24
- Added a new Data::ObjectDriver::ResultSet abstraction for building
result sets with lazy-loading of the actual results. This allows for
Index: MANIFEST.SKIP
===================================================================
--- MANIFEST.SKIP (.../tags/release-0.05) (revision 528)
+++ MANIFEST.SKIP (.../trunk) (revision 528)
@@ -12,3 +12,4 @@
\.tar\.gz$
\.svn
\.shipit$
+t/9\d.+\.t$
Index: README
===================================================================
--- README (.../tags/release-0.05) (revision 528)
+++ README (.../trunk) (revision 528)
@@ -27,4 +27,4 @@
% make install
-Six Apart / [email protected]
+Six Apart / [email protected]
\ No newline at end of file
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment