· 8 years ago · Feb 21, 2018, 06:12 AM
1Index: t/11-sql.t
2===================================================================
3--- t/11-sql.t (.../tags/release-0.05) (revision 528)
4+++ t/11-sql.t (.../trunk) (revision 528)
5@@ -3,7 +3,7 @@
6 use strict;
7
8 use Data::ObjectDriver::SQL;
9-use Test::More tests => 58;
10+use Test::More tests => 67;
11
12 my $stmt = ns();
13 ok($stmt, 'Created SQL object');
14@@ -212,4 +212,48 @@
15 LIMIT 2
16 SQL
17
18+# DISTINCT
19+$stmt = ns();
20+$stmt->add_select(foo => 'foo');
21+$stmt->from([ qw(baz) ]);
22+is($stmt->as_sql, "SELECT foo\nFROM baz\n", "DISTINCT is absent by default");
23+$stmt->distinct(1);
24+is($stmt->as_sql, "SELECT DISTINCT foo\nFROM baz\n", "we can turn on DISTINCT");
25+
26+# index hint
27+$stmt = ns();
28+$stmt->add_select(foo => 'foo');
29+$stmt->from([ qw(baz) ]);
30+is($stmt->as_sql, "SELECT foo\nFROM baz\n", "index hint is absent by default");
31+$stmt->add_index_hint('baz' => { type => 'USE', list => ['index_hint']});
32+is($stmt->as_sql, "SELECT foo\nFROM baz USE INDEX (index_hint)\n", "we can turn on USE INDEX");
33+
34+# index hint with joins
35+$stmt->joins([]);
36+$stmt->from([]);
37+$stmt->add_join(baz => { type => 'inner', table => 'baz',
38+ condition => 'baz.baz_id = foo.baz_id' });
39+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');
40+$stmt->from([]);
41+$stmt->joins([]);
42+$stmt->add_join(baz => [
43+ { type => 'inner', table => 'baz b1',
44+ condition => 'baz.baz_id = b1.baz_id AND b1.quux_id = 1' },
45+ { type => 'left', table => 'baz b2',
46+ condition => 'baz.baz_id = b2.baz_id AND b2.quux_id = 2' },
47+ ]);
48+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');
49+
50+$stmt = ns();
51+$stmt->add_select(foo => 'foo');
52+$stmt->from([ qw(baz) ]);
53+$stmt->comment("mycomment");
54+is($stmt->as_sql, "SELECT foo\nFROM baz\n-- mycomment");
55+
56+$stmt->comment("\nbad\n\nmycomment");
57+is($stmt->as_sql, "SELECT foo\nFROM baz\n-- bad", "correctly untainted");
58+
59+$stmt->comment("G\\G");
60+is($stmt->as_sql, "SELECT foo\nFROM baz\n-- G", "correctly untainted");
61+
62 sub ns { Data::ObjectDriver::SQL->new }
63Index: t/09-resultset.t
64===================================================================
65--- t/09-resultset.t (.../tags/release-0.05) (revision 0)
66+++ t/09-resultset.t (.../trunk) (revision 528)
67@@ -0,0 +1,149 @@
68+# $Id: 01-col-inheritance.t 989 2005-09-23 19:58:01Z btrott $
69+
70+use strict;
71+
72+use lib 't/lib';
73+
74+require 't/lib/db-common.pl';
75+
76+$Data::ObjectDriver::DEBUG = 0;
77+use Test::More;
78+unless (eval { require DBD::SQLite }) {
79+ plan skip_all => 'Tests require DBD::SQLite';
80+}
81+plan tests => 47;
82+
83+setup_dbs({
84+ global => [ qw( wines ) ],
85+});
86+
87+use Wine;
88+use Storable;
89+
90+my $wine = Wine->new;
91+$wine->name("Saumur Champigny, Le Grand Clos 2001");
92+$wine->rating(4);
93+
94+## generate some binary data (SQL_BLOB / MEDIUMBLOB)
95+my $glouglou = { tanin => "beaucoup", caudalies => "4" };
96+$wine->binchar("xxx\0yyy");
97+$wine->content(Storable::nfreeze($glouglou));
98+ok($wine->save, 'Object saved successfully');
99+
100+my $iter;
101+
102+$iter = Data::ObjectDriver::Iterator->new(sub {});
103+my $wine_id = $wine->id;
104+undef $wine;
105+$wine = Wine->lookup($wine_id);
106+
107+ok $wine;
108+is_deeply Storable::thaw($wine->content), $glouglou;
109+SKIP: {
110+ skip "Please upgrade to DBD::SQLite 1.11", 1
111+ if $DBD::SQLite::VERSION < 1.11;
112+ is $wine->binchar, "xxx\0yyy";
113+};
114+
115+Wine->bulk_insert(['name', 'rating'], [['Caymus', 4], ['Thunderbird', 1], ['Stags Leap', 3]]);
116+
117+
118+{
119+ my $result = Wine->result({});
120+
121+ my $objs = $result->slice(0, 100);
122+ is @$objs, 4;
123+
124+ my $rs = $result->slice(0, 2);
125+ is @$rs, 3;
126+ for my $r (@$rs) {
127+ isa_ok $r, 'Wine';
128+ }
129+}
130+
131+$wine = undef;
132+my ($result) = Wine->result({name => 'Caymus'});
133+ok! $result->is_finished;
134+$wine = $result->next;
135+ok $wine, 'Found Caymus';
136+is $wine->name, 'Caymus';
137+ok ! $result->next; #sets is_finished()
138+ok $result->is_finished;
139+
140+# testing iterator
141+my ($iterator) = $result->iterator([$wine]);
142+ok(! $iterator->is_finished );
143+$wine = $iterator->next;
144+ok $wine, 'Found Caymus';
145+is $wine->name, 'Caymus';
146+ok( ! $iterator->next );
147+ok( $iterator->is_finished );
148+
149+# testing bug in iterator, adding a limit where there was one before shouldn't invalidate results
150+($iterator) = $result->iterator([$wine]);
151+$iterator->add_limit(1);
152+ok(! $iterator->is_finished );
153+$wine = $iterator->next;
154+ok $wine, 'Found Caymus';
155+is $wine->name, 'Caymus';
156+ok ! $iterator->next;
157+ok $iterator->is_finished;
158+
159+
160+($result) = Wine->result({}, { sort => 'name', direction => 'ascend' });
161+($iterator) = $result->iterator( [ $result->next, $result->next ] );
162+$iterator->add_limit(1);
163+ok! $iterator->is_finished ;
164+$wine = $iterator->next;
165+ok $wine, 'Found Caymus';
166+is $wine->name, 'Caymus';
167+ok ! $iterator->next;
168+ok $iterator->is_finished;
169+
170+
171+# raising the limit should trigger a new search
172+($result) = Wine->result({}, { sort => 'name', direction => 'ascend' });
173+($iterator) = $result->iterator( [ $result->next, $result->next ] );
174+$iterator->add_limit(9999);
175+ok! $iterator->is_finished;
176+$wine = $iterator->next;
177+ok $wine, 'Found Caymus';
178+is $wine->name, 'Caymus';
179+ok $iterator->next, 'more to go';
180+ok ! $iterator->is_finished, "we're not finished";
181+
182+
183+# testing limit in args
184+($result) = Wine->result({}, { limit => 2, sort => 'name', direction => 'ascend' });
185+ok! $result->is_finished ;
186+$wine = $result->next;
187+is $wine->name, 'Caymus';
188+$wine = $result->next;
189+is $wine->name, 'Saumur Champigny, Le Grand Clos 2001';
190+ok ! $result->next;
191+ok $result->is_finished;
192+
193+# raising the limit should trigger a new search
194+($result) = Wine->result({}, { limit => 2, sort => 'name', direction => 'ascend' });
195+$result->add_limit(3);
196+is $result->next->name, 'Caymus';
197+is $result->next->name, 'Saumur Champigny, Le Grand Clos 2001';
198+is $result->next->name, 'Stags Leap';
199+
200+# test slice again with _results_loaded
201+$result->rewind;
202+{
203+ my $rs = $result->slice(0, 2);
204+ for my $r (@$rs) {
205+ isa_ok $r, 'Wine';
206+ }
207+
208+ my $objs;
209+ $objs = $result->slice(0, 100);
210+ is @$objs, 3;
211+
212+ $objs = $result->slice(5, 10);
213+ is @$objs, 0;
214+}
215+
216+teardown_dbs(qw( global ));
217Index: t/34-both.t
218===================================================================
219--- t/34-both.t (.../tags/release-0.05) (revision 528)
220+++ t/34-both.t (.../trunk) (revision 528)
221@@ -18,7 +18,7 @@
222 }
223 }
224
225-plan tests => 46;
226+plan tests => 86;
227
228 use Recipe;
229 use Ingredient;
230@@ -32,6 +32,7 @@
231 ## Install some deflate/inflate in the Cache driver.
232 {
233 no warnings 'once';
234+ no warnings 'redefine';
235 *Data::ObjectDriver::Driver::Cache::Cache::deflate = sub {
236 $_[1]->deflate;
237 };
238@@ -114,15 +115,24 @@
239 ok !$i4->{__cached};
240 is $i4->name, 'Flour';
241
242+## verify it's in the cache
243+my $key = $i4->driver->cache_key(ref($i4), $i4->primary_key);
244+my $data = $i4->driver->get_from_cache($key);
245+ok $data;
246+is $data->{columns}{id}, $i3->id, "it's in the cache";
247 ## Delete it from the cache, so that the next test is actually accurate.
248-my $driver = Ingredient->driver;
249-$driver->remove_from_cache($driver->cache_key('Ingredient', $i4->primary_key));
250+$i4->uncache_object;
251+ok ! $i4->driver->get_from_cache($key), "It's been purged from the cache";
252
253 ## Now look up the ingredients again. Milk and Eggs should already be cached,
254 ## and doing the search should now cache Flour.
255 @is = Ingredient->search({ recipe_id => $recipe->recipe_id });
256 is scalar(@is), 3;
257
258+## this is still working if we add a comment
259+@is = Ingredient->search({ recipe_id => $recipe->recipe_id }, { comment => "mytest" });
260+is scalar(@is), 3;
261+
262 ## Flour should now be cached.
263 $i4 = Ingredient->lookup([ $recipe->recipe_id, $i3->id ]);
264 ok $i4->{__cached};
265@@ -176,4 +186,6 @@
266 ok $replaced->{__cached};
267 is $replaced->title, 'Cup Cake';
268
269+require 't/txn-common.pl';
270+
271 teardown_dbs(qw( global cluster1 cluster2 ));
272Index: t/04-clone.t
273===================================================================
274--- t/04-clone.t (.../tags/release-0.05) (revision 528)
275+++ t/04-clone.t (.../trunk) (revision 528)
276@@ -18,7 +18,7 @@
277 }
278 }
279
280-plan tests => 26;
281+plan tests => 29;
282
283 use Wine;
284 use Recipe;
285@@ -68,6 +68,10 @@
286 ok !defined $clone->id, 'Basic clone has no id';
287
288 ok $clone->save, 'Basic clone could be saved';
289+ is $clone->name, 'Cul de Veau à la Sauge';
290+ is $clone->is_changed('name'), '', "This is documentation ;-)";
291+ $clone->refresh;
292+ is $clone->name, 'Cul de Veau à la Sauge';
293 ok defined $clone->id, 'Basic clone has an id after saving';
294 isnt $w->id, $clone->id, q(Basic clone's id differs from original's id);
295 }
296Index: t/35-multiplexed.t
297===================================================================
298--- t/35-multiplexed.t (.../tags/release-0.05) (revision 528)
299+++ t/35-multiplexed.t (.../trunk) (revision 528)
300@@ -11,7 +11,7 @@
301 unless (eval { require DBD::SQLite }) {
302 plan skip_all => 'Tests require DBD::SQLite';
303 }
304-plan tests => 26;
305+plan tests => 42;
306
307 setup_dbs({
308 global1 => [ qw( ingredient2recipe ) ],
309@@ -60,6 +60,54 @@
310 is $ok, 1, "Record is removed from $driver backend database";
311 }
312
313+## check transactions
314+$obj = Ingredient2Recipe->new;
315+$obj->ingredient_id(10);
316+$obj->recipe_id(50);
317+$obj->insert;
318+
319+Data::ObjectDriver::BaseObject->begin_work();
320+$obj->value1("will be rolled back");
321+$obj->update;
322+Data::ObjectDriver::BaseObject->rollback();
323+$obj->refresh;
324+is $obj->value1, undef, "properly rolled back";
325+_check_object($obj);
326+
327+Data::ObjectDriver::BaseObject->begin_work();
328+$obj->value1("commit");
329+$obj->update;
330+Data::ObjectDriver::BaseObject->commit();
331+$obj->refresh;
332+is $obj->value1, "commit", "yay";
333+_check_object($obj);
334+
335+## if something goes wrong writing the second partition we roll back
336+## the first one
337+## set up a trap:
338+my $second_driver = Ingredient2Recipe->driver->drivers->[-1];
339+my $dbh = $second_driver->dbh;
340+my $sth = $dbh->prepare("insert into ingredient2recipe (ingredient_id, recipe_id, value1) values (199, 199, 'tada')");
341+$sth->execute;
342+$sth->finish;
343+
344+Data::ObjectDriver::BaseObject->begin_work();
345+$obj = Ingredient2Recipe->new;
346+$obj->ingredient_id(199);
347+$obj->recipe_id(199);
348+$obj->value1("test");
349+eval { $obj->insert;};
350+ok $@, "rollback";
351+if ($@) {
352+ Data::ObjectDriver::BaseObject->rollback();
353+}
354+else {
355+ Data::ObjectDriver::BaseObject->commit();
356+}
357+# since on_lookup use the first driver this should be undef
358+my $void = Ingredient2Recipe->lookup(199);
359+is $void, undef, "rolled back";
360+
361 ## Object remove()
362 $obj = Ingredient2Recipe->new;
363 $obj->ingredient_id(4);
364Index: t/schemas/ingredient2recipe.sql
365===================================================================
366--- t/schemas/ingredient2recipe.sql (.../tags/release-0.05) (revision 528)
367+++ t/schemas/ingredient2recipe.sql (.../trunk) (revision 528)
368@@ -1,5 +1,6 @@
369 CREATE TABLE ingredient2recipe (
370 ingredient_id INTEGER NOT NULL,
371 recipe_id INTEGER NOT NULL,
372+ value1 VARCHAR(255),
373 PRIMARY KEY (recipe_id, ingredient_id)
374 )
375Index: t/05-deflate.t
376===================================================================
377--- t/05-deflate.t (.../tags/release-0.05) (revision 528)
378+++ t/05-deflate.t (.../trunk) (revision 528)
379@@ -42,6 +42,7 @@
380 ## Install some deflate/inflate in the Cache driver.
381 {
382 no warnings 'once';
383+ no warnings 'redefine';
384 *Data::ObjectDriver::Driver::Cache::Cache::deflate = sub {
385 $_[1]->deflate;
386 };
387Index: t/31-cached.t
388===================================================================
389--- t/31-cached.t (.../tags/release-0.05) (revision 528)
390+++ t/31-cached.t (.../trunk) (revision 528)
391@@ -16,7 +16,7 @@
392 plan skip_all => 'Tests require Cache::Memory';
393 }
394 }
395-plan tests => 62;
396+plan tests => 100;
397
398 setup_dbs({
399 global => [ qw( recipes ingredients ) ],
400@@ -151,6 +151,23 @@
401
402 is($ingredient->remove, 1, 'Ingredient removed successfully');
403 is($ingredient2->remove, 1, 'Ingredient removed successfully');
404+
405+## demonstration that we have a problem with caching and transaction
406+{
407+ # ingredient3 should already be hot in the cache anyway
408+ Data::ObjectDriver::BaseObject->begin_work;
409+ $ingredient3->quantity(300); # originally was 100
410+ $ingredient3->save;
411+
412+ my $same = Ingredient->lookup($ingredient3->primary_key);
413+ is $same->quantity, 300;
414+
415+ Data::ObjectDriver::BaseObject->rollback;
416+
417+ $same = Ingredient->lookup($ingredient3->primary_key);
418+ is $same->quantity, 100;
419+}
420+
421 # let's remove ingredient3 with Class methods
422 eval {
423 Ingredient->remove({ name => 'Chocolate Chips' }, { nofetch => 1 });
424@@ -160,8 +177,9 @@
425 is(Ingredient->remove({ name => 'Chocolate Chips' }), 1, "Removed with class method");
426 ok(! Ingredient->lookup(1), "really deleted");
427
428-
429 is($recipe->remove, 1, 'Recipe removed successfully');
430 is($recipe2->remove, 1, 'Recipe removed successfully');
431
432+require 't/txn-common.pl';
433+
434 teardown_dbs(qw( global ));
435Index: t/10-resultset-peek.t
436===================================================================
437--- t/10-resultset-peek.t (.../tags/release-0.05) (revision 0)
438+++ t/10-resultset-peek.t (.../trunk) (revision 528)
439@@ -0,0 +1,150 @@
440+# $Id: 01-col-inheritance.t 989 2005-09-23 19:58:01Z btrott $
441+
442+# this is about the same test as t/09-resultset.t, but with lots of peek_next'ing
443+# going on, to test that new method
444+
445+use strict;
446+
447+use lib 't/lib';
448+
449+require 't/lib/db-common.pl';
450+
451+$Data::ObjectDriver::DEBUG = 0;
452+use Test::More;
453+unless (eval { require DBD::SQLite }) {
454+ plan skip_all => 'Tests require DBD::SQLite';
455+}
456+plan tests => 65;
457+
458+setup_dbs({
459+ global => [ qw( wines ) ],
460+});
461+
462+use Wine;
463+use Storable;
464+
465+my $wine = Wine->new;
466+$wine->name("Saumur Champigny, Le Grand Clos 2001");
467+$wine->rating(4);
468+
469+## generate some binary data (SQL_BLOB / MEDIUMBLOB)
470+my $glouglou = { tanin => "beaucoup", caudalies => "4" };
471+$wine->binchar("xxx\0yyy");
472+$wine->content(Storable::nfreeze($glouglou));
473+ok($wine->save, 'Object saved successfully');
474+
475+my $iter;
476+
477+$iter = Data::ObjectDriver::Iterator->new(sub {});
478+my $wine_id = $wine->id;
479+undef $wine;
480+$wine = Wine->lookup($wine_id);
481+
482+ok $wine;
483+is_deeply Storable::thaw($wine->content), $glouglou;
484+SKIP: {
485+ skip "Please upgrade to DBD::SQLite 1.11", 1
486+ if $DBD::SQLite::VERSION < 1.11;
487+ is $wine->binchar, "xxx\0yyy";
488+};
489+
490+Wine->bulk_insert(['name', 'rating'], [['Caymus', 4], ['Thunderbird', 1], ['Stags Leap', 3]]);
491+
492+$wine = undef;
493+my ($result) = Wine->result({name => 'Caymus'});
494+is $result->peek_next->name, 'Caymus', 'before we start, peek_next says the first one is Caymus';
495+ok! $result->is_finished;
496+$wine = $result->next;
497+ok $wine, 'Found Caymus';
498+is $wine->name, 'Caymus';
499+ok ! $result->peek_next, "we're at the end of the set";
500+ok ! $result->next; #sets is_finished()
501+ok ! $result->peek_next, "we're *still* at the end of the set";
502+ok $result->is_finished;
503+
504+# testing iterator
505+my ($iterator) = $result->iterator([$wine]);
506+is $iterator->peek_next->name, 'Caymus', 'before we start, peek_next says the first one is Caymus';
507+ok(! $iterator->is_finished );
508+$wine = $iterator->next;
509+ok $wine, 'Found Caymus';
510+is $wine->name, 'Caymus';
511+ok ! $iterator->peek_next, "we're at the end of the set";
512+ok( ! $iterator->next );
513+ok ! $iterator->peek_next, "we're *still* at the end of the set";
514+ok( $iterator->is_finished );
515+
516+# testing bug in iterator, adding a limit where there was one before shouldn't invalidate results
517+($iterator) = $result->iterator([$wine]);
518+is $iterator->peek_next->name, 'Caymus', 'before we start, peek_next says the first one is Caymus';
519+$iterator->add_limit(1);
520+is $iterator->peek_next->name, 'Caymus', 'after adding limit, peek_next says the first one is Caymus';
521+ok(! $iterator->is_finished );
522+$wine = $iterator->next;
523+ok $wine, 'Found Caymus';
524+is $wine->name, 'Caymus';
525+ok ! $iterator->peek_next, "we're at the end of the set";
526+ok ! $iterator->next;
527+ok ! $iterator->peek_next, "we're *still* at the end of the set";
528+ok $iterator->is_finished;
529+
530+
531+($result) = Wine->result({}, { sort => 'name', direction => 'ascend' });
532+($iterator) = $result->iterator( [ $result->next, $result->next ] );
533+is $iterator->peek_next->name, 'Caymus', 'before we start, peek_next says the first one is Caymus';
534+$iterator->add_limit(1);
535+is $iterator->peek_next->name, 'Caymus', 'after adding limit, peek_next says the first one is Caymus';
536+ok! $iterator->is_finished ;
537+$wine = $iterator->next;
538+ok $wine, 'Found Caymus';
539+is $wine->name, 'Caymus';
540+ok ! $iterator->peek_next, "we're at the end of the set";
541+ok ! $iterator->next;
542+ok ! $iterator->peek_next, "we're *still* at the end of the set";
543+ok $iterator->is_finished;
544+
545+
546+# raising the limit should trigger a new search
547+($result) = Wine->result({}, { sort => 'name', direction => 'ascend' });
548+($iterator) = $result->iterator( [ $result->next, $result->next ] );
549+is $iterator->peek_next->name, 'Caymus', 'before we start, peek_next says the first one is Caymus';
550+$iterator->add_limit(9999);
551+is $iterator->peek_next->name, 'Caymus', 'after adding limit, peek_next says the first one is Caymus';
552+ok! $iterator->is_finished;
553+$wine = $iterator->next;
554+ok $wine, 'Found Caymus';
555+is $wine->name, 'Caymus';
556+ok $iterator->peek_next, "more to go";
557+ok $iterator->next, 'more to go';
558+ok ! $iterator->peek_next, "that was the last one, there are no more";
559+ok ! $iterator->is_finished, "we're not finished";
560+ok ! $iterator->next; #sets is_finished()
561+ok ! $iterator->peek_next, "that was the last one, there are no more";
562+ok $iterator->is_finished, "now we are finished";
563+
564+
565+# testing limit in args
566+($result) = Wine->result({}, { limit => 2, sort => 'name', direction => 'ascend' });
567+is $result->peek_next->name, 'Caymus', 'before we start, peek_next says the first one is Caymus';
568+ok! $result->is_finished ;
569+$wine = $result->next;
570+is $wine->name, 'Caymus';
571+is $result->peek_next->name, 'Saumur Champigny, Le Grand Clos 2001', 'the next one will be Saumur';
572+$wine = $result->next;
573+is $wine->name, 'Saumur Champigny, Le Grand Clos 2001';
574+ok ! $result->peek_next, "Saumur was the last one";
575+ok ! $result->next;
576+ok $result->is_finished;
577+ok ! $result->peek_next, "Saumur was really the last one";
578+
579+# raising the limit should trigger a new search
580+($result) = Wine->result({}, { limit => 2, sort => 'name', direction => 'ascend' });
581+$result->add_limit(3);
582+is $result->next->name, 'Caymus';
583+is $result->peek_next->name, 'Saumur Champigny, Le Grand Clos 2001', 'the next one will be Saumur';
584+is $result->next->name, 'Saumur Champigny, Le Grand Clos 2001';
585+is $result->peek_next->name, 'Stags Leap', 'the next one will be Stags Leap';
586+is $result->next->name, 'Stags Leap';
587+ok ! $result->peek_next, "Stags Leap was the last one";
588+
589+teardown_dbs(qw( global ));
590Index: t/98-perl_critic.t
591===================================================================
592--- t/98-perl_critic.t (.../tags/release-0.05) (revision 528)
593+++ t/98-perl_critic.t (.../trunk) (revision 528)
594@@ -1,6 +1,9 @@
595
596 use Test::More;
597-eval 'use Test::Perl::Critic';
598+eval {
599+ require Test::Perl::Critic;
600+ Test::Perl::Critic->import( -exclude => ['ProhibitNoStrict'] );
601+};
602 plan skip_all => 'Test::Perl::Critic required to criticise code' if $@;
603 all_critic_ok();
604
605Index: t/02-basic.t
606===================================================================
607--- t/02-basic.t (.../tags/release-0.05) (revision 528)
608+++ t/02-basic.t (.../trunk) (revision 528)
609@@ -19,7 +19,7 @@
610 }
611 }
612
613-plan tests => 58;
614+plan tests => 67;
615
616 use Wine;
617 use Recipe;
618@@ -196,6 +196,7 @@
619
620 # emulate a driver which doesn't support REPLACE INTO
621 {
622+ no warnings 'redefine';
623 local *Data::ObjectDriver::Driver::DBD::SQLite::can_replace = sub { 0 };
624 $r->title('replaced');
625 $r->recipe_id("lamer");
626@@ -244,5 +245,35 @@
627 is (Wine->remove({}, { nofetch => 1 }), '0E0', 'removing all bad wine');
628 }
629
630-#teardown_dbs(qw( global ));
631+# different utilities
632+{
633+ my $w1 = Wine->new;
634+ $w1->name("Chateau la pompe");
635+ $w1->insert;
636
637+ my $w3 = Wine->new;
638+ $w3->name("different");
639+ $w3->insert;
640+
641+ my $w2 = Wine->lookup($w1->id);
642+ ok $w1->is_same($w1);
643+ ok $w2->is_same($w1);
644+ ok $w1->is_same($w2);
645+ ok !$w1->is_same($w3);
646+ ok !$w3->is_same($w2);
647+
648+ like $w1->pk_str, qr/\d+/;
649+}
650+
651+# Test the new flag for persistent store insertion
652+{
653+ my $w = Wine->new(name => 'flag test', rating=> 4);
654+ ok !$w->object_is_stored, "this object needs to be saved!";
655+ $w->save;
656+ ok $w->object_is_stored, "this object is no saved";
657+ my $w2 = Wine->lookup( $w->id );
658+ ok $w2->object_is_stored, "an object fetched from the database is by definition NOT ephemeral";
659+}
660+
661+teardown_dbs(qw( global ));
662+
663Index: t/32-partitioned.t
664===================================================================
665--- t/32-partitioned.t (.../tags/release-0.05) (revision 528)
666+++ t/32-partitioned.t (.../trunk) (revision 528)
667@@ -10,7 +10,7 @@
668 unless (eval { require DBD::SQLite }) {
669 plan skip_all => 'Tests require DBD::SQLite';
670 }
671-plan tests => 52;
672+plan tests => 88;
673
674 setup_dbs({
675 global => [ qw( recipes ) ],
676@@ -48,6 +48,7 @@
677 ok(!$iter->(), 'Iterator gave us only one recipe');
678 is(ref $tmp, 'Recipe', 'Iterator gave us a recipe');
679 is($tmp->title, 'My Banana Milkshake', 'Title is My Banana Milkshake');
680+$iter->end();
681
682 my $ingredient = Ingredient->new;
683 $ingredient->recipe_id($recipe->recipe_id);
684@@ -72,6 +73,7 @@
685 ok(!$iter->(), 'Iterator gave us only one ingredient');
686 is(ref $tmp, 'Ingredient', 'Iterator gave us an ingredient');
687 is($tmp->name, 'Vanilla Ice Cream', 'Name is Vanilla Ice Cream');
688+$iter->end();
689
690 my $ingredient2 = Ingredient->new;
691 $ingredient2->recipe_id($recipe->recipe_id);
692@@ -121,4 +123,6 @@
693 is $recipe->remove, 1, 'Recipe removed successfully';
694 is $recipe2->remove, 1, 'Recipe removed successfully';
695
696+require 't/txn-common.pl';
697+
698 teardown_dbs(qw( global cluster1 cluster2 ));
699Index: t/lib/partitioned/Recipe.pm
700===================================================================
701--- t/lib/partitioned/Recipe.pm (.../tags/release-0.05) (revision 528)
702+++ t/lib/partitioned/Recipe.pm (.../trunk) (revision 528)
703@@ -12,16 +12,22 @@
704 primary_key => 'recipe_id',
705 driver => Data::ObjectDriver::Driver::DBI->new(
706 dsn => 'dbi:SQLite:dbname=global.db',
707+ reuse_dbh => 1,
708 ),
709 });
710
711+my %drivers;
712 __PACKAGE__->has_partitions(
713 number => 2,
714 get_driver => sub {
715- return Data::ObjectDriver::Driver::DBI->new(
716- dsn => 'dbi:SQLite:dbname=cluster' . shift() . '.db',
717- @_,
718- ),
719+ my $cluster = shift;
720+ my $driver = $drivers{$cluster} ||=
721+ Data::ObjectDriver::Driver::DBI->new(
722+ dsn => 'dbi:SQLite:dbname=cluster' . $cluster . '.db',
723+ reuse_dbh => 1,
724+ @_,
725+ );
726+ return $driver;
727 },
728 );
729
730Index: t/lib/cached/Recipe.pm
731===================================================================
732--- t/lib/cached/Recipe.pm (.../tags/release-0.05) (revision 528)
733+++ t/lib/cached/Recipe.pm (.../trunk) (revision 528)
734@@ -12,6 +12,7 @@
735 primary_key => 'recipe_id',
736 driver => Data::ObjectDriver::Driver::DBI->new(
737 dsn => 'dbi:SQLite:dbname=global.db',
738+ reuse_dbh => 1,
739 ),
740 });
741
742Index: t/lib/cached/Ingredient.pm
743===================================================================
744--- t/lib/cached/Ingredient.pm (.../tags/release-0.05) (revision 528)
745+++ t/lib/cached/Ingredient.pm (.../trunk) (revision 528)
746@@ -6,8 +6,7 @@
747
748 use Carp ();
749 use Data::ObjectDriver::Driver::DBI;
750-use Data::ObjectDriver::Driver::Cache::Cache;
751-use Cache::Memory;
752+use Data::ObjectDriver::Driver::Cache::RAM;
753
754 our %IDs;
755
756@@ -15,11 +14,11 @@
757 columns => [ 'id', 'recipe_id', 'name', 'quantity' ],
758 datasource => 'ingredients',
759 primary_key => [ 'recipe_id', 'id' ],
760- driver => Data::ObjectDriver::Driver::Cache::Cache->new(
761- cache => Cache::Memory->new,
762+ driver => Data::ObjectDriver::Driver::Cache::RAM->new(
763 fallback => Data::ObjectDriver::Driver::DBI->new(
764 dsn => 'dbi:SQLite:dbname=global.db',
765 pk_generator => \&generate_pk,
766+ reuse_dbh => 1,
767 ),
768 pk_generator => \&generate_pk,
769 ),
770Index: t/lib/both/Recipe.pm
771===================================================================
772--- t/lib/both/Recipe.pm (.../tags/release-0.05) (revision 528)
773+++ t/lib/both/Recipe.pm (.../trunk) (revision 528)
774@@ -16,17 +16,23 @@
775 cache => Cache::Memory->new,
776 fallback => Data::ObjectDriver::Driver::DBI->new(
777 dsn => 'dbi:SQLite:dbname=global.db',
778+ reuse_dbh => 1,
779 ),
780 ),
781 });
782
783+my %drivers;
784 __PACKAGE__->has_partitions(
785 number => 2,
786 get_driver => sub {
787- return Data::ObjectDriver::Driver::DBI->new(
788- dsn => 'dbi:SQLite:dbname=cluster' . shift() . '.db',
789- @_,
790- ),
791+ my $cluster = shift;
792+ my $driver = $drivers{$cluster} ||=
793+ Data::ObjectDriver::Driver::DBI->new(
794+ dsn => 'dbi:SQLite:dbname=cluster' . $cluster . '.db',
795+ reuse_dbh => 1,
796+ @_,
797+ );
798+ return $driver;
799 },
800 );
801
802Index: t/lib/multiplexed/Ingredient2Recipe.pm
803===================================================================
804--- t/lib/multiplexed/Ingredient2Recipe.pm (.../tags/release-0.05) (revision 528)
805+++ t/lib/multiplexed/Ingredient2Recipe.pm (.../trunk) (revision 528)
806@@ -16,7 +16,7 @@
807 );
808
809 __PACKAGE__->install_properties({
810- columns => [ 'recipe_id', 'ingredient_id' ],
811+ columns => [ 'recipe_id', 'ingredient_id', "value1" ],
812 datasource => 'ingredient2recipe',
813 primary_key => 'recipe_id', ## should match lookup XXX could we auto generate it ?
814 driver => Data::ObjectDriver::Driver::Multiplexer->new(
815Index: t/txn-common.pl
816===================================================================
817--- t/txn-common.pl (.../tags/release-0.05) (revision 0)
818+++ t/txn-common.pl (.../trunk) (revision 528)
819@@ -0,0 +1,139 @@
820+# $Id: db-common.pl 58 2006-05-04 00:04:10Z sky $
821+
822+use strict;
823+use Test::More;
824+
825+diag "executing common tests";
826+use Data::ObjectDriver::BaseObject;
827+
828+## testing basic rollback
829+{
830+ Data::ObjectDriver::BaseObject->begin_work;
831+
832+ my $recipe = Recipe->new;
833+ $recipe->title('gratin dauphinois');
834+ ok($recipe->save, 'Object saved successfully');
835+ ok(my $recipe_id = $recipe->recipe_id, 'Recipe has an ID');
836+ is($recipe->title, 'gratin dauphinois', 'Title is set');
837+
838+ my $ingredient = Ingredient->new;
839+ $ingredient->recipe_id($recipe->recipe_id);
840+ $ingredient->name('cheese');
841+ $ingredient->quantity(10);
842+ ok($ingredient->save, 'Ingredient saved successfully');
843+ ok(my $ingredient_pk = $ingredient->primary_key, 'Ingredient has an ID');
844+ ok($ingredient->id, 'ID is defined');
845+ is($ingredient->name, 'cheese', 'got a name for the ingredient');
846+
847+ #use YAML; warn Dump (Data::ObjectDriver::BaseObject->txn_debug);
848+ Data::ObjectDriver::BaseObject->rollback;
849+
850+ ## check that we don't have a trace of all the good stuff we cooked
851+ is(Recipe->lookup($recipe_id), undef, "no trace of object");
852+ is(eval { Ingredient->lookup($ingredient_pk) }, undef, "no trace of object");
853+ is(Recipe->lookup_multi([ $recipe_id ])->[0], undef);
854+}
855+
856+## testing basic commit
857+{
858+ Data::ObjectDriver::BaseObject->begin_work;
859+
860+ my $recipe = Recipe->new;
861+ $recipe->title('gratin dauphinois');
862+ ok($recipe->save, 'Object saved successfully');
863+ ok(my $recipe_id = $recipe->recipe_id, 'Recipe has an ID');
864+ is($recipe->title, 'gratin dauphinois', 'Title is set');
865+
866+ my $ingredient = Ingredient->new;
867+ $ingredient->recipe_id($recipe->recipe_id);
868+ $ingredient->name('cheese');
869+ $ingredient->quantity(10);
870+ ok($ingredient->save, 'Ingredient saved successfully');
871+ ok(my $ingredient_pk = $ingredient->primary_key, 'Ingredient has an ID');
872+ ok($ingredient->id, 'ID is defined');
873+ is($ingredient->name, 'cheese', 'got a name for the ingredient');
874+
875+ Data::ObjectDriver::BaseObject->commit;
876+
877+ ## check that we don't have a trace of all the good stuff we cooked
878+ ok(Recipe->lookup($recipe_id), "still here");
879+ ok(Ingredient->lookup($ingredient_pk), "still here");
880+ ok defined Recipe->lookup_multi([ $recipe_id ])->[0];
881+
882+ ## and now test a rollback of a remove
883+ Data::ObjectDriver::BaseObject->begin_work;
884+ $ingredient->remove;
885+ Data::ObjectDriver::BaseObject->rollback;
886+ ok(Ingredient->lookup($ingredient_pk), "still here");
887+
888+ ## finally let's delete it
889+ Data::ObjectDriver::BaseObject->begin_work;
890+ $ingredient->remove;
891+ Data::ObjectDriver::BaseObject->commit;
892+ ok(! Ingredient->lookup($ingredient_pk), "finally deleted");
893+}
894+
895+## nested transactions
896+{
897+ ## if there is no transaction active this will just warn
898+ is( Data::ObjectDriver::BaseObject->txn_active, 0);
899+ diag "will warn";
900+ Data::ObjectDriver::BaseObject->commit;
901+ is( Data::ObjectDriver::BaseObject->txn_active, 0);
902+
903+ ## do a commit in the end
904+ Data::ObjectDriver::BaseObject->begin_work;
905+ is( Data::ObjectDriver::BaseObject->txn_active, 1);
906+
907+ my $recipe = Recipe->new;
908+ $recipe->title('lasagnes');
909+ ok($recipe->save, 'Object saved successfully');
910+ diag $recipe->recipe_id;
911+
912+ diag "will warn";
913+ Data::ObjectDriver::BaseObject->begin_work;
914+ Data::ObjectDriver::BaseObject->begin_work;
915+ is( Data::ObjectDriver::BaseObject->txn_active, 3);
916+
917+
918+ my $ingredient = Ingredient->new;
919+ $ingredient->recipe_id($recipe->recipe_id);
920+ $ingredient->name("pasta");
921+ ok $ingredient->insert;
922+
923+ Data::ObjectDriver::BaseObject->rollback;
924+ Data::ObjectDriver::BaseObject->commit;
925+ Data::ObjectDriver::BaseObject->commit;
926+ is( Data::ObjectDriver::BaseObject->txn_active, 0);
927+
928+ $recipe = Recipe->lookup($recipe->primary_key);
929+ $ingredient = Ingredient->lookup($ingredient->primary_key);
930+ ok $recipe, "got committed";
931+ ok $ingredient, "got committed";
932+ is $ingredient->name, "pasta";
933+
934+ ## now test the same thing with a rollback in the end
935+ Data::ObjectDriver::BaseObject->begin_work;
936+
937+ $recipe = Recipe->new;
938+ $recipe->title('lasagnes');
939+ ok($recipe->save, 'Object saved successfully');
940+
941+ diag "will warn";
942+ Data::ObjectDriver::BaseObject->begin_work;
943+
944+ $ingredient = Ingredient->new;
945+ $ingredient->recipe_id($recipe->recipe_id);
946+ $ingredient->name("more layers");
947+ ok $ingredient->insert;
948+
949+ Data::ObjectDriver::BaseObject->commit;
950+ Data::ObjectDriver::BaseObject->rollback;
951+
952+ $recipe = Recipe->lookup($recipe->primary_key);
953+ $ingredient = eval { Ingredient->lookup($ingredient->primary_key) };
954+ ok ! $recipe, "rollback";
955+ ok ! $ingredient, "rollback";
956+}
957+
958+1;
959
960Property changes on: t/txn-common.pl
961___________________________________________________________________
962Name: svn:executable
963 + *
964
965Index: t/12-windows.t
966===================================================================
967--- t/12-windows.t (.../tags/release-0.05) (revision 0)
968+++ t/12-windows.t (.../trunk) (revision 528)
969@@ -0,0 +1,104 @@
970+# $Id$
971+
972+use strict;
973+
974+use Data::Dumper;
975+use lib 't/lib';
976+use lib 't/lib/cached';
977+
978+require 't/lib/db-common.pl';
979+
980+use Test::More;
981+use Test::Exception;
982+use Scalar::Util;
983+BEGIN {
984+ unless (eval { require DBD::SQLite }) {
985+ plan skip_all => 'Tests require DBD::SQLite';
986+ }
987+ unless (eval { require Cache::Memory }) {
988+ plan skip_all => 'Tests require Cache::Memory';
989+ }
990+}
991+
992+plan tests => 19;
993+
994+use Recipe;
995+use Ingredient;
996+
997+setup_dbs({
998+ global => [ qw( recipes ingredients ) ],
999+});
1000+
1001+my $r = Recipe->new;
1002+$r->title("Spaghetti");
1003+$r->save;
1004+
1005+my $i = Ingredient->new;
1006+$i->name("Oregano");
1007+$i->recipe_id($r->recipe_id);
1008+ok( $i->save, "Saved first ingredient" );
1009+
1010+$i = Ingredient->new;
1011+$i->name("Salt");
1012+$i->recipe_id($r->recipe_id);
1013+ok( $i->save, "Saved second ingredient" );
1014+
1015+$i = Ingredient->new;
1016+$i->name("Onion");
1017+$i->recipe_id($r->recipe_id);
1018+ok( $i->save, "Saved third ingredient" );
1019+
1020+my $load_count = 0;
1021+my $trigger = sub { $load_count++ };
1022+Ingredient->add_trigger( 'post_load', $trigger );
1023+
1024+$load_count = 0;
1025+Ingredient->driver->clear_cache;
1026+my $iter = Ingredient->search();
1027+$iter->end;
1028+is( $load_count, 3, "Default behavior: load all objects with plain search method" );
1029+
1030+$load_count = 0;
1031+Ingredient->driver->clear_cache;
1032+$iter = Ingredient->search( undef, { window_size => 1 });
1033+$i = $iter->();
1034+$iter->end;
1035+is( $load_count, 1, "1 ingredient loaded when window size = 1" );
1036+
1037+$load_count = 0;
1038+Ingredient->driver->clear_cache;
1039+$iter = Ingredient->search( undef, { window_size => 2 });
1040+$i = $iter->();
1041+$iter->end;
1042+is( $load_count, 2, "2 ingredients loaded" );
1043+
1044+$load_count = 0;
1045+Ingredient->driver->clear_cache;
1046+$iter = Ingredient->search( undef, { window_size => 1, sort => "name", direction => "asc" });
1047+my $i1 = $iter->();
1048+ok($i1, "First row from windowed select returned");
1049+is( $i1->name, "Onion", "Name is 'Onion'" );
1050+my $i2 = $iter->();
1051+ok( $i2, "Second row from windowed select returned");
1052+is( $i2->name, "Oregano", "Name is 'Oregano'" );
1053+ok( $iter->(), "Third row from windowed select returned" );
1054+ok( ! $iter->(), "No more rows, which is okay" );
1055+is( $load_count, 3, "3 objects loaded");
1056+$iter->end;
1057+
1058+$load_count = 0;
1059+Ingredient->driver->clear_cache;
1060+$iter = Ingredient->search( undef, { window_size => 5, limit => 2, sort => "name", direction => "asc" });
1061+$i1 = $iter->();
1062+ok($i1, "First row from windowed select returned");
1063+is( $i1->name, "Onion", "Name is 'Onion'" );
1064+$i2 = $iter->();
1065+ok( $i2, "Second row from windowed select returned");
1066+is( $i2->name, "Oregano", "Name is 'Oregano'" );
1067+ok( !$iter->(), "No third row; limit argument respected" );
1068+is( $load_count, 2, "2 objects loaded; limit argument respected");
1069+$iter->end;
1070+
1071+teardown_dbs(qw( global ));
1072+
1073+print Dumper( Data::ObjectDriver->profiler->query_log ) if $ENV{DOD_PROFILE};
1074
1075Property changes on: t/12-windows.t
1076___________________________________________________________________
1077Name: svn:keywords
1078 + Id Revision
1079
1080Index: lib/Data/ObjectDriver/ResultSet.pm
1081===================================================================
1082--- lib/Data/ObjectDriver/ResultSet.pm (.../tags/release-0.05) (revision 528)
1083+++ lib/Data/ObjectDriver/ResultSet.pm (.../trunk) (revision 528)
1084@@ -7,6 +7,7 @@
1085 use strict;
1086
1087 use base qw( Class::Accessor::Fast );
1088+use List::Util qw(min);
1089
1090 ## Public/_Private Accessors
1091
1092@@ -91,6 +92,7 @@
1093 my $cur_terms = $self->_terms || {};
1094 my $filter_terms = $self->_filter_terms || {};
1095 foreach my $k (keys %$terms) {
1096+ $self->_results_loaded(0) unless $cur_terms->{$k};
1097 $cur_terms->{$k} = $terms->{$k};
1098 $filter_terms->{$k} = 1 if $self->_results_loaded;
1099 }
1100@@ -107,10 +109,12 @@
1101 foreach my $k (keys %$args) {
1102 my $val = $args->{$k};
1103
1104- # If we get a limit arg that is bigger than our existing limit, then
1105+ # If we get a limit arg that is bigger than our existing limit (and
1106+ # we *have* an existing limit), then
1107 # make sure we force a requery. Same for any filter arguments.
1108 # Same for offset arg that is smaller than existing one.
1109- if ((($k eq 'limit') and (($cur_args->{'limit'}||0) < $val)) or
1110+ if ((($k eq 'limit') and
1111+ ( exists $cur_args->{'limit'} && defined $cur_args->{'limit'} && ($cur_args->{'limit'}||0) < $val)) or
1112 (($k eq 'offset') and (($cur_args->{'offset'}||0) > $val)) or
1113 ($k eq 'filters')) {
1114 $self->_results_loaded(0);
1115@@ -136,7 +140,9 @@
1116 if ref $term_names ne 'ARRAY';
1117
1118 foreach my $n (@$term_names) {
1119- delete $terms->{$n};
1120+ if (delete $terms->{$n}) {
1121+ $self->_results_loaded(0);
1122+ }
1123 }
1124 }
1125
1126@@ -211,6 +217,23 @@
1127 }
1128 }
1129
1130+# look at next() without incrementing the cursor
1131+# like if you just want to see what's coming down the road at you
1132+sub peek_next {
1133+ my $self = shift;
1134+
1135+ return if $self->is_finished;
1136+
1137+ # Load the results and return an object
1138+ my $results = $self->_load_results;
1139+
1140+ my $obj = $results->[$self->_cursor + 1];
1141+
1142+ return $obj;
1143+}
1144+
1145+
1146+
1147 sub prev {
1148 my $self = shift;
1149
1150@@ -239,13 +262,14 @@
1151 sub slice {
1152 my $self = shift;
1153 my ($start, $end) = @_;
1154- my $limit = $end - $start;
1155
1156 # Do we already have results?
1157 if ($self->_results) {
1158- return @{ $self->_results }[$start, $end];
1159+ return [ @{ $self->_results }[$start..min($self->count-1, $end)] ];
1160 }
1161
1162+ my $limit = $end - $start + 1;
1163+
1164 $self->add_offset($start);
1165 $self->add_limit($limit);
1166
1167@@ -254,6 +278,21 @@
1168 return $r;
1169 }
1170
1171+sub all {
1172+ my $self = shift;
1173+
1174+ return unless $self->count;
1175+
1176+ my @obj;
1177+ push @obj, $self->first;
1178+ while (my $obj = $self->next) {
1179+ push @obj, $obj;
1180+ }
1181+
1182+ $self->rewind;
1183+ return @obj;
1184+}
1185+
1186 sub count {
1187 my $self = shift;
1188
1189@@ -415,6 +454,12 @@
1190 return \@r;
1191 }
1192
1193+sub rewind {
1194+ my $self = shift;
1195+ $self->is_finished(0);
1196+ $self->_cursor(-1);
1197+ return $self;
1198+}
1199 1;
1200
1201 __END__
1202@@ -739,6 +784,39 @@
1203
1204 $obj = $res->next;
1205
1206+=head2 peek_next
1207+
1208+Retrieve the next item in the resultset WITHOUT advancing the cursor.
1209+
1210+Arguments:
1211+
1212+=over 4
1213+
1214+=item I<none>
1215+
1216+=back
1217+
1218+; Return value
1219+: The next object or undef if past the end of the result set
1220+
1221+; Notes
1222+: Calling this method will force a DB query. All subsequent calls to I<curr> will return this object
1223+
1224+; Example
1225+
1226+ while ($bottle = $res->next){
1227+
1228+ if ($bottle->type eq 'Bud Light'
1229+ && $res->peek_next->type eq 'Chimay'){
1230+
1231+ $bottle->pass; #don't spoil my palate
1232+
1233+ }else{
1234+ $bottle->drink;
1235+ }
1236+ }
1237+
1238+
1239 =head2 prev
1240
1241 Retrieve the previous item in the result set
1242@@ -859,6 +937,10 @@
1243 Set this and you'll see $Data::ObjectDriver::DEBUG output when
1244 I go to get the results.
1245
1246+=head2 rewind
1247+
1248+Move back to the start of the iterator for this instance of results of a query.
1249+
1250 =head2 first
1251
1252 Returns the first object in the result set.
1253Index: lib/Data/ObjectDriver/SQL.pm
1254===================================================================
1255--- lib/Data/ObjectDriver/SQL.pm (.../tags/release-0.05) (revision 528)
1256+++ lib/Data/ObjectDriver/SQL.pm (.../trunk) (revision 528)
1257@@ -6,12 +6,18 @@
1258
1259 use base qw( Class::Accessor::Fast );
1260
1261-__PACKAGE__->mk_accessors(qw( select select_map select_map_reverse from joins where bind limit offset group order having where_values column_mutator ));
1262+__PACKAGE__->mk_accessors(qw(
1263+ select distinct select_map select_map_reverse
1264+ from joins where bind limit offset group order
1265+ having where_values column_mutator index_hint
1266+ comment
1267+));
1268
1269 sub new {
1270 my $class = shift;
1271 my $stmt = $class->SUPER::new(@_);
1272 $stmt->select([]);
1273+ $stmt->distinct(0);
1274 $stmt->select_map({});
1275 $stmt->select_map_reverse({});
1276 $stmt->bind([]);
1277@@ -20,6 +26,7 @@
1278 $stmt->where_values({});
1279 $stmt->having([]);
1280 $stmt->joins([]);
1281+ $stmt->index_hint({});
1282 $stmt;
1283 }
1284
1285@@ -41,22 +48,34 @@
1286 };
1287 }
1288
1289+sub add_index_hint {
1290+ my $stmt = shift;
1291+ my($table, $hint) = @_;
1292+ $stmt->index_hint->{$table} = {
1293+ type => $hint->{type} || 'USE',
1294+ list => ref($hint->{list}) eq 'ARRAY' ? $hint->{list} : [ $hint->{list} ],
1295+ };
1296+}
1297+
1298 sub as_sql {
1299 my $stmt = shift;
1300 my $sql = '';
1301 if (@{ $stmt->select }) {
1302 $sql .= 'SELECT ';
1303+ $sql .= 'DISTINCT ' if $stmt->distinct;
1304 $sql .= join(', ', map {
1305 my $alias = $stmt->select_map->{$_};
1306 $alias && /(?:^|\.)\Q$alias\E$/ ? $_ : "$_ $alias";
1307 } @{ $stmt->select }) . "\n";
1308 }
1309 $sql .= 'FROM ';
1310+
1311 ## Add any explicit JOIN statements before the non-joined tables.
1312 if ($stmt->joins && @{ $stmt->joins }) {
1313 my $initial_table_written = 0;
1314 for my $j (@{ $stmt->joins }) {
1315 my($table, $joins) = map { $j->{$_} } qw( table joins );
1316+ $table = $stmt->_add_index_hint($table); ## index hint handling
1317 $sql .= $table unless $initial_table_written++;
1318 for my $join (@{ $j->{joins} }) {
1319 $sql .= ' ' .
1320@@ -66,7 +85,12 @@
1321 }
1322 $sql .= ', ' if @{ $stmt->from };
1323 }
1324- $sql .= join(', ', @{ $stmt->from }) . "\n";
1325+
1326+ if ($stmt->from && @{ $stmt->from }) {
1327+ $sql .= join ', ', map { $stmt->_add_index_hint($_) } @{ $stmt->from };
1328+ }
1329+
1330+ $sql .= "\n";
1331 $sql .= $stmt->as_sql_where;
1332
1333 $sql .= $stmt->as_aggregate('group');
1334@@ -74,7 +98,11 @@
1335 $sql .= $stmt->as_aggregate('order');
1336
1337 $sql .= $stmt->as_limit;
1338- $sql;
1339+ my $comment = $stmt->comment;
1340+ if ($comment && $comment =~ /([ 0-9a-zA-Z.:;()_#&,]+)/) {
1341+ $sql .= "-- $1" if $1;
1342+ }
1343+ return $sql;
1344 }
1345
1346 sub as_limit {
1347@@ -233,6 +261,19 @@
1348 ($term, \@bind, $col);
1349 }
1350
1351+sub _add_index_hint {
1352+ my $stmt = shift;
1353+ my ($tbl_name) = @_;
1354+ my $hint = $stmt->index_hint->{$tbl_name};
1355+ return $tbl_name unless $hint && ref($hint) eq 'HASH';
1356+ if ($hint->{list} && @{ $hint->{list} }) {
1357+ return $tbl_name . ' ' . uc($hint->{type} || 'USE') . ' INDEX (' .
1358+ join (',', @{ $hint->{list} }) .
1359+ ')';
1360+ }
1361+ return $tbl_name;
1362+}
1363+
1364 1;
1365
1366 __END__
1367@@ -276,6 +317,10 @@
1368
1369 The database columns to select in a C<SELECT> query.
1370
1371+=head2 C<distinct> (boolean)
1372+
1373+Whether the C<SELECT> query should return DISTINCT rows only.
1374+
1375 =head2 C<select_map> (hashref)
1376
1377 The map of database column names to object fields in a C<SELECT> query. Use
1378@@ -401,6 +446,10 @@
1379 Note you can set a single ordering field, or use an arrayref containing
1380 multiple ordering fields.
1381
1382+=head2 C<$sql-E<gt>comment([ $comment ])>
1383+
1384+Returns or sets a simple comment to the SQL statement
1385+
1386 =head1 USAGE
1387
1388 =head2 C<Data::ObjectDriver::SQL-E<gt>new()>
1389@@ -421,6 +470,10 @@
1390 C<JOIN> table references for the statement. The structure for the set of joins
1391 are as described for the C<joins> attribute member above.
1392
1393+=head2 C<$sql-E<gt>add_index_hint($table, $index)>
1394+
1395+Specifies a particular index to use for a particular table.
1396+
1397 =head2 C<$sql-E<gt>add_where($column, $value)>
1398
1399 Adds a condition on the value of the database column C<$column> to the
1400@@ -518,6 +571,23 @@
1401 HAVING> clause. The expression compares C<$column> using C<$value>, which can
1402 be any of the structures described above for the C<add_where()> method.
1403
1404+=head2 C<$sql-E<gt>add_index_hint($table, \@hints)>
1405+
1406+Addes the index hint into a C<SELECT> query. The structure for the set of
1407+C<\@hints> are arrayref of hashrefs containing these members:
1408+
1409+=over 4
1410+
1411+=item * C<type> (scalar)
1412+
1413+The name of the type. "USE", "IGNORE or "FORCE".
1414+
1415+=item * C<list> (arrayref)
1416+
1417+The list of name of indexes which to use.
1418+
1419+=back
1420+
1421 =head2 C<$sql-E<gt>as_sql()>
1422
1423 Returns the SQL fully representing the SQL statement C<$sql>.
1424Index: lib/Data/ObjectDriver/Driver/DBD.pm
1425===================================================================
1426--- lib/Data/ObjectDriver/Driver/DBD.pm (.../tags/release-0.05) (revision 528)
1427+++ lib/Data/ObjectDriver/Driver/DBD.pm (.../trunk) (revision 528)
1428@@ -10,6 +10,7 @@
1429 my($name) = @_;
1430 die "No Driver" unless $name;
1431 my $subclass = join '::', $class, $name;
1432+ no strict 'refs';
1433 unless (defined ${"${subclass}::"}) {
1434 eval "use $subclass"; ## no critic
1435 die $@ if $@;
1436@@ -40,6 +41,9 @@
1437
1438 sub sql_class { 'Data::ObjectDriver::SQL' }
1439
1440+# Some drivers have problems with prepared caches
1441+sub force_no_prepared_cache { 0 };
1442+
1443 1;
1444
1445 __END__
1446Index: lib/Data/ObjectDriver/Driver/Partition.pm
1447===================================================================
1448--- lib/Data/ObjectDriver/Driver/Partition.pm (.../tags/release-0.05) (revision 528)
1449+++ lib/Data/ObjectDriver/Driver/Partition.pm (.../trunk) (revision 528)
1450@@ -3,6 +3,7 @@
1451 package Data::ObjectDriver::Driver::Partition;
1452 use strict;
1453 use warnings;
1454+use Carp();
1455
1456 use base qw( Data::ObjectDriver Class::Accessor::Fast );
1457
1458@@ -13,18 +14,21 @@
1459 $driver->SUPER::init(@_);
1460 my %param = @_;
1461 $driver->get_driver($param{get_driver});
1462+ $driver->{__working_drivers} = [];
1463 $driver;
1464 }
1465
1466 sub lookup {
1467 my $driver = shift;
1468 my($class, $id) = @_;
1469+ return unless $id;
1470 $driver->get_driver->($id)->lookup($class, $id);
1471 }
1472
1473 sub lookup_multi {
1474 my $driver = shift;
1475 my($class, $ids) = @_;
1476+ return [] unless @$ids;
1477 $driver->get_driver->($ids->[0])->lookup_multi($class, $ids);
1478 }
1479
1480@@ -55,9 +59,56 @@
1481 } else {
1482 $d = $driver->get_driver->(@rest);
1483 }
1484+
1485+ if ( $driver->txn_active ) {
1486+ $driver->add_working_driver($d);
1487+ }
1488 $d->$meth($obj, @rest);
1489 }
1490
1491+sub add_working_driver {
1492+ my $driver = shift;
1493+ my $part_driver = shift;
1494+ if (! $part_driver->txn_active) {
1495+ $part_driver->begin_work;
1496+ push @{$driver->{__working_drivers}}, $part_driver;
1497+ }
1498+}
1499+
1500+sub commit {
1501+ my $driver = shift;
1502+
1503+ ## if the driver has its own internal txn_active flag
1504+ ## off, we don't bother ending. Maybe we already did
1505+ return unless $driver->txn_active;
1506+
1507+ $driver->SUPER::commit(@_);
1508+ _end_txn($driver, 'commit', @_);
1509+}
1510+
1511+sub rollback {
1512+ my $driver = shift;
1513+
1514+ ## if the driver has its own internal txn_active flag
1515+ ## off, we don't bother ending. Maybe we already did
1516+ return unless $driver->txn_active;
1517+
1518+ $driver->SUPER::rollback(@_);
1519+ _end_txn($driver, 'rollback', @_);
1520+}
1521+
1522+sub _end_txn {
1523+ my ($driver, $method) = @_;
1524+
1525+ my $wd = $driver->{__working_drivers};
1526+ $driver->{__working_drivers} = [];
1527+
1528+ for my $part_driver (@{ $wd || [] }) {
1529+ $part_driver->$method;
1530+ }
1531+}
1532+
1533+
1534 1;
1535
1536 __END__
1537Index: lib/Data/ObjectDriver/Driver/Multiplexer.pm
1538===================================================================
1539--- lib/Data/ObjectDriver/Driver/Multiplexer.pm (.../tags/release-0.05) (revision 528)
1540+++ lib/Data/ObjectDriver/Driver/Multiplexer.pm (.../trunk) (revision 528)
1541@@ -93,9 +93,10 @@
1542 my($meth, $obj, @args) = @_;
1543 my $orig_obj = Storable::dclone($obj);
1544 my $ret;
1545+
1546 ## We want to be sure to have the initial and final state of the object
1547 ## strictly identical as if we made only one call on $obj
1548- ## (Perhaps it's a bit overkill ? playing with 'changed_cols' may suffice)
1549+ ## (Perhaps it's a bit overkill ? playing with 'changed_cols' may do the trick)
1550 for my $sub_driver (@{ $driver->drivers }) {
1551 $obj = Storable::dclone($orig_obj);
1552 $ret = $sub_driver->$meth($obj, @args);
1553@@ -103,15 +104,33 @@
1554 return $ret;
1555 }
1556
1557-## Nobody should ask a dbh for us directly, if someone does, this
1558-## is probably to change handler properties (transaction). So
1559-## we assume that only the on_lookup is important (I said it was experimental..)
1560-sub get_dbh {
1561+sub begin_work {
1562 my $driver = shift;
1563- my $subdriver = $driver->on_lookup;
1564- return $subdriver->get_dbh(@_);
1565+ $driver->SUPER::begin_work(@_);
1566+ for my $sub_driver (@{ $driver->drivers }) {
1567+ $sub_driver->begin_work;
1568+ }
1569 }
1570
1571+sub commit {
1572+ my $driver = shift;
1573+ $driver->SUPER::commit(@_);
1574+ $driver->_end_txn('commit', @_);
1575+}
1576+
1577+sub rollback {
1578+ my $driver = shift;
1579+ $driver->SUPER::rollback(@_);
1580+ $driver->_end_txn('rollback', @_);
1581+}
1582+
1583+sub _end_txn {
1584+ my ($driver, $method) = @_;
1585+ for my $sub_driver (@{ $driver->drivers }) {
1586+ $sub_driver->$method;
1587+ }
1588+}
1589+
1590 1;
1591 __END__
1592
1593Index: lib/Data/ObjectDriver/Driver/BaseCache.pm
1594===================================================================
1595--- lib/Data/ObjectDriver/Driver/BaseCache.pm (.../tags/release-0.05) (revision 528)
1596+++ lib/Data/ObjectDriver/Driver/BaseCache.pm (.../trunk) (revision 528)
1597@@ -9,7 +9,7 @@
1598
1599 use Carp ();
1600
1601-__PACKAGE__->mk_accessors(qw( cache fallback ));
1602+__PACKAGE__->mk_accessors(qw( cache fallback txn_buffer));
1603 __PACKAGE__->mk_classdata(qw( Disabled ));
1604
1605 sub deflate { $_[1] }
1606@@ -29,9 +29,45 @@
1607 or Carp::croak("cache is required");
1608 $driver->fallback($param{fallback})
1609 or Carp::croak("fallback is required");
1610+ $driver->txn_buffer([]);
1611 $driver;
1612 }
1613
1614+sub begin_work {
1615+ my $driver = shift;
1616+ my $rv = $driver->fallback->begin_work(@_);
1617+ $driver->SUPER::begin_work(@_);
1618+ return $rv;
1619+}
1620+
1621+sub commit {
1622+ my $driver = shift;
1623+ return unless $driver->txn_active;
1624+
1625+ my $rv = $driver->fallback->commit(@_);
1626+
1627+ $driver->debug(sprintf("%14s", "COMMIT(" . scalar(@{$driver->txn_buffer}) . ")") . ": driver=$driver");
1628+ while (my $cb = shift @{$driver->txn_buffer}) {
1629+ $cb->();
1630+ }
1631+ $driver->SUPER::commit(@_);
1632+
1633+ return $rv;
1634+}
1635+
1636+sub rollback {
1637+ my $driver = shift;
1638+ return unless $driver->txn_active;
1639+ my $rv = $driver->fallback->rollback(@_);
1640+
1641+ $driver->debug(sprintf("%14s", "ROLLBACK(" . scalar(@{$driver->txn_buffer}) . ")") . ": driver=$driver");
1642+ $driver->txn_buffer([]);
1643+
1644+ $driver->SUPER::rollback(@_);
1645+
1646+ return $rv;
1647+}
1648+
1649 sub cache_object {
1650 my $driver = shift;
1651 my($obj) = @_;
1652@@ -40,10 +76,12 @@
1653 ## If it's already cached in this layer, assume it's already cached in
1654 ## all layers below this, as well.
1655 unless (exists $obj->{__cached} && $obj->{__cached}{ref $driver}) {
1656- $driver->add_to_cache(
1657+ $driver->modify_cache(sub {
1658+ $driver->add_to_cache(
1659 $driver->cache_key(ref($obj), $obj->primary_key),
1660 $driver->deflate($obj)
1661 );
1662+ });
1663 $driver->fallback->cache_object($obj);
1664 }
1665 }
1666@@ -53,7 +91,7 @@
1667 my($class, $id) = @_;
1668 return unless defined $id;
1669 return $driver->fallback->lookup($class, $id)
1670- if $driver->Disabled;
1671+ if $driver->Disabled or $driver->txn_active;
1672 my $key = $driver->cache_key($class, $id);
1673 my $obj = $driver->get_from_cache($key);
1674 if ($obj) {
1675@@ -83,7 +121,7 @@
1676 my $driver = shift;
1677 my($class, $ids) = @_;
1678 return $driver->fallback->lookup_multi($class, $ids)
1679- if $driver->Disabled;
1680+ if $driver->Disabled or $driver->txn_active;
1681
1682 my %id2key = map { $_ => $driver->cache_key($class, $_) } grep { defined } @$ids;
1683 my $got = $driver->get_multi_from_cache(values %id2key);
1684@@ -149,14 +187,35 @@
1685 local $args->{fetchonly} = $class->primary_key_tuple;
1686 ## Disable triggers for this load. We don't want the post_load trigger
1687 ## being called twice.
1688- $args->{no_triggers} = 1;
1689+ local $args->{no_triggers} = 1;
1690 my @objs = $driver->fallback->search($class, $terms, $args);
1691
1692- ## Load all of the objects using a lookup_multi, which is fast from
1693- ## cache.
1694- my $objs = $driver->lookup_multi($class, [ map { $_->primary_key } @objs ]);
1695+ my $windowed = (!wantarray) && $args->{window_size};
1696
1697- $driver->list_or_iterator($objs);
1698+ if ( $windowed ) {
1699+ my @window;
1700+ my $window_size = $args->{window_size};
1701+ my $iter = sub {
1702+ my $d = $driver;
1703+ while ( (!@window) && @objs ) {
1704+ my $objs = $driver->lookup_multi(
1705+ $class,
1706+ [ map { $_->primary_key }
1707+ splice( @objs, 0, $window_size ) ]
1708+ );
1709+ # A small possibility exists that we may fetch
1710+ # some IDs here that no longer exist; grep these out
1711+ @window = grep { defined $_ } @$objs if $objs;
1712+ }
1713+ return @window ? shift @window : undef;
1714+ };
1715+ return Data::ObjectDriver::Iterator->new($iter, sub { @objs = (); @window = () });
1716+ } else {
1717+ ## Load all of the objects using a lookup_multi, which is fast from
1718+ ## cache.
1719+ my $objs = $driver->lookup_multi($class, [ map { $_->primary_key } @objs ]);
1720+ return $driver->list_or_iterator($objs);
1721+ }
1722 }
1723
1724 sub update {
1725@@ -166,7 +225,9 @@
1726 if $driver->Disabled;
1727 my $ret = $driver->fallback->update($obj);
1728 my $key = $driver->cache_key(ref($obj), $obj->primary_key);
1729- $driver->update_cache($key, $driver->deflate($obj));
1730+ $driver->modify_cache(sub {
1731+ $driver->update_cache($key, $driver->deflate($obj));
1732+ });
1733 return $ret;
1734 }
1735
1736@@ -181,7 +242,9 @@
1737 my $ret = $driver->fallback->replace($obj);
1738 if ($has_pk) {
1739 my $key = $driver->cache_key(ref($obj), $obj->primary_key);
1740- $driver->update_cache($key, $driver->deflate($obj));
1741+ $driver->modify_cache(sub {
1742+ $driver->update_cache($key, $driver->deflate($obj));
1743+ });
1744 }
1745 return $ret;
1746 }
1747@@ -199,11 +262,22 @@
1748 Carp::croak("nofetch option isn't compatible with a cache driver");
1749 }
1750 if (ref $obj) {
1751- $driver->remove_from_cache($driver->cache_key(ref($obj), $obj->primary_key));
1752+ $driver->uncache_object($obj);
1753 }
1754 $driver->fallback->remove(@_);
1755 }
1756
1757+sub uncache_object {
1758+ my $driver = shift;
1759+ my($obj) = @_;
1760+ my $key = $driver->cache_key(ref($obj), $obj->primary_key);
1761+ return $driver->modify_cache(sub {
1762+ delete $obj->{__cached};
1763+ $driver->remove_from_cache($key);
1764+ $driver->fallback->uncache_object($obj);
1765+ });
1766+}
1767+
1768 sub cache_key {
1769 my $driver = shift;
1770 my($class, $id) = @_;
1771@@ -217,6 +291,18 @@
1772 return $key;
1773 }
1774
1775+# if we're operating within a transaction then we need to buffer CRUD
1776+# and only commit to the cache upon commit
1777+sub modify_cache {
1778+ my ($driver, $cb) = @_;
1779+
1780+ unless ($driver->txn_active) {
1781+ return $cb->();
1782+ }
1783+ $driver->debug(sprintf("%14s", "BUFFER(1)") . ": driver=$driver");
1784+ push @{$driver->txn_buffer} => $cb;
1785+}
1786+
1787 sub DESTROY { }
1788
1789 sub AUTOLOAD {
1790Index: lib/Data/ObjectDriver/Driver/DBD/SQLite.pm
1791===================================================================
1792--- lib/Data/ObjectDriver/Driver/DBD/SQLite.pm (.../tags/release-0.05) (revision 528)
1793+++ lib/Data/ObjectDriver/Driver/DBD/SQLite.pm (.../trunk) (revision 528)
1794@@ -56,7 +56,10 @@
1795 return 1;
1796 }
1797
1798+# TODO this should check the version
1799+sub force_no_prepared_cache { 1 };
1800
1801+
1802 1;
1803
1804 =pod
1805Index: lib/Data/ObjectDriver/Driver/DBI.pm
1806===================================================================
1807--- lib/Data/ObjectDriver/Driver/DBI.pm (.../tags/release-0.05) (revision 528)
1808+++ lib/Data/ObjectDriver/Driver/DBI.pm (.../trunk) (revision 528)
1809@@ -13,8 +13,10 @@
1810 use Data::ObjectDriver::Driver::DBD;
1811 use Data::ObjectDriver::Iterator;
1812
1813-__PACKAGE__->mk_accessors(qw( dsn username password connect_options dbh get_dbh dbd prefix ));
1814+__PACKAGE__->mk_accessors(qw( dsn username password connect_options dbh get_dbh dbd prefix reuse_dbh force_no_prepared_cache));
1815
1816+our $FORCE_NO_PREPARED_CACHE = 0;
1817+
1818 sub init {
1819 my $driver = shift;
1820 my %param = @_;
1821@@ -45,21 +47,45 @@
1822 }
1823 }
1824
1825+# Some versions of SQLite require the undefing to finalise properly
1826+sub _close_sth {
1827+ my $sth = shift;
1828+ $sth->finish;
1829+ undef $sth;
1830+}
1831+
1832+# Some versions of SQLite have problems with prepared caching due to finalisation order
1833+sub _prepare_cached {
1834+ my $driver = shift;
1835+ my $dbh = shift;
1836+ my $sql = shift;
1837+ return ($FORCE_NO_PREPARED_CACHE || $driver->force_no_prepared_cache || $driver->dbd->force_no_prepared_cache)? $dbh->prepare($sql) : $dbh->prepare_cached($sql);
1838+}
1839+
1840+my %Handles;
1841 sub init_db {
1842 my $driver = shift;
1843 my $dbh;
1844- eval {
1845- $dbh = DBI->connect($driver->dsn, $driver->username, $driver->password,
1846- { RaiseError => 1, PrintError => 0, AutoCommit => 1,
1847- %{$driver->connect_options || {}} })
1848- or Carp::croak("Connection error: " . $DBI::errstr);
1849- };
1850- if ($@) {
1851- Carp::croak($@);
1852+ if ($driver->reuse_dbh) {
1853+ $dbh = $Handles{$driver->dsn};
1854 }
1855+ unless ($dbh) {
1856+ eval {
1857+ $dbh = DBI->connect($driver->dsn, $driver->username, $driver->password,
1858+ { RaiseError => 1, PrintError => 0, AutoCommit => 1,
1859+ %{$driver->connect_options || {}} })
1860+ or Carp::croak("Connection error: " . $DBI::errstr);
1861+ };
1862+ if ($@) {
1863+ Carp::croak($@);
1864+ }
1865+ }
1866+ if ($driver->reuse_dbh) {
1867+ $Handles{$driver->dsn} = $dbh;
1868+ }
1869 $driver->dbd->init_dbh($dbh);
1870 $driver->{__dbh_init_by_driver} = 1;
1871- $dbh;
1872+ return $dbh;
1873 }
1874
1875 sub rw_handle {
1876@@ -88,7 +114,7 @@
1877 my $rec = {};
1878 my $sth = $driver->fetch($rec, $obj, $terms, $args);
1879 $sth->fetch;
1880- $sth->finish;
1881+ _close_sth($sth);
1882 $driver->end_query($sth);
1883 return $rec;
1884 }
1885@@ -98,8 +124,8 @@
1886 my($rec, $class, $orig_terms, $orig_args) = @_;
1887
1888 ## Use (shallow) duplicates so the pre_search trigger can modify them.
1889- my $terms = defined $orig_terms ? ( ref $orig_terms eq 'ARRAY' ? [ @$orig_terms ] : { %$orig_terms } ) : undef;
1890- my $args = defined $orig_args ? { %$orig_args } : undef;
1891+ my $terms = defined $orig_terms ? ( ref $orig_terms eq 'ARRAY' ? [ @$orig_terms ] : { %$orig_terms } ) : {};
1892+ my $args = defined $orig_args ? { %$orig_args } : {};
1893 $class->call_trigger('pre_search', $terms, $args);
1894
1895 my $stmt = $driver->prepare_statement($class, $terms, $args);
1896@@ -114,7 +140,7 @@
1897 $sql .= "\nFOR UPDATE" if $orig_args->{for_update};
1898 my $dbh = $driver->r_handle($class->properties->{db});
1899 $driver->start_query($sql, $stmt->{bind});
1900- my $sth = $orig_args->{no_cached_prepare} ? $dbh->prepare($sql) : $dbh->prepare_cached($sql);
1901+ my $sth = $orig_args->{no_cached_prepare} ? $dbh->prepare($sql) : $driver->_prepare_cached($dbh, $sql);
1902 $sth->execute(@{ $stmt->{bind} });
1903 $sth->bind_columns(undef, @bind);
1904
1905@@ -142,7 +168,7 @@
1906 my $d = $driver;
1907
1908 unless ($sth->fetch) {
1909- $sth->finish;
1910+ _close_sth($sth);
1911 $driver->end_query($sth);
1912 return;
1913 }
1914@@ -151,12 +177,10 @@
1915 $obj->set_values_internal($rec);
1916 ## Don't need a duplicate as there's no previous version in memory
1917 ## to preserve.
1918+ $obj->{__is_stored} = 1;
1919 $obj->call_trigger('post_load') unless $args->{no_triggers};
1920 $obj;
1921 };
1922- my $iterator = Data::ObjectDriver::Iterator->new(
1923- $iter, sub { $sth->finish; $driver->end_query($sth) },
1924- );
1925
1926 if (wantarray) {
1927 my @objs = ();
1928@@ -166,6 +190,9 @@
1929 }
1930 return @objs;
1931 } else {
1932+ my $iterator = Data::ObjectDriver::Iterator->new(
1933+ $iter, sub { _close_sth($sth); $driver->end_query($sth) },
1934+ );
1935 return $iterator;
1936 }
1937 return;
1938@@ -186,7 +213,7 @@
1939 return [] unless @$ids;
1940 my @got;
1941 ## If it's a single-column PK, assume it's in one partition, and
1942- ## use an OR search.
1943+ ## use an OR search. FIXME: can we instead check for partitioning?
1944 unless (ref($ids->[0])) {
1945 my $terms = $class->primary_key_to_terms([ $ids ]);
1946 my @sqlgot = $driver->search($class, $terms, { is_pk => 1 });
1947@@ -194,7 +221,7 @@
1948 @got = map { defined $_ ? $hgot{$_} : undef } @$ids;
1949 } else {
1950 for my $id (@$ids) {
1951- push @got, $class->driver->lookup($class, $id);
1952+ push @got, eval{ $class->driver->lookup($class, $id) };
1953 }
1954 }
1955 \@got;
1956@@ -206,16 +233,16 @@
1957 my $dbh = $driver->r_handle;
1958
1959 $driver->start_query($sql, $bind);
1960- my $sth = $dbh->prepare_cached($sql);
1961+ my $sth = $driver->_prepare_cached($dbh, $sql);
1962 $sth->execute(@$bind);
1963 $sth->bind_columns(undef, \my($val));
1964 unless ($sth->fetch) {
1965- $sth->finish;
1966+ _close_sth($sth);
1967 $driver->end_query($sth);
1968 return;
1969 }
1970
1971- $sth->finish;
1972+ _close_sth($sth);
1973 $driver->end_query($sth);
1974
1975 return $val;
1976@@ -237,6 +264,7 @@
1977 my $terms = $obj->primary_key_to_terms;
1978
1979 my $class = ref $obj;
1980+ $terms ||= {};
1981 $class->call_trigger('pre_search', $terms);
1982
1983 my $tbl = $driver->table_for($obj);
1984@@ -245,10 +273,10 @@
1985 $sql .= $stmt->as_sql_where;
1986 my $dbh = $driver->r_handle($obj->properties->{db});
1987 $driver->start_query($sql, $stmt->{bind});
1988- my $sth = $dbh->prepare_cached($sql);
1989+ my $sth = $driver->_prepare_cached($dbh, $sql);
1990 $sth->execute(@{ $stmt->{bind} });
1991 my $exists = $sth->fetch;
1992- $sth->finish;
1993+ _close_sth($sth);
1994 $driver->end_query($sth);
1995
1996 return $exists;
1997@@ -257,8 +285,9 @@
1998 sub replace {
1999 my $driver = shift;
2000 if ($driver->dbd->can_replace) {
2001- $driver->_insert_or_replace(@_, { replace => 1 });
2002- } else {
2003+ return $driver->_insert_or_replace(@_, { replace => 1 });
2004+ }
2005+ if (! $driver->txn_active) {
2006 $driver->begin_work;
2007 eval {
2008 $driver->remove(@_);
2009@@ -269,7 +298,10 @@
2010 Carp::croak("REPLACE transaction error $driver: $@");
2011 }
2012 $driver->commit;
2013+ return;
2014 }
2015+ $driver->remove(@_);
2016+ $driver->insert(@_);
2017 }
2018
2019 sub insert {
2020@@ -321,7 +353,7 @@
2021 'VALUES (' . join(', ', ('?') x @$cols) . ')' . "\n";
2022 my $dbh = $driver->rw_handle($obj->properties->{db});
2023 $driver->start_query($sql, $obj->{column_values});
2024- my $sth = $dbh->prepare_cached($sql);
2025+ my $sth = $driver->_prepare_cached($dbh, $sql);
2026 my $i = 1;
2027 my $col_defs = $obj->properties->{column_defs};
2028 for my $col (@$cols) {
2029@@ -330,8 +362,9 @@
2030 my $attr = $dbd->bind_param_attributes($type, $obj, $col);
2031 $sth->bind_param($i++, $val, $attr);
2032 }
2033- $sth->execute;
2034- $sth->finish;
2035+ eval { $sth->execute };
2036+ die "Failed to execute $sql with ".join(", ",@$cols).": $@" if $@;
2037+ _close_sth($sth);
2038 $driver->end_query($sth);
2039
2040 ## Now, if we didn't have an object ID, we need to grab the
2041@@ -349,12 +382,14 @@
2042 $obj->call_trigger('post_save', $orig_obj);
2043 $obj->call_trigger('post_insert', $orig_obj);
2044
2045+ $orig_obj->{__is_stored} = 1;
2046 $orig_obj->{changed_cols} = {};
2047 1;
2048 }
2049
2050 sub update {
2051 my $driver = shift;
2052+
2053 my($orig_obj, $terms) = @_;
2054
2055 ## Use a duplicate so the pre_save trigger can modify it.
2056@@ -387,7 +422,7 @@
2057
2058 my $dbh = $driver->rw_handle($obj->properties->{db});
2059 $driver->start_query($sql, $obj->{column_values});
2060- my $sth = $dbh->prepare_cached($sql);
2061+ my $sth = $driver->_prepare_cached($dbh, $sql);
2062 my $i = 1;
2063 my $col_defs = $obj->properties->{column_defs};
2064 for my $col (@changed_cols) {
2065@@ -403,7 +438,7 @@
2066 }
2067
2068 my $rows = $sth->execute;
2069- $sth->finish;
2070+ _close_sth($sth);
2071 $driver->end_query($sth);
2072
2073 $obj->call_trigger('post_save', $orig_obj);
2074@@ -448,13 +483,14 @@
2075 $sql .= $stmt->as_sql_where;
2076 my $dbh = $driver->rw_handle($obj->properties->{db});
2077 $driver->start_query($sql, $stmt->{bind});
2078- my $sth = $dbh->prepare_cached($sql);
2079+ my $sth = $driver->_prepare_cached($dbh, $sql);
2080 my $result = $sth->execute(@{ $stmt->{bind} });
2081- $sth->finish;
2082+ _close_sth($sth);
2083 $driver->end_query($sth);
2084
2085 $obj->call_trigger('post_remove', $orig_obj);
2086
2087+ $orig_obj->{__is_stored} = 1;
2088 return $result;
2089 }
2090
2091@@ -482,9 +518,9 @@
2092
2093 my $dbh = $driver->rw_handle($class->properties->{db});
2094 $driver->start_query($sql, $stmt->{bind});
2095- my $sth = $dbh->prepare_cached($sql);
2096+ my $sth = $driver->_prepare_cached($dbh, $sql);
2097 my $result = $sth->execute(@{ $stmt->{bind} });
2098- $sth->finish;
2099+ _close_sth($sth);
2100 $driver->end_query($sth);
2101 return $result;
2102 }
2103@@ -523,19 +559,29 @@
2104
2105 sub begin_work {
2106 my $driver = shift;
2107+
2108+ return if $driver->txn_active;
2109+
2110 my $dbh = $driver->dbh;
2111+
2112 unless ($dbh) {
2113 $driver->{__delete_dbh_after_txn} = 1;
2114 $dbh = $driver->rw_handle;
2115 $driver->dbh($dbh);
2116 }
2117- eval {
2118- $dbh->begin_work;
2119- };
2120- if ($@) {
2121- $driver->rollback;
2122- Carp::croak("Begin work failed for driver $driver: $@");
2123+
2124+ if ($dbh->{AutoCommit}) {
2125+ eval {
2126+ $dbh->begin_work;
2127+ };
2128+ if (my $err = $@) {
2129+ $driver->rollback;
2130+ Carp::croak("Begin work failed for driver $driver: $err");
2131+ }
2132 }
2133+ ## if for some reason AutoCommit was 0 but txn_active was false,
2134+ ## then we set it to true now
2135+ $driver->txn_active(1);
2136 }
2137
2138 sub commit { shift->_end_txn('commit') }
2139@@ -544,11 +590,21 @@
2140 sub _end_txn {
2141 my $driver = shift;
2142 my($action) = @_;
2143- my $dbh = $driver->dbh
2144- or Carp::croak("$action called without a stored handle--begin_work?");
2145- eval { $dbh->$action() };
2146- if ($@) {
2147- Carp::croak("$action failed for driver $driver: $@");
2148+
2149+ ## if the driver has its own internal txn_active flag
2150+ ## off, we don't bother ending. Maybe we already did
2151+ if ($driver->txn_active) {
2152+ $driver->txn_active(0);
2153+
2154+ my $dbh = $driver->dbh
2155+ or Carp::croak("$action called without a stored handle--begin_work?");
2156+
2157+ unless ($dbh->{AutoCommit}) {
2158+ eval { $dbh->$action() };
2159+ if ($@) {
2160+ Carp::croak("$action failed for driver $driver: $@");
2161+ }
2162+ }
2163 }
2164 if ($driver->{__delete_dbh_after_txn}) {
2165 $driver->dbh(undef);
2166@@ -629,8 +685,9 @@
2167 $stmt->order(\@order);
2168 }
2169 }
2170- $stmt->limit($args->{limit}) if $args->{limit};
2171- $stmt->offset($args->{offset}) if $args->{offset};
2172+ $stmt->limit( $args->{limit} ) if $args->{limit};
2173+ $stmt->offset( $args->{offset} ) if $args->{offset};
2174+ $stmt->comment( $args->{comment} ) if $args->{comment};
2175
2176 if (my $terms = $args->{having}) {
2177 for my $col (keys %$terms) {
2178Index: lib/Data/ObjectDriver/BaseObject.pm
2179===================================================================
2180--- lib/Data/ObjectDriver/BaseObject.pm (.../tags/release-0.05) (revision 528)
2181+++ lib/Data/ObjectDriver/BaseObject.pm (.../trunk) (revision 528)
2182@@ -5,7 +5,7 @@
2183 use warnings;
2184
2185 our $HasWeaken;
2186-eval "use Scalar::Util qw(weaken)";
2187+eval q{ use Scalar::Util qw(weaken) }; ## no critic
2188 $HasWeaken = !$@;
2189
2190 use Carp ();
2191@@ -16,6 +16,10 @@
2192
2193 use Data::ObjectDriver::ResultSet;
2194
2195+## Global Transaction variables
2196+our @WorkingDrivers;
2197+our $TransactionLevel = 0;
2198+
2199 sub install_properties {
2200 my $class = shift;
2201 my($props) = @_;
2202@@ -269,6 +273,27 @@
2203 \%terms;
2204 }
2205
2206+sub is_same {
2207+ my($obj, $other) = @_;
2208+
2209+ my @a;
2210+ for my $o ($obj, $other) {
2211+ push @a, [ map { $o->$_() } @{ $o->primary_key_tuple }];
2212+ }
2213+ return is_same_array( @a );
2214+}
2215+
2216+sub object_is_stored {
2217+ my $obj = shift;
2218+ return $obj->{__is_stored} ? 1 : 0;
2219+}
2220+sub pk_str {
2221+ my ($obj) = @_;
2222+ my $pk = $obj->primary_key;
2223+ return $pk unless ref ($pk) eq 'ARRAY';
2224+ return join (":", @$pk);
2225+}
2226+
2227 sub has_primary_key {
2228 my $obj = shift;
2229 return unless @{$obj->primary_key_tuple};
2230@@ -300,7 +325,7 @@
2231 my $values = shift;
2232 for my $col (keys %$values) {
2233 unless ( $obj->has_column($col) ) {
2234- Carp::croak("You tried to set inexistent column $col to value $values->{$col} on " . ref($obj));
2235+ Carp::croak("You tried to set non-existent column $col to value $values->{$col} on " . ref($obj));
2236 }
2237 $obj->$col($values->{$col});
2238 }
2239@@ -468,24 +493,43 @@
2240 my $class = shift;
2241 my($terms, $args) = @_;
2242 my $driver = $class->driver;
2243- my @objs = $driver->search($class, $terms, $args);
2244+ if (wantarray) {
2245+ my @objs = $driver->search($class, $terms, $args);
2246
2247- ## Don't attempt to cache objects where the caller specified fetchonly,
2248- ## because they won't be complete.
2249- ## Also skip this step if we don't get any objects back from the search
2250- if (!$args->{fetchonly} || !@objs) {
2251- for my $obj (@objs) {
2252- $driver->cache_object($obj) if $obj;
2253+ ## Don't attempt to cache objects where the caller specified fetchonly,
2254+ ## because they won't be complete.
2255+ ## Also skip this step if we don't get any objects back from the search
2256+ if (!$args->{fetchonly} || !@objs) {
2257+ for my $obj (@objs) {
2258+ $driver->cache_object($obj) if $obj;
2259+ }
2260 }
2261+ return @objs;
2262+ } else {
2263+ my $iter = $driver->search($class, $terms, $args);
2264+ return $iter if $args->{fetchonly};
2265+
2266+ my $caching_iter = sub {
2267+ my $d = $driver;
2268+
2269+ my $o = $iter->();
2270+ unless ($o) {
2271+ $iter->end;
2272+ return;
2273+ }
2274+ $driver->cache_object($o);
2275+ return $o;
2276+ };
2277+ return Data::ObjectDriver::Iterator->new($caching_iter, sub { $iter->end });
2278 }
2279- $driver->list_or_iterator(\@objs);
2280 }
2281
2282-sub remove { shift->_proxy('remove', @_) }
2283-sub update { shift->_proxy('update', @_) }
2284-sub insert { shift->_proxy('insert', @_) }
2285-sub replace { shift->_proxy('replace', @_) }
2286-sub fetch_data { shift->_proxy('fetch_data', @_) }
2287+sub remove { shift->_proxy( 'remove', @_ ) }
2288+sub update { shift->_proxy( 'update', @_ ) }
2289+sub insert { shift->_proxy( 'insert', @_ ) }
2290+sub replace { shift->_proxy( 'replace', @_ ) }
2291+sub fetch_data { shift->_proxy( 'fetch_data', @_ ) }
2292+sub uncache_object { shift->_proxy( 'uncache_object', @_ ) }
2293
2294 sub refresh {
2295 my $obj = shift;
2296@@ -496,12 +540,72 @@
2297 return 1;
2298 }
2299
2300+## NOTE: I wonder if it could be useful to BaseObject superclass
2301+## to override the global transaction flag. If so, I'd add methods
2302+## to manipulate this flag and the working drivers. -- Yann
2303 sub _proxy {
2304 my $obj = shift;
2305 my($meth, @args) = @_;
2306- $obj->driver->$meth($obj, @args);
2307+ my $driver = $obj->driver;
2308+ ## faster than $obj->txn_active && ! $driver->txn_active but see note.
2309+ if ($TransactionLevel && ! $driver->txn_active) {
2310+ $driver->begin_work;
2311+ push @WorkingDrivers, $driver;
2312+ }
2313+ $driver->$meth($obj, @args);
2314 }
2315
2316+sub txn_active { $TransactionLevel }
2317+
2318+sub begin_work {
2319+ my $class = shift;
2320+ if ($TransactionLevel > 0) {
2321+ warn __PACKAGE__ . ": one ore more transaction already active: $TransactionLevel";
2322+ }
2323+ $TransactionLevel++;
2324+}
2325+
2326+sub commit {
2327+ my $class = shift;
2328+ $class->_end_txn('commit');
2329+}
2330+
2331+sub rollback {
2332+ my $class = shift;
2333+ $class->_end_txn('rollback');
2334+}
2335+
2336+sub _end_txn {
2337+ my $class = shift;
2338+ my $meth = shift;
2339+
2340+ ## Ignore nested transactions
2341+ if ($TransactionLevel > 1) {
2342+ $TransactionLevel--;
2343+ return;
2344+ }
2345+
2346+ if (! $TransactionLevel) {
2347+ warn __PACKAGE__ . ": no transaction active, ignored $meth";
2348+ return;
2349+ }
2350+ my @wd = @WorkingDrivers;
2351+ $TransactionLevel--;
2352+ @WorkingDrivers = ();
2353+
2354+ for my $driver (@wd) {
2355+ $driver->$meth;
2356+ }
2357+}
2358+
2359+sub txn_debug {
2360+ my $class = shift;
2361+ return {
2362+ txn => $TransactionLevel,
2363+ drivers => \@WorkingDrivers,
2364+ };
2365+}
2366+
2367 sub deflate { { columns => shift->column_values } }
2368
2369 sub inflate {
2370@@ -930,10 +1034,31 @@
2371
2372 Returns the I<names> of the primary key fields of C<Class> objects.
2373
2374+=head2 C<$obj-E<gt>is_same($other_obj)>
2375+
2376+Do a primary key check on C<$obj> and $<other_obj> and returns true only if they
2377+are identical.
2378+
2379+=head2 C<$obj-E<gt>object_is_stored()>
2380+
2381+Returns true if the object hasn't been stored in the database yet.
2382+This is particularily useful in triggers where you can then determine
2383+if the object is being INSERTED or just UPDATED.
2384+
2385+=head2 C<$obj-E<gt>pk_str()>
2386+
2387+returns the primay key has a printable string.
2388+
2389 =head2 C<$obj-E<gt>has_primary_key()>
2390
2391 Returns whether the given object has values for all of its primary key fields.
2392
2393+=head2 C<$obj-E<gt>uncache_object()>
2394+
2395+If you use a Cache driver, returned object will be automatically cached as a result
2396+of common retrieve operations. In some rare cases you may want the cache to be cleared
2397+explicitely, and this method provides you with a way to do it.
2398+
2399 =head2 C<$obj-E<gt>primary_key_to_terms([$id])>
2400
2401 Returns C<$obj>'s primary key as a hashref of values keyed on column names,
2402@@ -1053,6 +1178,41 @@
2403 object in the class I<Class>. That is, undoes the operation C<$deflated =
2404 $obj-E<gt>deflate()> by returning a new object equivalent to C<$obj>.
2405
2406+=head1 TRANSACTION SUPPORT AND METHODS
2407+
2408+=head2 Introduction
2409+
2410+When dealing with the methods on this class, the transactions are global,
2411+i.e: applied to all drivers. You can still enable transactions per driver
2412+if you directly use the driver API.
2413+
2414+=head2 C<Class-E<gt>begin_work>
2415+
2416+This enable transactions globally for all drivers until the next L<rollback>
2417+or L<commit> call on the class.
2418+
2419+If begin_work is called while a transaction is still active (nested transaction)
2420+then the two transactions are merged. So inner transactions are ignored and
2421+a warning will be emitted.
2422+
2423+=head2 C<Class-E<gt>rollback>
2424+
2425+This rollbacks all the transactions since the last begin work, and exits
2426+from the active transaction state.
2427+
2428+=head2 C<Class-E<gt>commit>
2429+
2430+Commits the transactions, and exits from the active transaction state.
2431+
2432+=head2 C<Class-E<gt>txn_debug>
2433+
2434+Just return the value of the global flag and the current working drivers
2435+in a hashref.
2436+
2437+=head2 C<Class-E<gt>txn_active>
2438+
2439+Returns true if a transaction is already active.
2440+
2441 =head1 DIAGNOSTICS
2442
2443 =over 4
2444Index: lib/Data/ObjectDriver.pm
2445===================================================================
2446--- lib/Data/ObjectDriver.pm (.../tags/release-0.05) (revision 528)
2447+++ lib/Data/ObjectDriver.pm (.../trunk) (revision 528)
2448@@ -8,7 +8,7 @@
2449 use base qw( Class::Accessor::Fast );
2450 use Data::ObjectDriver::Iterator;
2451
2452-__PACKAGE__->mk_accessors(qw( pk_generator ));
2453+__PACKAGE__->mk_accessors(qw( pk_generator txn_active ));
2454
2455 our $VERSION = '0.05';
2456 our $DEBUG = $ENV{DOD_DEBUG} || 0;
2457@@ -38,6 +38,7 @@
2458 my $driver = shift;
2459 my %param = @_;
2460 $driver->pk_generator($param{pk_generator});
2461+ $driver->txn_active(0);
2462 $driver;
2463 }
2464
2465@@ -56,6 +57,29 @@
2466
2467 sub end_query { }
2468
2469+sub begin_work {
2470+ my $driver = shift;
2471+ $driver->txn_active(1);
2472+ $driver->debug(sprintf("%14s", "BEGIN_WORK") . ": driver=$driver");
2473+}
2474+
2475+sub commit {
2476+ my $driver = shift;
2477+ _end_txn($driver, 'commit');
2478+}
2479+
2480+sub rollback {
2481+ my $driver = shift;
2482+ _end_txn($driver, 'rollback');
2483+}
2484+
2485+sub _end_txn {
2486+ my $driver = shift;
2487+ my $method = shift;
2488+ $driver->txn_active(0);
2489+ $driver->debug(sprintf("%14s", uc($method)) . ": driver=$driver");
2490+}
2491+
2492 sub debug {
2493 my $driver = shift;
2494 return unless $DEBUG;
2495@@ -106,6 +130,7 @@
2496 }
2497
2498 sub cache_object { }
2499+sub uncache_object { }
2500
2501 1;
2502 __END__
2503@@ -396,6 +421,23 @@
2504 If set to a true value, the I<SELECT> statement generated will include a
2505 I<FOR UPDATE> clause.
2506
2507+=item * comment
2508+
2509+A sql comment to watermark the SQL query.
2510+
2511+=item * window_size
2512+
2513+Used when requesting an iterator for the search method and selecting
2514+a large result set or a result set of unknown size. In such a case,
2515+no LIMIT clause is assigned, which can load all available objects into
2516+memory. Specifying C<window_size> will load objects in manageable chunks.
2517+This will also cause any caching driver to be bypassed for issuing
2518+the search itself. Objects are still placed into the cache upon load.
2519+
2520+This attribute is ignored when the search method is invoked in an array
2521+context, or if a C<limit> attribute is also specified that is smaller than
2522+the C<window_size>.
2523+
2524 =back
2525
2526 =head2 Class->search(\@terms [, \%options ])
2527@@ -571,6 +613,89 @@
2528 Then see the documentation for I<Data::ObjectDriver::Profiler> to see the
2529 methods on that class.
2530
2531+
2532+=head1 TRANSACTIONS
2533+
2534+
2535+Transactions are supported by Data::ObjectDriver's default drivers. So each
2536+Driver is capable to deal with transactional state independently. Additionally
2537+<Data::ObjectDriver::BaseObject> class know how to turn transactions switch on
2538+for all objects.
2539+
2540+In the case of a global transaction all drivers used during this time are put
2541+in a transactional state until the end of the transaction.
2542+
2543+=head2 Example
2544+
2545+ ## start a transaction
2546+ Data::ObjectDriver::BaseObject->begin_work;
2547+
2548+ $recipe = Recipe->new;
2549+ $recipe->title('lasagnes');
2550+ $recipe->save;
2551+
2552+ my $ingredient = Ingredient->new;
2553+ $ingredient->recipe_id($recipe->recipe_id);
2554+ $ingredient->name("more layers");
2555+ $ingredient->insert;
2556+ $ingredient->remove;
2557+
2558+ if ($you_are_sure) {
2559+ Data::ObjectDriver::BaseObject->commit;
2560+ }
2561+ else {
2562+ ## erase all trace of the above
2563+ Data::ObjectDriver::BaseObject->rollback;
2564+ }
2565+
2566+=head2 Driver implementation
2567+
2568+Drivers have to implement the following methods:
2569+
2570+=over 4
2571+
2572+=item * begin_work to initialize a transaction
2573+
2574+=item * rollback
2575+
2576+=item * commmit
2577+
2578+=back
2579+
2580+=head2 Nested transactions
2581+
2582+Are not supported and will result in warnings and the inner transactions
2583+to be ignored. Be sure to B<end> each transaction and not to let et long
2584+running transaction open (i.e you should execute a rollback or commit for
2585+each open begin_work).
2586+
2587+=head2 Transactions and DBI
2588+
2589+In order to make transactions work properly you have to make sure that
2590+the C<$dbh> for each DBI drivers are shared among drivers using the same
2591+database (basically dsn).
2592+
2593+One way of doing that is to define a get_dbh() subref in each DBI driver
2594+to return the same dbh if the dsn and attributes of the connection are
2595+identical.
2596+
2597+The other way is to use the new configuration flag on the DBI driver that
2598+has been added specifically for this purpose: C<reuse_dbh>.
2599+
2600+ ## example coming from the test suite
2601+ __PACKAGE__->install_properties({
2602+ columns => [ 'recipe_id', 'partition_id', 'title' ],
2603+ datasource => 'recipes',
2604+ primary_key => 'recipe_id',
2605+ driver => Data::ObjectDriver::Driver::Cache::Cache->new(
2606+ cache => Cache::Memory->new,
2607+ fallback => Data::ObjectDriver::Driver::DBI->new(
2608+ dsn => 'dbi:SQLite:dbname=global.db',
2609+ reuse_dbh => 1, ## be sure that the corresponding dbh is shared
2610+ ),
2611+ ),
2612+ });
2613+
2614 =head1 EXAMPLES
2615
2616 =head2 A Partitioned, Caching Driver
2617Index: Changes
2618===================================================================
2619--- Changes (.../tags/release-0.05) (revision 528)
2620+++ Changes (.../trunk) (revision 528)
2621@@ -2,6 +2,31 @@
2622
2623 Revision history for Data::ObjectDriver
2624
2625+0.06
2626+ - Added peek_next() method to ResultSet, q.v.
2627+ - Localized creation of D::OD::Iterator object. Thanks to Hirotaka Ogawa
2628+ for the patch.
2629+ - Fixed compilation error with Perl 5.10. Thanks to smpeters for the patch.
2630+ - Added a new $object->uncache_object as a mirror of cache_object(), which
2631+ purge one object from the cache layer, for the cases where you want a
2632+ manual control over it.
2633+ - Added a "distinct" method to D::OD::SQL that forces the DISTINCT keyword
2634+ in the generated SQL statement. Thanks to John Berthels for the patch.
2635+ - Added a "window_size" argument for the search() method of the caching
2636+ layer to constrain the number of objects loaded from the database for
2637+ large or unbounded searches.
2638+ - Added a "comment" argument to search parameter allowing the SQL
2639+ queries to be watermarked with SQL comments.
2640+ - Added a "object_is_stored" method on DOD objects, which returns true until
2641+ the object has been saved in the persistent store.
2642+ - Added a "pk_str" method on base objects has a nice shortcut for printing
2643+ the primary key of an object.
2644+ - Added a "reuse_dbh" option to D::OD::D::DBI, if enabled it caches and reuses
2645+ $dbh using the dsn as the key.
2646+ - Exposed the transaction mechanism built in the drivers at the object levels:
2647+ D::OD::BO->begin_work now starts a global transaction across all drivers
2648+ ending with a rollback or a commit on the same class.
2649+
2650 0.05 2008.02.24
2651 - Added a new Data::ObjectDriver::ResultSet abstraction for building
2652 result sets with lazy-loading of the actual results. This allows for
2653Index: MANIFEST.SKIP
2654===================================================================
2655--- MANIFEST.SKIP (.../tags/release-0.05) (revision 528)
2656+++ MANIFEST.SKIP (.../trunk) (revision 528)
2657@@ -12,3 +12,4 @@
2658 \.tar\.gz$
2659 \.svn
2660 \.shipit$
2661+t/9\d.+\.t$
2662Index: README
2663===================================================================
2664--- README (.../tags/release-0.05) (revision 528)
2665+++ README (.../trunk) (revision 528)
2666@@ -27,4 +27,4 @@
2667
2668 % make install
2669
2670-Six Apart / cpan@sixapart.com
2671+Six Apart / cpan@sixapart.com
2672\ No newline at end of file