Data-ObjectDriver-0.09/000755 000767 000024 00000000000 11540451052 015002 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/Changes000644 000767 000024 00000024637 11540447612 016320 0ustar00yannstaff000000 000000 # $Id$ 0.09 2011.03.17 - Fix reuse_dbh behaviour when ping fails on driver->dbh (RT 65448) 0.08 2010.12.06 - Fixed issue where a profiler cannot be returned if $@ is set https://github.com/sixapart/data-objectdriver/pull/1 (Akira Sawada) - Adds a new restricted IO operation mode controlled by the $Data::ObjectDriver::RESTRICT_IO flag (Brad Whitaker) Revision history for Data::ObjectDriver 0.07 2010.03.22 - When an object is changed, delete the cache instead of updating it. It is a bit more expensive, but should safer. - Fixed a uuv warning thanks to Kazuhiro Shibuya - Fixed a issue in the test suite for newer version of SQLite reported by Emmanuel Seyman http://rt.cpan.org/Ticket/Display.html?id=45186 - Fixed boggus bulk_insert() in the MySQL driver - Fixed a perl5.11 warning - In case you haven't noticed DOD is now on github, bye svn. 0.06 2009.01.28 - 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. - Fix problem with prepare_cache in DBD::SQLite - Fix PerlCritic tests http://rt.cpan.org/Ticket/Display.html?id=37197 - Fix problems under 5.10 http://rt.cpan.org/Ticket/Display.html?id=30941 - Fix test failures under Win32 http://rt.cpan.org/Ticket/Display.html?id=24480 - Pg *can't* handle REPLACE https://rt.cpan.org/Ticket/Display.html?id=38840 - Fixed an issue where Pg would look into the wrong sequence if DBI has a 'prefix' configured (used in a undocumented TheSchwartz feature) https://rt.cpan.org/Ticket/Display.html?id=41880 - Added Oracle support, courtesy of Xiaoou Wu (Oracle) https://rt.cpan.org/Ticket/Display.html?id=41929 - Added an "add_index_hint" method to D::OD::SQL to allow specifying a "USE INDEX" hint. - Added an experimental GearmanDBI driver that provides query coalescing using Gearman workers (to sit in front of a direct DBI driver). 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 passing around a representation of a full result set (no limit, no offset, etc), and allowing callers to modify the set as needed. - search() now returns a subref blessed into the new D::OD::Iterator class. It's backwards-compatible (you can still call $iter->()), but it now supports $iter->next() as well. - Added a D::OD::SQL::add_complex_where method, for creating more complex WHERE clauses with boolean operations. - Added instrumentation/profiling for the memcached, Apache, and RAM caching drivers. - Improved "remove" support in the experimental Multiplexer driver. - Fixed an ordering bug with BaseCache->update: the cache is now updated after the fallback (a persistent store, usually) is updated, to prevent the cache being updated but the backend erroring out. - Let DSNs start with "DBI:" instead of only "dbi:" - Fix a bug where the iterator version of search() (search() called in scalar context) wasn't calling finish() on $sth. It was generating warnings on certain circumstances. - Fixed a circular reference when using has_a. 0.04 2007.05.02 - Fixed a bug where single-PK classes were not returning the objects correctly sorted during a lookup_multi. - Added support for MySQL 'REPLACE INTO' syntax with a new $obj->replace() method. - Added a new trigger 'post_inflate'. - Fixed a minor issue (warning) with no_changed_flags in column_func() - Added has_a() construct to build linking methods between classes. - remove() returns number of affected rows, with DBI semantics. - Bulk inserting of data can now be done with the new bulk_insert() Class method. It uses Postgres' COPY command or MySQL's multi-value inserts to load data quickly. - The new() constructor for objects now accepts column name/value pairs which are passed to a new init() method. - The new init() method can be called on any object to set many parameters in one call. - This init() method can also be overridden, allowing for custom initialization code. - Added parens around terms within complex SQL conditionals, to allow even more complex conditions to be created. - Made the second argument to D::OD::SQL::add_select optional. It defaults to the value of the first argument (the column name). - Pass along $orig_obj (original object) when calling post_save/post_update triggers, even when the object hasn't changed. - A non-numeric value in a LIMIT now causes an exception. - Fixed a bug where calling SQL->add_join twice would create an invalid SQL statement. - More documentation! - Added more DOD::DBD::* options: sql_for_unixtime, can_delete_with_limit, is_case_insensitive, can_replace, sql_class. - Added an experimental Multiplexer class to direct writes to multiple backend drivers. - Added a generic end_query method, analogous to start_query, which is called after each query. Useful for profiling etc. - Text::SimpleTable is now loaded dynamically so that it's no longer a requirement for D::OD. 0.03 2006.08.05 - Added an inflate and deflate mechanism to memcached caching. When objects are stored in memcached, they are now deflated to a hash reference containing only the column values; retrieving the object from memcached automatically inflates the object to the full representation. Classes can override inflate and deflate to store additional information in the memcached representation that's kept automatically up-to-date. - Added a SimplePartition driver, which helps to make partitioning, well, simpler. Still to come: documentation and a tutorial on partitioning. - Many, many bug fixes and improvements to the caching drivers. - Added detection of changed columns, such that only columns that have been changed are updated in an UPDATE statement. - Added a clear_cache method to the D::O::D::Cache::RAM class. - Added cross-DBD error handling, which maps local error codes to error constants in Data::ObjectDriver::Errors. The list of supported errors is pretty miniscule thus far (just one), but will be expanded as needed. - Added support for query profiling (Data::ObjectDriver::Profiler), which counts queries, calculates frequent queries, and can produce reports. - Added support for optional table prefixes, which simplifies setting up identical schemas in the same database. - Added an optional $terms argument to D::O::D::DBI->update, which can add additional terms to the UPDATE statement besides just the PK. - Added a D::O::D::DBI->begin_work method, and improved the commit and rollback methods. - Added a D::O::D::DBI->last_error method. - Added support for multiple JOIN clauses with a new D::O::D::SQL->add_join method. - Multiple OR values are now contained in an IN (...) clause rather than many joined OR clauses. - Added a for_update option to search, which allows constructing a SELECT ... FOR UPDATE query. - D::O::D::BaseObject->column is now removed and replaced with a column_func method, which returns a subroutine reference used to initialize the dynamically-created methods for each column. This allows some optimizations. 0.02 2006.02.21 - Added Data::ObjectDriver::BaseView, a base class for creating "views" across multiple tables, or involving more complex aggregate queries. - Added trigger/callback support for common operations. See the Data::ObjectDriver documentation for more details. - Added GROUP BY support in Data::ObjectDriver::SQL. - Data::ObjectDriver::BaseCache->search now uses lookup_multi to do a very fast PK lookup, which will hit the cache first before the backend DB. - Fixed bugs with BLOB columns in SQLite driver. - Added connect_options option to Data::ObjectDriver::Driver::DBI, for passing in custom options for a DBI->connect call. - Data::ObjectDriver::BaseObject->remove now works as a class method. - Added Data::ObjectDriver::BaseObject->primary_key_tuple for retrieving the primary key value(s) for an object. - Added Data::ObjectDriver::BaseObject->refresh to reload an object from the database. - Added support for HAVING clauses in Data::ObjectDriver::SQL. For views that are not attached to a particular datasource, any terms passed in to the query will automatically be turned into HAVING clauses. - Improved the lookup_multi method for all BaseCache subclasses: we now allow the subclass to look up multiple values in the cache and return any already-cached items, then make a list of the remaining IDs and send them to fallback->lookup_multi. - Driver::DBI->lookup_multi will now use an OR clause to look up multiple values in one query. - Added lots of test cases. - Pod fix (Thanks to Koichi Taniguchi) 0.01 2005.09.23 - Initial distribution. Data-ObjectDriver-0.09/inc/000755 000767 000024 00000000000 11540451052 015553 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/lib/000755 000767 000024 00000000000 11540451052 015550 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/Makefile.PL000644 000767 000024 00000001344 11352531424 016761 0ustar00yannstaff000000 000000 # $Id$ use inc::Module::Install; name('Data-ObjectDriver'); abstract(''); author('Six Apart '); all_from('lib/Data/ObjectDriver.pm'); license('perl'); no_index(directory => 't'); include('ExtUtils::AutoInstall'); requires('DBI'); requires('Class::Accessor::Fast'); requires('Class::Data::Inheritable'); requires('Class::Trigger'); requires('List::Util'); recommends('Text::SimpleTable'); build_requires('Test::Exception'); githubmeta; # Cache::Memory isn't in Debian, and the tests all SKIP if this isn't here anyway, # so it's more of a build_recommends than a build_requires, but that doesn't exist, # so.... commented out: # build_recommends('Cache::Memory'); auto_include_deps; author_tests('xt'); WriteAll; Data-ObjectDriver-0.09/MANIFEST000644 000767 000024 00000005005 11540447222 016137 0ustar00yannstaff000000 000000 Changes inc/Module/Install.pm inc/Module/Install/AuthorTests.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/GithubMeta.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm inc/parent.pm inc/PerlIO.pm inc/Sub/Uplevel.pm inc/Test/Builder.pm inc/Test/Builder/IO/Scalar.pm inc/Test/Exception.pm lib/Data/ObjectDriver.pm lib/Data/ObjectDriver/BaseObject.pm lib/Data/ObjectDriver/BaseView.pm lib/Data/ObjectDriver/Driver/BaseCache.pm lib/Data/ObjectDriver/Driver/Cache/Apache.pm lib/Data/ObjectDriver/Driver/Cache/Cache.pm lib/Data/ObjectDriver/Driver/Cache/Memcached.pm lib/Data/ObjectDriver/Driver/Cache/RAM.pm lib/Data/ObjectDriver/Driver/DBD.pm lib/Data/ObjectDriver/Driver/DBD/mysql.pm lib/Data/ObjectDriver/Driver/DBD/Oracle.pm lib/Data/ObjectDriver/Driver/DBD/Pg.pm lib/Data/ObjectDriver/Driver/DBD/SQLite.pm lib/Data/ObjectDriver/Driver/DBI.pm lib/Data/ObjectDriver/Driver/GearmanDBI.pm lib/Data/ObjectDriver/Driver/MultiPartition.pm lib/Data/ObjectDriver/Driver/Multiplexer.pm lib/Data/ObjectDriver/Driver/Partition.pm lib/Data/ObjectDriver/Driver/SimplePartition.pm lib/Data/ObjectDriver/Errors.pm lib/Data/ObjectDriver/Iterator.pm lib/Data/ObjectDriver/Profiler.pm lib/Data/ObjectDriver/ResultSet.pm lib/Data/ObjectDriver/SQL.pm lib/Data/ObjectDriver/SQL/Oracle.pm Makefile.PL MANIFEST This list of files META.yml README t/00-compile.t t/01-col-inheritance.t t/02-basic.t t/03-primary-keys.t t/04-clone.t t/05-deflate.t t/06-errors.t t/07-has-a-cached.t t/07-has-a.t t/08-iterator.t t/09-resultset.t t/10-resultset-peek.t t/11-sql.t t/12-windows.t t/20-driver-sqlite.t t/31-cached.t t/32-partitioned.t t/33-views.t t/34-both.t t/35-multiplexed.t t/41-callbacks.t t/42-callbacks-multi-pk.t t/50-profiling.t t/lib/both/Ingredient.pm t/lib/both/Recipe.pm t/lib/Cache/Memory.pm t/lib/cached/Ingredient.pm t/lib/cached/Recipe.pm t/lib/cached/User.pm t/lib/db-common.pl t/lib/ErrorTest.pm t/lib/multiplexed/Ingredient2Recipe.pm t/lib/partitioned/Ingredient.pm t/lib/partitioned/Recipe.pm t/lib/PkLess.pm t/lib/views/Ingredient.pm t/lib/views/Ingredient2Recipe.pm t/lib/views/IngredientsWeighted.pm t/lib/views/Recipe.pm t/lib/Wine.pm t/perf/inflate.pl t/schemas/error_test.sql t/schemas/ingredient2recipe.sql t/schemas/ingredients-view.sql t/schemas/ingredients.sql t/schemas/pkless.sql t/schemas/recipes.sql t/schemas/user.sql t/schemas/wines.sql t/txn-common.pl xt/perlcritic.t xt/pod-coverage.t xt/pod.t Data-ObjectDriver-0.09/META.yml000644 000767 000024 00000001432 11540451052 016253 0ustar00yannstaff000000 000000 --- abstract: 'Simple, transparent data interface, with caching' author: - 'Six Apart ' build_requires: ExtUtils::MakeMaker: 6.42 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 1.00' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Data-ObjectDriver no_index: directory: - inc - t - xt recommends: Text::SimpleTable: 0 requires: Class::Accessor::Fast: 0 Class::Data::Inheritable: 0 Class::Trigger: 0 DBI: 0 List::Util: 0 perl: 5.6.1 resources: homepage: http://github.com/yannk/data-objectdriver/tree license: http://dev.perl.org/licenses/ repository: git://github.com/yannk/data-objectdriver.git version: 0.09 Data-ObjectDriver-0.09/README000644 000767 000024 00000001151 11351753027 015667 0ustar00yannstaff000000 000000 $Id$ This is Data::ObjectDriver, providing a simple and generic abstraction to databases (DBI and otherwise), along with support for partitioning and caching. PREREQUISITES * DBI * Class::Accessor::Fast * Class::Data::Inheritable * Class::Trigger INSTALLATION Data::ObjectDriver installation is straightforward. If your CPAN shell is set up, you should just be able to do % perl -MCPAN -e 'install Data::ObjectDriver' Download it, unpack it, then build it as per the usual: % perl Makefile.PL % make && make test Then install it: % make install Six Apart / cpan@sixapart.comData-ObjectDriver-0.09/t/000755 000767 000024 00000000000 11540451052 015245 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/xt/000755 000767 000024 00000000000 11540451052 015435 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/xt/perlcritic.t000644 000767 000024 00000000331 11352004002 017745 0ustar00yannstaff000000 000000 use Test::More; 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(); Data-ObjectDriver-0.09/xt/pod-coverage.t000644 000767 000024 00000001247 11352004002 020167 0ustar00yannstaff000000 000000 use strict; use Test::More; eval "use Test::Pod::Coverage 1.08"; plan skip_all => "Test::Pod::Coverage 1.08 required for testing POD coverage" if $@; ## Eventually we would be able to test coverage for all modules with ## Test::Pod::all_pod_files(), but let's write the docs first. my %modules = ( 'Data::ObjectDriver::BaseObject' => { also_private => [ qr{ \A is_same_array \z }xms ], }, 'Data::ObjectDriver::Errors' => 1, 'Data::ObjectDriver::SQL' => 1, 'Data::ObjectDriver::Driver::DBD' => 1, ); plan tests => scalar keys %modules; while (my ($module, $params) = each %modules) { pod_coverage_ok($module, ref $params ? $params : ()); } Data-ObjectDriver-0.09/xt/pod.t000644 000767 000024 00000000216 11352004002 016371 0ustar00yannstaff000000 000000 use strict; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Data-ObjectDriver-0.09/t/00-compile.t000644 000767 000024 00000000161 11351753027 017304 0ustar00yannstaff000000 000000 # $Id$ use strict; use Test::More tests => 2; use_ok('Data::ObjectDriver'); use_ok('Data::ObjectDriver::SQL'); Data-ObjectDriver-0.09/t/01-col-inheritance.t000644 000767 000024 00000001472 11351753027 020727 0ustar00yannstaff000000 000000 # $Id$ use strict; use lib 't/lib'; require 't/lib/db-common.pl'; use Test::More; unless (eval { require DBD::SQLite }) { plan skip_all => 'Tests require DBD::SQLite'; } plan tests => 15; setup_dbs({ global => [ qw( wines ) ], }); use Wine; my $wine = Wine->new; my %expected = map { $_ => 1 } qw(name rating id cluster_id content binchar); my %data; # I know about Test::Deep. Do not ask... for my $col (@{ $wine->column_names }) { $data{$col}++; ok $expected{$col}, "$col was expected"; } for my $col (keys %expected) { ok $data{$col}, "expected $col is present"; } $wine->name("Saumur Champigny, Le Grand Clos 2001"); $wine->rating(4); ok($wine->save, 'Object saved successfully'); ok ($wine->has_column("id")) ; ok ($wine->has_column("rating")) ; sub DESTROY { teardown_dbs(qw( global )); } Data-ObjectDriver-0.09/t/02-basic.t000644 000767 000024 00000015772 11351753027 016755 0ustar00yannstaff000000 000000 # $Id: 01-col-inheritance.t 989 2005-09-23 19:58:01Z btrott $ use strict; use lib 't/lib'; use lib 't/lib/cached'; require 't/lib/db-common.pl'; use Test::More; use Test::Exception; 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 => 67; use Wine; use Recipe; use Ingredient; setup_dbs({ global => [ qw( wines recipes ingredients) ], }); # method installation { my $w = Wine->new; ok $w->name("name"); ok $w->has_column("name"); ok ! $w->has_column("inexistent"); dies_ok { $w->inexistent("hell") } "dies on setting inexistent column : 'inexistent()'"; dies_ok { $w->column('inexistent') } "dies on setting inexistent column : 'column()'"; } # refresh { my $old ='Cul de Veau à la Sauge'; # tastes good ! my $new ='At first my tests ran on Recipe, sorry (Yann)'; my $w1 = Wine->new; $w1->name($old); ok $w1->save; my $id = $w1->id; my $w2 = Wine->lookup($id); $w2->name($new); $w2->save; cmp_ok $w1->name, 'eq', $old, "Old name not updated..."; cmp_ok $w2->name, 'eq', $new, "... but new name is set"; $w1->refresh; cmp_ok $w1->name, 'eq', $new, "Refreshed"; is $w1->remove, 1, 'Remove correct number of rows'; is $w2->remove, '0E0', 'Remove correct number of rows'; } # Constructor testing { my $w = Wine->new(name=>'Mouton Rothschild', rating=> 4); ok ($w, 'constructed a new Wine'); is ($w->name, 'Mouton Rothschild', 'name constructor'); is ($w->rating, 4, 'rating constructor'); } # lookup with hash (single pk) { my $w = Wine->new; $w->name("Veuve Cliquot"); $w->save; my $id = $w->id; undef $w; # lookup test lives_ok { $w = Wine->lookup({ id => $id })} "Alive !"; cmp_ok $w->name, 'eq', 'Veuve Cliquot', "simple data test"; ok $w; is $w->remove, 1, 'Remove correct number of rows'; } ## lookup_multi give a sorted result set { my @ids; for (1 .. 14) { my $w = Wine->new(name => "wine-$_"); $w->save; push @ids, $w->id; } if (eval { require List::Util }) { @ids = List::Util::shuffle @ids; } else { @ids = reverse @ids; } my @got = map { $_->id } @{ Wine->lookup_multi(\@ids) }; is_deeply \@got, \@ids, "Sorted result set"; } # lookups with hash (multiple pk) { my $r = Recipe->new; $r->title("Good one"); ok $r->save; my $rid = $r->recipe_id; ok $rid; my $i = Ingredient->new; $i->recipe_id($rid); $i->quantity(1); $i->name('Chouchenn'); ok $i->save; my $id = $i->id; undef $i; # lookup test dies_ok { $i = Ingredient->lookup({ id => $id, quantity => 1 })} "Use Search !"; lives_ok { $i = Ingredient->lookup({ id => $id, recipe_id => $rid })} "Alive"; cmp_ok $i->name, 'eq', 'Chouchenn', "simple data test"; # lookup_multi with hash (multiple pk) lives_ok { $i = Ingredient->lookup_multi( [{ id => $id, recipe_id => $rid }]) } "Alive"; is scalar @$i, 1; # add a second ingredient my $i2 = Ingredient->new( recipe_id => $rid, quantity => 1, name => 'honey', ); $i2->save; my $id2 = $i2->id; lives_ok { $i = Ingredient->lookup_multi( [{ id => $id, recipe_id => $rid }, { id => $id2, recipe_id => $rid } ]) } "Alive"; is scalar @$i, 2; is $r->remove, 1, 'Remove correct number of rows'; is $i->[0]->remove, 1, 'Remove correct number or rows'; is $i->[1]->remove, 1, 'Remove correct number or rows'; } # replace { my $r = Recipe->new; $r->title("to replace"); ok $r->replace; ok(my $rid = $r->recipe_id); my $r2 = Recipe->new; $r2->recipe_id($rid); $r2->title('new title'); ok $r2->replace; ## check $r = Recipe->lookup($rid); is $r->title, 'new title'; $r2 = Recipe->new; $r2->recipe_id($rid); ok $r2->replace; ## check $r = Recipe->lookup($rid); is $r->title, undef; } # let's test atomicity of replace { my $r = Recipe->new; $r->title("to replace"); $r->insert; ## too long title: # Oh! right it's a feature :( # http://www.sqlite.org/faq.html#q3 #$r->title(join '', ("0123456789" x 6)); #dies_ok { $r->replace }; #$r->refresh; my $id = $r->recipe_id; $r->title('replaced'); $r->recipe_id("lamer"); dies_ok { $r->replace }; $r = Recipe->lookup($id); ok $r; is $r->title, "to replace"; # 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"); dies_ok { $r->replace }; $r = Recipe->lookup($id); ok $r; is $r->title, "to replace"; # emulate a driver which doesn't support REPLACE INTO } } # is_changed interface { my $w = Wine->new; $w->name("Veuve Cliquot"); $w->save; ok ! $w->is_changed; $w->name("veuve champenoise"); ok $w->is_changed; ok $w->is_changed('name'); ok ! $w->is_changed('content'); } # Remove counts { # Clear out the wine table ok (Wine->remove(), 'delete all from Wine table'); is (Wine->remove({name=>'moooo'}), 0E0, 'No rows deleted'); my @bad_wines = qw(Thunderbird MadDog Franzia); foreach my $name (@bad_wines) { my $w = Wine->new; $w->name($name); ok $w->save, "Saving bad_wine $name"; } is (Wine->remove(), scalar(@bad_wines), 'removing all bad wine'); # Do it again with direct remove from the DB foreach my $name (@bad_wines) { my $w = Wine->new; $w->name($name); ok $w->save, "Saving bad_wine $name"; } # note sqlite is stupid and doesn't return the number of affected rows # quick hack because I can't rely on version.pm to be installed everywhere my ($sqlite_version) = Wine->driver->rw_handle->{sqlite_version} =~ /(\d+(?:\.\d+))/; my $count = $sqlite_version > 3.5 ? scalar @bad_wines : "0E0"; is (Wine->remove({}, { nofetch => 1 }), $count, 'removing all bad wine'); } # 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"; } sub DESTROY { teardown_dbs(qw( global )); } Data-ObjectDriver-0.09/t/03-primary-keys.t000644 000767 000024 00000005631 11351753027 020322 0ustar00yannstaff000000 000000 # $Id$ use strict; use lib 't/lib'; use lib 't/lib/cached'; require 't/lib/db-common.pl'; use Test::More; use Test::Exception; 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 => 21; use Wine; use Recipe; use Ingredient; use PkLess; setup_dbs({ global => [ qw( wines recipes ingredients pkless) ], }); ## TODO: test primary_key # test correct behaviour of has_primary_key { my $w = Wine->new; $w->save; ok $w->has_primary_key, "wine has pk"; my $r = Recipe->new; $r->save; ok $r->has_primary_key, "recipe has pk";; my $i = Ingredient->new; $i->recipe_id($r->recipe_id); $i->save; ok $i->has_primary_key, "ingredient has (multi) pk"; ## PK less my $p = PkLess->new; $p->anything("x"); $p->save; ok ! $p->has_primary_key, "pkless has no pk";; my $p2 = PkLess->new; $p2->anything("y"); $p2->save; ## save behaves correctly (there's never an UPDATE) my @res = PkLess->search(); is scalar @res, 2, "Pk-less populated correctly"; } # simple class pk fields { isa_ok(Wine->primary_key_tuple(), 'ARRAY', q(Wine's primary key tuple is an arrayref)); is_deeply(Wine->primary_key_tuple(), ['id'], q(Wine's primary key tuple contains the string 'id')); is_deeply(Wine->primary_key_to_terms([100]), { id => 100 }); } # complex class pk fields { isa_ok(Ingredient->primary_key_tuple, 'ARRAY', q(Ingredient's primary key tuple is an arrayref)); is_deeply(Ingredient->primary_key_tuple, ['recipe_id', 'id'], q(Ingredient instance's primary key tuple contains 'recipe_id' and 'id')); is_deeply(Ingredient->primary_key_to_terms([100, 1000]), { recipe_id => 100, id => 1000 }); } # simple instance pk fields { my $w = Wine->new; isa_ok $w->primary_key_tuple, 'ARRAY', q(Wine instance's primary key tuple is an arrayref); is_deeply $w->primary_key_tuple, ['id'], q(Wine instance's primary key tuple contains the string 'id'); is_deeply($w->primary_key_to_terms, { id => $w->id }); } # complex instance pk fields { my $i = Ingredient->new; is ref $i->primary_key_tuple, 'ARRAY', q(Ingredient instance's primary key tuple is an arrayref); is_deeply $i->primary_key_tuple, ['recipe_id', 'id'], q(Ingredient instance's primary key tuple contains 'recipe_id' and 'id'); is_deeply($i->primary_key_to_terms, { recipe_id => $i->recipe_id, id => $i->id }); } # 0 might be a valid pk { my $rv = Wine->remove({}); # make sure that remove returns the number of records deleted (1) is($rv, 1, 'correct number of rows deleted'); my $wine = Wine->new; $wine->id(0); $wine->name("zero"); ok $wine->save; $wine = Wine->lookup(0); ok $wine; is $wine->name, "zero"; } sub DESTROY { teardown_dbs(qw( global )); } Data-ObjectDriver-0.09/t/04-clone.t000644 000767 000024 00000004372 11351753027 016770 0ustar00yannstaff000000 000000 # $Id$ use strict; use lib 't/lib'; use lib 't/lib/cached'; require 't/lib/db-common.pl'; use Test::More; use Test::Exception; 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 => 29; use Wine; use Recipe; use Ingredient; setup_dbs({ global => [ qw( wines recipes ingredients) ], }); sub test_basic_cloning { my $method = shift; my $old ='Cul de Veau à la Sauge'; # tastes good ! my $new ='At first my tests ran on Recipe, sorry (Yann)'; my $w = Wine->new; $w->name($old); ok $w->save; my $id = $w->id; ok $id, 'Saved Wine has an id'; my $clone = $w->$method(); ok defined $clone, 'Successfully cloned'; isnt $w, $clone, 'Clone is not reference to the original'; is $w->name, $clone->name, 'Clone has the same name'; $clone->name($new); isnt $w->name, $clone->name, 'Changing clone does not affect the original'; my $clone2 = $w->clone; isnt $w, $clone2, 'Second clone is not a reference to the original'; isnt $clone, $clone2, 'Second clone is not a reference to the first clone'; } test_basic_cloning('clone'); test_basic_cloning('clone_all'); # clone pk behavior { my $w = Wine->new; $w->name('Cul de Veau à la Sauge'); ok $w->save; ok $w->id, 'Saved original wine received an id'; my $clone = $w->clone; 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); } # clone_all pk behavior { my $w = Wine->new; $w->name('Cul de Veau à la Sauge'); ok $w->save; ok $w->id, 'Saved original wine received an id'; my $clone = $w->clone_all; ok defined $clone->id, 'Full clone has an id'; is $w->id, $clone->id, q(Full clone's id matches original's id); } sub DESTROY { teardown_dbs(qw( global )); } Data-ObjectDriver-0.09/t/05-deflate.t000644 000767 000024 00000004345 11351753027 017275 0ustar00yannstaff000000 000000 # $Id$ use strict; use lib 't/lib'; use lib 't/lib/cached'; require 't/lib/db-common.pl'; use Test::More; use Test::Exception; 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 $recipe = Recipe->new; $recipe->title('Cake'); $recipe->save; my $deflated = $recipe->deflate; is $deflated->{columns}{recipe_id}, $recipe->recipe_id; is $deflated->{columns}{title}, $recipe->title; my $r2 = Recipe->inflate($deflated); ok ! $r2->is_changed; is $r2->recipe_id, $recipe->recipe_id; is $r2->title, $recipe->title; ## Install some deflate/inflate in the Cache driver. { no warnings 'once'; no warnings 'redefine'; *Data::ObjectDriver::Driver::Cache::Cache::deflate = sub { $_[1]->deflate; }; *Data::ObjectDriver::Driver::Cache::Cache::inflate = sub { $_[1]->inflate($_[2]); }; } ## Ingredients are cached, so make sure that they survive the ## deflate/inflate process. my $ingredient = Ingredient->new; $ingredient->recipe_id($recipe->recipe_id); $ingredient->name('Egg'); $ingredient->quantity(5); $ingredient->save; my $i2 = Ingredient->lookup([ $recipe->recipe_id, $ingredient->id ]); is $i2->id, $ingredient->id; is $i2->recipe_id, $ingredient->recipe_id; is $i2->name, $ingredient->name; is $i2->quantity, $ingredient->quantity; my $i3 = Ingredient->new; $i3->recipe_id($recipe->recipe_id); $i3->name('Milk'); $i3->quantity(1); $i3->save; my $is = Ingredient->lookup_multi([ [ $recipe->recipe_id, $ingredient->id ], [ $recipe->recipe_id, $i3->id ], ]); is scalar(@$is), 2; is $is->[0]->name, 'Egg'; ok $is->[0]->{__cached}; is $is->[1]->name, 'Milk'; ok !$is->[1]->{__cached}; ## Do it again! They should both be cached, now. $is = Ingredient->lookup_multi([ [ $recipe->recipe_id, $ingredient->id ], [ $recipe->recipe_id, $i3->id ], ]); is scalar(@$is), 2; is $is->[0]->name, 'Egg'; ok $is->[0]->{__cached}; is $is->[1]->name, 'Milk'; ok $is->[1]->{__cached}; sub DESTROY { teardown_dbs(qw( global )); } Data-ObjectDriver-0.09/t/06-errors.t000644 000767 000024 00000001212 11351753027 017174 0ustar00yannstaff000000 000000 # $Id$ use strict; use lib 't/lib'; require 't/lib/db-common.pl'; use Test::More; use Test::Exception; BEGIN { unless (eval { require DBD::SQLite }) { plan skip_all => 'Tests require DBD::SQLite'; } } plan tests => 3; use ErrorTest; setup_dbs({ global => [ qw( error_test ) ], }); my $t = ErrorTest->new; $t->foo('bar'); lives_ok { $t->insert } 'Inserted first record'; $t = ErrorTest->new; $t->foo('bar'); dies_ok { $t->insert } 'Second insert fails'; is(ErrorTest->driver->last_error, Data::ObjectDriver::Errors->UNIQUE_CONSTRAINT, 'Failed because of a unique constraint'); sub DESTROY { teardown_dbs(qw( global )); } Data-ObjectDriver-0.09/t/07-has-a-cached.t000644 000767 000024 00000002776 11351753027 020077 0ustar00yannstaff000000 000000 # $Id: 05-deflate.t 1170 2006-03-24 05:29:48Z btrott $ use strict; 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'; } unless (eval 'use Scalar::Util qw(weaken); 1') { plan skip_all => 'Tests require weakref'; } } plan tests => 3; use Recipe; use Ingredient; setup_dbs({ global => [ qw( recipes ingredients) ], }); Ingredient->has_a( { class => 'Recipe', column => 'recipe_id', parent_method => 'ingredients', method => 'recipe', cached => 1, }, ); ## setup a few datas my $recipe = Recipe->new; $recipe->title('Cake'); $recipe->save; my $ingredient = Ingredient->new; $ingredient->recipe_id($recipe->recipe_id); $ingredient->name('Egg'); $ingredient->quantity(5); $ingredient->save; my $i3 = Ingredient->new; $i3->recipe_id($recipe->recipe_id); $i3->name('Milk'); $i3->quantity(1); $i3->save; { my $r = $ingredient->recipe; is $r->recipe_id, $recipe->recipe_id, "recipe id back using 'parent_method'"; ## show me what you have in your belly. ok Scalar::Util::isweak($ingredient->{__cache_recipe}), "weak ref"; } is $ingredient->{__cache_recipe}, undef, "cache has effectively been destroyed"; sub DESTROY { teardown_dbs(qw( global )); } Data-ObjectDriver-0.09/t/07-has-a.t000644 000767 000024 00000002667 11351753027 016671 0ustar00yannstaff000000 000000 # $Id: 05-deflate.t 1170 2006-03-24 05:29:48Z btrott $ use strict; 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 => 7; use Recipe; use Ingredient; setup_dbs({ global => [ qw( recipes ingredients) ], }); Ingredient->has_a( { class => 'Recipe', column => 'recipe_id', parent_method => 'ingredients', method => 'recipe', }, ); ## setup a few datas my $recipe = Recipe->new; $recipe->title('Cake'); $recipe->save; my $ingredient = Ingredient->new; $ingredient->recipe_id($recipe->recipe_id); $ingredient->name('Egg'); $ingredient->quantity(5); $ingredient->save; my $i3 = Ingredient->new; $i3->recipe_id($recipe->recipe_id); $i3->name('Milk'); $i3->quantity(1); $i3->save; my @i = $recipe->ingredients; is scalar @i, 2, "2 ingredients back using 'method'"; map { isa_ok $_, "Ingredient"; } @i; my $iter = $recipe->ingredients; isa_ok $iter, "CODE", "iterator is also available"; while (my $i = $iter->()) { isa_ok $i, "Ingredient", "next"; } my $r = $ingredient->recipe; is $r->recipe_id, $recipe->recipe_id, "recipe id back using 'parent_method'"; sub DESTROY { teardown_dbs(qw( global )); } Data-ObjectDriver-0.09/t/08-iterator.t000644 000767 000024 00000003542 11351753027 017523 0ustar00yannstaff000000 000000 # $Id$ use strict; 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 => 17; use_ok 'Data::ObjectDriver::Iterator'; my $iter; $iter = Data::ObjectDriver::Iterator->new(sub {}); ok Scalar::Util::blessed($iter), "blessed obj"; isa_ok $iter, "CODE", "it's a subref"; isa_ok $iter, "Data::ObjectDriver::Iterator"; can_ok $iter, "next"; is $iter->next, undef; is $iter->(), undef; my $i = 0; my $sub = sub { return undef if $i >= 10; return $i++; }; $iter = Data::ObjectDriver::Iterator->new($sub); is $iter->next, 0; is $iter->(), 1; $i = 11; is $iter->(), undef; $i = 2; $iter->end(); # do nothing is $iter->next, 2; { my $sub2 = sub { $sub->() }; # new reference my $iter2 = Data::ObjectDriver::Iterator->new($sub2, sub { $i = 10 }); is $iter2->(), 3; } is $i, 10, "end has been called"; { $i = 0; my $sub2 = sub { $sub->() }; # new reference my $iter2 = Data::ObjectDriver::Iterator->new($sub2, sub { $i = 10 }); { my $sub3 = sub { $sub->() }; # new reference my $iter3 = Data::ObjectDriver::Iterator->new($sub3, sub { $i = -1 }); is $iter2->(), 0; is $iter3->(), 1; } is $i, -1; } is $i, 10; __END__ use Recipe; use Ingredient; setup_dbs({ global => [ qw( recipes ingredients) ], }); my $iter = $recipe->ingredients; isa_ok $iter, "CODE", "iterator is also available"; while (my $i = $iter->()) { isa_ok $i, "Ingredient", "next"; } my $r = $ingredient->recipe; is $r->recipe_id, $recipe->recipe_id, "recipe id back using 'parent_method'"; teardown_dbs(qw( global )); Data-ObjectDriver-0.09/t/09-resultset.t000644 000767 000024 00000011442 11351753027 017723 0ustar00yannstaff000000 000000 # $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 => 50; 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; } # test add_term { my $result = Wine->result({rating => { op => '<=', 'value' => 4}}, { sort => 'rating', direction => 'descend' }); $result->add_term({rating => 3}); is $result->next->rating, 3; } ## now call add_term after loading objects { my $result = Wine->result({rating => { op => '<=', 'value' => 4}}, { sort => 'rating', direction => 'descend' }); $result->_load_results; $result->add_term({rating => 3}); is $result->next->rating, 3; } ## filtering with 'op', which does work if objects are not loaded { my $result = Wine->result({rating => { op => '<=', 'value' => 4}}, { sort => 'rating', direction => 'descend' }); $result->add_term({rating => { op => '<=', 'value' => 3}}); is $result->next->rating, 3; } ## filtering with 'op', which doesn't work now. { my $result = Wine->result({rating => { op => '<=', 'value' => 4}}, { sort => 'rating', direction => 'descend' }); $result->_load_results; $result->add_term({rating => { op => '<=', 'value' => 3}}); diag "calling next() after add_term() with 'op'" . $result->next; ## this should return the object which has "rating == 3". } teardown_dbs(qw( global )); Data-ObjectDriver-0.09/t/10-resultset-peek.t000644 000767 000024 00000012574 11351753027 020644 0ustar00yannstaff000000 000000 # $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 )); Data-ObjectDriver-0.09/t/11-sql.t000644 000767 000024 00000021221 11351753027 016455 0ustar00yannstaff000000 000000 # $Id$ use strict; use Data::ObjectDriver::SQL; use Test::More tests => 67; my $stmt = ns(); ok($stmt, 'Created SQL object'); ## Testing FROM $stmt->from([ 'foo' ]); is($stmt->as_sql, "FROM foo\n"); $stmt->from([ 'foo', 'bar' ]); is($stmt->as_sql, "FROM foo, bar\n"); ## Testing JOINs $stmt->from([]); $stmt->joins([]); $stmt->add_join(foo => { type => 'inner', table => 'baz', condition => 'foo.baz_id = baz.baz_id' }); is($stmt->as_sql, "FROM foo INNER JOIN baz ON foo.baz_id = baz.baz_id\n"); $stmt->from([ 'bar' ]); is($stmt->as_sql, "FROM foo INNER JOIN baz ON foo.baz_id = baz.baz_id, bar\n"); $stmt->from([]); $stmt->joins([]); $stmt->add_join(foo => [ { type => 'inner', table => 'baz b1', condition => 'foo.baz_id = b1.baz_id AND b1.quux_id = 1' }, { type => 'left', table => 'baz b2', condition => 'foo.baz_id = b2.baz_id AND b2.quux_id = 2' }, ]); is $stmt->as_sql, "FROM foo INNER JOIN baz b1 ON foo.baz_id = b1.baz_id AND b1.quux_id = 1 LEFT JOIN baz b2 ON foo.baz_id = b2.baz_id AND b2.quux_id = 2\n"; # test case for bug found where add_join is called twice $stmt->joins([]); $stmt->add_join(foo => [ { type => 'inner', table => 'baz b1', condition => 'foo.baz_id = b1.baz_id AND b1.quux_id = 1' }, ]); $stmt->add_join(foo => [ { type => 'left', table => 'baz b2', condition => 'foo.baz_id = b2.baz_id AND b2.quux_id = 2' }, ]); is $stmt->as_sql, "FROM foo INNER JOIN baz b1 ON foo.baz_id = b1.baz_id AND b1.quux_id = 1 LEFT JOIN baz b2 ON foo.baz_id = b2.baz_id AND b2.quux_id = 2\n"; # test case adding another table onto the whole mess $stmt->add_join(quux => [ { type => 'inner', table => 'foo f1', condition => 'f1.quux_id = quux.q_id'} ]); is $stmt->as_sql, "FROM foo INNER JOIN baz b1 ON foo.baz_id = b1.baz_id AND b1.quux_id = 1 LEFT JOIN baz b2 ON foo.baz_id = b2.baz_id AND b2.quux_id = 2 INNER JOIN foo f1 ON f1.quux_id = quux.q_id\n"; ## Testing GROUP BY $stmt = ns(); $stmt->from([ 'foo' ]); $stmt->group({ column => 'baz' }); is($stmt->as_sql, "FROM foo\nGROUP BY baz\n", 'single bare group by'); $stmt = ns(); $stmt->from([ 'foo' ]); $stmt->group({ column => 'baz', desc => 'DESC' }); is($stmt->as_sql, "FROM foo\nGROUP BY baz DESC\n", 'single group by with desc'); $stmt = ns(); $stmt->from([ 'foo' ]); $stmt->group([ { column => 'baz' }, { column => 'quux' }, ]); is($stmt->as_sql, "FROM foo\nGROUP BY baz, quux\n", 'multiple group by'); $stmt = ns(); $stmt->from([ 'foo' ]); $stmt->group([ { column => 'baz', desc => 'DESC' }, { column => 'quux', desc => 'DESC' }, ]); is($stmt->as_sql, "FROM foo\nGROUP BY baz DESC, quux DESC\n", 'multiple group by with desc'); ## Testing ORDER BY $stmt = ns(); $stmt->from([ 'foo' ]); $stmt->order({ column => 'baz', desc => 'DESC' }); is($stmt->as_sql, "FROM foo\nORDER BY baz DESC\n", 'single order by'); $stmt = ns(); $stmt->from([ 'foo' ]); $stmt->order([ { column => 'baz', desc => 'DESC' }, { column => 'quux', desc => 'ASC' }, ]); is($stmt->as_sql, "FROM foo\nORDER BY baz DESC, quux ASC\n", 'multiple order by'); ## Testing GROUP BY plus ORDER BY $stmt = ns(); $stmt->from([ 'foo' ]); $stmt->group({ column => 'quux' }); $stmt->order({ column => 'baz', desc => 'DESC' }); is($stmt->as_sql, "FROM foo\nGROUP BY quux\nORDER BY baz DESC\n", 'group by with order by'); ## Testing LIMIT and OFFSET $stmt = ns(); $stmt->from([ 'foo' ]); $stmt->limit(5); is($stmt->as_sql, "FROM foo\nLIMIT 5\n"); $stmt->offset(10); is($stmt->as_sql, "FROM foo\nLIMIT 5 OFFSET 10\n"); $stmt->limit(" 15g"); ## Non-numerics should cause an error { my $sql = eval { $stmt->as_sql }; like($@, qr/Non-numerics/, "bogus limit causes as_sql assertion"); } ## Testing WHERE $stmt = ns(); $stmt->add_where(foo => 'bar'); is($stmt->as_sql_where, "WHERE (foo = ?)\n"); is(scalar @{ $stmt->bind }, 1); is($stmt->bind->[0], 'bar'); $stmt = ns(); $stmt->add_where(foo => [ 'bar', 'baz' ]); is($stmt->as_sql_where, "WHERE (foo IN (?,?))\n"); is(scalar @{ $stmt->bind }, 2); is($stmt->bind->[0], 'bar'); is($stmt->bind->[1], 'baz'); $stmt = ns(); $stmt->add_where(foo => { op => '!=', value => 'bar' }); is($stmt->as_sql_where, "WHERE (foo != ?)\n"); is(scalar @{ $stmt->bind }, 1); is($stmt->bind->[0], 'bar'); $stmt = ns(); $stmt->add_where(foo => { column => 'bar', op => '!=', value => 'bar' }); is($stmt->as_sql_where, "WHERE (bar != ?)\n"); is(scalar @{ $stmt->bind }, 1); is($stmt->bind->[0], 'bar'); $stmt = ns(); $stmt->add_where(foo => \'IS NOT NULL'); is($stmt->as_sql_where, "WHERE (foo IS NOT NULL)\n"); is(scalar @{ $stmt->bind }, 0); $stmt = ns(); $stmt->add_where(foo => 'bar'); $stmt->add_where(baz => 'quux'); is($stmt->as_sql_where, "WHERE (foo = ?) AND (baz = ?)\n"); is(scalar @{ $stmt->bind }, 2); is($stmt->bind->[0], 'bar'); is($stmt->bind->[1], 'quux'); $stmt = ns(); $stmt->add_where(foo => [ { op => '>', value => 'bar' }, { op => '<', value => 'baz' } ]); is($stmt->as_sql_where, "WHERE ((foo > ?) OR (foo < ?))\n"); is(scalar @{ $stmt->bind }, 2); is($stmt->bind->[0], 'bar'); is($stmt->bind->[1], 'baz'); $stmt = ns(); $stmt->add_where(foo => [ -and => { op => '>', value => 'bar' }, { op => '<', value => 'baz' } ]); is($stmt->as_sql_where, "WHERE ((foo > ?) AND (foo < ?))\n"); is(scalar @{ $stmt->bind }, 2); is($stmt->bind->[0], 'bar'); is($stmt->bind->[1], 'baz'); $stmt = ns(); $stmt->add_where(foo => [ -and => 'foo', 'bar', 'baz']); is($stmt->as_sql_where, "WHERE ((foo = ?) AND (foo = ?) AND (foo = ?))\n"); is(scalar @{ $stmt->bind }, 3); is($stmt->bind->[0], 'foo'); is($stmt->bind->[1], 'bar'); is($stmt->bind->[2], 'baz'); ## regression bug. modified parameters my %terms = ( foo => [-and => 'foo', 'bar', 'baz']); $stmt = ns(); $stmt->add_where(%terms); is($stmt->as_sql_where, "WHERE ((foo = ?) AND (foo = ?) AND (foo = ?))\n"); $stmt->add_where(%terms); is($stmt->as_sql_where, "WHERE ((foo = ?) AND (foo = ?) AND (foo = ?)) AND ((foo = ?) AND (foo = ?) AND (foo = ?))\n"); $stmt = ns(); $stmt->add_select(foo => 'foo'); $stmt->add_select('bar'); $stmt->from([ qw( baz ) ]); is($stmt->as_sql, "SELECT foo, bar\nFROM baz\n"); $stmt = ns(); $stmt->add_select('f.foo' => 'foo'); $stmt->add_select('COUNT(*)' => 'count'); $stmt->from([ qw( baz ) ]); is($stmt->as_sql, "SELECT f.foo, COUNT(*) count\nFROM baz\n"); my $map = $stmt->select_map; is(scalar(keys %$map), 2); is($map->{'f.foo'}, 'foo'); is($map->{'COUNT(*)'}, 'count'); # HAVING $stmt = ns(); $stmt->add_select(foo => 'foo'); $stmt->add_select('COUNT(*)' => 'count'); $stmt->from([ qw(baz) ]); $stmt->add_where(foo => 1); $stmt->group({ column => 'baz' }); $stmt->order({ column => 'foo', desc => 'DESC' }); $stmt->limit(2); $stmt->add_having(count => 2); is($stmt->as_sql, <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 } Data-ObjectDriver-0.09/t/12-windows.t000644 000767 000024 00000005313 11351753027 017355 0ustar00yannstaff000000 000000 # $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}; Data-ObjectDriver-0.09/t/20-driver-sqlite.t000644 000767 000024 00000003242 11351753027 020453 0ustar00yannstaff000000 000000 # $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 => 13; 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 $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"; }; ## SQL_VARBINARY test (for binary CHAR) my @results = Wine->search({ binchar => "xxx\0yyy"}); is scalar @results, 1; is $results[0]->rating, 4; is $results[0]->name, "Saumur Champigny, Le Grand Clos 2001"; ## Test Bulk Loading Wine->bulk_insert(['name', 'rating'], [['Caymus', 4], ['Thunderbird', 1], ['Stags Leap', 3]]); my ($result) = Wine->search({name => 'Caymus'}); ok $result, 'Found Caymus'; is $result->rating, 4, 'Caymus is a 4'; ($result) = Wine->search({name => 'Thunderbird'}); ok $result, 'Found Thunderbird'; is $result->rating, 1, 'Thunderbird is a 1'; ($result) = Wine->search({name => 'Stags Leap'}); ok $result, 'Found Stags Leap'; is $result->rating, 3, 'Stags Leap is a 3'; sub DESTROY { teardown_dbs(qw( global )); } Data-ObjectDriver-0.09/t/31-cached.t000644 000767 000024 00000015241 11351753027 017074 0ustar00yannstaff000000 000000 # $Id$ use strict; use lib 't/lib'; # for Cache::Memory substitute. use lib 't/lib/cached'; require 't/lib/db-common.pl'; use Test::More; 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 => 104; setup_dbs({ global => [ qw( recipes ingredients ) ], }); use Recipe; use Ingredient; my($tmp, $iter); my $recipe = Recipe->new; $recipe->title('Banana Milkshake'); ok($recipe->save, 'Object saved successfully'); ok($recipe->recipe_id, 'Recipe has an ID'); is($recipe->title, 'Banana Milkshake', 'Title is Banana Milkshake'); $recipe->title('My Banana Milkshake'); ok($recipe->save, 'Object updated successfully'); is($recipe->title, 'My Banana Milkshake', 'Title is My Banana Milkshake'); $tmp = Recipe->lookup($recipe->recipe_id); is(ref $tmp, 'Recipe', 'lookup gave us a recipe'); is($tmp->title, 'My Banana Milkshake', 'Title is My Banana Milkshake'); ## same with a hash lookup $tmp = Recipe->lookup({ recipe_id => $recipe->recipe_id }); is(ref $tmp, 'Recipe', 'lookup gave us a recipe'); is($tmp->title, 'My Banana Milkshake', 'Title is My Banana Milkshake'); my @recipes = Recipe->search; is(scalar @recipes, 1, 'Got one recipe back from search'); is($recipes[0]->title, 'My Banana Milkshake', 'Title is My Banana Milkshake'); $iter = Recipe->search; ok($iter, 'Got an iterator object'); $tmp = $iter->(); 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'); my $ingredient = Ingredient->new; $ingredient->recipe_id($recipe->recipe_id); $ingredient->name('Vanilla Ice Cream'); $ingredient->quantity(1); ok($ingredient->save, 'Ingredient saved successfully'); ok($ingredient->id, 'Ingredient has an ID'); is($ingredient->id, 1, 'ID is 1'); is($ingredient->name, 'Vanilla Ice Cream', 'Name is Vanilla Ice Cream'); $tmp = Ingredient->lookup([ $recipe->recipe_id, $ingredient->id ]); is(ref $tmp, 'Ingredient', 'lookup gave us an ingredient'); is($tmp->name, 'Vanilla Ice Cream', 'Name is Vanilla Ice Cream'); my @ingredients = Ingredient->search({ recipe_id => $recipe->recipe_id }); is(scalar @ingredients, 1, 'Got one ingredient back from search'); is($ingredients[0]->name, 'Vanilla Ice Cream', 'Name is Vanilla Ice Cream'); $iter = Ingredient->search({ recipe_id => $recipe->recipe_id }); ok($iter, 'Got an iterator object'); $tmp = $iter->(); 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'); my $ingredient2 = Ingredient->new; $ingredient2->recipe_id($recipe->recipe_id); $ingredient2->name('Bananas'); $ingredient2->quantity(5); ok($ingredient2->save, 'Ingredient saved successfully'); ok($ingredient2->id, 'Ingredient has an ID'); is($ingredient2->id, 2, 'ID is 2'); is($ingredient2->name, 'Bananas', 'Name is Bananas'); @ingredients = Ingredient->search({ recipe_id => $recipe->recipe_id, quantity => 5 }); is(scalar @ingredients, 1, 'Got one ingredient back from search'); is($ingredients[0]->id, $ingredient2->id, 'ID is for the Bananas object'); is($ingredients[0]->name, 'Bananas', 'Name is Bananas'); my $recipe2 = Recipe->new; $recipe2->title('Chocolate Chip Cookies'); ok($recipe2->save, 'Object saved successfully'); ok($recipe2->recipe_id, 'Recipe has an ID'); is($recipe2->title, 'Chocolate Chip Cookies', 'Title is Chocolate Chip Cookies'); my $ingredient3 = Ingredient->new; $ingredient3->recipe_id($recipe2->recipe_id); $ingredient3->name('Chocolate Chips'); $ingredient3->quantity(100); ok($ingredient3->save, 'Ingredient saved successfully'); ok($ingredient3->id, 'Ingredient has an ID'); is($ingredient3->id, 1, 'ID is 1'); is($ingredient3->name, 'Chocolate Chips', 'Name is Chocolate Chips'); $tmp = Ingredient->lookup([ $recipe2->recipe_id, 1 ]); is(ref $tmp, 'Ingredient', 'lookup gave us an ingredient'); is($tmp->name, 'Chocolate Chips', 'Name is Chocolate Chips'); $tmp = Ingredient->lookup([ $recipe2->recipe_id, 1 ]); is(ref $tmp, 'Ingredient', 'lookup again (for caching)'); is($tmp->name, 'Chocolate Chips', 'Name is Chocolate Chips'); my $all = Ingredient->lookup_multi([ [ $recipe->recipe_id, 1 ], [ $recipe->recipe_id, 2 ], [ $recipe2->recipe_id, 1 ], ]); is(scalar @$all, 3, 'Got back 3 ingredients from lookup_multi'); is($all->[0]->name, 'Vanilla Ice Cream', 'lookup_multi results in right order'); is($all->[1]->name, 'Bananas', 'lookup_multi results in right order'); is($all->[2]->name, 'Chocolate Chips', 'lookup_multi results in right order'); ## lookup_multi using hashes (Same test than above) $all = Ingredient->lookup_multi([ { recipe_id => $recipe->recipe_id, id => 1 }, { recipe_id => $recipe->recipe_id, id => 2 }, { recipe_id => $recipe2->recipe_id, id => 1 }, ]); is(scalar @$all, 3, 'Got back 3 ingredients from lookup_multi'); is($all->[0]->name, 'Vanilla Ice Cream', 'lookup_multi results in right order'); is($all->[1]->name, 'Bananas', 'lookup_multi results in right order'); is($all->[2]->name, 'Chocolate Chips', 'lookup_multi results in right order'); # fetch_data tests my $data = $recipe->fetch_data; is_deeply $data, { title => "My Banana Milkshake", recipe_id => 1 }, "(DBI) fetch_data - recipe not cached"; $data = $ingredient->fetch_data; is_deeply $data, { name => "Vanilla Ice Cream", quantity => 1, recipe_id => 1, id => 1 }, "(Cache) fetch_data - ingredient is cached"; 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 }); }; ok($@, "nofetch option will make the driver dies if cache is involved"); 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'; sub DESTROY { teardown_dbs(qw( global )); } Data-ObjectDriver-0.09/t/32-partitioned.t000644 000767 000024 00000011016 11351753027 020204 0ustar00yannstaff000000 000000 # $Id$ use strict; use lib 't/lib/partitioned'; require 't/lib/db-common.pl'; use Test::More; unless (eval { require DBD::SQLite }) { plan skip_all => 'Tests require DBD::SQLite'; } plan tests => 92; setup_dbs({ global => [ qw( recipes ) ], cluster1 => [ qw( ingredients ) ], cluster2 => [ qw( ingredients ) ], }); use Recipe; use Ingredient; my($tmp, $iter); my $recipe = Recipe->new; $recipe->title('Banana Milkshake'); ok($recipe->save, 'Object saved successfully'); ok($recipe->recipe_id, 'Recipe has an ID'); ok($recipe->partition_id, 'Recipe assigned to a cluster'); is($recipe->title, 'Banana Milkshake', 'Title is Banana Milkshake'); $recipe->title('My Banana Milkshake'); ok($recipe->save, 'Object updated successfully'); is($recipe->title, 'My Banana Milkshake', 'Title is My Banana Milkshake'); $tmp = Recipe->lookup($recipe->recipe_id); is(ref $tmp, 'Recipe', 'lookup gave us a recipe'); is($tmp->title, 'My Banana Milkshake', 'Title is My Banana Milkshake'); my @recipes = Recipe->search; is(scalar @recipes, 1, 'Got one recipe back from search'); is($recipes[0]->title, 'My Banana Milkshake', 'Title is My Banana Milkshake'); $iter = Recipe->search; ok($iter, 'Got an iterator object'); $tmp = $iter->(); 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); $ingredient->name('Vanilla Ice Cream'); $ingredient->quantity(1); ok($ingredient->save, 'Ingredient saved successfully'); ok($ingredient->id, 'Ingredient has an ID'); is($ingredient->id, 1, 'ID is 1'); is($ingredient->name, 'Vanilla Ice Cream', 'Name is Vanilla Ice Cream'); $tmp = Ingredient->lookup([ $recipe->recipe_id, $ingredient->id ]); is(ref $tmp, 'Ingredient', 'lookup gave us an ingredient'); is($tmp->name, 'Vanilla Ice Cream', 'Name is Vanilla Ice Cream'); my @ingredients = Ingredient->search({ recipe_id => $recipe->recipe_id }); is(scalar @ingredients, 1, 'Got one ingredient back from search'); is($ingredients[0]->name, 'Vanilla Ice Cream', 'Name is Vanilla Ice Cream'); $iter = Ingredient->search({ recipe_id => $recipe->recipe_id }); ok($iter, 'Got an iterator object'); $tmp = $iter->(); 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); $ingredient2->name('Bananas'); $ingredient2->quantity(5); ok($ingredient2->save, 'Ingredient saved successfully'); ok($ingredient2->id, 'Ingredient has an ID'); is($ingredient2->id, 2, 'ID is 2'); is($ingredient2->name, 'Bananas', 'Name is Bananas'); @ingredients = Ingredient->search({ recipe_id => $recipe->recipe_id, quantity => 5 }); is(scalar @ingredients, 1, 'Got one ingredient back from search'); is($ingredients[0]->id, $ingredient2->id, 'ID is for the Bananas object'); is($ingredients[0]->name, 'Bananas', 'Name is Bananas'); my $recipe2 = Recipe->new; $recipe2->title('Chocolate Chip Cookies'); ok($recipe2->save, 'Object saved successfully'); ok($recipe2->recipe_id, 'Recipe has an ID'); ok($recipe2->partition_id, 'Recipe assigned to a cluster'); is($recipe2->title, 'Chocolate Chip Cookies', 'Title is Chocolate Chip Cookies'); my $ingredient3 = Ingredient->new; $ingredient3->recipe_id($recipe2->recipe_id); $ingredient3->name('Chocolate Chips'); $ingredient3->quantity(100); ok($ingredient3->save, 'Ingredient saved successfully'); ok($ingredient3->id, 'Ingredient has an ID'); is($ingredient3->id, 1, 'ID is 1'); is($ingredient3->name, 'Chocolate Chips', 'Name is Chocolate Chips'); $tmp = Ingredient->lookup([ $recipe2->recipe_id, 1 ]); is(ref $tmp, 'Ingredient', 'lookup gave us an ingredient'); is($tmp->name, 'Chocolate Chips', 'Name is Chocolate Chips'); eval { my @i = Ingredient->search({ name => 'Chocolate Chips' }); }; ok ($@); like $@, qr/Cannot extract/; my @i = Ingredient->search({ name => 'Chocolate Chips' }, { multi_partition => 1 }); is @i, 1; is $i[0]->name, 'Chocolate Chips'; is $ingredient->remove, 1, 'Ingredient removed successfully'; is $ingredient2->remove, 1, 'Ingredient removed successfully'; is $ingredient3->remove, 1, 'Ingredient removed successfully'; is $recipe->remove, 1, 'Recipe removed successfully'; is $recipe2->remove, 1, 'Recipe removed successfully'; require 't/txn-common.pl'; sub DESTROY { teardown_dbs(qw( global cluster1 cluster2 )); } Data-ObjectDriver-0.09/t/33-views.t000644 000767 000024 00000002420 11351753027 017017 0ustar00yannstaff000000 000000 # $Id$ use strict; use lib 't/lib/views'; require 't/lib/db-common.pl'; use Test::More; BEGIN { unless (eval { require DBD::SQLite }) { plan skip_all => 'Tests require DBD::SQLite'; } } plan tests => 6; setup_dbs({ global => [ qw( recipes ingredients-view ingredient2recipe ) ], }); use Recipe; use Ingredient; use IngredientsWeighted; my($tmp, $iter); my $milkshake = Recipe->new; $milkshake->title('Banana Milkshake'); $milkshake->save; my $ice_cream = $milkshake->add_ingredient_by_name('Vanilla Ice Cream', 1); my $banana = $milkshake->add_ingredient_by_name('Bananas', 5); my $cookies = Recipe->new; $cookies->title('Chocolate Chip Cookies'); $cookies->save; my $chip = $cookies->add_ingredient_by_name('Chocolate Chips', 100); $cookies->add_ingredient($ice_cream); my @ingredients = IngredientsWeighted->search; is(scalar(@ingredients), 3); my %counts = map { $_->ingredient_name => $_->c } @ingredients; is($counts{'Vanilla Ice Cream'}, 2); is($counts{'Bananas'}, 1); is($counts{'Chocolate Chips'}, 1); @ingredients = IngredientsWeighted->search( { c => { op => '<', value => 2 } }, ); SKIP: { skip "DBD::SQLite bug?", 2; is @ingredients, 1; is $ingredients[0]->name, 'Vanilla Ice Cream'; } sub DESTROY { teardown_dbs(qw( global )); } Data-ObjectDriver-0.09/t/34-both.t000644 000767 000024 00000012371 11351753027 016625 0ustar00yannstaff000000 000000 # $Id$ use strict; use lib 't/lib'; use lib 't/lib/both'; require 't/lib/db-common.pl'; use Test::More; use Test::Exception; 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 => 90; use Recipe; use Ingredient; setup_dbs({ global => [ qw( recipes ) ], cluster1 => [ qw( ingredients) ], cluster2 => [ qw( ingredients) ], }); ## Install some deflate/inflate in the Cache driver. { no warnings 'once'; no warnings 'redefine'; *Data::ObjectDriver::Driver::Cache::Cache::deflate = sub { $_[1]->deflate; }; *Data::ObjectDriver::Driver::Cache::Cache::inflate = sub { $_[1]->inflate($_[2]); }; } my $recipe = Recipe->new; $recipe->title('Cake'); $recipe->save; my $deflated = $recipe->deflate; is $deflated->{columns}{recipe_id}, $recipe->recipe_id; is $deflated->{columns}{title}, $recipe->title; isa_ok $deflated->{ingredients}, 'ARRAY'; is scalar(@{ $deflated->{ingredients} }), 0; my $ingredient = Ingredient->new; $ingredient->recipe_id($recipe->recipe_id); $ingredient->name('Egg'); $ingredient->quantity(5); $ingredient->save; delete $recipe->{__ingredients}; $deflated = $recipe->deflate; isa_ok $deflated->{ingredients}, 'ARRAY'; is scalar(@{ $deflated->{ingredients} }), 1; my $r2 = Recipe->inflate($deflated); is $r2->recipe_id, $recipe->recipe_id; is $r2->title, $recipe->title; ## Inspect the internal array, since it should have been populated ## by inflate. my $ingredients = $r2->{__ingredients}; isa_ok $ingredients, 'ARRAY'; is scalar(@$ingredients), 1; isa_ok $ingredients->[0], 'Ingredient'; is $ingredients->[0]->id, $ingredient->id; is $ingredients->[0]->recipe_id, $ingredient->recipe_id; is $ingredients->[0]->name, $ingredient->name; is $ingredients->[0]->quantity, $ingredient->quantity; my $i2 = Ingredient->new; $i2->recipe_id($recipe->recipe_id); $i2->name('Egg'); $i2->quantity(5); $i2->save; my $is = Ingredient->lookup_multi([ [ $recipe->recipe_id, $ingredient->id ], [ $recipe->recipe_id, $i2->id ], ]); is scalar(@$is), 2; ok $is->[0]{__cached}; ok !$is->[1]{__cached}; $is = Ingredient->lookup_multi([ [ $recipe->recipe_id, $ingredient->id ], [ $recipe->recipe_id, $i2->id ], ]); is scalar(@$is), 2; ok $is->[0]{__cached}; ok $is->[1]{__cached}; my $i3 = Ingredient->new; $i3->recipe_id($recipe->recipe_id); $i3->name('Flour'); $i3->quantity(10); $i3->save; ## Try loading with fetchonly first. The driver shouldn't cache the results. my @is = Ingredient->search({ recipe_id => $recipe->recipe_id }, { fetchonly => [ 'recipe_id', 'id' ] }); is scalar(@is), 3; ## Flour should not yet be cached. my $i4 = Ingredient->lookup([ $recipe->recipe_id, $i3->id ]); 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. $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}; is $i4->name, 'Flour'; ## Now look up the recipe, so that we make sure it gets cached... my $r3 = Recipe->lookup($recipe->recipe_id); ok !$r3->{__cached}; is $r3->recipe_id, $recipe->recipe_id; is $r3->title, $recipe->title; ## Now look it up again. We should get the cached version, and it ## should get inflated. $r3 = Recipe->lookup($recipe->recipe_id); ok $r3->{__cached}; is $r3->recipe_id, $recipe->recipe_id; is $r3->title, $recipe->title; $ingredients = $r3->{__ingredients}; isa_ok $ingredients, 'ARRAY'; is scalar(@$ingredients), 3; isa_ok $ingredients->[0], 'Ingredient'; is $ingredients->[0]->id, $ingredient->id; is $ingredients->[0]->recipe_id, $ingredient->recipe_id; is $ingredients->[0]->name, $ingredient->name; is $ingredients->[0]->quantity, $ingredient->quantity; ## Now add a cache_version to Recipe dynamically, so that the cache_key ## changes the next time we try to do a lookup. *Recipe::cache_version = *Recipe::cache_version = sub { '1.0' }; $r3 = Recipe->lookup($recipe->recipe_id); ok !$r3->{__cached}; $r3 = Recipe->lookup($recipe->recipe_id); ok $r3->{__cached}; ## test replace my $to_replace = Recipe->new; $to_replace->title('Cake'); $to_replace->replace; ok (my $rid = $to_replace->recipe_id); my $replaced = Recipe->lookup($rid); ok ! $replaced->{__cached}; $to_replace = Recipe->new; $to_replace->recipe_id($rid); $to_replace->title('Cup Cake'); $to_replace->replace; $replaced = Recipe->lookup($rid); ok $replaced->{__cached}; is $replaced->title, 'Cup Cake'; require 't/txn-common.pl'; sub DESTROY { teardown_dbs(qw( global cluster1 cluster2 )); } Data-ObjectDriver-0.09/t/35-multiplexed.t000644 000767 000024 00000007423 11351753027 020230 0ustar00yannstaff000000 000000 # $Id$ use strict; use lib 't/lib/multiplexed'; require 't/lib/db-common.pl'; use Test::Exception; use Test::More; unless (eval { require DBD::SQLite }) { plan skip_all => 'Tests require DBD::SQLite'; } plan tests => 42; setup_dbs({ global1 => [ qw( ingredient2recipe ) ], global2 => [ qw( ingredient2recipe ) ], }); use Ingredient2Recipe; my $obj; my $objs; for my $driver (@{ Ingredient2Recipe->driver->drivers }) { isa_ok $driver, 'Data::ObjectDriver::Driver::DBI'; } $obj = Ingredient2Recipe->new; $obj->ingredient_id(1); $obj->recipe_id(5); $obj->insert; lives_ok { $obj = Ingredient2Recipe->lookup(5) } 'lookup lives'; lives_ok { $objs = Ingredient2Recipe->lookup_multi([5, 5]) } 'lookup_multi lives'; lives_ok { $obj->exists } 'exists lives'; is $obj->ingredient_id, 1; is $obj->recipe_id, 5; isa_ok( $_, 'Ingredient2Recipe' ) for @$objs; is $objs->[0]->ingredient_id, 1; is $objs->[1]->ingredient_id, 1; for my $driver (@{ Ingredient2Recipe->driver->drivers }) { my $ok = $driver->select_one(<remove({ ingredient_id => 1, recipe_id => 5 }, { nofetch => 1 }), 2, 'Removed 2 records for 1 object'); for my $driver (@{ Ingredient2Recipe->driver->drivers }) { my $ok = !$driver->select_one(<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); $obj->recipe_id(42); $obj->replace; my $pk = $obj->primary_key; is $pk, 42; my $obj2 = Ingredient2Recipe->lookup($pk); ok $obj2, "got our object back"; $obj2->remove; $obj = Ingredient2Recipe->lookup($pk); is $obj, undef, "Object deleted"; ($obj) = Ingredient2Recipe->search({ingredient_id => 4}); is $obj, undef, "the other driver has deleted it too"; sub _check_object { my($obj) = @_; my($obj2) = Ingredient2Recipe->search({ ingredient_id => $obj->ingredient_id }); isa_ok $obj2, 'Ingredient2Recipe'; is $obj2->ingredient_id, $obj->ingredient_id; is $obj2->recipe_id, $obj->recipe_id; ($obj2) = Ingredient2Recipe->search({ recipe_id => $obj->recipe_id }); isa_ok $obj2, 'Ingredient2Recipe'; is $obj2->ingredient_id, $obj->ingredient_id; is $obj2->recipe_id, $obj->recipe_id; } teardown_dbs(qw( global1 global2 )); Data-ObjectDriver-0.09/t/41-callbacks.t000644 000767 000024 00000007025 11351753027 017606 0ustar00yannstaff000000 000000 # $Id$ use strict; use lib 't/lib'; require 't/lib/db-common.pl'; use Test::More; unless (eval { require DBD::SQLite }) { plan skip_all => 'Tests require DBD::SQLite'; } plan tests => 25; setup_dbs({ global => [ qw( wines ) ], }); use Wine; ## can add callbacks { ok(Data::ObjectDriver::BaseObject->can('add_trigger'), 'can add triggers to BaseObject class'); ok(My::BaseObject->can('add_trigger'), 'can add triggers to directly derived class'); ok(Wine->can('add_trigger'), 'can add triggers to doubly derived class'); }; sub clear_triggers { my ($obj, $when) = @_; my $triggers = Class::Trigger::__fetch_triggers($obj); delete $triggers->{$when}; } ## test pre_save { my $wine = Wine->new; $wine->name("Saumur Champigny, Le Grand Clos 2001"); $wine->rating(4); my $ran_callback = 0; my $test_pre_save = sub { is scalar(@_), 2, 'callback received correct number of parameters'; my ($saving_wine, $orig_wine) = @_; ## This is not the original object, so we can't test it that way. isa_ok $saving_wine, 'Wine', 'callback received correct kind of object'; cmp_ok $saving_wine->name, 'eq', "Saumur Champigny, Le Grand Clos 2001"; cmp_ok $saving_wine->rating, '==', 4, "modifiable Wine has a rating"; ok !defined($saving_wine->id), 'modifiable Wine has no id yet'; isa_ok $orig_wine, 'Wine', 'callback received correct kind of object'; cmp_ok $orig_wine->name, 'eq', "Saumur Champigny, Le Grand Clos 2001"; cmp_ok $orig_wine->rating, '==', 4, "original Wine has a rating"; ok !defined($orig_wine->id), 'original Wine has no id yet either'; ## Change rating of modifiable Wine to test immutability of original. $saving_wine->rating(5); $ran_callback++; return; }; Wine->add_trigger('pre_save', $test_pre_save); $wine->save or die "Object did not save successfully"; is $ran_callback, 1, 'callback ran exactly once'; ok defined $wine->id, 'object did receive an id'; ok ! $wine->is_changed, "not changed, since we've just saved the obj"; my $saved_wine = Wine->lookup($wine->id) or die "Object just saved could not be retrieved successfully"; is $saved_wine->rating, 5, 'change in callback did change saved data'; is $wine->rating, 4, 'change in callback did not change original object'; clear_triggers('Wine', 'pre_save'); is $wine->remove, 1, 'Remove correct number or rows'; }; ## test pre_search { Wine->add_trigger('pre_search', sub { return unless $_[1]->{rating}; $_[1]->{rating} = $_[1]->{rating} * 2; } ); my $wine = Wine->new; $wine->name('I will change rating'); $wine->rating(10); $wine->save; ($wine) = Wine->search({ rating => 5 }); ok $wine; cmp_ok $wine->rating, '==', 10, "object has still the same rating"; cmp_ok $wine->name, 'eq', 'I will change rating', "indeed"; is $wine->remove, 1, 'Remove correct number of rows'; clear_triggers('Wine', 'pre_search'); } ## test post_load { Wine->add_trigger('post_load', sub { $_[0]->rating($_[0]->rating * 3, {no_changed_flag => 1}); } ); my $wine = Wine->new; $wine->name('I will change rating'); $wine->rating(10); $wine->save; $wine = Wine->lookup($wine->id); ok $wine, "loaded"; cmp_ok $wine->rating, '==', 30, "post_load in action"; ok ! $wine->is_changed, "wine hasn't changed"; clear_triggers('Wine', 'post_load'); }; sub DESTROY { teardown_dbs(qw( global )); } 1; Data-ObjectDriver-0.09/t/42-callbacks-multi-pk.t000644 000767 000024 00000004652 11351753027 021352 0ustar00yannstaff000000 000000 # $Id: 41-callbacks.t 1037 2005-11-25 14:51:09Z ykerherve $ use strict; use lib 't/lib/partitioned'; require 't/lib/db-common.pl'; use Test::More; unless (eval { require DBD::SQLite }) { plan skip_all => 'Tests require DBD::SQLite'; } plan tests => 13; setup_dbs({ global => [ qw( recipes ) ], cluster1 => [ qw( ingredients ) ], cluster2 => [ qw( ingredients ) ], }); use Recipe; use Ingredient; ## test pre_save { my $title = "Crême brûlée à la pistache"; my $name = "Eggs"; my $quantity = 10; my $recipe = Recipe->new; $recipe->title($title); $recipe->save; my $ingredient = Ingredient->new; $ingredient->recipe_id($recipe->recipe_id); $ingredient->name($name); $ingredient->quantity($quantity); ## it makes no sense to test if have the wrong init. cond. isa_ok $ingredient->primary_key_tuple, 'ARRAY'; ok($recipe->partition_id, 'Recipe assigned to a cluster'); my $ran_callback = 0; my $test_pre_save = sub { is scalar(@_), 2, 'callback received correct number of parameters'; my ($saving) = @_; ## This is not the original object, so we can't test it that way. isa_ok $saving, 'Ingredient', 'callback received correct kind of object'; cmp_ok $saving->name, 'eq', $name, $name; cmp_ok $saving->quantity, '==', $quantity, 'quantity'; ok !defined($saving->id), 'callback received object with right data'; ## Change rating to test immutability of original. $saving->quantity($quantity * 2); $ran_callback++; return; }; ## Add callback Ingredient->add_trigger('pre_save', $test_pre_save); ## Call the save that should trigger the callback $ingredient->save or die "Object did not save successfully"; is $ran_callback, 1, 'callback ran exactly once'; ok defined $ingredient->primary_key, 'object did receive a pk'; my $saved = Ingredient->lookup($ingredient->primary_key) or die "Object just saved could not be retrieved successfully"; is $saved->quantity, $quantity * 2, 'change in callback did change saved data'; is $ingredient->quantity, $quantity, 'change in callback did not change original object'; $ingredient->refresh; is $ingredient->quantity, $quantity * 2, 'refreshed worked'; ok($ingredient->recipe_id, 'Ingredient assigned to a recipe'); }; sub DESTROY { teardown_dbs(qw( global )); } 1; Data-ObjectDriver-0.09/t/50-profiling.t000644 000767 000024 00000006232 11477275110 017660 0ustar00yannstaff000000 000000 # $Id$ use strict; use lib 't/lib'; use lib 't/lib/both'; require 't/lib/db-common.pl'; use Test::More; use Test::Exception; 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 => 22; use Recipe; use Ingredient; setup_dbs({ global => [ qw( recipes ) ], cluster1 => [ qw( ingredients ) ], cluster2 => [ qw( ingredients ) ], }); $Data::ObjectDriver::PROFILE = 1; my $recipe = Recipe->new; $recipe->title('Cake'); $recipe->save; ## test profiling in exception handling blocks: i.e w/ $@ defined ## see https://github.com/aklaswad/data-objectdriver/commit/39ea4f0c90342f1d196670aac2bc04b9d60acfe3 { ## Can get instance of D::OD::Profiler via profiler() ok( my $profiler = Data::ObjectDriver->profiler ); ## But when some error was already set to $@, Can't get instance... $@ = "beep"; ok( my $one_more_profiler = Data::ObjectDriver->profiler, "get profiler after exception", ); } ## disable caching because it makes the test more complicate ## to understand. Indeed inflate and deflate generates additional ## queries difficult to account for use Data::ObjectDriver::Driver::Cache::Cache; Data::ObjectDriver::Driver::Cache::Cache->Disabled(1); my $profiler = Data::ObjectDriver->profiler; my $stats = $profiler->statistics; is $stats->{'DBI:total_queries'}, 1; is $stats->{'DBI:query_insert'}, 1; my $log = $profiler->query_log; isa_ok $log, 'ARRAY'; is scalar(@$log), 1; like $log->[0], qr/^\s*INSERT INTO recipe/; my $frequent = $profiler->query_frequency; isa_ok $frequent, 'HASH'; my $sql = (keys %$frequent)[0]; like $sql, qr/^\s*INSERT INTO recipe/; is $frequent->{$sql}, 1; Data::ObjectDriver->profiler->reset; $stats = $profiler->statistics; is scalar(keys %$stats), 0; $recipe = Recipe->lookup($recipe->recipe_id); $stats = $profiler->statistics; is $stats->{'DBI:total_queries'}, 1; is $stats->{'DBI:query_select'}, 1; $recipe->title('Brownies'); $recipe->save; $stats = $profiler->statistics; is $stats->{'DBI:total_queries'}, 3; is $stats->{'DBI:query_select'}, 2; is $stats->{'DBI:query_update'}, 1; $recipe->title('Flan'); $recipe->save; $frequent = $profiler->query_frequency; is $frequent->{"SELECT 1 FROM recipes WHERE (recipes.recipe_id = ?)"}, 2; is $profiler->total_queries, 5; # testing $Data::ObjectDriver::RESTRICT_IO $recipe = Recipe->new; $recipe->title('Cookies'); $recipe->save; # this didn't die, great! { local $Data::ObjectDriver::RESTRICT_IO = 1; dies_ok { $recipe = Recipe->lookup($recipe->recipe_id); } 'I/O attempt intercepted in restricted mode'; } lives_ok { $recipe = Recipe->lookup($recipe->recipe_id); } 'I/O succeeded with restriced mode disabled'; SKIP: { my $simpletable = eval { require Text::SimpleTable }; skip "Text::SimpleTable not installed", 2 unless $simpletable; like $profiler->report_query_frequency, qr/FROM recipes/; like $profiler->report_queries_by_type, qr/SELECT/; }; sub DESTROY { teardown_dbs(qw( global cluster1 cluster2 )); } Data-ObjectDriver-0.09/t/lib/000755 000767 000024 00000000000 11540451052 016013 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/t/perf/000755 000767 000024 00000000000 11540451052 016201 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/t/schemas/000755 000767 000024 00000000000 11540451052 016670 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/t/txn-common.pl000755 000767 000024 00000012223 11351753027 017713 0ustar00yannstaff000000 000000 # $Id: db-common.pl 58 2006-05-04 00:04:10Z sky $ use strict; use Test::More; #diag "executing common transaction 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"); } sub warns_ok (&;$) { my ($sub, $msg) = @_; my $warn = 0; local $SIG{__WARN__} = sub { $warn++ }; $sub->(); $warn ? pass($msg) : fail($msg); } ## nested transactions { ## if there is no transaction active this will just warn is( Data::ObjectDriver::BaseObject->txn_active, 0); warns_ok { Data::ObjectDriver::BaseObject->commit() } 'committing with no active transaction caused warning'; 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'); warns_ok { Data::ObjectDriver::BaseObject->begin_work() } 'beginning new transaction with a transaction already open ' . 'causes warning'; warns_ok { Data::ObjectDriver::BaseObject->begin_work() } 'beginning new transaction with two transactions already open ' . 'causes warning'; 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'); warns_ok { Data::ObjectDriver::BaseObject->begin_work() } 'beginning new transaction with a transaction already open ' . 'still causes warning'; $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; Data-ObjectDriver-0.09/t/schemas/error_test.sql000644 000767 000024 00000000103 11351753027 021602 0ustar00yannstaff000000 000000 CREATE TABLE error_test ( foo VARCHAR(20), UNIQUE( foo ) ) Data-ObjectDriver-0.09/t/schemas/ingredient2recipe.sql000644 000767 000024 00000000243 11351753027 023021 0ustar00yannstaff000000 000000 CREATE TABLE ingredient2recipe ( ingredient_id INTEGER NOT NULL, recipe_id INTEGER NOT NULL, value1 VARCHAR(255), PRIMARY KEY (recipe_id, ingredient_id) ) Data-ObjectDriver-0.09/t/schemas/ingredients-view.sql000644 000767 000024 00000000160 11351753027 022700 0ustar00yannstaff000000 000000 CREATE TABLE ingredients ( id INTEGER NOT NULL, name VARCHAR(50), quantity SMALLINT, PRIMARY KEY (id) ) Data-ObjectDriver-0.09/t/schemas/ingredients.sql000644 000767 000024 00000000230 11351753027 021726 0ustar00yannstaff000000 000000 CREATE TABLE ingredients ( id INTEGER NOT NULL, recipe_id INTEGER NOT NULL, name VARCHAR(50), quantity SMALLINT, PRIMARY KEY (id,recipe_id) ) Data-ObjectDriver-0.09/t/schemas/pkless.sql000644 000767 000024 00000000062 11351753027 020717 0ustar00yannstaff000000 000000 CREATE TABLE pkless ( anything varchar(200) ) Data-ObjectDriver-0.09/t/schemas/recipes.sql000644 000767 000024 00000000160 11351753027 021047 0ustar00yannstaff000000 000000 CREATE TABLE recipes ( recipe_id INTEGER NOT NULL PRIMARY KEY, partition_id SMALLINT, title VARCHAR(50) ) Data-ObjectDriver-0.09/t/schemas/user.sql000644 000767 000024 00000000744 11351753027 020403 0ustar00yannstaff000000 000000 CREATE TABLE user ( user_id INTEGER NOT NULL PRIMARY KEY, first_name VARCHAR(50), last_name VARCHAR(50), address1 VARCHAR(50), address2 VARCHAR(50), email VARCHAR(50), hair_color VARCHAR(50), eyes_color VARCHAR(50), timezone VARCHAR(50), language1 VARCHAR(50), language2 VARCHAR(50), language3 VARCHAR(50), language4 VARCHAR(50), language5 VARCHAR(50), language6 VARCHAR(50), SSN VARCHAR(50), TIN VARCHAR(50), PIN VARCHAR(50), city VARCHAR(50) ) Data-ObjectDriver-0.09/t/schemas/wines.sql000644 000767 000024 00000000242 11351753027 020543 0ustar00yannstaff000000 000000 CREATE TABLE wines ( id INTEGER NOT NULL PRIMARY KEY, cluster_id SMALLINT, name VARCHAR(50), content MEDIUMBLOB, binchar CHAR(50), rating SMALLINT ) Data-ObjectDriver-0.09/t/perf/inflate.pl000644 000767 000024 00000001144 11351753027 020167 0ustar00yannstaff000000 000000 # $Id$ use strict; use lib 't/lib'; use lib 't/lib/cached'; require 't/lib/db-common.pl'; use Benchmark qw(:all); use User; setup_dbs({ global => [ qw( user ) ], }); my $how_many = shift || 10_000; my @recipes; =cut for (1..$how_many) { my $recipe = Recipe->new; $recipe->title("recipe $_"); $recipe->insert; } =cut ## generate some data my $data = { map { $_ => $_ } @{ User->properties->{columns} } }; $data->{user_id} = int rand 100000; my @users; my $i; timethis( $how_many, sub { push @users, User->inflate({ columns => $data }); }); sub DESTROY { teardown_dbs(qw( global )); } Data-ObjectDriver-0.09/t/lib/both/000755 000767 000024 00000000000 11540451052 016747 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/t/lib/Cache/000755 000767 000024 00000000000 11540451052 017016 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/t/lib/cached/000755 000767 000024 00000000000 11540451052 017222 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/t/lib/db-common.pl000755 000767 000024 00000001601 11351753027 020233 0ustar00yannstaff000000 000000 # $Id$ use strict; use File::Spec; sub db_filename { my($dbname) = @_; $dbname . '.db'; } sub setup_dbs { my($info) = @_; teardown_dbs(keys %$info); for my $dbname (keys %$info) { my $dbh = DBI->connect('dbi:SQLite:dbname=' . db_filename($dbname), '', '', { RaiseError => 1, PrintError => 0 }); for my $table (@{ $info->{$dbname} }) { $dbh->do( create_sql($table) ); } $dbh->disconnect; } } sub teardown_dbs { my(@dbs) = @_; for my $db (@dbs) { my $file = db_filename($db); next unless -e $file; unlink $file or die "Can't teardown $db: $!"; } } sub create_sql { my($table) = @_; my $file = File::Spec->catfile('t', 'schemas', $table . '.sql'); open my $fh, $file or die "Can't open $file: $!"; my $sql = do { local $/; <$fh> }; close $fh; $sql; } 1; Data-ObjectDriver-0.09/t/lib/ErrorTest.pm000644 000767 000024 00000000544 11351753027 020314 0ustar00yannstaff000000 000000 # $Id$ package ErrorTest; use strict; use base qw( Data::ObjectDriver::BaseObject ); use Data::ObjectDriver::Driver::DBI; __PACKAGE__->install_properties({ columns => [ 'foo' ], datasource => 'error_test', primary_key => [ ], driver => Data::ObjectDriver::Driver::DBI->new( dsn => 'dbi:SQLite:dbname=global.db', ), }); Data-ObjectDriver-0.09/t/lib/multiplexed/000755 000767 000024 00000000000 11540451052 020347 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/t/lib/partitioned/000755 000767 000024 00000000000 11540451052 020335 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/t/lib/PkLess.pm000644 000767 000024 00000000665 11351753027 017570 0ustar00yannstaff000000 000000 # $Id: Wine.pm 1050 2005-12-08 13:46:22Z ykerherve $ use strict; package PkLess; use base qw/Data::ObjectDriver::BaseObject/; use Data::ObjectDriver::Driver::DBI; __PACKAGE__->install_properties({ columns => [ 'anything' ], datasource => 'pkless', primary_key => [ ], # proper way to skip pk (for now XXX) driver => Data::ObjectDriver::Driver::DBI->new( dsn => 'dbi:SQLite:dbname=global.db', ), }); Data-ObjectDriver-0.09/t/lib/views/000755 000767 000024 00000000000 11540451052 017150 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/t/lib/Wine.pm000644 000767 000024 00000001664 11351753027 017271 0ustar00yannstaff000000 000000 # $Id$ use strict; package My::BaseObject; use base qw/Data::ObjectDriver::BaseObject/; sub install_properties { my $this = shift; my $props = $this->SUPER::install_properties(@_); $this->install_column('rating'); return $props; } package Wine; use base qw( My::BaseObject ); use Data::ObjectDriver::Driver::DBI; __PACKAGE__->install_properties({ # rating is defined on the fly in My::BaseObject columns => [ 'id', 'cluster_id', 'name', 'content', 'binchar'], datasource => 'wines', primary_key => 'id', column_defs => { content => 'blob', binchar => 'binchar' }, driver => Data::ObjectDriver::Driver::DBI->new( dsn => 'dbi:SQLite:dbname=global.db', ), }); sub insert { my $obj = shift; ## Choose a cluster for this recipe. This isn't a very solid way of ## doing this, but it works for testing. $obj->cluster_id(int(rand 2) + 1); $obj->SUPER::insert(@_); } # 1; Data-ObjectDriver-0.09/t/lib/views/Ingredient.pm000644 000767 000024 00000001003 11351753027 021577 0ustar00yannstaff000000 000000 # $Id$ package Ingredient; use strict; use base qw( Data::ObjectDriver::BaseObject ); use Data::ObjectDriver::Driver::DBI; our $ID = 0; __PACKAGE__->install_properties({ columns => [ 'id', 'name', 'quantity' ], datasource => 'ingredients', primary_key => 'id', driver => Data::ObjectDriver::Driver::DBI->new( dsn => 'dbi:SQLite:dbname=global.db', pk_generator => \&generate_pk, ), }); sub generate_pk { my($obj) = @_; $obj->id(++$ID); 1; } 1; Data-ObjectDriver-0.09/t/lib/views/Ingredient2Recipe.pm000644 000767 000024 00000000664 11351753027 023025 0ustar00yannstaff000000 000000 # $Id$ package Ingredient2Recipe; use strict; use base qw( Data::ObjectDriver::BaseObject ); use Data::ObjectDriver::Driver::DBI; __PACKAGE__->install_properties({ columns => [ 'recipe_id', 'ingredient_id' ], datasource => 'ingredient2recipe', primary_key => [ 'recipe_id', 'ingredient_id', ], driver => Data::ObjectDriver::Driver::DBI->new( dsn => 'dbi:SQLite:dbname=global.db', ), }); 1; Data-ObjectDriver-0.09/t/lib/views/IngredientsWeighted.pm000644 000767 000024 00000001466 11351753027 023460 0ustar00yannstaff000000 000000 # $Id$ package IngredientsWeighted; use strict; use base qw( Data::ObjectDriver::BaseView ); use Data::ObjectDriver::Driver::DBI; use Data::ObjectDriver::SQL; __PACKAGE__->install_properties({ columns => [ 'ingredient_name', 'c' ], driver => Data::ObjectDriver::Driver::DBI->new( dsn => 'dbi:SQLite:dbname=global.db', pk_generator => \&generate_pk, ), }); sub base_statement { my $class = shift; my $stmt = Data::ObjectDriver::SQL->new; $stmt->add_select('ingredients.name' => 'ingredient_name'); $stmt->add_select('COUNT(*)' => 'c'); $stmt->from([ 'ingredient2recipe', 'ingredients' ]); $stmt->add_where('ingredients.id' => \'= ingredient2recipe.ingredient_id'); $stmt->group({ column => 'ingredient2recipe.ingredient_id' }); $stmt; } 1; Data-ObjectDriver-0.09/t/lib/views/Recipe.pm000644 000767 000024 00000001563 11351753027 020731 0ustar00yannstaff000000 000000 # $Id$ package Recipe; use strict; use base qw( Data::ObjectDriver::BaseObject ); use Data::ObjectDriver::Driver::DBI; use Ingredient; use Ingredient2Recipe; __PACKAGE__->install_properties({ columns => [ 'id', 'title' ], datasource => 'recipes', primary_key => 'id', driver => Data::ObjectDriver::Driver::DBI->new( dsn => 'dbi:SQLite:dbname=global.db', ), }); sub add_ingredient_by_name { my $recipe = shift; my($name, $quantity) = @_; my $ingredient = Ingredient->new; $ingredient->name($name); $ingredient->quantity($quantity); $ingredient->save; $recipe->add_ingredient($ingredient); $ingredient; } sub add_ingredient { my $recipe = shift; my($ingredient) = @_; my $map = Ingredient2Recipe->new; $map->ingredient_id($ingredient->id); $map->recipe_id($recipe->id); $map->save; } 1; Data-ObjectDriver-0.09/t/lib/partitioned/Ingredient.pm000644 000767 000024 00000001074 11351753027 022774 0ustar00yannstaff000000 000000 # $Id$ package Ingredient; use strict; use base qw( Data::ObjectDriver::BaseObject ); use Carp (); use Data::ObjectDriver::Driver::SimplePartition; our %IDs; __PACKAGE__->install_properties({ columns => [ 'id', 'recipe_id', 'name', 'quantity' ], datasource => 'ingredients', primary_key => [ 'recipe_id', 'id' ], driver => Data::ObjectDriver::Driver::SimplePartition->new( using => 'Recipe', pk_generator => \&generate_pk, ), }); sub generate_pk { my($obj) = @_; $obj->id(++$IDs{$obj->recipe_id}); 1; } 1; Data-ObjectDriver-0.09/t/lib/partitioned/Recipe.pm000644 000767 000024 00000001434 11351753027 022113 0ustar00yannstaff000000 000000 # $Id$ package Recipe; use strict; use base qw( Data::ObjectDriver::BaseObject ); use Data::ObjectDriver::Driver::DBI; __PACKAGE__->install_properties({ columns => [ 'recipe_id', 'partition_id', 'title' ], datasource => 'recipes', 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 { my $cluster = shift; my $driver = $drivers{$cluster} ||= Data::ObjectDriver::Driver::DBI->new( dsn => 'dbi:SQLite:dbname=cluster' . $cluster . '.db', reuse_dbh => 1, @_, ); return $driver; }, ); 1; Data-ObjectDriver-0.09/t/lib/multiplexed/Ingredient2Recipe.pm000644 000767 000024 00000002021 11351753027 024211 0ustar00yannstaff000000 000000 # $Id$ package Ingredient2Recipe; use strict; use base qw( Data::ObjectDriver::BaseObject ); use Data::ObjectDriver::Driver::DBI; use Data::ObjectDriver::Driver::Multiplexer; my $global1_driver = Data::ObjectDriver::Driver::DBI->new( dsn => 'dbi:SQLite:dbname=global1.db', ); my $global2_driver = Data::ObjectDriver::Driver::DBI->new( dsn => 'dbi:SQLite:dbname=global2.db', ); __PACKAGE__->install_properties({ 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( ## Send searches by recipe_id to $global1_driver, and ## searches by ingredient_id to $global2_driver. on_search => { recipe_id => $global1_driver, ingredient_id => $global2_driver, }, on_lookup => $global1_driver, drivers => [ $global1_driver, $global2_driver ], ), }); 1; Data-ObjectDriver-0.09/t/lib/cached/Ingredient.pm000644 000767 000024 00000001370 11351753027 021660 0ustar00yannstaff000000 000000 # $Id$ package Ingredient; use strict; use base qw( Data::ObjectDriver::BaseObject ); use Carp (); use Data::ObjectDriver::Driver::DBI; use Data::ObjectDriver::Driver::Cache::RAM; our %IDs; __PACKAGE__->install_properties({ columns => [ 'id', 'recipe_id', 'name', 'quantity' ], datasource => 'ingredients', primary_key => [ 'recipe_id', 'id' ], 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, ), }); sub generate_pk { my($obj) = @_; $obj->id(++$IDs{$obj->recipe_id}); 1; } 1; Data-ObjectDriver-0.09/t/lib/cached/Recipe.pm000644 000767 000024 00000000620 11351753027 020774 0ustar00yannstaff000000 000000 # $Id$ package Recipe; use strict; use base qw( Data::ObjectDriver::BaseObject ); use Data::ObjectDriver::Driver::DBI; __PACKAGE__->install_properties({ columns => [ 'recipe_id', 'title' ], datasource => 'recipes', primary_key => 'recipe_id', driver => Data::ObjectDriver::Driver::DBI->new( dsn => 'dbi:SQLite:dbname=global.db', reuse_dbh => 1, ), }); 1; Data-ObjectDriver-0.09/t/lib/cached/User.pm000644 000767 000024 00000001350 11351753027 020504 0ustar00yannstaff000000 000000 package User; use strict; use base qw( Data::ObjectDriver::BaseObject ); use Data::ObjectDriver::Driver::DBI; our $LAST_ID = 0; __PACKAGE__->install_properties({ columns => [ qw/ user_id first_name last_name address1 address2 email hair_color eyes_color timezone language1 language2 language3 language4 language5 language6 SSN TIN PIN city /], datasource => 'user', primary_key => 'user_id', driver => Data::ObjectDriver::Driver::DBI->new( dsn => 'dbi:SQLite:dbname=global.db', reuse_dbh => 1, ), genereate_pk => sub { ++$LAST_ID }, }); 1; Data-ObjectDriver-0.09/t/lib/Cache/Memory.pm000644 000767 000024 00000001317 11351753027 020635 0ustar00yannstaff000000 000000 # so we don't need the Cache::* family installed just to make test... # lowering the barrier to others hacking on this stuff. package Cache::Memory; use strict; use Storable; sub new { my $class = shift; return bless {}, $class; } sub remove { my ($self, $key) = @_; delete $self->{$key}; } sub thaw { my ($self, $key) = @_; my $val = $self->{$key}; return unless defined $val; my $magic = eval { Storable::read_magic($val); }; if ($magic && $magic->{major} && $magic->{major} >= 2) { return Storable::thaw($val); } return $val; } sub freeze { my ($self, $key, $val) = @_; $self->{$key} = ref($val) ? Storable::freeze($val) : $val; return 1; } 1; Data-ObjectDriver-0.09/t/lib/both/Ingredient.pm000644 000767 000024 00000001376 11351753027 021413 0ustar00yannstaff000000 000000 # $Id$ package Ingredient; use strict; use base qw( Data::ObjectDriver::BaseObject ); use Carp (); use Cache::Memory; use Data::ObjectDriver::Driver::Cache::Cache; use Data::ObjectDriver::Driver::SimplePartition; our %IDs; __PACKAGE__->install_properties({ columns => [ 'id', 'recipe_id', 'name', 'quantity' ], datasource => 'ingredients', primary_key => [ 'recipe_id', 'id' ], driver => Data::ObjectDriver::Driver::Cache::Cache->new( cache => Cache::Memory->new, fallback => Data::ObjectDriver::Driver::SimplePartition->new( using => 'Recipe', pk_generator => \&generate_pk, ), ), }); sub generate_pk { my($obj) = @_; $obj->id(++$IDs{$obj->recipe_id}); 1; } 1; Data-ObjectDriver-0.09/t/lib/both/Recipe.pm000644 000767 000024 00000003217 11351753027 020526 0ustar00yannstaff000000 000000 # $Id$ package Recipe; use strict; use base qw( Data::ObjectDriver::BaseObject ); use Cache::Memory; use Data::ObjectDriver::Driver::Cache::Cache; use Data::ObjectDriver::Driver::DBI; __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, ), ), }); my %drivers; __PACKAGE__->has_partitions( number => 2, get_driver => sub { my $cluster = shift; my $driver = $drivers{$cluster} ||= Data::ObjectDriver::Driver::DBI->new( dsn => 'dbi:SQLite:dbname=cluster' . $cluster . '.db', reuse_dbh => 1, @_, ); return $driver; }, ); sub ingredients { my $recipe = shift; unless (exists $recipe->{__ingredients}) { $recipe->{__ingredients} = [ Ingredient->search({ recipe_id => $recipe->recipe_id }) ]; } $recipe->{__ingredients}; } sub deflate { my $recipe = shift; my $deflated = $recipe->SUPER::deflate; $deflated->{ingredients} = [ map $_->deflate, @{ $recipe->ingredients } ]; $deflated; } sub inflate { my $class = shift; my($deflated) = @_; my $recipe = $class->SUPER::inflate($deflated); $recipe->{__ingredients} = [ map Ingredient->inflate($_), @{ $deflated->{ingredients} } ]; $recipe; } 1; Data-ObjectDriver-0.09/lib/Data/000755 000767 000024 00000000000 11540451052 016421 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/lib/Data/ObjectDriver/000755 000767 000024 00000000000 11540451052 021003 5ustar00yannstaff000000 000000 Data-ObjectDriver-0.09/lib/Data/ObjectDriver.pm000644 000767 000024 00000056773 11540447736 021401 0ustar00yannstaff000000 000000 # $Id$ package Data::ObjectDriver; use strict; use warnings; use 5.006_001; use Class::Accessor::Fast; use base qw( Class::Accessor::Fast ); use Data::ObjectDriver::Iterator; __PACKAGE__->mk_accessors(qw( pk_generator txn_active )); our $VERSION = '0.09'; our $DEBUG = $ENV{DOD_DEBUG} || 0; our $PROFILE = $ENV{DOD_PROFILE} || 0; our $PROFILER; our $LOGGER; sub new { my $class = shift; my $driver = bless {}, $class; $driver->init(@_); $driver; } sub logger { my $class = shift; if ( @_ ) { return $LOGGER = shift; } else { return $LOGGER ||= sub { print STDERR @_; }; } } sub init { my $driver = shift; my %param = @_; $driver->pk_generator($param{pk_generator}); $driver->txn_active(0); $driver; } # Alias record_query to start_query *record_query = \*start_query; sub start_query { my $driver = shift; my($sql, $bind) = @_; $driver->debug($sql, $bind) if $DEBUG; $driver->profiler($sql) if $PROFILE; return; } 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; my $class = ref $driver || $driver; my @caller; my $i = 0; while (1) { @caller = caller($i++); last if $caller[0] !~ /^(Data::ObjectDriver|$class)/; } my $where = " in file $caller[1] line $caller[2]\n"; if (@_ == 1 && !ref($_[0])) { $driver->logger->( @_, $where ); } else { require Data::Dumper; local $Data::Dumper::Indent = 1; $driver->logger->( Data::Dumper::Dumper(@_), $where ); } } sub profiler { my $driver = shift; my ($sql) = @_; local $@; $PROFILER ||= eval { require Data::ObjectDriver::Profiler; Data::ObjectDriver::Profiler->new; }; return $PROFILE = 0 if $@ || !$PROFILER; return $PROFILER unless @_; $PROFILER->record_query($driver, $sql); } sub list_or_iterator { my $driver = shift; my($objs) = @_; ## Emulate the standard search behavior of returning an ## iterator in scalar context, and the full list in list context. if (wantarray) { return @{$objs}; } else { my $iter = sub { shift @{$objs} }; return Data::ObjectDriver::Iterator->new($iter); } } sub cache_object { } sub uncache_object { } 1; __END__ =head1 NAME Data::ObjectDriver - Simple, transparent data interface, with caching =head1 SYNOPSIS ## Set up your database driver code. package FoodDriver; sub driver { Data::ObjectDriver::Driver::DBI->new( dsn => 'dbi:mysql:dbname', username => 'username', password => 'password', ) } ## Set up the classes for your recipe and ingredient objects. package Recipe; use base qw( Data::ObjectDriver::BaseObject ); __PACKAGE__->install_properties({ columns => [ 'recipe_id', 'title' ], datasource => 'recipe', primary_key => 'recipe_id', driver => FoodDriver->driver, }); package Ingredient; use base qw( Data::ObjectDriver::BaseObject ); __PACKAGE__->install_properties({ columns => [ 'ingredient_id', 'recipe_id', 'name', 'quantity' ], datasource => 'ingredient', primary_key => [ 'recipe_id', 'ingredient_id' ], driver => FoodDriver->driver, }); ## And now, use them! my $recipe = Recipe->new; $recipe->title('Banana Milkshake'); $recipe->save; my $ingredient = Ingredient->new; $ingredient->recipe_id($recipe->id); $ingredient->name('Bananas'); $ingredient->quantity(5); $ingredient->save; ## Needs more bananas! $ingredient->quantity(10); $ingredient->save; ## Shorthand constructor my $ingredient = Ingredient->new(recipe_id=> $recipe->id, name => 'Milk', quantity => 2); =head1 DESCRIPTION I is an object relational mapper, meaning that it maps object-oriented design concepts onto a relational database. It's inspired by, and descended from, the I classes in Six Apart's Movable Type and TypePad weblogging products. But it adds in caching and partitioning layers, allowing you to spread data across multiple physical databases, without your application code needing to know where the data is stored. =head1 METHODOLOGY I provides you with a framework for building database-backed applications. It provides built-in support for object caching and database partitioning, and uses a layered approach to allow building very sophisticated database interfaces without a lot of code. You can build a driver that uses any number of caching layers, plus a partitioning layer, then a final layer that actually knows how to load data from a backend datastore. For example, the following code: my $driver = Data::ObjectDriver::Driver::Cache::Memcached->new( cache => Cache::Memcached->new( servers => [ '127.0.0.1:11211' ], ), fallback => Data::ObjectDriver::Driver::Partition->new( get_driver => \&get_driver, ), ); creates a new driver that supports both caching (using memcached) and partitioning. It's useful to demonstrate the flow of a sample request through this driver framework. The following code: my $ingredient = Ingredient->lookup([ $recipe->recipe_id, 1 ]); would take the following path through the I framework: =over 4 =item 1. The caching layer would look up the object with the given primary key in all of the specified memcached servers. If the object was found in the cache, it would be returned immediately. If the object was not found in the cache, the caching layer would fall back to the driver listed in the I setting: the partitioning layer. =item 2. The partitioning layer does not know how to look up objects by itself--all it knows how to do is to give back a driver that I know how to look up objects in a backend datastore. In our example above, imagine that we're partitioning our ingredient data based on the recipe that the ingredient is found in. For example, all of the ingredients for a "Banana Milkshake" would be found in one partition; all of the ingredients for a "Chocolate Sundae" might be found in another partition. So the partitioning layer needs to tell us which partition to look in to load the ingredients for I<$recipe-Erecipe_id>. If we store a I column along with each I<$recipe> object, that information can be loaded very easily, and the partitioning layer will then instantiate a I driver that knows how to load an ingredient from that recipe. =item 3. Using the I driver that the partitioning layer created, I can look up the ingredient with the specified primary key. It will return that key back up the chain, giving each layer a chance to do something with it. =item 4. The caching layer, when it receives the object loaded in Step 3, will store the object in memcached. =item 5. The object will be passed back to the caller. Subsequent lookups of that same object will come from the cache. =back =head1 HOW IS IT DIFFERENT? I differs from other similar frameworks (e.g. L) in a couple of ways: =over 4 =item * It has built-in support for caching. =item * It has built-in support for data partitioning. =item * Drivers are attached to classes, not to the application as a whole. This is essential for partitioning, because your partition drivers need to know how to load a specific class of data. But it can also be useful for caching, because you may find that it doesn't make sense to cache certain classes of data that change constantly. =item * The driver class != the base object class. All of the object classes you declare will descend from I, and all of the drivers you instantiate or subclass will descend from I itself. This provides a useful distinction between your data/classes, and the drivers that describe how to B on that data, meaning that an object based on I is not tied to any particular type of driver. =back =head1 USAGE =head2 Class->lookup($id) Looks up/retrieves a single object with the primary key I<$id>, and returns the object. I<$id> can be either a scalar or a reference to an array, in the case of a class with a multiple column primary key. =head2 Class->lookup_multi(\@ids) Looks up/retrieves multiple objects with the IDs I<\@ids>, which should be a reference to an array of IDs. As in the case of I, an ID can be either a scalar or a reference to an array. Returns a reference to an array of objects B as the IDs you passed in. Any objects that could not successfully be loaded will be represented in that array as an C element. So, for example, if you wanted to load 2 objects with the primary keys C<[ 5, 3 ]> and C<[ 4, 2 ]>, you'd call I like this: Class->lookup_multi([ [ 5, 3 ], [ 4, 2 ], ]); And if the first object in that list could not be loaded successfully, you'd get back a reference to an array like this: [ undef, $object ] where I<$object> is an instance of I. =head2 Class->search(\%terms [, \%options ]) Searches for objects matching the terms I<%terms>. In list context, returns an array of matching objects; in scalar context, returns a reference to a subroutine that acts as an iterator object, like so: my $iter = Ingredient->search({ recipe_id => 5 }); while (my $ingredient = $iter->()) { ... } C<$iter> is blessed in L package, so the above could also be written: my $iter = Ingredient->search({ recipe_id => 5 }); while (my $ingredient = $iter->next()) { ... } The keys in I<%terms> should be column names for the database table modeled by I (and the values should be the desired values for those columns). I<%options> can contain: =over 4 =item * sort The name of a column to use to sort the result set. Optional. =item * direction The direction in which you want to sort the result set. Must be either C or C. Optional. =item * limit The value for a I clause, to limit the size of the result set. Optional. =item * offset The offset to start at when limiting the result set. Optional. =item * fetchonly A reference to an array of column names to fetch in the I statement generated will include a I 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 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 attribute is also specified that is smaller than the C. =back =head2 Class->search(\@terms [, \%options ]) This is an alternative calling signature for the search method documented above. When providing an array of terms, it allows for constructing complex expressions that mix 'and' and 'or' clauses. For example: my $iter = Ingredient->search([ { recipe_id => 5 }, -or => { calories => { value => 300, op => '<' } } ]); while (my $ingredient = $iter->()) { ... } Supported logic operators are: '-and', '-or', '-and_not', '-or_not'. =head2 Class->add_trigger($trigger, \&callback) Adds a trigger to all objects of class I, such that when the event I<$trigger> occurs to any of the objects, subroutine C<&callback> is run. Note that triggers will not occur for instances of I of I, only of I itself. See TRIGGERS for the available triggers. =head2 Class->call_trigger($trigger, [@callback_params]) Invokes the triggers watching class I. The parameters to send to the callbacks (in addition to I) are specified in I<@callback_params>. See TRIGGERS for the available triggers. =head2 $obj->save Saves the object I<$obj> to the database. If the object is not yet in the database, I will automatically generate a primary key and insert the record into the database table. Otherwise, it will update the existing record. If an error occurs, I will I. Internally, I calls I for records that already exist in the database, and I for those that don't. =head2 $obj->remove Removes the object I<$obj> from the database. If an error occurs, I will I. =head2 Class->remove(\%terms, \%args) Removes objects found with the I<%terms>. So it's a shortcut of: my @obj = Class->search(\%terms, \%args); for my $obj (@obj) { $obj->remove; } However, when you pass C option set to C<%args>, it won't create objects with C, but issues I SQL directly to the database. ## issues "DELETE FROM tbl WHERE user_id = 2" Class->remove({ user_id => 2 }, { nofetch => 1 }); This might be much faster and useful for tables without Primary Key, but beware that in this case B because no objects are instanciated. =head2 Class->bulk_insert([col1, col2], [[d1,d2], [d1,d2]]); Bulk inserts data into the underlying table. The first argument is an array reference of columns names as specified in install_properties =head2 $obj->add_trigger($trigger, \&callback) Adds a trigger to the object I<$obj>, such that when the event I<$trigger> occurs to the object, subroutine C<&callback> is run. See TRIGGERS for the available triggers. Triggers are invoked in the order in which they are added. =head2 $obj->call_trigger($trigger, [@callback_params]) Invokes the triggers watching all objects of I<$obj>'s class and the object I<$obj> specifically for trigger event I<$trigger>. The additional parameters besides I<$obj>, if any, are passed as I<@callback_params>. See TRIGGERS for the available triggers. =head1 TRIGGERS I provides a trigger mechanism by which callbacks can be called at certain points in the life cycle of an object. These can be set on a class as a whole or individual objects (see USAGE). Triggers can be added and called for these events: =over 4 =item * pre_save -> ($obj, $orig_obj) Callbacks on the I trigger are called when the object is about to be saved to the database. For example, use this callback to translate special code strings into numbers for storage in an integer column in the database. Note that this hook is also called when you C the object. Modifications to I<$obj> will affect the values passed to subsequent triggers and saved in the database, but not the original object on which the I method was invoked. =item * post_save -> ($obj, $orig_obj) Callbaks on the I triggers are called after the object is saved to the database. Use this trigger when your hook needs primary key which is automatically assigned (like auto_increment and sequence). Note that this hooks is B called when you remove the object. =item * pre_insert/post_insert/pre_update/post_update/pre_remove/post_remove -> ($obj, $orig_obj) Those triggers are fired before and after $obj is created, updated and deleted. =item * post_load -> ($obj) Callbacks on the I trigger are called when an object is being created from a database query, such as with the I and I class methods. For example, use this callback to translate the numbers your I callback caused to be saved I into string codes. Modifications to I<$obj> will affect the object passed to subsequent triggers and returned from the loading method. Note I should only be used as a trigger on a class, as the object to which the load is occuring was not previously available for triggers to be added. =item * pre_search -> ($class, $terms, $args) Callbacks on the I trigger are called when a content addressed query for objects of class I<$class> is performed with the I method. For example, use this callback to translate the entry in I<$terms> for your code string field to its appropriate integer value. Modifications to I<$terms> and I<$args> will affect the parameters to subsequent triggers and what objects are loaded, but not the original hash references used in the I query. Note I should only be used as a trigger on a class, as I is never invoked on specific objects. =over The return values from your callbacks are ignored. Note that the invocation of callbacks is the responsibility of the object driver. If you implement a driver that does not delegate to I, it is I responsibility to invoke the appropriate callbacks with the I method. =back =back =head1 PROFILING For performance tuning, you can turn on query profiling by setting I<$Data::ObjectDriver::PROFILE> to a true value. Or, alternatively, you can set the I environment variable to a true value before starting your application. To obtain the profile statistics, get the global I instance: my $profiler = Data::ObjectDriver->profiler; Then see the documentation for I to see the methods on that class. In some applications there are phases of execution in which no I/O operations should occur, but sometimes it's difficult to tell when, where, or if those I/O operations are happening. One approach to surfacing these situations is to set, either globally or locally, the $Data::ObjectDriver::RESTRICT_IO flag. If set, this will tell Data::ObjectDriver to die with some context rather than executing network calls for data. =head1 TRANSACTIONS Transactions are supported by Data::ObjectDriver's default drivers. So each Driver is capable to deal with transactional state independently. Additionally 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 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. ## 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 package Ingredient; use strict; use base qw( Data::ObjectDriver::BaseObject ); use Data::ObjectDriver::Driver::DBI; use Data::ObjectDriver::Driver::Partition; use Data::ObjectDriver::Driver::Cache::Cache; use Cache::Memory; use Carp; our $IDs; __PACKAGE__->install_properties({ columns => [ 'ingredient_id', 'recipe_id', 'name', 'quantity', ], datasource => 'ingredients', primary_key => [ 'recipe_id', 'ingredient_id' ], driver => Data::ObjectDriver::Driver::Cache::Cache->new( cache => Cache::Memory->new( namespace => __PACKAGE__ ), fallback => Data::ObjectDriver::Driver::Partition->new( get_driver => \&get_driver, pk_generator => \&generate_pk, ), ), }); sub get_driver { my($terms) = @_; my $recipe; if (ref $terms eq 'HASH') { my $recipe_id = $terms->{recipe_id} or Carp::croak("recipe_id is required"); $recipe = Recipe->lookup($recipe_id); } elsif (ref $terms eq 'ARRAY') { $recipe = Recipe->lookup($terms->[0]); } Carp::croak("Unknown recipe") unless $recipe; Data::ObjectDriver::Driver::DBI->new( dsn => 'dbi:mysql:database=cluster' . $recipe->cluster_id, username => 'foo', pk_generator => \&generate_pk, ); } sub generate_pk { my($obj) = @_; $obj->ingredient_id(++$IDs{$obj->recipe_id}); 1; } 1; =head1 SUPPORTED DATABASES I is very modular and it's not very diffucult to add new drivers. =over 4 =item * MySQL is well supported and has been heavily tested. =item * PostgreSQL has been been used in production and should just work, too. =item * SQLite is supported, but YMMV depending on the version. This is the backend used for the test suite. =item * Oracle support has been added in 0.06 =back =head1 LICENSE I is free software; you may redistribute it and/or modify it under the same terms as Perl itself. =head1 MAILING LIST, CODE & MORE INFORMATION I developers can be reached via the following group: L Bugs should be reported using the CPAN RT system, patches are encouraged when reporting bugs. L =head1 AUTHOR & COPYRIGHT Except where otherwise noted, I is Copyright 2005-2006 Six Apart, cpan@sixapart.com. All rights reserved. =cut Data-ObjectDriver-0.09/lib/Data/ObjectDriver/BaseObject.pm000644 000767 000024 00000111176 11351753027 023360 0ustar00yannstaff000000 000000 # $Id$ package Data::ObjectDriver::BaseObject; use strict; use warnings; our $HasWeaken; eval q{ use Scalar::Util qw(weaken) }; ## no critic $HasWeaken = !$@; use Carp (); use Class::Trigger qw( pre_save post_save post_load pre_search pre_insert post_insert pre_update post_update pre_remove post_remove post_inflate ); use Data::ObjectDriver::ResultSet; ## Global Transaction variables our @WorkingDrivers; our $TransactionLevel = 0; sub install_properties { my $class = shift; my($props) = @_; my $columns = delete $props->{columns}; $props->{columns} = []; { no strict 'refs'; ## no critic *{"${class}::__properties"} = sub { $props }; } foreach my $col (@$columns) { $class->install_column($col); } return $props; } sub install_column { my($class, $col, $type) = @_; my $props = $class->properties; push @{ $props->{columns} }, $col; $props->{column_names}{$col} = (); # predefine getter/setter methods here # Skip adding this method if the class overloads it. # this lets the SUPER::columnname magic do it's thing if (! $class->can($col)) { no strict 'refs'; ## no critic *{"${class}::$col"} = $class->column_func($col); } if ($type) { $props->{column_defs}{$col} = $type; } } sub properties { my $this = shift; my $class = ref($this) || $this; $class->__properties; } # see docs below sub has_a { my $class = shift; my @args = @_; # Iterate over each remote object foreach my $config (@args) { my $parentclass = $config->{class}; # Parameters my $column = $config->{column}; my $method = $config->{method}; my $cached = $config->{cached} || 0; my $parent_method = $config->{parent_method}; # column is required if (!defined($column)) { die "Please specify a valid column for $parentclass" } # create a method name based on the column if (! defined $method) { if (!ref($column)) { $method = $column; $method =~ s/_id$//; $method .= "_obj"; } elsif (ref($column) eq 'ARRAY') { foreach my $col (@{$column}) { my $part = $col; $part =~ s/_id$//; $method .= $part . '_'; } $method .= "obj"; } } # die if we have clashing methods method if (! defined $method || defined(*{"${class}::$method"})) { die "Please define a valid method for $class->$column"; } if ($cached) { # Store cached item inside this object's namespace my $cachekey = "__cache_$method"; no strict 'refs'; ## no critic *{"${class}::$method"} = sub { my $obj = shift; return $obj->{$cachekey} if defined $obj->{$cachekey}; my $id = (ref($column) eq 'ARRAY') ? [ map { $obj->{column_values}->{$_} } @{$column}] : $obj->{column_values}->{$column} ; ## Hold in a variable here too, so we don't lose it immediately ## by having only the weak reference. my $ret = $parentclass->lookup($id); if ($HasWeaken) { $obj->{$cachekey} = $ret; weaken($obj->{$cachekey}); } return $ret; }; } else { if (ref($column)) { no strict 'refs'; ## no critic *{"${class}::$method"} = sub { my $obj = shift; return $parentclass->lookup([ map{ $obj->{column_values}->{$_} } @{$column}]); }; } else { no strict 'refs'; ## no critic *{"${class}::$method"} = sub { return $parentclass->lookup(shift()->{column_values}->{$column}); }; } } # now add to the parent if (!defined $parent_method) { $parent_method = lc($class); $parent_method =~ s/^.*:://; $parent_method .= '_objs'; } if (ref($column)) { no strict 'refs'; ## no critic *{"${parentclass}::$parent_method"} = sub { my $obj = shift; my $terms = shift || {}; my $args = shift; my $primary_key = $obj->primary_key; # inject pk search into given terms. # composite key, ugh foreach my $key (@$column) { $terms->{$key} = shift(@{$primary_key}); } return $class->search($terms, $args); }; } else { no strict 'refs'; ## no critic *{"${parentclass}::$parent_method"} = sub { my $obj = shift; my $terms = shift || {}; my $args = shift; # TBD - use primary_key_to_terms $terms->{$column} = $obj->primary_key; return $class->search($terms, $args); }; }; } # end of loop over class names return; } sub driver { my $class = shift; $class->properties->{driver} ||= $class->properties->{get_driver}->(); } sub get_driver { my $class = shift; $class->properties->{get_driver} = shift if @_; } sub new { my $obj = bless {}, shift; return $obj->init(@_); } sub init { my $self = shift; while (@_) { my $field = shift; my $val = shift; $self->$field($val); } return $self; } sub is_pkless { my $obj = shift; my $prop_pk = $obj->properties->{primary_key}; return 1 if ! $prop_pk; return 1 if ref $prop_pk eq 'ARRAY' && ! @$prop_pk; } sub is_primary_key { my $obj = shift; my($col) = @_; my $prop_pk = $obj->properties->{primary_key}; if (ref($prop_pk)) { for my $pk (@$prop_pk) { return 1 if $pk eq $col; } } else { return 1 if $prop_pk eq $col; } return; } sub primary_key_tuple { my $obj = shift; my $pk = $obj->properties->{primary_key} || return; $pk = [ $pk ] unless ref($pk) eq 'ARRAY'; $pk; } sub primary_key { my $obj = shift; my $pk = $obj->primary_key_tuple; my @val = map { $obj->$_() } @$pk; @val == 1 ? $val[0] : \@val; } sub is_same_array { my($a1, $a2) = @_; return if ($#$a1 != $#$a2); for (my $i = 0; $i <= $#$a1; $i++) { return if $a1->[$i] ne $a2->[$i]; } return 1; } sub primary_key_to_terms { my($obj, $id) = @_; my $pk = $obj->primary_key_tuple; if (! defined $id) { $id = $obj->primary_key; } else { if (ref($id) eq 'HASH') { my @keys = sort keys %$id; unless (is_same_array(\@keys, [ sort @$pk ])) { Carp::confess("keys don't match with primary keys: @keys|@$pk"); } return $id; } } $id = [ $id ] unless ref($id) eq 'ARRAY'; my %terms; @terms{@$pk} = @$id; \%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}; my $val = $obj->primary_key; $val = [ $val ] unless ref($val) eq 'ARRAY'; for my $v (@$val) { return unless defined $v; } 1; } sub datasource { $_[0]->properties->{datasource} } sub columns_of_type { my $obj = shift; my($type) = @_; my $props = $obj->properties; my $cols = $props->{columns}; my $col_defs = $props->{column_defs}; my @cols; for my $col (@$cols) { push @cols, $col if $col_defs->{$col} && $col_defs->{$col} eq $type; } \@cols; } sub set_values { my $obj = shift; my $values = shift; for my $col (keys %$values) { unless ( $obj->has_column($col) ) { Carp::croak("You tried to set non-existent column $col to value $values->{$col} on " . ref($obj)); } $obj->$col($values->{$col}); } } sub set_values_internal { my $obj = shift; my $values = shift; for my $col (keys %$values) { # Not needed for the internal version of this method #unless ( $obj->has_column($col) ) { # Carp::croak("You tried to set inexistent column $col to value $values->{$col} on " . ref($obj)); #} $obj->column_values->{$col} = $values->{$col}; } } sub clone { my $obj = shift; my $clone = $obj->clone_all; for my $pk (@{ $obj->primary_key_tuple }) { $clone->$pk(undef); } $clone; } sub clone_all { my $obj = shift; my $clone = ref($obj)->new(); $clone->set_values_internal($obj->column_values); $clone->{changed_cols} = defined $obj->{changed_cols} ? { %{$obj->{changed_cols}} } : undef; $clone; } sub has_column { return exists $_[0]->properties->{column_names}{$_[1]}; } sub column_names { ## Reference to a copy. [ @{ shift->properties->{columns} } ] } sub column_values { $_[0]->{'column_values'} ||= {} } ## In 0.1 version we didn't die on inexistent column ## which might lead to silent bugs ## You should override column if you want to find the old ## behaviour sub column { my $obj = shift; my $col = shift or return; unless ($obj->has_column($col)) { Carp::croak("Cannot find column '$col' for class '" . ref($obj) . "'"); } # set some values if (@_) { $obj->{column_values}->{$col} = shift; unless ($_[0] && ref($_[0]) eq 'HASH' && $_[0]->{no_changed_flag}) { $obj->{changed_cols}->{$col}++; } } $obj->{column_values}->{$col}; } sub column_func { my $obj = shift; my $col = shift or die "Must specify column"; return sub { my $obj = shift; # getter return $obj->{column_values}->{$col} unless (@_); # setter my ($val, $flags) = @_; $obj->{column_values}->{$col} = $val; unless ($flags && ref($flags) eq 'HASH' && $flags->{no_changed_flag}) { $obj->{changed_cols}->{$col}++; } return $obj->{column_values}->{$col}; }; } sub changed_cols_and_pk { my $obj = shift; keys %{$obj->{changed_cols}}; } sub changed_cols { my $obj = shift; my $pk = $obj->primary_key_tuple; my %pk = map { $_ => 1 } @$pk; grep !$pk{$_}, $obj->changed_cols_and_pk; } sub is_changed { my $obj = shift; if (@_) { return exists $obj->{changed_cols}->{$_[0]}; } else { return $obj->changed_cols > 0; } } sub exists { my $obj = shift; return 0 unless $obj->has_primary_key; $obj->_proxy('exists', @_); } sub save { my $obj = shift; if ($obj->exists(@_)) { return $obj->update(@_); } else { return $obj->insert(@_); } } sub bulk_insert { my $class = shift; my $driver = $class->driver; return $driver->bulk_insert($class, @_); } sub lookup { my $class = shift; my $driver = $class->driver; my $obj = $driver->lookup($class, @_) or return; $driver->cache_object($obj); $obj; } sub lookup_multi { my $class = shift; my $driver = $class->driver; my $objs = $driver->lookup_multi($class, @_) or return; for my $obj (@$objs) { $driver->cache_object($obj) if $obj; } $objs; } sub result { my $class = shift; my ($terms, $args) = @_; return Data::ObjectDriver::ResultSet->new({ class => (ref $class || $class), page_size => delete $args->{page_size}, paging => delete $args->{no_paging}, terms => $terms, args => $args, }); } sub search { my $class = shift; my($terms, $args) = @_; my $driver = $class->driver; 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; } } 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 }); } } 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; return unless $obj->has_primary_key; my $fields = $obj->fetch_data; $obj->set_values_internal($fields); $obj->call_trigger('post_load'); $obj->driver->cache_object($obj); 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) = @_; 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 ) { Carp::carp( $TransactionLevel > 1 ? "$TransactionLevel transactions already active" : "Transaction already active" ); } $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) { Carp::carp("No active transaction to end; ignoring $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 { my $class = shift; my($deflated) = @_; my $obj = $class->new; $obj->set_values_internal($deflated->{columns}); $obj->call_trigger('post_inflate'); return $obj; } sub DESTROY { } sub AUTOLOAD { my $obj = $_[0]; (my $col = our $AUTOLOAD) =~ s!.+::!!; Carp::croak("Cannot find method '$col' for class '$obj'") unless ref $obj; unless ($obj->has_column($col)) { Carp::croak("Cannot find column '$col' for class '" . ref($obj) . "'"); } { no strict 'refs'; ## no critic *$AUTOLOAD = $obj->column_func($col); } goto &$AUTOLOAD; } sub has_partitions { my $class = shift; my(%param) = @_; my $how_many = delete $param{number} or Carp::croak("number (of partitions) is required"); ## save the number of partitions in the class $class->properties->{number_of_partitions} = $how_many; ## Save the get_driver subref that we were passed, so that the ## SimplePartition driver can access it. $class->properties->{partition_get_driver} = delete $param{get_driver} or Carp::croak("get_driver is required"); ## When creating a new $class object, we should automatically fill in ## the partition ID by selecting one at random, unless a partition_id ## is already defined. This allows us to keep it simple but for the ## caller to do something more complex, if it wants to. $class->add_trigger(pre_insert => sub { my($obj, $orig_obj) = @_; unless (defined $obj->partition_id) { my $partition_id = int(rand $how_many) + 1; $obj->partition_id($partition_id); $orig_obj->partition_id($partition_id); } }); } 1; __END__ =head1 NAME Data::ObjectDriver::BaseObject - base class for modeled objects =head1 SYNOPSIS package Ingredient; use base qw( Data::ObjectDriver::BaseObject ); __PACKAGE__->install_properties({ columns => [ 'ingredient_id', 'recipe_id', 'name', 'quantity' ], datasource => 'ingredient', primary_key => [ 'recipe_id', 'ingredient_id' ], driver => FoodDriver->driver, }); __PACKAGE__->has_a( { class => 'Recipe', column => 'recipe_id', } ); package main; my ($ingredient) = Ingredient->search({ recipe_id => 4, name => 'rutabaga' }); $ingredient->quantity(7); $ingredient->save(); =head1 DESCRIPTION I provides services to data objects modeled with the I object relational mapper. =head1 CLASS DEFINITION =head2 Cinstall_properties(\%params)> Defines all the properties of the specified object class. Generally you should call C in the body of your class definition, so the properties can be set when the class is Cd or Cd. Required members of C<%params> are: =over 4 =item * C All the columns in the object class. This property is an arrayref. =item * C The identifier of the table in which the object class's data are stored. Usually the datasource is simply the table name, but the datasource can be decorated into the table name by the C module if the database requires special formatting of table names. =item * C or C The driver used to perform database operations (lookup, update, etc) for the object class. C is the instance of C to use. If your driver requires configuration options not available when the properties are initially set, specify a coderef as C instead. It will be called the first time the driver is needed, storing the driver in the class's C property for subsequent calls. =back The optional members of C<%params> are: =over 4 =item * C The column or columns used to uniquely identify an instance of the object class. If one column (such as a simple numeric ID) identifies the class, C should be a scalar. Otherwise, C is an arrayref. =item * C Specifies types for specially typed columns, if any, as a hashref. For example, if a column holds a timestamp, name it in C as a C for proper handling with some C database drivers. Columns for which types aren't specified are handled as C columns. Known C types are: =over 4 =item * C A blob of binary data. C maps this to C, C to C and C to C. =item * C A non-blob string of binary data. C maps this to C. =back Other types may be defined by custom database drivers as needed, so consult their documentation. =item * C The name of the database. When used with C type object drivers, this name is passed to the C method when the actual database handle is being created. =back Custom object drivers may define other properties for your object classes. Consult the documentation of those object drivers for more information. =head2 Cinstall_column($col, $def)> Modify the Class definition to declare a new column C<$col> of definition <$def> (see L). =head2 Chas_a(@definitions)> B C is an experimental system, likely to both be buggy and change in future versions. Defines a foreign key reference between two classes, creating accessor methods to retrieve objects both ways across the reference. For each defined reference, two methods are created: one for objects of class C to load the objects they reference, and one for objects of the referenced class to load the set of C objects that reference I. For example, this definition: package Ingredient; __PACKAGE__->has_a( { class => 'Recipe', column => 'recipe_id' }, ); would create Crecipe_obj> and Cingredient_objs> instance methods. Each member of C<@definitions> is a hashref containing the parameters for creating one accessor method. The required members of these hashes are: =over 4 =item * C The class to associate. =item * C The column or columns in this class that identify the primary key of the associated object. As with primary keys, use a single scalar string for a single column or an arrayref for a composite key. =back The optional members of C definitions are: =over 4 =item * C The name of the accessor method to create. By default, the method name is the concatenated set of column names with each C<_id> suffix removed, and the suffix C<_obj> appended at the end of the method name. For example, if C were C<['recipe_id', 'ingredient_id']>, the resulting method would be called C by default. =item * C Whether to keep a reference to the foreign object once it's loaded. Subsequent calls to the accessor method would return that reference immediately. =item * C The name of the reciprocal method created in the referenced class named in C. By default, that method is named with the lowercased name of the current class with the suffix C<_objs>. For example, if in your C class you defined a relationship with C on the column C, this would create a C<$recipe-Eingredient_objs> method. Note that if you reference one class with multiple sets of fields, you can omit only one parent_method; otherwise the methods would be named the same thing. For instance, if you had a C class with two references to C objects in its C and C columns, one of them would need a C. =back =head2 Chas_partitions(%param)> Defines that the given class is partitioned, configuring it for use with the C object driver. Required members of C<%param> are: =over 4 =item * C The number of partitions in which objects of this class may be stored. =item * C A function that returns an object driver, given a partition ID and any extra parameters specified when the class's C was instantiated. =back Note that only the parent object for use with the C driver should use C. See C for more about partitioning. =head1 BASIC USAGE =head2 Clookup($id)> Returns the instance of C with the given value for its primary key. If C has a complex primary key (more than one column), C<$id> should be an arrayref specifying the column values in the same order as specified in the C property. =head2 Csearch(\%terms, [\%args])> Returns all instances of C that match the values specified in C<\%terms>, keyed on column names. In list context, C returns the objects containing those values. In scalar context, C returns an iterator function containing the same set of objects. Your search can be customized with parameters specified in C<\%args>. Commonly recognized parameters (those implemented by the standard C object drivers) are: =over 4 =item * C A column by which to order the object results. =item * C If set to C, the results (ordered by the C column) are returned in descending order. Otherwise, results will be in ascending order. =item * C The number of results to return, at most. You can use this with C to paginate your C results. =item * C The number of results to skip before the first returned result. Use this with C to paginate your C results. =item * C A list (arrayref) of columns that should be requested. If specified, only the specified columns of the resulting objects are guaranteed to be set to the correct values. Note that any caching object drivers you use may opt to ignore C instructions, or decline to cache objects queried with C. =item * C If true, instructs the object driver to indicate the query is a search, but the application may want to update the data after. That is, the generated SQL C. =head2 $profiler->query_frequency Returns a reference to a hash containing, as keys, all of the SQL statements in the query log, where the value for each of the keys is a number representing the number of times the query was executed. =head2 $profiler->reset Resets the statistics and the query log. =head2 $profiler->total_queries Returns the total number of queries currently logged in the profiler. =head2 $profiler->report_queries_by_type Returns a string containing a pretty report of information about the current number of each type of query in the profiler (e.g. C (arrayref) The database columns to select in a C query should return DISTINCT rows only. =head2 C (hashref) The map of database column names to object fields in a C list to column names. =head2 C (hashref) The map of object fields to database column names in a C query. Note if you perform a C query. The requested object member will be indicated to be C<$term> in the statement's C and C attributes. C<$term> is optional, and defaults to the same value as C<$column>. =head2 C<$sql-Eadd_join($table, \@joins)> Adds the join statement indicated by C<$table> and C<\@joins> to the list of C table references for the statement. The structure for the set of joins are as described for the C attribute member above. =head2 C<$sql-Eadd_index_hint($table, $index)> Specifies a particular index to use for a particular table. =head2 C<$sql-Eadd_where($column, $value)> Adds a condition on the value of the database column C<$column> to the statement's C clause. A record will be tested against the below conditions according to what type of data structure C<$value> is: =over 4 =item * a scalar The value of C<$column> must equal C<$value>. =item * a reference to a scalar The value of C<$column> must evaluate true against the SQL given in C<$$value>. For example, if C<$$value> were C, C<$column> must be C for a record to pass. =item * a hashref The value of C<$column> must compare against the condition represented by C<$value>, which can contain the members: =over 4 =item * C The value with which to compare (required). =item * C The SQL operator with which to compare C and the value of C<$column> (required). =item * C The column name for the comparison. If this is present, it overrides the column name C<$column>, allowing you to build more complex conditions like C<((foo = 1 AND bar = 2) OR (baz = 3))>. =back For example, if C were C and C were C, a record's C<$column> column would have to be C to match. =item * an arrayref of scalars The value of C<$column> may equal any of the members of C<@$value>. The generated SQL performs the comparison with as an C expression. =item * an arrayref of (mostly) references The value of C<$column> must compare against I of the expressions represented in C<@$value>. Each member of the list can be any of the structures described here as possible forms of C<$value>. If the first member of the C<@$value> array is the scalar string C<-and>, I subsequent members of <@$value> must be met for the record to match. Note this is not very useful unless contained as one option of a larger C alternation. =back All individual conditions specified with C must be true for a record to be a result of the query. Beware that you can create a circular reference that will recursively generate an infinite SQL statement (for example, by specifying a arrayref C<$value> that itself contains C<$value>). As C evaluates your expressions before storing the conditions in the C attribute as a generated SQL string, this will occur when calling C, not C. So don't do that. =head2 C<$sql-Eadd_complex_where(\@list)> This method accepts an array reference of clauses that are glued together with logical operators. With it, you can express where clauses that mix logical operators together to produce more complex queries. For instance: [ { foo => 1, bar => 2 }, -or => { baz => 3 } ] The values given for the columns support all the variants documented for the C method above. Logical operators used inbetween the hashref elements can be one of: '-or', '-and', '-or_not', '-and_not'. =head2 C<$sql-Ehas_where($column, [$value])> Returns whether a where clause for the column C<$column> was added to the statement with the C method. The C<$value> argument is currently ignored. =head2 C<$sql-Eadd_having($column, $value)> Adds an expression to the C portion of the statement's C clause. The expression compares C<$column> using C<$value>, which can be any of the structures described above for the C method. =head2 C<$sql-Eadd_index_hint($table, \@hints)> Addes the index hint into a C