[Bast-commits] r5437 - in DBIx-Class/0.08/branches/rt_bug_41083: .
examples lib/DBIx lib/DBIx/Class lib/DBIx/Class/InflateColumn
lib/DBIx/Class/Manual lib/DBIx/Class/Relationship
lib/DBIx/Class/ResultSourceProxy lib/DBIx/Class/Schema
lib/DBIx/Class/Storage lib/DBIx/Class/Storage/DBI
lib/DBIx/Class/Storage/DBI/ODBC lib/DBIx/Class/Storage/DBI/Oracle
lib/DBIx/Class/Storage/DBI/Replicated
lib/DBIx/Class/Storage/DBI/Role
lib/SQL/Translator/Parser/DBIx t t/cdbi
t/cdbi/DeepAbstractSearch t/cdbi/abstract t/cdbi/sweet
t/cdbi/testlib t/lib t/lib/DBIC t/lib/DBICTest t/lib/DBICTest/Schema
jmmills at dev.catalyst.perl.org
jmmills at dev.catalyst.perl.org
Tue Feb 10 05:30:07 GMT 2009
Author: jmmills
Date: 2009-02-10 05:30:07 +0000 (Tue, 10 Feb 2009)
New Revision: 5437
Added:
DBIx-Class/0.08/branches/rt_bug_41083/Features_09
DBIx-Class/0.08/branches/rt_bug_41083/examples/
DBIx-Class/0.08/branches/rt_bug_41083/t/103many_to_many_warning.t
DBIx-Class/0.08/branches/rt_bug_41083/t/95sql_maker.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/01-columns.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/02-Film.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/03-subclassing.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/04-lazy.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/06-hasa.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/08-inheritcols.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/09-has_many.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/11-triggers.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/12-filter.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/13-constraint.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/14-might_have.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/15-accessor.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/16-reserved.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/18-has_a.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/19-set_sql.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/21-iterator.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/22-deflate_order.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/22-self_referential.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/23-cascade.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/24-meta_info.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/26-mutator.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/30-pager.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/68-inflate_has_a.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/98-failure.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/DeepAbstractSearch/
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/abstract/
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/columns_as_hashes.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/columns_dont_override_custom_accessors.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/construct.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/copy.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/early_column_heisenbug.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/has_many_loads_foreign_class.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/hasa_without_loading.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/max_min_value_of.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/mk_group_accessors.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/multi_column_set.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/object_cache.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/retrieve_from_sql_with_limit.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/set_to_undef.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/set_vs_DateTime.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/sweet/
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/
DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBIC/
DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBIC/DebugObj.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBIC/SqlMakerTest.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/BindType.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/Encoded.pm
Removed:
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-DeepAbstractSearch/
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-abstract/
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-sweet-t/
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/
DBIx-Class/0.08/branches/rt_bug_41083/t/examples/
DBIx-Class/0.08/branches/rt_bug_41083/t/testlib/
Modified:
DBIx-Class/0.08/branches/rt_bug_41083/
DBIx-Class/0.08/branches/rt_bug_41083/Changes
DBIx-Class/0.08/branches/rt_bug_41083/MANIFEST.SKIP
DBIx-Class/0.08/branches/rt_bug_41083/Makefile.PL
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Componentised.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/DB.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/InflateColumn/DateTime.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Manual/Cookbook.pod
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Manual/FAQ.pod
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Manual/Glossary.pod
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship/Accessor.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship/BelongsTo.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship/ManyToMany.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/ResultSet.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/ResultSource.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/ResultSourceProxy/Table.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Row.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Schema.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Schema/Versioned.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/MSSQL.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Oracle.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Pg.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Replicated/Replicant.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm
DBIx-Class/0.08/branches/rt_bug_41083/lib/SQL/Translator/Parser/DBIx/Class.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/101populate_rs.t
DBIx-Class/0.08/branches/rt_bug_41083/t/19quotes.t
DBIx-Class/0.08/branches/rt_bug_41083/t/19quotes_newstyle.t
DBIx-Class/0.08/branches/rt_bug_41083/t/39load_namespaces_1.t
DBIx-Class/0.08/branches/rt_bug_41083/t/41orrible.t
DBIx-Class/0.08/branches/rt_bug_41083/t/60core.t
DBIx-Class/0.08/branches/rt_bug_41083/t/66relationship.t
DBIx-Class/0.08/branches/rt_bug_41083/t/72pg.t
DBIx-Class/0.08/branches/rt_bug_41083/t/745db2.t
DBIx-Class/0.08/branches/rt_bug_41083/t/746db2_400.t
DBIx-Class/0.08/branches/rt_bug_41083/t/746mssql.t
DBIx-Class/0.08/branches/rt_bug_41083/t/76joins.t
DBIx-Class/0.08/branches/rt_bug_41083/t/76select.t
DBIx-Class/0.08/branches/rt_bug_41083/t/86sqlt.t
DBIx-Class/0.08/branches/rt_bug_41083/t/89dbicadmin.t
DBIx-Class/0.08/branches/rt_bug_41083/t/89inflate_datetime.t
DBIx-Class/0.08/branches/rt_bug_41083/t/90ensure_class_loaded.t
DBIx-Class/0.08/branches/rt_bug_41083/t/91debug.t
DBIx-Class/0.08/branches/rt_bug_41083/t/92storage_on_connect_do.t
DBIx-Class/0.08/branches/rt_bug_41083/t/93storage_replication.t
DBIx-Class/0.08/branches/rt_bug_41083/t/94versioning.t
DBIx-Class/0.08/branches/rt_bug_41083/t/95sql_maker_quote.t
DBIx-Class/0.08/branches/rt_bug_41083/t/99dbic_sqlt_parser.t
DBIx-Class/0.08/branches/rt_bug_41083/t/bindtype_columns.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/DeepAbstractSearch/01_search.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/abstract/search_where.t
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Actor.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/ActorAlias.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Binary.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Blurb.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Director.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Film.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Lazy.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Log.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/MyFilm.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/MyFoo.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/MyStar.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/MyStarLink.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/MyStarLinkMCPK.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Order.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/CD.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/EventTZ.pm
DBIx-Class/0.08/branches/rt_bug_41083/t/lib/sqlite.sql
Log:
Merged trunk in to rt_bug_t41083 branch via svk merge.
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083
___________________________________________________________________
Name: svn:ignore
- _build
blib
pm_to_blib
Build
Build.bat
Makefile
inc
README
META.yml
+ _build
blib
pm_to_blib
Build
Build.bat
Makefile
Makefile.old
inc
README
META.yml
MANIFEST
Modified: DBIx-Class/0.08/branches/rt_bug_41083/Changes
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/Changes 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/Changes 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,8 +1,24 @@
Revision history for DBIx::Class
+ - Possible to set locale in IC::DateTime extra => {} config
+
+0.08099_06 2009-01-23 07:30:00 (UTC)
- Allow a scalarref to be supplied to the 'from' resultset attribute
- Classes submitted as result_class for a resultsource are now
automatically loaded via ensure_loaded()
- 'result_class' resultset attribute, identical to result_class()
+ - add 'undef_on_null_fk' option for relationship accessors of type 'single'.
+ This will prevent DBIC from querying the database if one or more of
+ the key columns IS NULL
+ - for 'belongs_to' rels, 'undef_on_null_fk' defaults to true.
+ - fixed scope unaware last_insert_id fetching for MSSQL
+ (http://msdn.microsoft.com/en-us/library/ms190315.aspx)
+ - an sqlt_deploy_hook can now be shared between result sources using
+ a configurable callback trigger
+ - new order_by => { -desc => 'colname' } syntax supported with
+ SQLA >= 1.50
+ - PG array datatype supported with SQLA >= 1.50
+ - insert should use store_column, not set_column to avoid marking
+ clean just-stored values as dirty. New test for this (groditi)
0.08099_05 2008-10-30 21:30:00 (UTC)
- Rewritte of Storage::DBI::connect_info(), extended with an
Added: DBIx-Class/0.08/branches/rt_bug_41083/Features_09
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/Features_09 (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/Features_09 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,66 @@
+(Potential) Features for 0.09
+=============================
+
+Subselects - everyone wants these
+ - Will require new/improved SQL::Abstract
+ - The API will involve passing ResultSets to searches as conditions/values/whatever.
+
+Row/find caching - would be pretty useful
+ - Need to have good definitions of when the cache should be queried and when invalidated
+ - Be able to supply own expiry?
+ - Be able to invalidate manually? Single item / entire cache / single table
+
+Deprecate compose_connection / DB.pm
+ - Everyone has probably forgotten what this is anyway..
+
+Syntax improvements?
+ - "as" to "alias" ?
+ - "belongs_to" to "contains/refers/something"
+ - order_by to take a arrayref/hashref so it also just works with quoting
+ - ??
+
+Using inflated objects/references as values in searches
+ - Goes together with subselects above
+ - should deflate then run search
+
+FilterColumn - like Inflate, only for changing scalar values
+ - This seems to be vaporware atm..
+
+SQL/API feature complete?
+ - UNION
+ - proper join conditions!
+ - function calls on the LHS of conditions..
+
+Moosification - ouch
+
+Prefetch improvements
+ - slow on mysql, speedup?
+ - multi has_many prefetch
+ - paging working with prefetch
+
+Magically "discover" needed joins/prefetches and add them
+ - eg $books->search({ 'author.name' => 'Fred'}), autoadds: join => 'author'
+ - also guess aliases when supplying column names that are on joined/related tables
+
+Metamodel stuff - introspection
+
+Storage API/restructure
+ - call update/insert etc on the ResultSource, which then calls to storage
+ - handle different storages/db-specific code better
+ - better cross-db code .. eg LIKE/ILIKE
+
+Relationships
+ - single vs filter, discrepancies.. remove one of them and make behave the same?
+
+SQL::Abstract et al
+ - be able to extract/view/dump what the SQL is *going to* be before running it
+ - bind params sanity? (order of bind params broken when using a resultsource based on a select statement)
+ - etc
+
+Joining/searching weird attribute tables?
+ - Support legacy/badly designed junk better..
+
+Documentation - improvements
+ - better indexing for finding of stuff in general
+ - more cross-referencing of docs
+
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/Features_09
___________________________________________________________________
Name: svn:mergeinfo
+
Modified: DBIx-Class/0.08/branches/rt_bug_41083/MANIFEST.SKIP
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/MANIFEST.SKIP 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/MANIFEST.SKIP 2009-02-10 05:30:07 UTC (rev 5437)
@@ -14,6 +14,7 @@
# for developers only :)
^TODO$
+^Features_09$
# Avoid Module::Build generated and utility files.
\bBuild$
@@ -40,8 +41,9 @@
# Skip maint stuff
^maint/
-# Avoid copies to .orig
+# Avoid patch remnants
\.orig$
+\.rej$
# Dont use Module::Build anymore
^Build.PL$
Modified: DBIx-Class/0.08/branches/rt_bug_41083/Makefile.PL
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/Makefile.PL 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/Makefile.PL 2009-02-10 05:30:07 UTC (rev 5437)
@@ -10,17 +10,17 @@
requires 'Data::Page' => 2.00;
requires 'Scalar::Util' => 0;
-requires 'SQL::Abstract' => 1.20;
-requires 'SQL::Abstract::Limit' => 0.101;
-requires 'Class::C3' => 0.13;
+requires 'SQL::Abstract' => 1.24;
+requires 'SQL::Abstract::Limit' => 0.13;
+requires 'Class::C3' => 0.20;
requires 'Class::C3::Componentised' => 0;
requires 'Storable' => 0;
requires 'Carp::Clan' => 0;
requires 'DBI' => 1.40;
requires 'Module::Find' => 0;
requires 'Class::Inspector' => 0;
-requires 'Class::Accessor::Grouped' => 0.05002;
-requires 'JSON::Any' => 1.00;
+requires 'Class::Accessor::Grouped' => 0.08002;
+requires 'JSON::Any' => 1.17;
requires 'Scope::Guard' => 0.03;
requires 'Path::Class' => 0;
requires 'List::Util' => 1.19;
@@ -33,10 +33,11 @@
test_requires 'Test::Builder' => 0.33;
test_requires 'Test::Warn' => 0.11;
test_requires 'Test::Exception' => 0;
+test_requires 'Test::Deep' => 0;
install_script 'script/dbicadmin';
-tests "t/*.t t/*/*.t";
+tests_recursive 't';
# re-build README and require CDBI modules for testing if we're in a checkout
@@ -63,14 +64,44 @@
auto_install;
# Have all prerequisites, check DBD::SQLite sanity
-{
+if (! $ENV{DBICTEST_NO_SQLITE_CHECK} ) {
+
my $pid = fork();
if (not defined $pid) {
die "Unable to fork(): $!";
}
elsif (! $pid) {
+
+ # Win32 does not have real fork()s so a segfault will bring
+ # everything down. Warn about it.
+ if ($^O eq 'MSWin32') {
+ print <<'EOW';
+
+######################################################################
+# #
+# A short stress-testing of DBD::SQLite will follow. If you have a #
+# buggy library this might very well be the last text you will see #
+# before the installation silently terminates. If this happens it #
+# would mean that you are running a buggy version of DBD::SQLite #
+# known to randomly segfault on errors. Even if you have the latest #
+# CPAN module version, the system sqlite3 dynamic library might have #
+# been compiled against an older buggy sqlite3 dev library (oddly #
+# DBD::SQLite will prefer the system library against the one bundled #
+# with it). You are strongly advised to resolve this issue before #
+# proceeding. #
+# #
+# If this happens to you (this text is the last thing you see), and #
+# you just want to install this module without worrying about the #
+# tests (which will almost certainly fail) - set the environment #
+# variable DBICTEST_NO_SQLITE_CHECK to a true value and try again. #
+# #
+######################################################################
+
+EOW
+ }
+
require DBI;
- for (1 .. 10) {
+ for (1 .. 100) {
my $dbh;
$dbh = DBI->connect ('dbi:SQLite::memory:', undef, undef, {
AutoCommit => 1,
@@ -91,14 +122,16 @@
if ($sig == 11) {
warn (<<EOE);
-############################### WARNING ###################################
-# #
-# You are running a buggy version of DBD::SQLite known to randomly #
-# segfault on errors. Even if you have the latest CPAN module version, #
-# the actual sqlite3.so might have been compiled against an older buggy #
-# sqlite3 dev library. You are strongly advised to update DBD::SQLite. #
-# #
-###########################################################################
+############################### WARNING #################################
+# #
+# You are running a buggy version of DBD::SQLite known to randomly #
+# segfault on errors. Even if you have the latest CPAN module version, #
+# the sqlite3 dynamic library on this system might have been compiled #
+# against an older buggy sqlite3 dev library (oddly DBD::SQLite will #
+# prefer the system library against the one bundled with it). You are #
+# strongly advised to resolve this issue before proceeding. #
+# #
+#########################################################################
EOE
my $ans = prompt (
@@ -144,6 +177,3 @@
];
Meta->write;
}
-
-
-
Copied: DBIx-Class/0.08/branches/rt_bug_41083/examples (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/examples)
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/examples
___________________________________________________________________
Name: svn:mergeinfo
+
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Componentised.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Componentised.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Componentised.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -36,12 +36,20 @@
# successfully, and false if the class is not installed
sub load_optional_class {
my ($class, $f_class) = @_;
- if ($class->ensure_class_found($f_class)) {
- $class->ensure_class_loaded($f_class);
+ eval { $class->ensure_class_loaded($f_class) };
+ my $err = $@; # so we don't lose it
+ if (! $err) {
return 1;
- } else {
- return 0;
}
+ else {
+ my $fn = (join ('/', split ('::', $f_class) ) ) . '.pm';
+ if ($err =~ /Can't locate ${fn} in \@INC/ ) {
+ return 0;
+ }
+ else {
+ die $err;
+ }
+ }
}
1;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/DB.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/DB.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/DB.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -152,27 +152,47 @@
__PACKAGE__->mk_classdata('_result_source_instance' => []);
+# Yep. this is horrific. Basically what's happening here is that
+# (with good reason) DBIx::Class::Schema copies the result source for
+# registration. Because we have a retarded setup order forced on us we need
+# to actually make our ->result_source_instance -be- the source used, and we
+# need to get the source name and schema into ourselves. So this makes it
+# happen.
+
+sub _maybe_attach_source_to_schema {
+ my ($class, $source) = @_;
+ if (my $meth = $class->can('schema_instance')) {
+ my $schema = $class->$meth;
+ $schema->register_class($class, $class);
+ my $new_source = $schema->source($class);
+ %$source = %$new_source;
+ $schema->source_registrations->{$class} = $source;
+ }
+}
+
sub result_source_instance {
my $class = shift;
$class = ref $class || $class;
- return $class->_result_source_instance([$_[0], $class]) if @_;
+ if (@_) {
+ my $source = $_[0];
+ $class->_result_source_instance([$source, $class]);
+ $class->_maybe_attach_source_to_schema($source);
+ return $source;
+ }
my($source, $result_class) = @{$class->_result_source_instance};
return unless Scalar::Util::blessed($source);
if ($result_class ne $class) { # new class
# Give this new class it's own source and register it.
-
$source = $source->new({
%$source,
source_name => $class,
result_class => $class
} );
$class->_result_source_instance([$source, $class]);
- if (my $coderef = $class->can('schema_instance')) {
- $coderef->($class)->register_class($class, $class);
- }
+ $class->_maybe_attach_source_to_schema($source);
}
return $source;
}
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/InflateColumn/DateTime.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/InflateColumn/DateTime.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/InflateColumn/DateTime.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -24,10 +24,10 @@
print "This event starts the month of ".
$event->starts_when->month_name();
-If you want to set a specific timezone for that field, use:
+If you want to set a specific timezone and locale for that field, use:
__PACKAGE__->add_columns(
- starts_when => { data_type => 'datetime', extra => { timezone => "America/Chicago" } }
+ starts_when => { data_type => 'datetime', extra => { timezone => "America/Chicago", locale => "de_DE" } }
);
If you want to inflate no matter what data_type your column is,
@@ -107,10 +107,15 @@
}
my $timezone;
- if ( exists $info->{extra} and exists $info->{extra}{timezone} and defined $info->{extra}{timezone} ) {
+ if ( defined $info->{extra}{timezone} ) {
$timezone = $info->{extra}{timezone};
}
+ my $locale;
+ if ( defined $info->{extra}{locale} ) {
+ $locale = $info->{extra}{locale};
+ }
+
my $undef_if_invalid = $info->{datetime_undef_if_invalid};
if ($type eq 'datetime' || $type eq 'date') {
@@ -140,6 +145,7 @@
die "Error while inflating ${value} for ${column} on ${self}: $@"
if $@ and not $undef_if_invalid;
$dt->set_time_zone($timezone) if $timezone;
+ $dt->set_locale($locale) if $locale;
return $dt;
},
deflate => sub {
@@ -151,6 +157,7 @@
and not $floating_tz_ok
and not $ENV{DBIC_FLOATING_TZ_OK};
$value->set_time_zone($timezone);
+ $value->set_locale($locale) if $locale;
}
$obj->_datetime_parser->$format($value);
},
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Manual/Cookbook.pod
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Manual/Cookbook.pod 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Manual/Cookbook.pod 2009-02-10 05:30:07 UTC (rev 5437)
@@ -151,8 +151,37 @@
}
) ];
-... and you'll get back a perfect L<DBIx::Class::ResultSet>.
+... and you'll get back a perfect L<DBIx::Class::ResultSet> (except, of course,
+that you cannot modify the rows it contains, ie. cannot call L</update>,
+L</delete>, ... on it).
+If you prefer to have the definitions of these custom ResultSources in separate
+files (instead of stuffing all of them into the same resultset class), you can
+achieve the same with subclassing the resultset class and defining the
+ResultSource there:
+
+ package My::Schema::UserFriendsComplex;
+
+ use My::Schema::User;
+ use base qw/My::Schema::User/;
+
+ __PACKAGE__->table('dummy'); # currently must be called before anything else
+
+ # Hand in your query as a scalar reference
+ # It will be added as a sub-select after FROM,
+ # so pay attention to the surrounding brackets!
+ __PACKAGE__->name( \<<SQL );
+ ( SELECT u.* FROM user u
+ INNER JOIN user_friends f ON u.id = f.user_id
+ WHERE f.friend_user_id = ?
+ UNION
+ SELECT u.* FROM user u
+ INNER JOIN user_friends f ON u.id = f.friend_user_id
+ WHERE f.user_id = ? )
+ SQL
+
+TIMTOWDI.
+
=head2 Using specific columns
When you only want specific columns from a table, you can use
@@ -791,7 +820,7 @@
exactly as they come out of the data base with none of the convenience methods
wrapped round them.
-This is used like so:-
+This is used like so:
my $cursor = $rs->cursor
while (my @vals = $cursor->next) {
@@ -1138,7 +1167,9 @@
Often you will want indexes on columns on your table to speed up searching. To
do this, create a method called C<sqlt_deploy_hook> in the relevant source
-class:
+class (refer to the advanced
+L<callback system|DBIx::Class::ResultSource/sqlt_deploy_callback> if you wish
+to share a hook between multiple sources):
package My::Schema::Artist;
@@ -1172,10 +1203,12 @@
$sqlt_schema->drop_table('table_name');
}
-You could also add views or procedures to the output using
-L<SQL::Translator::Schema/add_view> or
-L<SQL::Translator::Schema/add_procedure>.
+You could also add views, procedures or triggers to the output using
+L<SQL::Translator::Schema/add_view>,
+L<SQL::Translator::Schema/add_procedure> or
+L<SQL::Translator::Schema/add_trigger>.
+
=head2 Schema versioning
The following example shows simplistically how you might use DBIx::Class to
@@ -1268,7 +1301,7 @@
generator to put the quotes the correct place.
In most cases you should set these as part of the arguments passed to
-L<DBIx::Class::Schema/conect>:
+L<DBIx::Class::Schema/connect>:
my $schema = My::Schema->connect(
'dbi:mysql:my_db',
@@ -1298,6 +1331,40 @@
The limit dialect can also be set at connect time by specifying a
C<limit_dialect> key in the final hash as shown above.
+=head2 Working with PostgreSQL array types
+
+If your SQL::Abstract version (>= 1.50) supports it, you can assign to
+PostgreSQL array values by passing array references in the C<\%columns>
+(C<\%vals>) hashref of the L<DBIx::Class::ResultSet/create> and
+L<DBIx::Class::Row/update> family of methods:
+
+ $resultset->create({
+ numbers => [1, 2, 3]
+ });
+
+ $row->update(
+ {
+ numbers => [1, 2, 3]
+ },
+ {
+ day => '2008-11-24'
+ }
+ );
+
+In conditions (eg. C<\%cond> in the L<DBIx::Class::ResultSet/search> family of
+methods) you cannot directly use array references (since this is interpreted as
+a list of values to be C<OR>ed), but you can use the following syntax to force
+passing them as bind values:
+
+ $resultset->search(
+ {
+ numbers => \[ '= ?', [1, 2, 3] ]
+ }
+ );
+
+See L<SQL::Abstract/array_datatypes> and L<SQL::Abstract/Literal SQL with
+placeholders and bind values (subqueries)> for more explanation.
+
=head1 BOOTSTRAPPING/MIGRATING
=head2 Easy migration from class-based to schema-based setup
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Manual/FAQ.pod
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Manual/FAQ.pod 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Manual/FAQ.pod 2009-02-10 05:30:07 UTC (rev 5437)
@@ -428,6 +428,41 @@
You can add your own data accessors to your classes.
+One method is to use the built in mk_group_accessors (via L<Class::Accessor::Grouped>)
+
+ package MyTable;
+
+ use parent 'DBIx::Class';
+
+ __PACKAGE__->table('foo'); #etc
+ __PACKAGE__->mk_group_accessors('simple' => qw/non_column_data/); # must use simple group
+
+An another method is to use L<Moose> with your L<DBIx::Class> package.
+
+ package MyTable;
+
+ use Moose; # import Moose
+ use Moose::Util::TypeConstraint; # import Moose accessor type constraints
+
+ extends 'DBIx::Class'; # Moose changes the way we define our parent (base) package
+
+ has 'non_column_data' => ( is => 'rw', isa => 'Str' ); # define a simple attribute
+
+ __PACKAGE__->table('foo'); # etc
+
+With either of these methods the resulting use of the accesssor would be
+
+ my $row;
+
+ # assume that some where in here $row will get assigned to a MyTable row
+
+ $row->non_column_data('some string'); # would set the non_column_data accessor
+
+ # some other stuff happens here
+
+ $row->update(); # would not inline the non_column_data accessor into the update
+
+
=item How do I use DBIx::Class objects in my TT templates?
Like normal objects, mostly. However you need to watch out for TT
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Manual/Glossary.pod
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Manual/Glossary.pod 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Manual/Glossary.pod 2009-02-10 05:30:07 UTC (rev 5437)
@@ -36,6 +36,18 @@
way it's a method of mapping the contents of database tables (rows),
to objects in programming-language-space. DBIx::Class is an ORM.
+=head2 Relationship
+
+In DBIx::Class a relationship defines the connection between exactly
+two tables. The relationship condition lists the columns in each table
+that contain the same values. It is used to output an SQL JOIN
+condition between the tables.
+
+=head2 Relationship bridge
+
+A relationship bridge, such as C<many_to_many> defines an accessor to
+retrieve row contents across multiple relationships.
+
=head2 ResultSet
This is an object representing a set of data. It can either be an
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship/Accessor.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship/Accessor.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship/Accessor.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -18,6 +18,7 @@
my ($class, $rel, $acc_type) = @_;
my %meth;
if ($acc_type eq 'single') {
+ my $rel_info = $class->relationship_info($rel);
$meth{$rel} = sub {
my $self = shift;
if (@_) {
@@ -26,6 +27,12 @@
} elsif (exists $self->{_relationship_data}{$rel}) {
return $self->{_relationship_data}{$rel};
} else {
+ my $cond = $self->result_source->resolve_condition(
+ $rel_info->{cond}, $rel, $self
+ );
+ if ($rel_info->{attrs}->{undef_on_null_fk}){
+ return if grep { not defined } values %$cond;
+ }
my $val = $self->find_related($rel, {}, {});
return unless $val;
return $self->{_relationship_data}{$rel} = $val;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship/BelongsTo.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship/BelongsTo.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship/BelongsTo.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -13,6 +13,8 @@
# assume a foreign key contraint unless defined otherwise
$attrs->{is_foreign_key_constraint} = 1
if not exists $attrs->{is_foreign_key_constraint};
+ $attrs->{undef_on_null_fk} = 1
+ if not exists $attrs->{undef_on_null_fk};
# no join condition or just a column name
if (!ref $cond) {
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship/ManyToMany.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship/ManyToMany.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship/ManyToMany.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -3,6 +3,7 @@
use strict;
use warnings;
+use warnings::register;
use Sub::Name ();
sub many_to_many {
@@ -26,10 +27,21 @@
my $rs_meth = "${meth}_rs";
for ($add_meth, $remove_meth, $set_meth, $rs_meth) {
- warn "***************************************************************************\n".
- "The many-to-many relationship $meth is trying to create a utility method called $_. This will overwrite the existing method on $class. You almost certainly want to rename your method or the many-to-many relationship, as your method will not be callable (it will use the one from the relationship instead.) YOU HAVE BEEN WARNED\n".
- "***************************************************************************\n"
- if $class->can($_);
+ if ( $class->can ($_) ) {
+ warnings::warnif(<<"EOW")
+***************************************************************************
+The many-to-many relationship $meth is trying to create a utility method called
+$_. This will overwrite the existing method on $class. You almost certainly
+want to rename your method or the many-to-many relationship, as your method
+will not be callable (it will use the one from the relationship instead.)
+
+To disable this warning add the following to $class
+
+ no warnings 'DBIx::Class::Relationship::ManyToMany';
+
+***************************************************************************
+EOW
+ }
}
$rel_attrs->{alias} ||= $f_rel;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Relationship.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -39,6 +39,9 @@
=head1 DESCRIPTION
+The word I<Relationship> has a specific meaning in DBIx::Class, see
+the definition in the L<Glossary|DBIx::Class::Manual::Glossary/Relationship>.
+
This class provides methods to set up relationships between the tables
in your database model. Relationships are the most useful and powerful
technique that L<DBIx::Class> provides. To create efficient database queries,
@@ -102,20 +105,20 @@
All helper methods are called similar to the following template:
- __PACKAGE__->$method_name('relname', 'Foreign::Class', $cond, $attrs);
+ __PACKAGE__->$method_name('relname', 'Foreign::Class', \%cond | \@cond, \%attrs);
Both C<$cond> and C<$attrs> are optional. Pass C<undef> for C<$cond> if
-you want to use the default value for it, but still want to set C<$attrs>.
+you want to use the default value for it, but still want to set C<\%attrs>.
See L<DBIx::Class::Relationship::Base> for documentation on the
-attrubutes that are allowed in the C<$attrs> argument.
+attrubutes that are allowed in the C<\%attrs> argument.
=head2 belongs_to
=over 4
-=item Arguments: $accessor_name, $related_class, $our_fk_column|\%cond|\@cond?, \%attr?
+=item Arguments: $accessor_name, $related_class, $our_fk_column|\%cond|\@cond?, \%attrs?
=back
@@ -208,6 +211,11 @@
relationship. To turn them on, pass C<< cascade_delete => 1 >>
in the $attr hashref.
+By default, DBIC will return undef and avoid querying the database if a
+C<belongs_to> accessor is called when any part of the foreign key IS NULL. To
+disable this behavior, pass C<< undef_on_null_fk => 0 >> in the C<$attr>
+hashref.
+
NOTE: If you are used to L<Class::DBI> relationships, this is the equivalent
of C<has_a>.
@@ -220,7 +228,7 @@
=over 4
-=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond?, \%attr?
+=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond?, \%attrs?
=back
@@ -353,7 +361,7 @@
=over 4
-=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond?, \%attr?
+=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond?, \%attrs?
=back
@@ -437,7 +445,7 @@
=over 4
-=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond?, \%attr?
+=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond?, \%attrs?
=back
@@ -524,10 +532,14 @@
=over 4
-=item Arguments: $accessor_name, $link_rel_name, $foreign_rel_name, \%attr?
+=item Arguments: $accessor_name, $link_rel_name, $foreign_rel_name, \%attrs?
=back
+C<many_to_many> is a I<Relationship bridge> which has a specific
+meaning in DBIx::Class, see the definition in the
+L<Glossary|DBIx::Class::Manual::Glossary/Relationship bridge>.
+
C<many_to_many> is not strictly a relationship in its own right. Instead, it is
a bridge between two resultsets which provide the same kind of convenience
accessors as true relationships provide. Although the accessor will return a
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/ResultSet.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/ResultSet.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/ResultSet.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -737,8 +737,8 @@
$cd_rs = $rs->search_like({ title => '%blue%'});
Performs a search, but uses C<LIKE> instead of C<=> as the condition. Note
-that this is simply a convenience method. You most likely want to use
-L</search> with specific operators.
+that this is simply a convenience method retained for ex Class::DBI users.
+You most likely want to use L</search> with specific operators.
For more information, see L<DBIx::Class::Manual::Cookbook>.
@@ -1362,8 +1362,9 @@
=back
-Pass an arrayref of hashrefs. Each hashref should be a structure suitable for
-submitting to a $resultset->create(...) method.
+Accepts either an arrayref of hashrefs or alternatively an arrayref of arrayrefs.
+For the arrayref of hashrefs style each hashref should be a structure suitable
+forsubmitting to a $resultset->create(...) method.
In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
to insert the data, as this is a faster method.
@@ -1403,7 +1404,18 @@
print $ArtistOne->name; ## response is 'Artist One'
print $ArtistThree->cds->count ## reponse is '2'
-
+
+For the arrayref of arrayrefs style, the first element should be a list of the
+fieldsnames to which the remaining elements are rows being inserted. For
+example:
+
+ $Arstist_rs->populate([
+ [qw/artistid name/],
+ [100, 'A Formally Unknown Singer'],
+ [101, 'A singer that jumped the shark two albums ago'],
+ [102, 'An actually cool singer.'],
+ ]);
+
Please note an important effect on your data when choosing between void and
wantarray context. Since void context goes straight to C<insert_bulk> in
L<DBIx::Class::Storage::DBI> this will skip any component that is overriding
@@ -1415,7 +1427,10 @@
=cut
sub populate {
- my ($self, $data) = @_;
+ my $self = shift @_;
+ my $data = ref $_[0][0] eq 'HASH'
+ ? $_[0] : ref $_[0][0] eq 'ARRAY' ? $self->_normalize_populate_args($_[0]) :
+ $self->throw_exception('Populate expects an arrayref of hashes or arrayref of arrayrefs');
if(defined wantarray) {
my @created;
@@ -1489,6 +1504,28 @@
}
}
+=head2 _normalize_populate_args ($args)
+
+Private method used by L</populate> to normalize its incoming arguments. Factored
+out in case you want to subclass and accept new argument structures to the
+L</populate> method.
+
+=cut
+
+sub _normalize_populate_args {
+ my ($self, $data) = @_;
+ my @names = @{shift(@$data)};
+ my @results_to_create;
+ foreach my $datum (@$data) {
+ my %result_to_create;
+ foreach my $index (0..$#names) {
+ $result_to_create{$names[$index]} = $$datum[$index];
+ }
+ push @results_to_create, \%result_to_create;
+ }
+ return \@results_to_create;
+}
+
=head2 pager
=over 4
@@ -1688,7 +1725,7 @@
$cd->cd_to_producer->find_or_new({ producer => $producer },
{ key => 'primary });
-Find an existing record from this resultset, based on it's primary
+Find an existing record from this resultset, based on its primary
key, or a unique constraint. If none exists, instantiate a new result
object and return it. The object will not be saved into your storage
until you call L<DBIx::Class::Row/insert> on it.
@@ -1734,7 +1771,7 @@
pairs representing the columns of the table and the values you wish to
store. If the appropriate relationships are set up, foreign key fields
can also be passed an object representing the foreign row, and the
-value will be set to it's primary key.
+value will be set to its primary key.
To create related objects, pass a hashref for the value if the related
item is a foreign key relationship (L<DBIx::Class::Relationship/belongs_to>),
@@ -1753,7 +1790,7 @@
$person_rs->create({
name=>"Some Person",
- email=>"somebody at someplace.com"
+ email=>"somebody at someplace.com"
});
Example of creating a new row and also creating rows in a related C<has_many>
@@ -1772,10 +1809,10 @@
$cd_rs->create({
title=>"Music for Silly Walks",
- year=>2000,
- artist => {
- name=>"Silly Musician",
- }
+ year=>2000,
+ artist => {
+ name=>"Silly Musician",
+ }
});
=cut
@@ -2057,6 +2094,49 @@
};
}
+=head2 current_source_alias
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: $source_alias
+
+=back
+
+Returns the current table alias for the result source this resultset is built
+on, that will be used in the SQL query. Usually it is C<me>.
+
+Currently the source alias that refers to the result set returned by a
+L</search>/L</find> family method depends on how you got to the resultset: it's
+C<me> by default, but eg. L</search_related> aliases it to the related result
+source name (and keeps C<me> referring to the original result set). The long
+term goal is to make L<DBIx::Class> always alias the current resultset as C<me>
+(and make this method unnecessary).
+
+Thus it's currently necessary to use this method in predefined queries (see
+L<DBIx::Class::Manual::Cookbook/Predefined searches>) when referring to the
+source alias of the current result set:
+
+ # in a result set class
+ sub modified_by {
+ my ($self, $user) = @_;
+
+ my $me = $self->current_source_alias;
+
+ return $self->search(
+ "$me.modified" => $user->id,
+ );
+ }
+
+=cut
+
+sub current_source_alias {
+ my ($self) = @_;
+
+ return ($self->{attrs} || {})->{alias} || 'me';
+}
+
sub _resolve_from {
my ($self, $extra_join) = @_;
my $source = $self->result_source;
@@ -2338,6 +2418,10 @@
specify an order. (The scalar ref causes it to be passed as raw sql to the DB,
so you will need to manually quote things as appropriate.)
+If your L<SQL::Abstract> version supports it (>=1.50), you can also use
+C<{-desc => 'year'}>, which takes care of the quoting for you. This is the
+recommended syntax.
+
=head2 columns
=over 4
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/ResultSource.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/ResultSource.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/ResultSource.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -13,7 +13,7 @@
__PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
_columns _primaries _unique_constraints name resultset_attributes
schema from _relationships column_info_from_storage source_info
- source_name/);
+ source_name sqlt_deploy_callback/);
__PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
result_class/);
@@ -33,14 +33,6 @@
=pod
-=head2 new
-
- $class->new();
-
- $class->new({attribute_name => value});
-
-Creates a new ResultSource object. Not normally called directly by end users.
-
=cut
sub new {
@@ -55,34 +47,32 @@
$new->{_relationships} = { %{$new->{_relationships}||{}} };
$new->{name} ||= "!!NAME NOT SET!!";
$new->{_columns_info_loaded} ||= 0;
+ $new->{sqlt_deploy_callback} ||= "default_sqlt_deploy_hook";
return $new;
}
=pod
-=head2 source_info
+=head2 add_columns
-Stores a hashref of per-source metadata. No specific key names
-have yet been standardized, the examples below are purely hypothetical
-and don't actually accomplish anything on their own:
+=over
- __PACKAGE__->source_info({
- "_tablespace" => 'fast_disk_array_3',
- "_engine" => 'InnoDB',
- });
+=item Arguments: @columns
-=head2 add_columns
+=item Return value: The ResultSource object
- $table->add_columns(qw/col1 col2 col3/);
+=back
- $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
+ $source->add_columns(qw/col1 col2 col3/);
+ $source->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
+
Adds columns to the result source. If supplied key => hashref pairs, uses
the hashref as the column_info for that column. Repeated calls of this
method will add more columns, not replace them.
The column names given will be created as accessor methods on your
-L<DBIx::Class::Row> objects, you can change the name of the accessor
+L<DBIx::Class::Row> objects. You can change the name of the accessor
by supplying an L</accessor> in the column_info hash.
The contents of the column_info are not set in stone. The following
@@ -146,7 +136,7 @@
=item auto_nextval
Set this to a true value for a column whose value is retrieved
-automatically from an oracle sequence. If you do not use an oracle
+automatically from an oracle sequence. If you do not use an Oracle
trigger to get the nextval, you have to set sequence as well.
=item extra
@@ -161,10 +151,19 @@
=head2 add_column
- $table->add_column('col' => \%info?);
+=over
-Convenience alias to add_columns.
+=item Arguments: $colname, [ \%columninfo ]
+=item Return value: 1/0 (true/false)
+
+=back
+
+ $source->add_column('col' => \%info?);
+
+Add a single column and optional column info. Uses the same column
+info keys as L</add_columns>.
+
=cut
sub add_columns {
@@ -188,8 +187,16 @@
=head2 has_column
- if ($obj->has_column($col)) { ... }
+=over
+=item Arguments: $colname
+
+=item Return value: 1/0 (true/false)
+
+=back
+
+ if ($source->has_column($colname)) { ... }
+
Returns true if the source has a column of this name, false otherwise.
=cut
@@ -201,11 +208,20 @@
=head2 column_info
- my $info = $obj->column_info($col);
+=over
-Returns the column metadata hashref for a column. See the description
-of add_column for information on the contents of the hashref.
+=item Arguments: $colname
+=item Return value: Hashref of info
+
+=back
+
+ my $info = $source->column_info($col);
+
+Returns the column metadata hashref for a column, as originally passed
+to L</add_columns>. See the description of L</add_columns> for information
+on the contents of the hashref.
+
=cut
sub column_info {
@@ -238,20 +254,20 @@
return $self->_columns->{$column};
}
-=head2 column_info_from_storage
+=head2 columns
-Enables the on-demand automatic loading of the above column
-metadata from storage as neccesary. This is *deprecated*, and
-should not be used. It will be removed before 1.0.
+=over
- __PACKAGE__->column_info_from_storage(1);
+=item Arguments: None
-=head2 columns
+=item Return value: Ordered list of column names
- my @column_names = $obj->columns;
+=back
-Returns all column names in the order they were declared to add_columns.
+ my @column_names = $source->columns;
+Returns all column names in the order they were declared to L</add_columns>.
+
=cut
sub columns {
@@ -264,35 +280,56 @@
=head2 remove_columns
- $table->remove_columns(qw/col1 col2 col3/);
+=over
-Removes columns from the result source.
+=item Arguments: @colnames
+=item Return value: undefined
+
+=back
+
+ $source->remove_columns(qw/col1 col2 col3/);
+
+Removes the given list of columns by name, from the result source.
+
+B<Warning>: Removing a column that is also used in the sources primary
+key, or in one of the sources unique constraints, B<will> result in a
+broken result source.
+
=head2 remove_column
- $table->remove_column('col');
+=over
-Convenience alias to remove_columns.
+=item Arguments: $colname
+=item Return value: undefined
+
+=back
+
+ $source->remove_column('col');
+
+Remove a single column by name from the result source, similar to
+L</remove_columns>.
+
+B<Warning>: Removing a column that is also used in the sources primary
+key, or in one of the sources unique constraints, B<will> result in a
+broken result source.
+
=cut
sub remove_columns {
- my ($self, @cols) = @_;
+ my ($self, @to_remove) = @_;
- return unless $self->_ordered_columns;
+ my $columns = $self->_columns
+ or return;
- my $columns = $self->_columns;
- my @remaining;
-
- foreach my $col (@{$self->_ordered_columns}) {
- push @remaining, $col unless grep(/$col/, @cols);
+ my %to_remove;
+ for (@to_remove) {
+ delete $columns->{$_};
+ ++$to_remove{$_};
}
- foreach (@cols) {
- delete $columns->{$_};
- };
-
- $self->_ordered_columns(\@remaining);
+ $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]);
}
sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
@@ -303,12 +340,15 @@
=item Arguments: @cols
+=item Return value: undefined
+
=back
Defines one or more columns as primary key for this source. Should be
-called after C<add_columns>.
+called after L</add_columns>.
-Additionally, defines a unique constraint named C<primary>.
+Additionally, defines a L<unique constraint|add_unique_constraint>
+named C<primary>.
The primary key columns are used by L<DBIx::Class::PK::Auto> to
retrieve automatically created values from the database.
@@ -329,8 +369,17 @@
=head2 primary_columns
-Read-only accessor which returns the list of primary keys.
+=over 4
+=item Arguments: None
+
+=item Return value: Ordered list of primary column names
+
+=back
+
+Read-only accessor which returns the list of primary keys, supplied by
+L</set_primary_key>.
+
=cut
sub primary_columns {
@@ -339,6 +388,14 @@
=head2 add_unique_constraint
+=over 4
+
+=item Arguments: [ $name ], \@colnames
+
+=item Return value: undefined
+
+=back
+
Declare a unique constraint on this source. Call once for each unique
constraint.
@@ -357,6 +414,9 @@
Unique constraints are used, for example, when you call
L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
+Throws an error if any of the given column names do not yet exist on
+the result source.
+
=cut
sub add_unique_constraint {
@@ -378,12 +438,29 @@
=head2 name_unique_constraint
-Return a name for a unique constraint containing the specified columns. These
-names consist of the table name and each column name, separated by underscores.
+=over 4
+=item Arguments: @colnames
+
+=item Return value: Constraint name
+
+=back
+
+ $source->table('mytable');
+ $source->name_unique_constraint('col1', 'col2');
+ # returns
+ 'mytable_col1_col2'
+
+Return a name for a unique constraint containing the specified
+columns. The name is created by joining the table name and each column
+name, using an underscore character.
+
For example, a constraint on a table named C<cd> containing the columns
C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
+This is used by L</add_unique_constraint> if you do not specify the
+optional constraint name.
+
=cut
sub name_unique_constraint {
@@ -394,8 +471,21 @@
=head2 unique_constraints
-Read-only accessor which returns the list of unique constraints on this source.
+=over 4
+=item Arguments: None
+
+=item Return value: Hash of unique constraint data
+
+=back
+
+ $source->unique_constraints();
+
+Read-only accessor which returns a hash of unique constraints on this source.
+
+The hash is keyed by constraint name, and contains an arrayref of
+column names as values.
+
=cut
sub unique_constraints {
@@ -404,6 +494,16 @@
=head2 unique_constraint_names
+=over 4
+
+=item Arguments: None
+
+=item Return value: Unique constraint names
+
+=back
+
+ $source->unique_constraint_names();
+
Returns the list of unique constraint names defined on this source.
=cut
@@ -418,6 +518,16 @@
=head2 unique_constraint_columns
+=over 4
+
+=item Arguments: $constraintname
+
+=item Return value: List of constraint columns
+
+=back
+
+ $source->unique_constraint_columns('myconstraint');
+
Returns the list of columns that make up the specified unique constraint.
=cut
@@ -434,19 +544,214 @@
return @{ $unique_constraints{$constraint_name} };
}
+=head2 sqlt_deploy_callback
+
+=over
+
+=item Arguments: $callback
+
+=back
+
+ __PACKAGE__->sqlt_deploy_callback('mycallbackmethod');
+
+An accessor to set a callback to be called during deployment of
+the schema via L<DBIx::Class::Schema/create_ddl_dir> or
+L<DBIx::Class::Schema/deploy>.
+
+The callback can be set as either a code reference or the name of a
+method in the current result class.
+
+If not set, the L</default_sqlt_deploy_hook> is called.
+
+Your callback will be passed the $source object representing the
+ResultSource instance being deployed, and the
+L<SQL::Translator::Schema::Table> object being created from it. The
+callback can be used to manipulate the table object or add your own
+customised indexes. If you need to manipulate a non-table object, use
+the L<DBIx::Class::Schema/sqlt_deploy_hook>.
+
+See L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To
+Your SQL> for examples.
+
+This sqlt deployment callback can only be used to manipulate
+SQL::Translator objects as they get turned into SQL. To execute
+post-deploy statements which SQL::Translator does not currently
+handle, override L<DBIx::Class::Schema/deploy> in your Schema class
+and call L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
+
+=head2 default_sqlt_deploy_hook
+
+=over
+
+=item Arguments: $source, $sqlt_table
+
+=item Return value: undefined
+
+=back
+
+This is the sensible default for L</sqlt_deploy_callback>.
+
+If a method named C<sqlt_deploy_hook> exists in your Result class, it
+will be called and passed the current C<$source> and the
+C<$sqlt_table> being deployed.
+
+=cut
+
+sub default_sqlt_deploy_hook {
+ my $self = shift;
+
+ my $class = $self->result_class;
+
+ if ($class and $class->can('sqlt_deploy_hook')) {
+ $class->sqlt_deploy_hook(@_);
+ }
+}
+
+sub _invoke_sqlt_deploy_hook {
+ my $self = shift;
+ if ( my $hook = $self->sqlt_deploy_callback) {
+ $self->$hook(@_);
+ }
+}
+
+=head2 resultset
+
+=over 4
+
+=item Arguments: None
+
+=item Return value: $resultset
+
+=back
+
+Returns a resultset for the given source. This will initially be created
+on demand by calling
+
+ $self->resultset_class->new($self, $self->resultset_attributes)
+
+but is cached from then on unless resultset_class changes.
+
+=head2 resultset_class
+
+=over 4
+
+=item Arguments: $classname
+
+=item Return value: $classname
+
+=back
+
+ package My::ResultSetClass;
+ use base 'DBIx::Class::ResultSet';
+ ...
+
+ $source->resultset_class('My::ResultSet::Class');
+
+Set the class of the resultset. This is useful if you want to create your
+own resultset methods. Create your own class derived from
+L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
+this method returns the name of the existing resultset class, if one
+exists.
+
+=head2 resultset_attributes
+
+=over 4
+
+=item Arguments: \%attrs
+
+=item Return value: \%attrs
+
+=back
+
+ $source->resultset_attributes({ order_by => [ 'id' ] });
+
+Store a collection of resultset attributes, that will be set on every
+L<DBIx::Class::ResultSet> produced from this result source. For a full
+list see L<DBIx::Class::ResultSet/ATTRIBUTES>.
+
+=cut
+
+sub resultset {
+ my $self = shift;
+ $self->throw_exception(
+ 'resultset does not take any arguments. If you want another resultset, '.
+ 'call it on the schema instead.'
+ ) if scalar @_;
+
+ return $self->resultset_class->new(
+ $self,
+ {
+ %{$self->{resultset_attributes}},
+ %{$self->schema->default_resultset_attributes}
+ },
+ );
+}
+
+=head2 source_name
+
+=over 4
+
+=item Arguments: $source_name
+
+=item Result value: $source_name
+
+=back
+
+Set an alternate name for the result source when it is loaded into a schema.
+This is useful if you want to refer to a result source by a name other than
+its class name.
+
+ package ArchivedBooks;
+ use base qw/DBIx::Class/;
+ __PACKAGE__->table('books_archive');
+ __PACKAGE__->source_name('Books');
+
+ # from your schema...
+ $schema->resultset('Books')->find(1);
+
=head2 from
+=over 4
+
+=item Arguments: None
+
+=item Return value: FROM clause
+
+=back
+
+ my $from_clause = $source->from();
+
Returns an expression of the source to be supplied to storage to specify
retrieval from this source. In the case of a database, the required FROM
clause contents.
=head2 schema
+=over 4
+
+=item Arguments: None
+
+=item Return value: A schema object
+
+=back
+
+ my $schema = $source->schema();
+
Returns the L<DBIx::Class::Schema> object that this result source
-belongs too.
+belongs to.
=head2 storage
+=over 4
+
+=item Arguments: None
+
+=item Return value: A Storage object
+
+=back
+
+ $source->storage->debug(1);
+
Returns the storage handle for the current schema.
See also: L<DBIx::Class::Storage>
@@ -457,8 +762,20 @@
=head2 add_relationship
+=over 4
+
+=item Arguments: $relname, $related_source_name, \%cond, [ \%attrs ]
+
+=item Return value: 1/true if it succeeded
+
+=back
+
$source->add_relationship('relname', 'related_source', $cond, $attrs);
+L<DBIx::Class::Relationship> describes a series of methods which
+create pre-defined useful types of relationships. Look there first
+before using this method directly.
+
The relationship name can be arbitrary, but must be unique for each
relationship attached to this result source. 'related_source' should
be the name with which the related result source was registered with
@@ -470,7 +787,7 @@
The condition C<$cond> needs to be an L<SQL::Abstract>-style
representation of the join between the tables. For example, if you're
-creating a rel from Author to Book,
+creating a relation from Author to Book,
{ 'foreign.author_id' => 'self.id' }
@@ -517,6 +834,9 @@
=back
+Throws an exception if the condition is improperly supplied, or cannot
+be resolved using L</resolve_join>.
+
=cut
sub add_relationship {
@@ -567,6 +887,16 @@
=head2 relationships
+=over 4
+
+=item Arguments: None
+
+=item Return value: List of relationship names
+
+=back
+
+ my @relnames = $source->relationships();
+
Returns all relationship names for this source.
=cut
@@ -581,10 +911,12 @@
=item Arguments: $relname
+=item Return value: Hashref of relation data,
+
=back
Returns a hash of relationship information for the specified relationship
-name.
+name. The keys/values are as specified for L</add_relationship>.
=cut
@@ -599,6 +931,8 @@
=item Arguments: $rel
+=item Return value: 1/0 (true/false)
+
=back
Returns true if the source has a relationship of this name, false otherwise.
@@ -616,11 +950,22 @@
=item Arguments: $relname
+=item Return value: Hashref of relationship data
+
=back
-Returns an array of hash references of relationship information for
-the other side of the specified relationship name.
+Looks through all the relationships on the source this relationship
+points to, looking for one whose condition is the reverse of the
+condition on this relationship.
+A common use of this is to find the name of the C<belongs_to> relation
+opposing a C<has_many> relation. For definition of these look in
+L<DBIx::Class::Relationship>.
+
+The returned hashref is keyed by the name of the opposing
+relationship, and contains it's data in the same manner as
+L</relationship_info>.
+
=cut
sub reverse_relationship_info {
@@ -676,8 +1021,10 @@
=over 4
-=item Arguments: $keys1, $keys2
+=item Arguments: \@keys1, \@keys2
+=item Return value: 1/0 (true/false)
+
=back
Returns true if both sets of keynames are the same, false otherwise.
@@ -723,6 +1070,8 @@
=item Arguments: $relation
+=item Return value: Join condition arrayref
+
=back
Returns the join structure required for the related result source.
@@ -774,6 +1123,8 @@
=item Arguments: $relname, $rel_data
+=item Return value: 1/0 (true/false)
+
=back
Determines whether a relation is dependent on an object from this source
@@ -1000,6 +1351,8 @@
=item Arguments: $relname
+=item Return value: $source
+
=back
Returns the result source object for the given relationship.
@@ -1020,6 +1373,8 @@
=item Arguments: $relname
+=item Return value: $classname
+
=back
Returns the class name for objects in the given relationship.
@@ -1034,75 +1389,6 @@
return $self->schema->class($self->relationship_info($rel)->{source});
}
-=head2 resultset
-
-Returns a resultset for the given source. This will initially be created
-on demand by calling
-
- $self->resultset_class->new($self, $self->resultset_attributes)
-
-but is cached from then on unless resultset_class changes.
-
-=head2 resultset_class
-
-` package My::ResultSetClass;
- use base 'DBIx::Class::ResultSet';
- ...
-
- $source->resultset_class('My::ResultSet::Class');
-
-Set the class of the resultset, this is useful if you want to create your
-own resultset methods. Create your own class derived from
-L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
-this method returns the name of the existing resultset class, if one
-exists.
-
-=head2 resultset_attributes
-
- $source->resultset_attributes({ order_by => [ 'id' ] });
-
-Specify here any attributes you wish to pass to your specialised
-resultset. For a full list of these, please see
-L<DBIx::Class::ResultSet/ATTRIBUTES>.
-
-=cut
-
-sub resultset {
- my $self = shift;
- $self->throw_exception(
- 'resultset does not take any arguments. If you want another resultset, '.
- 'call it on the schema instead.'
- ) if scalar @_;
-
- return $self->resultset_class->new(
- $self,
- {
- %{$self->{resultset_attributes}},
- %{$self->schema->default_resultset_attributes}
- },
- );
-}
-
-=head2 source_name
-
-=over 4
-
-=item Arguments: $source_name
-
-=back
-
-Set the name of the result source when it is loaded into a schema.
-This is usefull if you want to refer to a result source by a name other than
-its class name.
-
- package ArchivedBooks;
- use base qw/DBIx::Class/;
- __PACKAGE__->table('books_archive');
- __PACKAGE__->source_name('Books');
-
- # from your schema...
- $schema->resultset('Books')->find(1);
-
=head2 handle
Obtain a new handle to this source. Returns an instance of a
@@ -1132,15 +1418,42 @@
}
}
-=head2 sqlt_deploy_hook($sqlt_table)
+=head2 source_info
-An optional sub which you can declare in your own Schema class that will get
-passed the L<SQL::Translator::Schema::Table> object when you deploy the schema
-via L</create_ddl_dir> or L</deploy>.
+Stores a hashref of per-source metadata. No specific key names
+have yet been standardized, the examples below are purely hypothetical
+and don't actually accomplish anything on their own:
-For an example of what you can do with this, see
-L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
+ __PACKAGE__->source_info({
+ "_tablespace" => 'fast_disk_array_3',
+ "_engine" => 'InnoDB',
+ });
+=head2 new
+
+ $class->new();
+
+ $class->new({attribute_name => value});
+
+Creates a new ResultSource object. Not normally called directly by end users.
+
+=head2 column_info_from_storage
+
+=over
+
+=item Arguments: 1/0 (default: 0)
+
+=item Return value: 1/0
+
+=back
+
+ __PACKAGE__->column_info_from_storage(1);
+
+Enables the on-demand automatic loading of the above column
+metadata from storage as neccesary. This is *deprecated*, and
+should not be used. It will be removed before 1.0.
+
+
=head1 AUTHORS
Matt S. Trout <mst at shadowcatsystems.co.uk>
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/ResultSourceProxy/Table.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/ResultSourceProxy/Table.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/ResultSourceProxy/Table.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -40,11 +40,6 @@
$class->result_source_instance($table);
- if ($class->can('schema_instance') && $class->schema_instance) {
- $class =~ m/([^:]+)$/;
- $class->schema_instance->register_class($class, $class);
- }
-
return $table;
}
@@ -95,10 +90,6 @@
$class->result_source_instance($table);
- if ($class->can('schema_instance')) {
- $class =~ m/([^:]+)$/;
- $class->schema_instance->register_class($class, $class);
- }
return $class->result_source_instance->name;
}
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Row.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Row.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Row.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -263,7 +263,9 @@
}
my $updated_cols = $source->storage->insert($source, { $self->get_columns });
- $self->set_columns($updated_cols);
+ foreach my $col (keys %$updated_cols) {
+ $self->store_column($col, $updated_cols->{$col});
+ }
## PK::Auto
my @auto_pri = grep {
@@ -450,6 +452,14 @@
database-level cascade or restrict will take precedence over a
DBIx-Class-based cascading delete.
+If you delete an object within a txn_do() (see L<DBIx::Class::Storage/txn_do>)
+and the transaction subsequently fails, the row object will remain marked as
+not being in storage. If you know for a fact that the object is still in
+storage (i.e. by inspecting the cause of the transaction's failure), you can
+use C<< $obj->in_storage(1) >> to restore consistency between the object and
+the database. This would allow a subsequent C<< $obj->delete >> to work
+as expected.
+
See also L<DBIx::Class::ResultSet/delete>.
=cut
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Schema/Versioned.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Schema/Versioned.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Schema/Versioned.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -519,9 +519,9 @@
return;
}
- eval 'require SQL::Translator "0.09"';
+ eval 'require SQL::Translator "0.09003"';
if ($@) {
- $self->throw_exception("SQL::Translator 0.09 required");
+ $self->throw_exception("SQL::Translator 0.09003 required");
}
my $db_tr = SQL::Translator->new({
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Schema.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Schema.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Schema.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -89,7 +89,7 @@
matching is done by assuming the package name of the ResultSet class
is the same as that of the Result class.
-You will be warned if ResulSet classes are discovered for which there
+You will be warned if ResultSet classes are discovered for which there
are no matching Result classes like this:
load_namespaces found ResultSet class $classname with no corresponding Result class
@@ -214,7 +214,6 @@
foreach my $result (@subclass_last) {
my $result_class = $results{$result};
- $result_class->source_name($result) unless $result_class->source_name;
my $rs_class = delete $resultsets{$result};
my $rs_set = $result_class->resultset_class;
@@ -230,7 +229,9 @@
$result_class->resultset_class($rs_class);
}
- push(@to_register, [ $result_class->source_name, $result_class ]);
+ my $source_name = $result_class->source_name || $result;
+
+ push(@to_register, [ $source_name, $result_class ]);
}
}
@@ -443,6 +444,13 @@
For an example of what you can do with this, see
L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
+Note that sqlt_deploy_hook is called by L</deployment_statements>, which in turn
+is called before L</deploy>. Therefore the hook can be used only to manipulate
+the L<SQL::Translator::Schema> object before it is turned into SQL fed to the
+database. If you want to execute post-deploy statements which can not be generated
+by L<SQL::Translator>, the currently suggested method is to overload L</deploy>
+and use L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
+
=head1 METHODS
=head2 connect
@@ -576,6 +584,14 @@
This interface is preferred over using the individual methods L</txn_begin>,
L</txn_commit>, and L</txn_rollback> below.
+WARNING: If you are connected with C<AutoCommit => 0> the transaction is
+considered nested, and you will still need to call L</txn_commit> to write your
+changes when appropriate. You will also want to connect with C<auto_savepoint =>
+1> to get partial rollback to work, if the storage driver for your database
+supports it.
+
+Connecting with C<AutoCommit => 1> is recommended.
+
=cut
sub txn_do {
@@ -711,26 +727,15 @@
sub populate {
my ($self, $name, $data) = @_;
- my $rs = $self->resultset($name);
- my @names = @{shift(@$data)};
- if(defined wantarray) {
- my @created;
- foreach my $item (@$data) {
- my %create;
- @create{@names} = @$item;
- push(@created, $rs->create(\%create));
+ if(my $rs = $self->resultset($name)) {
+ if(defined wantarray) {
+ return $rs->populate($data);
+ } else {
+ $rs->populate($data);
}
- return @created;
+ } else {
+ $self->throw_exception("$name is not a resultset");
}
- my @results_to_create;
- foreach my $datum (@$data) {
- my %result_to_create;
- foreach my $index (0..$#names) {
- $result_to_create{$names[$index]} = $$datum[$index];
- }
- push @results_to_create, \%result_to_create;
- }
- $rs->populate(\@results_to_create);
}
=head2 connection
@@ -1243,7 +1248,7 @@
sub _register_source {
my ($self, $moniker, $source, $params) = @_;
- %$source = %{ $source->new( { %$source, source_name => $moniker }) };
+ $source = $source->new({ %$source, source_name => $moniker });
my %reg = %{$self->source_registrations};
$reg{$moniker} = $source;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/MSSQL.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/MSSQL.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/MSSQL.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -7,7 +7,7 @@
sub _dbh_last_insert_id {
my ($self, $dbh, $source, $col) = @_;
- my ($id) = $dbh->selectrow_array('SELECT @@IDENTITY');
+ my ($id) = $dbh->selectrow_array('SELECT SCOPE_IDENTITY()');
return $id;
}
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -54,7 +54,7 @@
=head1 NAME
-DBIx::Class::Storage::ODBC::ACCESS - Support specific to MS Access over ODBC
+DBIx::Class::Storage::DBI::ODBC::ACCESS - Support specific to MS Access over ODBC
=head1 WARNING
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -6,7 +6,7 @@
=head1 NAME
-DBIx::Class::Storage::DBI::Oracle - Automatic primary key class for Oracle
+DBIx::Class::Storage::DBI::Oracle::Generic - Automatic primary key class for Oracle
=head1 SYNOPSIS
@@ -103,6 +103,22 @@
sub datetime_parser_type { return "DateTime::Format::Oracle"; }
+sub _svp_begin {
+ my ($self, $name) = @_;
+
+ $self->dbh->do("SAVEPOINT $name");
+}
+
+# Oracle automatically releases a savepoint when you start another one with the
+# same name.
+sub _svp_release { 1 }
+
+sub _svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->dbh->do("ROLLBACK TO SAVEPOINT $name")
+}
+
=head1 AUTHORS
Andy Grundman <andy at hybridized.org>
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Oracle.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Oracle.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Oracle.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -25,20 +25,6 @@
}
}
-sub _svp_begin {
- my ($self, $name) = @_;
-
- $self->dbh->do("SAVEPOINT $name");
-}
-
-# Would've implemented _svp_release here, but Oracle doesn't support it.
-
-sub _svp_rollback {
- my ($self, $name) = @_;
-
- $self->dbh->do("ROLLBACK TO SAVEPOINT $name")
-}
-
1;
=head1 NAME
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Pg.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Pg.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Pg.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -70,6 +70,7 @@
my $bind_attributes = {
bytea => { pg_type => DBD::Pg::PG_BYTEA },
+ blob => { pg_type => DBD::Pg::PG_BYTEA },
};
if( defined $bind_attributes->{$data_type} ) {
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -126,19 +126,20 @@
around 'next_storage' => sub {
my ($next_storage, $self, @args) = @_;
my $now = time;
-
+
## Do we need to validate the replicants?
if(
$self->has_auto_validate_every &&
($self->auto_validate_every + $self->pool->last_validated) <= $now
- ) {
+ ) {
$self->pool->validate_replicants;
}
-
+
## Get a replicant, or the master if none
if(my $next = $self->$next_storage(@args)) {
return $next;
} else {
+ $self->master->debugobj->print("No Replicants validate, falling back to master reads. ");
return $self->master;
}
};
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -168,14 +168,38 @@
sub connect_replicant {
my ($self, $schema, $connect_info) = @_;
my $replicant = $self->create_replicant($schema);
-
- $replicant->connect_info($connect_info);
- $replicant->ensure_connected;
- DBIx::Class::Storage::DBI::Replicated::Replicant->meta->apply($replicant);
-
+ $replicant->connect_info($connect_info);
+ $self->_safely_ensure_connected($replicant);
+ DBIx::Class::Storage::DBI::Replicated::Replicant->meta->apply($replicant);
return $replicant;
}
+=head2 _safely_ensure_connected ($replicant)
+
+The standard ensure_connected method with throw an exception should it fail to
+connect. For the master database this is desirable, but since replicants are
+allowed to fail, this behavior is not desirable. This method wraps the call
+to ensure_connected in an eval in order to catch any generated errors. That
+way a slave to go completely offline (ie, the box itself can die) without
+bringing down your entire pool of databases.
+
+=cut
+
+sub _safely_ensure_connected {
+ my ($self, $replicant, @args) = @_;
+ my $return; eval {
+ $return = $replicant->ensure_connected(@args);
+ }; if ($@) {
+ $replicant
+ ->debugobj
+ ->print(
+ sprintf( "Exception trying to ->ensure_connected for replicant %s, error is %s",
+ $self->_dbi_connect_info->[0], $@)
+ );
+ }
+ return $return;
+}
+
=head2 connected_replicants
Returns true if there are connected replicants. Actually is overloaded to
@@ -242,23 +266,43 @@
Calling this method will generate queries on the replicant databases so it is
not recommended that you run them very often.
+This method requires that your underlying storage engine supports some sort of
+native replication mechanism. Currently only MySQL native replication is
+supported. Your patches to make other replication types work are welcomed.
+
=cut
sub validate_replicants {
my $self = shift @_;
foreach my $replicant($self->all_replicants) {
- if(
- $replicant->is_replicating &&
- $replicant->lag_behind_master <= $self->maximum_lag &&
- $replicant->ensure_connected
- ) {
- $replicant->active(1)
+ if($self->_safely_ensure_connected($replicant)) {
+ my $is_replicating = $replicant->is_replicating;
+ unless(defined $is_replicating) {
+ $replicant->debugobj->print("Storage Driver ".ref $self." Does not support the 'is_replicating' method. Assuming you are manually managing.");
+ next;
+ } else {
+ if($is_replicating) {
+ my $lag_behind_master = $replicant->lag_behind_master;
+ unless(defined $lag_behind_master) {
+ $replicant->debugobj->print("Storage Driver ".ref $self." Does not support the 'lag_behind_master' method. Assuming you are manually managing.");
+ next;
+ } else {
+ if($lag_behind_master <= $self->maximum_lag) {
+ $replicant->active(1);
+ } else {
+ $replicant->active(0);
+ }
+ }
+ } else {
+ $replicant->active(0);
+ }
+ }
} else {
$replicant->active(0);
}
}
## Mark that we completed this validation.
- $self->_last_validated(time);
+ $self->_last_validated(time);
}
=head1 AUTHOR
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Replicated/Replicant.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Replicated/Replicant.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Replicated/Replicant.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -52,7 +52,7 @@
This class defines the following methods.
-=head2 after: _query_start
+=head2 around: _query_start
advice iof the _query_start method to add more debuggin
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -5,7 +5,7 @@
=head1 NAME
-DBIx::Class::Storage::DBI::Role::QueryCounter; Role to add a query counter
+DBIx::Class::Storage::DBI::Role::QueryCounter - Role to add a query counter
=head1 SYNOPSIS
@@ -78,4 +78,4 @@
=cut
-1;
\ No newline at end of file
+1;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class/Storage/DBI.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -50,6 +50,9 @@
$self;
}
+# DB2 is the only remaining DB using this. Even though we are not sure if
+# RowNumberOver is still needed here (should be part of SQLA) leave the
+# code in place
sub _RowNumberOver {
my ($self, $sql, $order, $rows, $offset ) = @_;
@@ -57,7 +60,7 @@
my $last = $rows + $offset;
my ( $order_by ) = $self->_order_by( $order );
- $sql = <<"";
+ $sql = <<"SQL";
SELECT * FROM
(
SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
@@ -67,6 +70,8 @@
) Q2
WHERE ROW_NUM BETWEEN $offset AND $last
+SQL
+
return $sql;
}
@@ -76,11 +81,15 @@
use Scalar::Util 'blessed';
sub _find_syntax {
my ($self, $syntax) = @_;
- my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
+
+ # DB2 is the only remaining DB using this. Even though we are not sure if
+ # RowNumberOver is still needed here (should be part of SQLA) leave the
+ # code in place
+ my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
if(ref($self) && $dbhname && $dbhname eq 'DB2') {
return 'RowNumberOver';
}
-
+
$self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
}
@@ -182,6 +191,9 @@
if (defined $_[0]->{order_by}) {
$ret .= $self->_order_by($_[0]->{order_by});
}
+ if (grep { $_ =~ /^-(desc|asc)/i } keys %{$_[0]}) {
+ return $self->SUPER::_order_by($_[0]);
+ }
} elsif (ref $_[0] eq 'SCALAR') {
$ret = $self->_sqlcase(' order by ').${ $_[0] };
} elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
@@ -880,7 +892,7 @@
sub _sql_maker_args {
my ($self) = @_;
- return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
+ return ( bindtype=>'columns', array_datatypes => 1, limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
}
sub sql_maker {
@@ -911,11 +923,11 @@
}
}
+ $self->_conn_pid($$);
+ $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
+
my $connection_do = $self->on_connect_do;
$self->_do_connection_actions($connection_do) if ref($connection_do);
-
- $self->_conn_pid($$);
- $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
}
sub _do_connection_actions {
@@ -926,7 +938,7 @@
$self->_do_query($_) foreach @$connection_do;
}
elsif (ref $connection_do eq 'CODE') {
- $connection_do->();
+ $connection_do->($self);
}
return $self;
@@ -1221,7 +1233,8 @@
}
foreach my $data (@data) {
- $data = ref $data ? ''.$data : $data; # stringify args
+ my $ref = ref $data;
+ $data = $ref && $ref ne 'ARRAY' ? ''.$data : $data; # stringify args (except arrayrefs)
$sth->bind_param($placeholder_index, $data, $attributes);
$placeholder_index++;
@@ -1595,7 +1608,7 @@
%{$sqltargs || {}}
};
- $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.09: '}
+ $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.09003: '}
. $self->_check_sqlt_message . q{'})
if !$self->_check_sqlt_version;
@@ -1742,7 +1755,7 @@
return join('', @rows);
}
- $self->throw_exception(q{Can't deploy without SQL::Translator 0.09: '}
+ $self->throw_exception(q{Can't deploy without SQL::Translator 0.09003: '}
. $self->_check_sqlt_message . q{'})
if !$self->_check_sqlt_version;
@@ -1824,7 +1837,7 @@
my $_check_sqlt_message; # private
sub _check_sqlt_version {
return $_check_sqlt_version if defined $_check_sqlt_version;
- eval 'use SQL::Translator "0.09"';
+ eval 'use SQL::Translator "0.09003"';
$_check_sqlt_message = $@ || '';
$_check_sqlt_version = !$@;
}
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/DBIx/Class.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -24,7 +24,7 @@
# i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
# brain damage and presumably various other packaging systems too
-$VERSION = '0.08099_05';
+$VERSION = '0.08099_06';
$VERSION = eval $VERSION; # numify for warning-free dev releases
@@ -217,6 +217,8 @@
bricas: Brian Cassidy <bricas at cpan.org>
+caelum: Rafael Kitover <rkitover at cpan.org>
+
captainL: Luke Saunders <luke.saunders at gmail.com>
castaway: Jess Robinson
@@ -285,8 +287,10 @@
rdj: Ryan D Johnson <ryan at innerfence.com>
-ribasushi: Peter Rabbitson <rabbit at rabbit.us>
+ribasushi: Peter Rabbitson <rabbit+dbic at rabbit.us>
+rjbs: Ricardo Signes <rjbs at cpan.org>
+
sc_: Just Another Perl Hacker
scotty: Scotty Allen <scotty at scottyallen.com>
@@ -311,6 +315,8 @@
zamolxes: Bogdan Lucaciu <bogdan at wiz.ro>
+norbi: Norbert Buchmuller <norbi at nix.hu>
+
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
Modified: DBIx-Class/0.08/branches/rt_bug_41083/lib/SQL/Translator/Parser/DBIx/Class.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/lib/SQL/Translator/Parser/DBIx/Class.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/lib/SQL/Translator/Parser/DBIx/Class.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -214,9 +214,7 @@
}
}
- if ($source->result_class->can('sqlt_deploy_hook')) {
- $source->result_class->sqlt_deploy_hook($table);
- }
+ $source->_invoke_sqlt_deploy_hook($table);
}
if ($dbicschema->can('sqlt_deploy_hook')) {
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/101populate_rs.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/101populate_rs.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/101populate_rs.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -15,7 +15,7 @@
use lib qw(t/lib);
use DBICTest;
-plan tests => 134;
+plan tests => 142;
## ----------------------------------------------------------------------------
@@ -601,4 +601,30 @@
ok( $cd2->title eq "VOID_Yet More Tweeny-Pop crap", "Got Expected CD Title");
}
+}
+
+ARRAYREF_OF_ARRAYREF_STYLE: {
+ $art_rs->populate([
+ [qw/artistid name/],
+ [1000, 'A Formally Unknown Singer'],
+ [1001, 'A singer that jumped the shark two albums ago'],
+ [1002, 'An actually cool singer.'],
+ ]);
+
+ ok my $unknown = $art_rs->find(1000), "got Unknown";
+ ok my $jumped = $art_rs->find(1001), "got Jumped";
+ ok my $cool = $art_rs->find(1002), "got Cool";
+
+ is $unknown->name, 'A Formally Unknown Singer', 'Correct Name';
+ is $jumped->name, 'A singer that jumped the shark two albums ago', 'Correct Name';
+ is $cool->name, 'An actually cool singer.', 'Correct Name';
+
+ my ($cooler, $lamer) = $art_rs->populate([
+ [qw/artistid name/],
+ [1003, 'Cooler'],
+ [1004, 'Lamer'],
+ ]);
+
+ is $cooler->name, 'Cooler', 'Correct Name';
+ is $lamer->name, 'Lamer', 'Correct Name';
}
\ No newline at end of file
Added: DBIx-Class/0.08/branches/rt_bug_41083/t/103many_to_many_warning.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/103many_to_many_warning.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/103many_to_many_warning.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,108 @@
+use strict;
+use warnings;
+use Test::More;
+
+use lib qw(t/lib);
+use Data::Dumper;
+
+plan ( ($] >= 5.009000 and $] < 5.010001)
+ ? (skip_all => 'warnings::register broken under 5.10: http://rt.perl.org/rt3/Public/Bug/Display.html?id=62522')
+ : (tests => 4)
+);
+
+{
+ my @w;
+ local $SIG{__WARN__} = sub { push @w, @_ };
+ my $code = gen_code ( suffix => 1 );
+ eval "$code";
+ ok (! $@, 'Eval code without warnings suppression')
+ || diag $@;
+
+ ok ( (grep { $_ =~ /The many-to-many relationship bars is trying to create/ } @w), "Warning triggered without relevant 'no warnings'");
+}
+
+{
+ my @w;
+ local $SIG{__WARN__} = sub { push @w, @_ };
+
+ my $code = gen_code ( suffix => 2, no_warn => 1 );
+ eval "$code";
+ ok (! $@, 'Eval code with warnings suppression')
+ || diag $@;
+
+ ok ( (not grep { $_ =~ /The many-to-many relationship bars is trying to create/ } @w), "No warning triggered with relevant 'no warnings'");
+}
+
+sub gen_code {
+
+ my $args = { @_ };
+ my $suffix = $args->{suffix};
+ my $no_warn = ( $args->{no_warn}
+ ? "no warnings 'DBIx::Class::Relationship::ManyToMany';"
+ : '',
+ );
+
+ return <<EOF;
+use strict;
+use warnings;
+
+{
+ package #
+ DBICTest::Schema::Foo${suffix};
+ use base 'DBIx::Class::Core';
+
+ __PACKAGE__->table('foo');
+ __PACKAGE__->add_columns(
+ 'fooid' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ );
+ __PACKAGE__->set_primary_key('fooid');
+
+
+ __PACKAGE__->has_many('foo_to_bar' => 'DBICTest::Schema::FooToBar${suffix}' => 'bar');
+ __PACKAGE__->many_to_many( foos => foo_to_bar => 'bar' );
+}
+{
+ package #
+ DBICTest::Schema::FooToBar${suffix};
+
+ use base 'DBIx::Class::Core';
+ __PACKAGE__->table('foo_to_bar');
+ __PACKAGE__->add_columns(
+ 'foo' => {
+ data_type => 'integer',
+ },
+ 'bar' => {
+ data_type => 'integer',
+ },
+ );
+ __PACKAGE__->belongs_to('foo' => 'DBICTest::Schema::Foo${suffix}');
+ __PACKAGE__->belongs_to('bar' => 'DBICTest::Schema::Foo${suffix}');
+}
+{
+ package #
+ DBICTest::Schema::Bar${suffix};
+
+ use base 'DBIx::Class::Core';
+
+ __PACKAGE__->table('bar');
+ __PACKAGE__->add_columns(
+ 'barid' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ );
+
+ ${no_warn}
+ __PACKAGE__->set_primary_key('barid');
+ __PACKAGE__->has_many('foo_to_bar' => 'DBICTest::Schema::FooToBar${suffix}' => 'foo');
+
+ __PACKAGE__->many_to_many( bars => foo_to_bar => 'foo' );
+
+ sub add_to_bars {}
+}
+EOF
+
+}
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/19quotes.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/19quotes.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/19quotes.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -4,29 +4,28 @@
use Test::More;
use IO::File;
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+
BEGIN {
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 6 );
+ : ( tests => 7 );
}
-use lib qw(t/lib);
use_ok('DBICTest');
+use_ok('DBIC::DebugObj');
my $schema = DBICTest->init_schema();
-my $orig_debugcb = $schema->storage->debugcb;
-my $orig_debug = $schema->storage->debug;
-
diag('Testing against ' . join(' ', map { $schema->storage->dbh->get_info($_) } qw/17 18/));
$schema->storage->sql_maker->quote_char('`');
$schema->storage->sql_maker->name_sep('.');
-my $sql = '';
-
-$schema->storage->debugcb(sub { $sql = $_[1] });
+my ($sql, @bind) = ('');
+$schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind));
$schema->storage->debug(1);
my $rs;
@@ -35,7 +34,11 @@
{ 'me.year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
{ join => 'artist' });
eval { $rs->count };
-like($sql, qr/\QSELECT COUNT( * ) FROM `cd` `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )\E/, 'got correct SQL for count query with quoting');
+is_same_sql_bind(
+ $sql, \@bind,
+ "SELECT COUNT( * ) FROM `cd` `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )", ["'Caterwauler McCrae'", "'2001'"],
+ 'got correct SQL for count query with quoting'
+);
my $order = 'year DESC';
$rs = $schema->resultset('CD')->search({},
@@ -55,7 +58,11 @@
{ 'me.year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
{ join => 'artist' });
eval { $rs->count };
-like($sql, qr/\QSELECT COUNT( * ) FROM [cd] [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )\E/, 'got correct SQL for count query with bracket quoting');
+is_same_sql_bind(
+ $sql, \@bind,
+ "SELECT COUNT( * ) FROM [cd] [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )", ["'Caterwauler McCrae'", "'2001'"],
+ 'got correct SQL for count query with bracket quoting'
+);
my %data = (
name => 'Bill',
@@ -66,6 +73,3 @@
$schema->storage->sql_maker->name_sep('.');
is($schema->storage->sql_maker->update('group', \%data), 'UPDATE `group` SET `name` = ?, `order` = ?', 'quoted table names for UPDATE');
-
-$schema->storage->debugcb($orig_debugcb);
-$schema->storage->debug($orig_debug);
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/19quotes_newstyle.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/19quotes_newstyle.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/19quotes_newstyle.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -4,21 +4,21 @@
use Test::More;
use IO::File;
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+
BEGIN {
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 6 );
+ : ( tests => 7 );
}
-use lib qw(t/lib);
+use_ok('DBICTest');
+use_ok('DBIC::DebugObj');
-use_ok('DBICTest');
my $schema = DBICTest->init_schema();
-my $orig_debugcb = $schema->storage->debugcb;
-my $orig_debug = $schema->storage->debug;
-
diag('Testing against ' . join(' ', map { $schema->storage->dbh->get_info($_) } qw/17 18/));
my $dsn = $schema->storage->_dbi_connect_info->[0];
@@ -30,8 +30,8 @@
{ quote_char => '`', name_sep => '.' },
);
-my $sql = '';
-$schema->storage->debugcb(sub { $sql = $_[1] });
+my ($sql, @bind) = ('');
+$schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind)),
$schema->storage->debug(1);
my $rs;
@@ -40,7 +40,11 @@
{ 'me.year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
{ join => 'artist' });
eval { $rs->count };
-like($sql, qr/\QSELECT COUNT( * ) FROM `cd` `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )\E/, 'got correct SQL for count query with quoting');
+is_same_sql_bind(
+ $sql, \@bind,
+ "SELECT COUNT( * ) FROM `cd` `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )", ["'Caterwauler McCrae'", "'2001'"],
+ 'got correct SQL for count query with quoting'
+);
my $order = 'year DESC';
$rs = $schema->resultset('CD')->search({},
@@ -59,14 +63,19 @@
undef,
{ AutoCommit => 1, quote_char => [qw/[ ]/], name_sep => '.' }
);
-$schema->storage->debugcb(sub { $sql = $_[1] });
+
+$schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind)),
$schema->storage->debug(1);
$rs = $schema->resultset('CD')->search(
{ 'me.year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
{ join => 'artist' });
eval { $rs->count };
-like($sql, qr/\QSELECT COUNT( * ) FROM [cd] [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )\E/, 'got correct SQL for count query with bracket quoting');
+is_same_sql_bind(
+ $sql, \@bind,
+ "SELECT COUNT( * ) FROM [cd] [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )", ["'Caterwauler McCrae'", "'2001'"],
+ 'got correct SQL for count query with bracket quoting'
+);
my %data = (
name => 'Bill',
@@ -81,6 +90,3 @@
);
is($schema->storage->sql_maker->update('group', \%data), 'UPDATE `group` SET `name` = ?, `order` = ?', 'quoted table names for UPDATE');
-
-$schema->storage->debugcb($orig_debugcb);
-$schema->storage->debug($orig_debug);
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/39load_namespaces_1.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/39load_namespaces_1.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/39load_namespaces_1.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -6,7 +6,7 @@
unshift(@INC, './t/lib');
-plan tests => 6;
+plan tests => 8;
my $warnings;
eval {
@@ -27,3 +27,8 @@
isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
my $rset_b = DBICNSTest->resultset('B');
isa_ok($rset_b, 'DBIx::Class::ResultSet');
+
+for my $moniker (qw/A B/) {
+ my $class = "DBICNSTest::Result::$moniker";
+ ok(!defined($class->result_source_instance->source_name));
+}
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/41orrible.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/41orrible.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/41orrible.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -2,9 +2,11 @@
use warnings;
use Test::More;
-#use DBIx::Class::Storage::DBI;
use DBIx::Class::Storage::DBI::Oracle::WhereJoins;
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+
plan tests => 4;
my $sa = new DBIC::SQL::Abstract::Oracle;
@@ -29,7 +31,8 @@
# search with undefined or empty $cond
# my ($self, $table, $fields, $where, $order, @rest) = @_;
-is($sa->select([
+my ($sql, @bind) = $sa->select(
+ [
{ me => "cd" },
[
{ "-join_type" => "LEFT", artist => "artist" },
@@ -38,10 +41,16 @@
],
[ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
undef,
- undef),
- 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( artist.artistid(+) = me.artist )', 'WhereJoins search with empty where clause');
+ undef
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( artist.artistid(+) = me.artist )', [],
+ 'WhereJoins search with empty where clause'
+);
-is($sa->select([
+($sql, @bind) = $sa->select(
+ [
{ me => "cd" },
[
{ "-join_type" => "", artist => "artist" },
@@ -50,10 +59,16 @@
],
[ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
{ 'artist.artistid' => 3 },
- undef),
- 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid = me.artist ) AND ( artist.artistid = ? ) ) )', 'WhereJoins search with where clause');
+ undef
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid = me.artist ) AND ( artist.artistid = ? ) ) )', [3],
+ 'WhereJoins search with where clause'
+);
-is($sa->select([
+($sql, @bind) = $sa->select(
+ [
{ me => "cd" },
[
{ "-join_type" => "LEFT", artist => "artist" },
@@ -62,7 +77,12 @@
],
[ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
[{ 'artist.artistid' => 3 }, { 'me.cdid' => 5 }],
- undef),
- 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid(+) = me.artist ) AND ( ( ( artist.artistid = ? ) OR ( me.cdid = ? ) ) ) ) )', 'WhereJoins search with or in where clause');
+ undef
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid(+) = me.artist ) AND ( ( ( artist.artistid = ? ) OR ( me.cdid = ? ) ) ) ) )', [3, 5],
+ 'WhereJoins search with or in where clause'
+);
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/60core.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/60core.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/60core.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -7,7 +7,7 @@
my $schema = DBICTest->init_schema();
-plan tests => 84;
+plan tests => 88;
eval { require DateTime::Format::MySQL };
my $NO_DTFM = $@ ? 1 : 0;
@@ -335,10 +335,29 @@
# test remove_columns
{
- is_deeply([$schema->source('CD')->columns], [qw/cdid artist title year genreid single_track/]);
- $schema->source('CD')->remove_columns('year');
- is_deeply([$schema->source('CD')->columns], [qw/cdid artist title genreid single_track/]);
- ok(! exists $schema->source('CD')->_columns->{'year'}, 'year still exists in _columns');
+ is_deeply(
+ [$schema->source('CD')->columns],
+ [qw/cdid artist title year genreid single_track/],
+ 'initial columns',
+ );
+
+ $schema->source('CD')->remove_columns('coolyear'); #should not delete year
+ is_deeply(
+ [$schema->source('CD')->columns],
+ [qw/cdid artist title year genreid single_track/],
+ 'nothing removed when removing a non-existent column',
+ );
+
+ $schema->source('CD')->remove_columns('genreid', 'year');
+ is_deeply(
+ [$schema->source('CD')->columns],
+ [qw/cdid artist title single_track/],
+ 'removed two columns',
+ );
+
+ my $priv_columns = $schema->source('CD')->_columns;
+ ok(! exists $priv_columns->{'year'}, 'year purged from _columns');
+ ok(! exists $priv_columns->{'genreid'}, 'genreid purged from _columns');
}
# test get_inflated_columns with objects
@@ -360,3 +379,11 @@
my $table = $class->table($class->table);
is($table, $class->table, '->table($table) returns $table');
}
+
+#make sure insert doesn't use set_column
+{
+ my $en_row = $schema->resultset('Encoded')->new_result({encoded => 'wilma'});
+ is($en_row->encoded, 'amliw', 'new encodes');
+ $en_row->insert;
+ is($en_row->encoded, 'amliw', 'insert does not encode again');
+}
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/66relationship.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/66relationship.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/66relationship.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -8,7 +8,7 @@
my $schema = DBICTest->init_schema();
-plan tests => 72;
+plan tests => 74;
# has_a test
my $cd = $schema->resultset("CD")->find(4);
@@ -41,8 +41,21 @@
} );
}
-is( ($artist->search_related('cds'))[3]->title, 'Big Flop', 'create_related ok' );
+my $big_flop_cd = ($artist->search_related('cds'))[3];
+is( $big_flop_cd->title, 'Big Flop', 'create_related ok' );
+{ # make sure we are not making pointless select queries when a FK IS NULL
+ my $queries = 0;
+ $schema->storage->debugcb(sub { $queries++; });
+ $schema->storage->debug(1);
+ $big_flop_cd->genre; #should not trigger a select query
+ is($queries, 0, 'No SELECT made for belongs_to if key IS NULL');
+ $big_flop_cd->genre_inefficient; #should trigger a select query
+ is($queries, 1, 'SELECT made for belongs_to if key IS NULL when undef_on_null_fk disabled');
+ $schema->storage->debug(0);
+ $schema->storage->debugcb(undef);
+}
+
my( $rs_from_list ) = $artist->search_related_rs('cds');
is( ref($rs_from_list), 'DBIx::Class::ResultSet', 'search_related_rs in list context returns rs' );
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/72pg.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/72pg.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/72pg.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -2,6 +2,7 @@
use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
@@ -13,23 +14,40 @@
use base 'DBIx::Class';
__PACKAGE__->load_components(qw/Core/);
- __PACKAGE__->table('casecheck');
+ __PACKAGE__->table('testschema.casecheck');
__PACKAGE__->add_columns(qw/id name NAME uc_name/);
__PACKAGE__->column_info_from_storage(1);
__PACKAGE__->set_primary_key('id');
}
+{
+ package DBICTest::Schema::ArrayTest;
+
+ use strict;
+ use warnings;
+ use base 'DBIx::Class';
+
+ __PACKAGE__->load_components(qw/Core/);
+ __PACKAGE__->table('testschema.array_test');
+ __PACKAGE__->add_columns(qw/id arrayfield/);
+ __PACKAGE__->column_info_from_storage(1);
+ __PACKAGE__->set_primary_key('id');
+
+}
+
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-#warn "$dsn $user $pass";
+plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test '.
+ '(note: This test drops and creates tables called \'artist\', \'casecheck\', \'array_test\' and \'sequence_test\''.
+ ' as well as following sequences: \'pkid1_seq\', \'pkid2_seq\' and \'nonpkid_seq\''.
+ ' as well as following schemas: \'testschema\'!)'
+ unless ($dsn && $user);
-plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
- . ' (note: creates and drops tables named artist and casecheck!)' unless ($dsn && $user);
-plan tests => 32;
+plan tests => 37;
-DBICTest::Schema->load_classes( 'Casecheck' );
+DBICTest::Schema->load_classes( 'Casecheck', 'ArrayTest' );
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
# Check that datetime_parser returns correctly before we explicitly connect.
@@ -50,12 +68,13 @@
{
local $SIG{__WARN__} = sub {};
$dbh->do("CREATE SCHEMA testschema;");
- $dbh->do("CREATE TABLE testschema.artist (artistid serial PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10));");
+ $dbh->do("CREATE TABLE testschema.artist (artistid serial PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10), arrayfield INTEGER[]);");
$dbh->do("CREATE TABLE testschema.sequence_test (pkid1 integer, pkid2 integer, nonpkid integer, name VARCHAR(100), CONSTRAINT pk PRIMARY KEY(pkid1, pkid2));");
$dbh->do("CREATE SEQUENCE pkid1_seq START 1 MAXVALUE 999999 MINVALUE 0");
$dbh->do("CREATE SEQUENCE pkid2_seq START 10 MAXVALUE 999999 MINVALUE 0");
$dbh->do("CREATE SEQUENCE nonpkid_seq START 20 MAXVALUE 999999 MINVALUE 0");
ok ( $dbh->do('CREATE TABLE testschema.casecheck (id serial PRIMARY KEY, "name" VARCHAR(1), "NAME" VARCHAR(2), "UC_NAME" VARCHAR(3));'), 'Creation of casecheck table');
+ ok ( $dbh->do('CREATE TABLE testschema.array_test (id serial PRIMARY KEY, arrayfield INTEGER[]);'), 'Creation of array_test table');
}
# This is in Core now, but it's here just to test that it doesn't break
@@ -94,6 +113,12 @@
'size' => 10,
'default_value' => undef,
},
+ 'arrayfield' => {
+ 'data_type' => 'integer[]',
+ 'is_nullable' => 1,
+ 'size' => undef,
+ 'default_value' => undef,
+ },
};
@@ -105,6 +130,36 @@
is_deeply($type_info, $test_type_info,
'columns_info_for - column data types');
+SKIP: {
+ skip "SQL::Abstract < 1.49 does not pass through arrayrefs", 4
+ if $SQL::Abstract::VERSION < 1.49;
+
+ lives_ok {
+ $schema->resultset('ArrayTest')->create({
+ arrayfield => [1, 2],
+ });
+ } 'inserting arrayref as pg array data';
+
+ lives_ok {
+ $schema->resultset('ArrayTest')->update({
+ arrayfield => [3, 4],
+ });
+ } 'updating arrayref as pg array data';
+
+ $schema->resultset('ArrayTest')->create({
+ arrayfield => [5, 6],
+ });
+
+ my $count;
+ lives_ok {
+ $count = $schema->resultset('ArrayTest')->search({
+ arrayfield => \[ '= ?' => [3, 4] ], #TODO anything less ugly than this?
+ })->count;
+ } 'comparing arrayref to pg array data does not blow up';
+ is($count, 1, 'comparing arrayref to pg array data gives correct result');
+}
+
+
my $name_info = $schema->source('Casecheck')->column_info( 'name' );
is( $name_info->{size}, 1, "Case sensitive matching info for 'name'" );
@@ -210,6 +265,7 @@
$dbh->do("DROP TABLE testschema.artist;");
$dbh->do("DROP TABLE testschema.casecheck;");
$dbh->do("DROP TABLE testschema.sequence_test;");
+ $dbh->do("DROP TABLE testschema.array_test;");
$dbh->do("DROP SEQUENCE pkid1_seq");
$dbh->do("DROP SEQUENCE pkid2_seq");
$dbh->do("DROP SEQUENCE nonpkid_seq");
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/745db2.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/745db2.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/745db2.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -20,7 +20,7 @@
eval { $dbh->do("DROP TABLE artist") };
-$dbh->do("CREATE TABLE artist (artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1), name VARCHAR(255), charfield CHAR(10));");
+$dbh->do("CREATE TABLE artist (artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1), name VARCHAR(255), charfield CHAR(10), rank INTEGER DEFAULT 13);");
# This is in core, just testing that it still loads ok
$schema->class('Artist')->load_components('PK::Auto');
@@ -60,6 +60,11 @@
'is_nullable' => 1,
'size' => 10
},
+ 'rank' => {
+ 'data_type' => 'INTEGER',
+ 'is_nullable' => 1,
+ 'size' => 10
+ },
};
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/746db2_400.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/746db2_400.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/746db2_400.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -23,7 +23,13 @@
eval { $dbh->do("DROP TABLE artist") };
-$dbh->do("CREATE TABLE artist (artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1), name VARCHAR(255), charfield CHAR(10))");
+$dbh->do(<<'');
+CREATE TABLE artist (
+ artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1),
+ name VARCHAR(255),
+ rank INTEGER default 13 not null,
+ charfield CHAR(10)
+)
# Just to test loading, already in Core
$schema->class('Artist')->load_components('PK::Auto');
@@ -58,6 +64,11 @@
'is_nullable' => 1,
'size' => 255
},
+ 'rank' => {
+ 'data_type' => 'INTEGER',
+ 'is_nullable' => 0,
+ 'size' => 10,
+ },
'charfield' => {
'data_type' => 'CHAR',
'is_nullable' => 1,
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/746mssql.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/746mssql.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/746mssql.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -17,11 +17,11 @@
$schema->storage->ensure_connected;
isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server' );
-my $dbh = $schema->storage->_dbh;
+$schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ eval { $dbh->do("DROP TABLE artist") };
+ $dbh->do(<<'SQL');
-eval { $dbh->do("DROP TABLE artist") };
-
- $dbh->do(<<'');
CREATE TABLE artist (
artistid INT IDENTITY NOT NULL,
name VARCHAR(100),
@@ -30,6 +30,10 @@
primary key(artistid)
)
+SQL
+
+});
+
my %seen_id;
# fresh $schema so we start unconnected
@@ -62,7 +66,7 @@
# clean up our mess
END {
- $dbh = eval { $schema->storage->_dbh };
+ my $dbh = eval { $schema->storage->_dbh };
$dbh->do('DROP TABLE artist') if $dbh;
}
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/76joins.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/76joins.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/76joins.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -5,6 +5,7 @@
use lib qw(t/lib);
use DBICTest;
use Data::Dumper;
+use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
@@ -43,7 +44,11 @@
. 'child.father_id ) JOIN person mother ON ( mother.person_id '
. '= child.mother_id )'
;
-is( $sa->_recurse_from(@j), $match, 'join 1 ok' );
+is_same_sql_bind(
+ $sa->_recurse_from(@j), [],
+ $match, [],
+ 'join 1 ok'
+);
my @j2 = (
{ mother => 'person' },
@@ -59,8 +64,13 @@
. ' father.person_id = child.father_id )) ON ( mother.person_id = '
. 'child.mother_id )'
;
-is( $sa->_recurse_from(@j2), $match, 'join 2 ok' );
+is_same_sql_bind(
+ $sa->_recurse_from(@j2), [],
+ $match, [],
+ 'join 2 ok'
+);
+
my @j3 = (
{ child => 'person' },
[ { father => 'person', -join_type => 'inner' }, { 'father.person_id' => 'child.father_id' }, ],
@@ -71,7 +81,11 @@
. '= child.mother_id )'
;
-is( $sa->_recurse_from(@j3), $match, 'join 3 (inner join) ok');
+is_same_sql_bind(
+ $sa->_recurse_from(@j3), [],
+ $match, [],
+ 'join 3 (inner join) ok'
+);
my @j4 = (
{ mother => 'person' },
@@ -87,7 +101,11 @@
. ' father.person_id = child.father_id )) ON ( mother.person_id = '
. 'child.mother_id )'
;
-is( $sa->_recurse_from(@j4), $match, 'join 4 (nested joins + join types) ok');
+is_same_sql_bind(
+ $sa->_recurse_from(@j4), [],
+ $match, [],
+ 'join 4 (nested joins + join types) ok'
+);
my @j5 = (
{ child => 'person' },
@@ -98,7 +116,11 @@
. 'child.father_id ) JOIN person mother ON ( mother.person_id '
. '= child.mother_id )'
;
-is( $sa->_recurse_from(@j5), $match, 'join 5 (SCALAR reference for ON statement) ok' );
+is_same_sql_bind(
+ $sa->_recurse_from(@j5), [],
+ $match, [],
+ 'join 5 (SCALAR reference for ON statement) ok'
+);
my @j6 = (
{ child => 'person' },
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/76select.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/76select.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/76select.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -8,7 +8,7 @@
my $schema = DBICTest->init_schema();
-plan tests => 11;
+plan tests => 12;
my $rs = $schema->resultset('CD')->search({},
{
@@ -61,3 +61,5 @@
is ($subsel->count, 2, 'Subselect correctly limited the rs to 2 cds');
is ($subsel->next->title, $cds->next->title, 'First CD title match');
is ($subsel->next->title, $cds->next->title, 'Second CD title match');
+
+is($schema->resultset('CD')->current_source_alias, "me", '$rs->current_source_alias returns "me"');
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/86sqlt.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/86sqlt.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/86sqlt.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -10,7 +10,7 @@
my $schema = DBICTest->init_schema;
-plan tests => 131;
+plan tests => 132;
my $translator = SQL::Translator->new(
parser_args => {
@@ -26,6 +26,17 @@
my $relinfo = $schema->source('Artist')->relationship_info ('cds');
local $relinfo->{attrs}{on_delete} = 'restrict';
+ $schema->source('Track')->sqlt_deploy_callback(sub {
+ my ($self, $sqlt_table) = @_;
+
+ if ($sqlt_table->schema->translator->producer_type =~ /SQLite$/ ) {
+ $sqlt_table->add_index( name => 'track_title', fields => ['title'] )
+ or die $sqlt_table->error;
+ }
+
+ $self->default_sqlt_deploy_hook($sqlt_table);
+ });
+
$translator->parser('SQL::Translator::Parser::DBIx::Class');
$translator->producer('SQLite');
@@ -258,7 +269,12 @@
{
'fields' => ['name']
},
- ]
+ ],
+ track => [
+ {
+ 'fields' => ['title']
+ }
+ ],
);
my $tschema = $translator->schema();
@@ -300,7 +316,6 @@
for my $table_index (keys %indexes) {
for my $expected_index ( @{ $indexes{$table_index} } ) {
-
ok ( get_index($table_index, $expected_index), "Got a matching index on $table_index table");
}
}
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/89dbicadmin.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/89dbicadmin.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/89dbicadmin.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -6,7 +6,6 @@
use lib qw(t/lib);
use DBICTest;
-my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
eval 'require JSON::Any';
plan skip_all => 'Install JSON::Any to run this test' if ($@);
@@ -17,33 +16,75 @@
plan skip_all => 'Install Text::CSV_XS or Text::CSV_PP to run this test' if ($@);
}
-plan tests => 5;
+my @json_backends = qw/XS JSON DWIW Syck/;
+my $tests_per_run = 5;
-# the script supports double quotes round the arguments and single-quote within
-# to make sure it runs on windows as well, but only if JSON::Any picks the right module
+plan tests => $tests_per_run * @json_backends;
+use JSON::Any;
+for my $js (@json_backends) {
+ eval {JSON::Any->import ($js) };
+ SKIP: {
+ skip ("Json backend $js is not available, skip testing", $tests_per_run) if $@;
-my $employees = $schema->resultset('Employee');
-my @cmd = ($^X, qw|script/dbicadmin --quiet --schema=DBICTest::Schema --class=Employee --tlibs|, q|--connect=["dbi:SQLite:dbname=t/var/DBIxClass.db","","",{"AutoCommit":1}]|, qw|--force --tlibs|);
+ $ENV{JSON_ANY_ORDER} = $js;
+ eval { test_dbicadmin () };
+ diag $@ if $@;
+ }
+}
-system(@cmd, qw|--op=insert --set={"name":"Matt"}|);
-ok( ($employees->count()==1), 'insert count' );
+sub test_dbicadmin {
+ my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); # reinit a fresh db for every run
-my $employee = $employees->find(1);
-ok( ($employee->name() eq 'Matt'), 'insert valid' );
+ my $employees = $schema->resultset('Employee');
-system(@cmd, qw|--op=update --set={"name":"Trout"}|);
-$employee = $employees->find(1);
-ok( ($employee->name() eq 'Trout'), 'update' );
+ system( _prepare_system_args( qw|--op=insert --set={"name":"Matt"}| ) );
+ ok( ($employees->count()==1), "$ENV{JSON_ANY_ORDER}: insert count" );
-system(@cmd, qw|--op=insert --set={"name":"Aran"}|);
+ my $employee = $employees->find(1);
+ ok( ($employee->name() eq 'Matt'), "$ENV{JSON_ANY_ORDER}: insert valid" );
-open(my $fh, "-|", @cmd, qw|--op=select --attrs={"order_by":"name"}|) or die $!;
-my $data = do { local $/; <$fh> };
-close($fh);
-ok( ($data=~/Aran.*Trout/s), 'select with attrs' );
+ system( _prepare_system_args( qw|--op=update --set={"name":"Trout"}| ) );
+ $employee = $employees->find(1);
+ ok( ($employee->name() eq 'Trout'), "$ENV{JSON_ANY_ORDER}: update" );
-system(@cmd, qw|--op=delete --where={"name":"Trout"}|);
-ok( ($employees->count()==1), 'delete' );
+ system( _prepare_system_args( qw|--op=insert --set={"name":"Aran"}| ) );
+ SKIP: {
+ skip ("MSWin32 doesn't support -| either", 1) if $^O eq 'MSWin32';
+
+ open(my $fh, "-|", _prepare_system_args( qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!;
+ my $data = do { local $/; <$fh> };
+ close($fh);
+ ok( ($data=~/Aran.*Trout/s), "$ENV{JSON_ANY_ORDER}: select with attrs" );
+ }
+
+ system( _prepare_system_args( qw|--op=delete --where={"name":"Trout"}| ) );
+ ok( ($employees->count()==1), "$ENV{JSON_ANY_ORDER}: delete" );
+}
+
+# Why do we need this crap? Apparently MSWin32 can not pass through quotes properly
+# (sometimes it will and sometimes not, depending on what compiler was used to build
+# perl). So we go the extra mile to escape all the quotes. We can't also use ' instead
+# of ", because JSON::XS (proudly) does not support "malformed JSON" as the author
+# calls it. Bleh.
+#
+sub _prepare_system_args {
+ my $perl = $^X;
+ my @args = (
+ qw|script/dbicadmin --quiet --schema=DBICTest::Schema --class=Employee --tlibs|,
+ q|--connect=["dbi:SQLite:dbname=t/var/DBIxClass.db","","",{"AutoCommit":1}]|,
+ qw|--force --tlibs|,
+ @_,
+ );
+
+ if ( $^O eq 'MSWin32' ) {
+ $perl = qq|"$perl"|; # execution will fail if $^X contains paths
+ for (@args) {
+ $_ =~ s/"/\\"/g;
+ }
+ }
+
+ return ($perl, @args);
+}
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/89inflate_datetime.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/89inflate_datetime.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/89inflate_datetime.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -10,7 +10,7 @@
eval { require DateTime::Format::MySQL };
plan skip_all => "Need DateTime::Format::MySQL for inflation tests" if $@;
-plan tests => 28;
+plan tests => 32;
# inflation test
my $event = $schema->resultset("Event")->find(1);
@@ -58,6 +58,11 @@
hour => 13, minute => 34, second => 56, time_zone => "America/New_York" ),
});
+is ($event_tz->starts_at->day_name, "Montag", 'Locale de_DE loaded: day_name');
+is ($event_tz->starts_at->month_name, "Dezember", 'Locale de_DE loaded: month_name');
+is ($event_tz->created_on->day_name, "Tuesday", 'Default locale loaded: day_name');
+is ($event_tz->created_on->month_name, "January", 'Default locale loaded: month_name');
+
my $starts_at = $event_tz->starts_at;
is("$starts_at", '2007-12-31T00:00:00', 'Correct date/time using timezone');
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/90ensure_class_loaded.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/90ensure_class_loaded.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/90ensure_class_loaded.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -13,7 +13,7 @@
my $schema = DBICTest->init_schema();
-plan tests => 20;
+plan tests => 28;
# Test ensure_class_found
ok( $schema->ensure_class_found('DBIx::Class::Schema'),
@@ -40,6 +40,50 @@
like( $@, qr/did not return a true value/,
'DBICTest::ErrorComponent threw ok' );
+# Simulate a PAR environment
+{
+ my @code;
+ local @INC = @INC;
+ unshift @INC, sub {
+ if ($_[1] eq 'VIRTUAL/PAR/PACKAGE.pm') {
+ return (sub { return 0 unless @code; $_ = shift @code; 1; } );
+ }
+ else {
+ return ();
+ }
+ };
+
+ $retval = eval { $schema->load_optional_class('FAKE::PAR::PACKAGE') };
+ ok( !$@, 'load_optional_class on a nonexistent PAR class did not throw' );
+ ok( !$retval, 'nonexistent PAR package not loaded' );
+
+
+ # simulate a class which does load but does not return true
+ @code = (
+ q/package VIRTUAL::PAR::PACKAGE;/,
+ q/0;/,
+ );
+
+ $retval = eval { $schema->load_optional_class('VIRTUAL::PAR::PACKAGE') };
+ ok( $@, 'load_optional_class of a no-true-returning PAR module did throw' );
+ ok( !$retval, 'no-true-returning PAR package not loaded' );
+
+ # simulate a normal class (no one adjusted %INC so it will be tried again
+ @code = (
+ q/package VIRTUAL::PAR::PACKAGE;/,
+ q/1;/,
+ );
+
+ $retval = eval { $schema->load_optional_class('VIRTUAL::PAR::PACKAGE') };
+ ok( !$@, 'load_optional_class of a PAR module did not throw' );
+ ok( $retval, 'PAR package "loaded"' );
+
+ # see if we can still load stuff with the coderef present
+ $retval = eval { $schema->load_optional_class('DBIx::Class::ResultClass::HashRefInflator') };
+ ok( !$@, 'load_optional_class did not throw' ) || diag $@;
+ ok( $retval, 'DBIx::Class::ResultClass::HashRefInflator loaded' );
+}
+
# Test ensure_class_loaded
ok( Class::Inspector->loaded('TestPackage::A'), 'anonymous package exists' );
eval { $schema->ensure_class_loaded('TestPackage::A'); };
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/91debug.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/91debug.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/91debug.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -4,10 +4,12 @@
use Test::More;
use lib qw(t/lib);
use DBICTest;
+use DBIC::DebugObj;
+use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
-plan tests => 6;
+plan tests => 7;
ok ( $schema->storage->debug(1), 'debug' );
ok ( defined(
@@ -49,15 +51,24 @@
# test trace output correctness for bind params
{
- my $sql = '';
+ my ($sql, @bind) = ('');
$schema->storage->debugcb( sub { $sql = $_[1] } );
my @cds = $schema->resultset('CD')->search( { artist => 1, cdid => { -between => [ 1, 3 ] }, } );
- like(
- $sql,
- qr/\QSELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( artist = ? AND cdid BETWEEN ? AND ? ): '1', '1', '3'\E/,
- 'got correct SQL with all bind parameters'
+ is_same_sql_bind(
+ $sql, [],
+ "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( artist = ? AND cdid BETWEEN ? AND ? ): '1', '1', '3'", [],
+ 'got correct SQL with all bind parameters (debugcb)'
);
+
+ $schema->storage->debugcb(undef);
+ $schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind));
+ @cds = $schema->resultset('CD')->search( { artist => 1, cdid => { -between => [ 1, 3 ] }, } );
+ is_same_sql_bind(
+ $sql, \@bind,
+ "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( artist = ? AND cdid BETWEEN ? AND ? )", ["'1'", "'1'", "'3'"],
+ 'got correct SQL with all bind parameters (debugobj)'
+ );
}
1;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/92storage_on_connect_do.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/92storage_on_connect_do.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/92storage_on_connect_do.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,7 +1,7 @@
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More tests => 10;
use lib qw(t/lib);
use base 'DBICTest';
@@ -33,11 +33,11 @@
$schema->storage->disconnect();
-my($connected, $disconnected);
+my($connected, $disconnected, @cb_args);
ok $schema->connection(
DBICTest->_database,
{
- on_connect_do => sub { $connected = 1 },
+ on_connect_do => sub { $connected = 1; @cb_args = @_; },
on_disconnect_do => sub { $disconnected = 1 },
},
), 'second connection()';
@@ -47,6 +47,7 @@
$schema->storage->disconnect();
ok $disconnected, 'on_disconnect_do() called after disconnect()';
+isa_ok($cb_args[0], 'DBIx::Class::Storage', 'first arg to on_connect_do hook');
sub check_exists {
my $storage = shift;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/93storage_replication.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/93storage_replication.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/93storage_replication.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -249,6 +249,7 @@
$replicated->replicate;
$replicated->schema->storage->replicants->{$replicant_names[0]}->active(1);
$replicated->schema->storage->replicants->{$replicant_names[1]}->active(1);
+$replicated->schema->storage->pool->validate_replicants;
## Make sure we can read the data.
@@ -311,7 +312,7 @@
=> 'Found expected name for first result';
is $replicated->schema->storage->pool->connected_replicants => 1
- => "One replicant reconnected to handle the job";
+ => "At Least One replicant reconnected to handle the job";
## What happens when we try to select something that doesn't exist?
@@ -355,6 +356,7 @@
$replicated->schema->storage->replicants->{$replicant_names[0]}->active(1);
$replicated->schema->storage->replicants->{$replicant_names[1]}->active(1);
+$replicated->schema->storage->pool->validate_replicants;
ok $replicated->schema->resultset('Artist')->find(2)
=> 'Returned to replicates';
@@ -576,8 +578,11 @@
## Delete the old database files
$replicated->cleanup;
+use Data::Dump qw/dump/;
+#warn dump $replicated->schema->storage->read_handler;
+
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/94versioning.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/94versioning.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/94versioning.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -16,9 +16,9 @@
unless ($dsn);
- eval "use DBD::mysql; use SQL::Translator 0.09;";
+ eval "use DBD::mysql; use SQL::Translator 0.09003;";
plan $@
- ? ( skip_all => 'needs DBD::mysql and SQL::Translator 0.09 for testing' )
+ ? ( skip_all => 'needs DBD::mysql and SQL::Translator 0.09003 for testing' )
: ( tests => 22 );
}
Added: DBIx-Class/0.08/branches/rt_bug_41083/t/95sql_maker.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/95sql_maker.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/95sql_maker.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,57 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+
+BEGIN {
+ eval "use DBD::SQLite";
+ plan $@
+ ? ( skip_all => 'needs DBD::SQLite for testing' )
+ : ( tests => 3 );
+}
+
+use_ok('DBICTest');
+
+my $schema = DBICTest->init_schema();
+
+my $sql_maker = $schema->storage->sql_maker;
+
+
+SKIP: {
+ skip "SQL::Abstract < 1.49 does not pass through arrayrefs", 2
+ if $SQL::Abstract::VERSION < 1.49;
+
+ my ($sql, @bind) = $sql_maker->insert(
+ 'lottery',
+ {
+ 'day' => '2008-11-16',
+ 'numbers' => [13, 21, 34, 55, 89]
+ }
+ );
+
+ is_same_sql_bind(
+ $sql, \@bind,
+ q/INSERT INTO lottery (day, numbers) VALUES (?, ?)/,
+ [ ['day' => '2008-11-16'], ['numbers' => [13, 21, 34, 55, 89]] ],
+ 'sql_maker passes arrayrefs in insert'
+ );
+
+
+ ($sql, @bind) = $sql_maker->update(
+ 'lottery',
+ {
+ 'day' => '2008-11-16',
+ 'numbers' => [13, 21, 34, 55, 89]
+ }
+ );
+
+ is_same_sql_bind(
+ $sql, \@bind,
+ q/UPDATE lottery SET day = ?, numbers = ?/,
+ [ ['day' => '2008-11-16'], ['numbers' => [13, 21, 34, 55, 89]] ],
+ 'sql_maker passes arrayrefs in update'
+ );
+}
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/95sql_maker_quote.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/95sql_maker_quote.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/95sql_maker_quote.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -3,16 +3,16 @@
use Test::More;
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
BEGIN {
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 8 );
+ : ( tests => 12 );
}
-use lib qw(t/lib);
-
use_ok('DBICTest');
my $schema = DBICTest->init_schema();
@@ -22,7 +22,7 @@
$sql_maker->quote_char('`');
$sql_maker->name_sep('.');
-my ($sql,) = $sql_maker->select(
+my ($sql, @bind) = $sql_maker->select(
[
{
'me' => 'cd'
@@ -51,11 +51,14 @@
undef
);
-is($sql,
- q/SELECT COUNT( * ) FROM `cd` `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )/,
- 'got correct SQL for count query with quoting');
+is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT COUNT( * ) FROM `cd` `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )/, [ ['artist.name' => 'Caterwauler McCrae'], ['me.year' => 2001] ],
+ 'got correct SQL and bind parameters for count query with quoting'
+);
-($sql,) = $sql_maker->select(
+
+($sql, @bind) = $sql_maker->select(
[
{
'me' => 'cd'
@@ -68,43 +71,130 @@
'me.year'
],
undef,
+ 'year DESC',
+ undef,
+ undef
+);
+
+is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year DESC`/, [],
+ 'scalar ORDER BY okay (single value)'
+);
+
+
+($sql, @bind) = $sql_maker->select(
[
- 'year DESC'
+ {
+ 'me' => 'cd'
+ }
],
+ [
+ 'me.cdid',
+ 'me.artist',
+ 'me.title',
+ 'me.year'
+ ],
undef,
+ [
+ 'year DESC',
+ 'title ASC'
+ ],
+ undef,
undef
);
-TODO: {
- local $TODO = "order_by with quoting needs fixing (ash/castaway)";
+is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year DESC`, `title ASC`/, [],
+ 'scalar ORDER BY okay (multiple values)'
+);
- is($sql,
- q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year` DESC/,
- 'quoted ORDER BY with DESC okay');
+SKIP: {
+ skip "SQL::Abstract < 1.49 does not support hashrefs in order_by", 2
+ if $SQL::Abstract::VERSION < 1.49;
+
+ ($sql, @bind) = $sql_maker->select(
+ [
+ {
+ 'me' => 'cd'
+ }
+ ],
+ [
+ 'me.cdid',
+ 'me.artist',
+ 'me.title',
+ 'me.year'
+ ],
+ undef,
+ { -desc => 'year' },
+ undef,
+ undef
+ );
+
+ is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year` DESC/, [],
+ 'hashref ORDER BY okay (single value)'
+ );
+
+
+ ($sql, @bind) = $sql_maker->select(
+ [
+ {
+ 'me' => 'cd'
+ }
+ ],
+ [
+ 'me.cdid',
+ 'me.artist',
+ 'me.title',
+ 'me.year'
+ ],
+ undef,
+ [
+ { -desc => 'year' },
+ { -asc => 'title' }
+ ],
+ undef,
+ undef
+ );
+
+ is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year` DESC, `title` ASC/, [],
+ 'hashref ORDER BY okay (multiple values)'
+ );
+
}
-TODO: {
- local $TODO = "select attr with star needs fixing (mst/nate)";
- ($sql,) = $sql_maker->select(
+($sql, @bind) = $sql_maker->select(
[
{
'me' => 'cd'
}
],
[
- 'me.*'
+ 'me.cdid',
+ 'me.artist',
+ 'me.title',
+ 'me.year'
],
undef,
- [],
+ \'year DESC',
undef,
- undef
- );
+ undef
+);
- is($sql, q/SELECT `me`.* FROM `cd` `me`/, 'select attr with me.* is right');
-}
+is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY year DESC/, [],
+ 'did not quote ORDER BY with scalarref (single value)'
+);
-($sql,) = $sql_maker->select(
+
+($sql, @bind) = $sql_maker->select(
[
{
'me' => 'cd'
@@ -118,24 +208,21 @@
],
undef,
[
- \'year DESC'
+ \'year DESC',
+ \'title ASC'
],
undef,
undef
);
-is($sql,
- q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY year DESC/,
- 'did not quote ORDER BY with scalarref');
-
-my %data = (
- name => 'Bill',
- order => 12
+is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY year DESC, title ASC/, [],
+ 'did not quote ORDER BY with scalarref (multiple values)'
);
-my @binds;
-($sql, at binds) = $sql_maker->update(
+($sql, @bind) = $sql_maker->update(
'group',
{
'order' => '12',
@@ -143,13 +230,42 @@
}
);
-is($sql,
- q/UPDATE `group` SET `name` = ?, `order` = ?/,
- 'quoted table names for UPDATE');
+is_same_sql_bind(
+ $sql, \@bind,
+ q/UPDATE `group` SET `name` = ?, `order` = ?/, [ ['name' => 'Bill'], ['order' => '12'] ],
+ 'quoted table names for UPDATE'
+);
+SKIP: {
+ skip "select attr with star does not work in SQL::Abstract < 1.49", 1
+ if $SQL::Abstract::VERSION < 1.49;
+
+ ($sql, @bind) = $sql_maker->select(
+ [
+ {
+ 'me' => 'cd'
+ }
+ ],
+ [
+ 'me.*'
+ ],
+ undef,
+ [],
+ undef,
+ undef
+ );
+
+ is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.* FROM `cd` `me`/, [],
+ 'select attr with me.* is right'
+ );
+}
+
+
$sql_maker->quote_char([qw/[ ]/]);
-($sql,) = $sql_maker->select(
+($sql, @bind) = $sql_maker->select(
[
{
'me' => 'cd'
@@ -178,12 +294,14 @@
undef
);
-is($sql,
- q/SELECT COUNT( * ) FROM [cd] [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )/,
- 'got correct SQL for count query with bracket quoting');
+is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT COUNT( * ) FROM [cd] [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )/, [ ['artist.name' => 'Caterwauler McCrae'], ['me.year' => 2001] ],
+ 'got correct SQL and bind parameters for count query with bracket quoting'
+);
-($sql, at binds) = $sql_maker->update(
+($sql, @bind) = $sql_maker->update(
'group',
{
'order' => '12',
@@ -191,6 +309,8 @@
}
);
-is($sql,
- q/UPDATE [group] SET [name] = ?, [order] = ?/,
- 'bracket quoted table names for UPDATE');
+is_same_sql_bind(
+ $sql, \@bind,
+ q/UPDATE [group] SET [name] = ?, [order] = ?/, [ ['name' => 'Bill'], ['order' => '12'] ],
+ 'bracket quoted table names for UPDATE'
+);
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/99dbic_sqlt_parser.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/99dbic_sqlt_parser.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/99dbic_sqlt_parser.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -5,19 +5,22 @@
use lib qw(t/lib);
use DBICTest;
+
BEGIN {
- eval "use DBD::mysql; use SQL::Translator 0.09;";
- plan $@
- ? ( skip_all => 'needs SQL::Translator 0.09 for testing' )
- : ( tests => 114 );
+ eval "use DBD::mysql; use SQL::Translator 0.09003;";
+ if ($@) {
+ plan skip_all => 'needs DBD::mysql and SQL::Translator 0.09003 for testing';
+ }
}
my $schema = DBICTest->init_schema();
+my @sources = grep { $_ ne 'Dummy' } ($schema->sources); # Dummy was yanked out by the sqlt hook test
+plan tests => ( @sources * 3);
{
my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { } } });
- foreach my $source ($schema->sources) {
+ foreach my $source (@sources) {
my $table = $sqlt_schema->get_table($schema->source($source)->from);
my $fk_count = scalar(grep { $_->type eq 'FOREIGN KEY' } $table->get_constraints);
@@ -31,7 +34,7 @@
{
my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { add_fk_index => 1 } } });
- foreach my $source ($schema->sources) {
+ foreach my $source (@sources) {
my $table = $sqlt_schema->get_table($schema->source($source)->from);
my $fk_count = scalar(grep { $_->type eq 'FOREIGN KEY' } $table->get_constraints);
@@ -45,7 +48,7 @@
{
my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { add_fk_index => 0 } } });
- foreach my $source ($schema->sources) {
+ foreach my $source (@sources) {
my $table = $sqlt_schema->get_table($schema->source($source)->from);
my @indices = $table->get_indices;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/bindtype_columns.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/bindtype_columns.t 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/bindtype_columns.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -19,46 +19,32 @@
{
local $SIG{__WARN__} = sub {};
$dbh->do('DROP TABLE IF EXISTS artist');
+
+ # the blob/clob are for reference only, will be useful when we switch to SQLT and can test Oracle along the way
$dbh->do(qq[
- CREATE TABLE artist
+ CREATE TABLE bindtype_test
(
- artistid serial NOT NULL PRIMARY KEY,
- media bytea NOT NULL,
- name varchar(100) NULL,
- rank integer NOT NULL DEFAULT '13',
- charfield char(10) NULL
+ id serial NOT NULL PRIMARY KEY,
+ bytea bytea NULL,
+ blob bytea NULL,
+ clob text NULL
);
],{ RaiseError => 1, PrintError => 1 });
}
-$schema->class('Artist')->load_components(qw/
-
- PK::Auto
- Core
-/);
-
-$schema->class('Artist')->add_columns(
-
- "media", {
-
- data_type => "bytea",
- is_nullable => 0,
- },
-);
-
# test primary key handling
my $big_long_string = 'abcd' x 250000;
-my $new = $schema->resultset('Artist')->create({ media => $big_long_string });
+my $new = $schema->resultset('BindType')->create({ bytea => $big_long_string });
-ok($new->artistid, "Created a blob row");
-is($new->media, $big_long_string, "Set the blob correctly.");
+ok($new->id, "Created a bytea row");
+is($new->bytea, $big_long_string, "Set the blob correctly.");
-my $rs = $schema->resultset('Artist')->find({artistid=>$new->artistid});
+my $rs = $schema->resultset('BindType')->find({ id => $new->id });
-is($rs->get_column('media'), $big_long_string, "Created the blob correctly.");
+is($rs->get_column('bytea'), $big_long_string, "Created the blob correctly.");
-$dbh->do("DROP TABLE artist");
+$dbh->do("DROP TABLE bindtype_test");
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/01-columns.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/01-columns.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/01-columns.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/01-columns.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,153 @@
+use strict;
+
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@") : (tests=> 24);
+}
+
+
+#-----------------------------------------------------------------------
+# Make sure that we can set up columns properly
+#-----------------------------------------------------------------------
+package State;
+
+use base 'DBIx::Class::Test::SQLite';
+
+State->table('State');
+State->columns(Essential => qw/Abbreviation Name/);
+State->columns(Primary => 'Name');
+State->columns(Weather => qw/Rain Snowfall/);
+State->columns(Other => qw/Capital Population/);
+#State->has_many(cities => "City");
+
+sub accessor_name_for {
+ my ($class, $column) = @_;
+ my $return = $column eq "Rain" ? "Rainfall" : $column;
+ return $return;
+}
+
+sub mutator_name_for {
+ my ($class, $column) = @_;
+ my $return = $column eq "Rain" ? "set_Rainfall" : "set_$column";
+ return $return;
+}
+
+sub Snowfall { 1 }
+
+
+package City;
+
+use base 'DBIx::Class::Test::SQLite';
+
+City->table('City');
+City->columns(All => qw/Name State Population/);
+
+{
+ # Disable the `no such table' warning
+ local $SIG{__WARN__} = sub {
+ my $warning = shift;
+ warn $warning unless ($warning =~ /\Qno such table: City(1)\E/);
+ };
+
+ City->has_a(State => 'State');
+}
+
+#-------------------------------------------------------------------------
+package CD;
+use base 'DBIx::Class::Test::SQLite';
+
+CD->table('CD');
+CD->columns('All' => qw/artist title length/);
+
+#-------------------------------------------------------------------------
+
+package main;
+
+is(State->table, 'State', 'State table()');
+is(State->primary_column, 'name', 'State primary()');
+is_deeply [ State->columns('Primary') ] => [qw/name/],
+ 'State Primary:' . join ", ", State->columns('Primary');
+is_deeply [ sort State->columns('Essential') ] => [qw/abbreviation name/],
+ 'State Essential:' . join ", ", State->columns('Essential');
+is_deeply [ sort State->columns('All') ] =>
+ [ sort qw/name abbreviation rain snowfall capital population/ ],
+ 'State All:' . join ", ", State->columns('All');
+
+is(CD->primary_column, 'artist', 'CD primary()');
+is_deeply [ CD->columns('Primary') ] => [qw/artist/],
+ 'CD primary:' . join ", ", CD->columns('Primary');
+is_deeply [ sort CD->columns('All') ] => [qw/artist length title/],
+ 'CD all:' . join ", ", CD->columns('All');
+is_deeply [ sort CD->columns('Essential') ] => [qw/artist/],
+ 'CD essential:' . join ", ", CD->columns('Essential');
+
+ok(State->find_column('Rain'), 'find_column Rain');
+ok(State->find_column('rain'), 'find_column rain');
+ok(!State->find_column('HGLAGAGlAG'), '!find_column HGLAGAGlAG');
+
+{
+
+ can_ok +State => qw/Rainfall _Rainfall_accessor set_Rainfall
+ _set_Rainfall_accessor Snowfall _Snowfall_accessor set_Snowfall
+ _set_Snowfall_accessor/;
+
+ foreach my $method (qw/Rain _Rain_accessor rain snowfall/) {
+ ok !State->can($method), "State can't $method";
+ }
+
+}
+
+{
+ SKIP: {
+ skip "No column objects", 1;
+
+ eval { my @grps = State->__grouper->groups_for("Huh"); };
+ ok $@, "Huh not in groups";
+ }
+
+ my @grps = sort State->__grouper->groups_for(State->_find_columns(qw/rain capital/));
+ is @grps, 2, "Rain and Capital = 2 groups";
+ @grps = sort @grps; # Because the underlying API is hash-based
+ is $grps[0], 'Other', " - Other";
+ is $grps[1], 'Weather', " - Weather";
+}
+
+#{
+#
+# package DieTest;
+# @DieTest::ISA = qw(DBIx::Class);
+# DieTest->load_components(qw/CDBICompat::Retrieve Core/);
+# package main;
+# local $SIG{__WARN__} = sub { };
+# eval { DieTest->retrieve(1) };
+# like $@, qr/unless primary columns are defined/, "Need primary key for retrieve";
+#}
+
+#-----------------------------------------------------------------------
+# Make sure that columns inherit properly
+#-----------------------------------------------------------------------
+package State;
+
+package A;
+ at A::ISA = qw(DBIx::Class);
+__PACKAGE__->load_components(qw/CDBICompat Core/);
+__PACKAGE__->table('dummy');
+__PACKAGE__->columns(Primary => 'id');
+
+package A::B;
+ at A::B::ISA = 'A';
+__PACKAGE__->table('dummy2');
+__PACKAGE__->columns(All => qw(id b1));
+
+package A::C;
+ at A::C::ISA = 'A';
+__PACKAGE__->table('dummy3');
+__PACKAGE__->columns(All => qw(id c1 c2 c3));
+
+package main;
+is join (' ', sort A->columns), 'id', "A columns";
+is join (' ', sort A::B->columns), 'b1 id', "A::B columns";
+is join (' ', sort A::C->columns), 'c1 c2 c3 id', "A::C columns";
+
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/01-columns.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/02-Film.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/02-Film.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/02-Film.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/02-Film.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,417 @@
+use strict;
+use Test::More;
+$| = 1;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 98);
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+ use Film;
+}
+
+ok(Film->can('db_Main'), 'set_db()');
+is(Film->__driver, "SQLite", "Driver set correctly");
+
+{
+ my $nul = eval { Film->retrieve() };
+ is $nul, undef, "Can't retrieve nothing";
+ like $@, qr/./, "retrieve needs parameters"; # TODO fix this...
+}
+
+{
+ eval { my $id = Film->id };
+ like $@, qr/class method/, "Can't get id with no object";
+}
+
+{
+ eval { my $id = Film->title };
+ #like $@, qr/class method/, "Can't get title with no object";
+ ok $@, "Can't get title with no object";
+}
+
+eval { my $duh = Film->insert; };
+like $@, qr/create needs a hashref/, "needs a hashref";
+
+ok +Film->create_test_film;
+
+my $btaste = Film->retrieve('Bad Taste');
+isa_ok $btaste, 'Film';
+is($btaste->Title, 'Bad Taste', 'Title() get');
+is($btaste->Director, 'Peter Jackson', 'Director() get');
+is($btaste->Rating, 'R', 'Rating() get');
+is($btaste->NumExplodingSheep, 1, 'NumExplodingSheep() get');
+
+{
+ my $bt2 = Film->find_or_create(Title => 'Bad Taste');
+ is $bt2->Director, $btaste->Director, "find_or_create";
+ my @bt = Film->search(Title => 'Bad Taste');
+ is @bt, 1, " doesn't create a new one";
+}
+
+ok my $gone = Film->find_or_create(
+ {
+ Title => 'Gone With The Wind',
+ Director => 'Bob Baggadonuts',
+ Rating => 'PG',
+ NumExplodingSheep => 0
+ }
+ ),
+ "Add Gone With The Wind";
+isa_ok $gone, 'Film';
+ok $gone = Film->retrieve(Title => 'Gone With The Wind'),
+ "Fetch it back again";
+isa_ok $gone, 'Film';
+
+# Shocking new footage found reveals bizarre Scarlet/sheep scene!
+is($gone->NumExplodingSheep, 0, 'NumExplodingSheep() get again');
+$gone->NumExplodingSheep(5);
+is($gone->NumExplodingSheep, 5, 'NumExplodingSheep() set');
+is($gone->numexplodingsheep, 5, 'numexplodingsheep() set');
+
+is($gone->Rating, 'PG', 'Rating() get again');
+$gone->Rating('NC-17');
+is($gone->Rating, 'NC-17', 'Rating() set');
+$gone->update;
+
+{
+ my @films = eval { Film->retrieve_all };
+ cmp_ok(@films, '==', 2, "We have 2 films in total");
+}
+
+# EXTRA TEST: added by mst to check a bug found by Numa
+cmp_ok(Film->count_all, '==', 2, "count_all confirms 2 films");
+
+my $gone_copy = Film->retrieve('Gone With The Wind');
+ok($gone->NumExplodingSheep == 5, 'update()');
+ok($gone->Rating eq 'NC-17', 'update() again');
+
+# Grab the 'Bladerunner' entry.
+Film->create(
+ {
+ Title => 'Bladerunner',
+ Director => 'Bob Ridley Scott',
+ Rating => 'R'
+ }
+);
+
+my $blrunner = Film->retrieve('Bladerunner');
+is(ref $blrunner, 'Film', 'retrieve() again');
+is $blrunner->Title, 'Bladerunner', "Correct title";
+is $blrunner->Director, 'Bob Ridley Scott', " and Director";
+is $blrunner->Rating, 'R', " and Rating";
+is $blrunner->NumExplodingSheep, undef, " and sheep";
+
+# Make a copy of 'Bladerunner' and create an entry of the directors cut
+my $blrunner_dc = $blrunner->copy(
+ {
+ title => "Bladerunner: Director's Cut",
+ rating => "15",
+ }
+);
+is(ref $blrunner_dc, 'Film', "copy() produces a film");
+is($blrunner_dc->Title, "Bladerunner: Director's Cut", 'Title correct');
+is($blrunner_dc->Director, 'Bob Ridley Scott', 'Director correct');
+is($blrunner_dc->Rating, '15', 'Rating correct');
+is($blrunner_dc->NumExplodingSheep, undef, 'Sheep correct');
+
+# Set up own SQL:
+{
+ Film->add_constructor(title_asc => "title LIKE ? ORDER BY title");
+ Film->add_constructor(title_desc => "title LIKE ? ORDER BY title DESC");
+ Film->add_constructor(title_asc_nl => q{
+ title LIKE ?
+ ORDER BY title
+ LIMIT 1
+ });
+
+ {
+ my @films = Film->title_asc("Bladerunner%");
+ is @films, 2, "We have 2 Bladerunners";
+ is $films[0]->Title, $blrunner->Title, "Ordered correctly";
+ }
+ {
+ my @films = Film->title_desc("Bladerunner%");
+ is @films, 2, "We have 2 Bladerunners";
+ is $films[0]->Title, $blrunner_dc->Title, "Ordered correctly";
+ }
+ {
+ my @films = Film->title_asc_nl("Bladerunner%");
+ is @films, 1, "We have 2 Bladerunners";
+ is $films[0]->Title, $blrunner->Title, "Ordered correctly";
+ }
+}
+
+# Multi-column search
+{
+ my @films = $blrunner->search_like(title => "Bladerunner%", rating => '15');
+ is @films, 1, "Only one Bladerunner is a 15";
+}
+
+# Inline SQL
+{
+ my @films = Film->retrieve_from_sql("numexplodingsheep > 0 ORDER BY title");
+ is @films, 2, "Inline SQL";
+ is $films[0]->id, $btaste->id, "Correct film";
+ is $films[1]->id, $gone->id, "Correct film";
+}
+
+# Inline SQL removes WHERE
+{
+ my @films =
+ Film->retrieve_from_sql(" WHErE numexplodingsheep > 0 ORDER BY title");
+ is @films, 2, "Inline SQL";
+ is $films[0]->id, $btaste->id, "Correct film";
+ is $films[1]->id, $gone->id, "Correct film";
+}
+
+eval {
+ my $ishtar = Film->insert({ Title => 'Ishtar', Director => 'Elaine May' });
+ my $mandn =
+ Film->insert({ Title => 'Mikey and Nicky', Director => 'Elaine May' });
+ my $new_leaf =
+ Film->insert({ Title => 'A New Leaf', Director => 'Elaine May' });
+
+#use Data::Dumper; die Dumper(Film->search( Director => 'Elaine May' ));
+ cmp_ok(Film->search(Director => 'Elaine May'), '==', 3,
+ "3 Films by Elaine May");
+ ok(Film->retrieve('Ishtar')->delete,
+ "Ishtar doesn't deserve an entry any more");
+ ok(!Film->retrieve('Ishtar'), 'Ishtar no longer there');
+ {
+ my $deprecated = 0;
+ #local $SIG{__WARN__} = sub { $deprecated++ if $_[0] =~ /deprecated/ };
+ ok(
+ Film->delete(Director => 'Elaine May'),
+ "In fact, delete all films by Elaine May"
+ );
+ cmp_ok(Film->search(Director => 'Elaine May'), '==',
+ 0, "0 Films by Elaine May");
+ SKIP: {
+ skip "No deprecated warnings from compat layer", 1;
+ is $deprecated, 1, "Got a deprecated warning";
+ }
+ }
+};
+is $@, '', "No problems with deletes";
+
+# Find all films which have a rating of NC-17.
+my @films = Film->search('Rating', 'NC-17');
+is(scalar @films, 1, ' search returns one film');
+is($films[0]->id, $gone->id, ' ... the correct one');
+
+# Find all films which were directed by Bob
+ at films = Film->search_like('Director', 'Bob %');
+is(scalar @films, 3, ' search_like returns 3 films');
+ok(
+ eq_array(
+ [ sort map { $_->id } @films ],
+ [ sort map { $_->id } $blrunner_dc, $gone, $blrunner ]
+ ),
+ 'the correct ones'
+);
+
+# Find Ridley Scott films which don't have vomit
+ at films =
+ Film->search(numExplodingSheep => undef, Director => 'Bob Ridley Scott');
+is(scalar @films, 2, ' search where attribute is null returns 2 films');
+ok(
+ eq_array(
+ [ sort map { $_->id } @films ],
+ [ sort map { $_->id } $blrunner_dc, $blrunner ]
+ ),
+ 'the correct ones'
+);
+
+# Test that a disconnect doesnt harm anything.
+{
+ # SQLite is loud on disconnect/reconnect.
+ # This is solved in DBIC but not in ContextualFetch
+ local $SIG{__WARN__} = sub {
+ warn @_ unless $_[0] =~
+ /active statement handles|inactive database handle/;
+ };
+
+ Film->db_Main->disconnect;
+ @films = Film->search({ Rating => 'NC-17' });
+ ok(@films == 1 && $films[0]->id eq $gone->id, 'auto reconnection');
+
+ # Test discard_changes().
+ my $orig_director = $btaste->Director;
+ $btaste->Director('Lenny Bruce');
+ is($btaste->Director, 'Lenny Bruce', 'set new Director');
+ $btaste->discard_changes;
+ is($btaste->Director, $orig_director, 'discard_changes()');
+}
+
+SKIP: {
+ skip "ActiveState perl produces additional warnings", 3
+ if ($^O eq 'MSWin32');
+
+ Film->autoupdate(1);
+ my $btaste2 = Film->retrieve($btaste->id);
+ $btaste->NumExplodingSheep(18);
+ my @warnings;
+ local $SIG{__WARN__} = sub { push(@warnings, @_); };
+ {
+
+ # unhook from live object cache, so next one is not from cache
+ $btaste2->remove_from_object_index;
+ my $btaste3 = Film->retrieve($btaste->id);
+ is $btaste3->NumExplodingSheep, 18, "Class based AutoCommit";
+ $btaste3->autoupdate(0); # obj a/c should override class a/c
+ is @warnings, 0, "No warnings so far";
+ $btaste3->NumExplodingSheep(13);
+ }
+ is @warnings, 1, "DESTROY without update warns";
+ Film->autoupdate(0);
+}
+
+{ # update unchanged object
+ my $film = Film->retrieve($btaste->id);
+ my $retval = $film->update;
+ is $retval, -1, "Unchanged object";
+}
+
+{ # update deleted object
+ my $rt = "Royal Tenenbaums";
+ my $ten = Film->insert({ title => $rt, Rating => "R" });
+ $ten->rating(18);
+ Film->set_sql(drt => "DELETE FROM __TABLE__ WHERE title = ?");
+ Film->sql_drt->execute($rt);
+ my @films = Film->search({ title => $rt });
+ is @films, 0, "RT gone";
+ my $retval = eval { $ten->update };
+ like $@, qr/row not found/, "Update deleted object throws error";
+ $ten->discard_changes;
+}
+
+{
+ $btaste->autoupdate(1);
+ $btaste->NumExplodingSheep(32);
+ my $btaste2 = Film->retrieve($btaste->id);
+ is $btaste2->NumExplodingSheep, 32, "Object based AutoCommit";
+ $btaste->autoupdate(0);
+}
+
+# Primary key of 0
+{
+ my $zero = Film->insert({ Title => 0, Rating => "U" });
+ ok defined $zero, "Create 0";
+ ok my $ret = Film->retrieve(0), "Retrieve 0";
+ is $ret->Title, 0, "Title OK";
+ is $ret->Rating, "U", "Rating OK";
+}
+
+# Change after_update policy
+SKIP: {
+ skip "DBIx::Class compat doesn't handle the exists stuff quite right yet", 4;
+ my $bt = Film->retrieve($btaste->id);
+ $bt->autoupdate(1);
+
+ $bt->rating("17");
+ ok !$bt->_attribute_exists('rating'), "changed column needs reloaded";
+ ok $bt->_attribute_exists('title'), "but we still have the title";
+
+ # Don't re-load
+ $bt->add_trigger(
+ after_update => sub {
+ my ($self, %args) = @_;
+ my $discard_columns = $args{discard_columns};
+ @$discard_columns = qw/title/;
+ }
+ );
+ $bt->rating("19");
+ ok $bt->_attribute_exists('rating'), "changed column needs reloaded";
+ ok !$bt->_attribute_exists('title'), "but no longer have the title";
+}
+
+# Make sure that we can have other accessors. (Bugfix in 0.28)
+if (0) {
+ Film->mk_accessors(qw/temp1 temp2/);
+ my $blrunner = Film->retrieve('Bladerunner');
+ $blrunner->temp1("Foo");
+ $blrunner->NumExplodingSheep(2);
+ eval { $blrunner->update };
+ ok(!$@, "Other accessors");
+}
+
+# overloading
+{
+ is "$blrunner", "Bladerunner", "stringify";
+
+ ok(Film->columns(Stringify => 'rating'), "Can change stringify column");
+ is "$blrunner", "R", "And still stringifies correctly";
+
+ ok(
+ Film->columns(Stringify => qw/title rating/),
+ "Can have multiple stringify columns"
+ );
+ is "$blrunner", "Bladerunner/R", "And still stringifies correctly";
+
+ no warnings 'once';
+ local *Film::stringify_self = sub { join ":", $_[0]->title, $_[0]->rating };
+ is "$blrunner", "Bladerunner:R", "Provide stringify_self()";
+}
+
+{
+ {
+ ok my $byebye = DeletingFilm->insert(
+ {
+ Title => 'Goodbye Norma Jean',
+ Rating => 'PG',
+ }
+ ),
+ "Add a deleting Film";
+
+ isa_ok $byebye, 'DeletingFilm';
+ isa_ok $byebye, 'Film';
+ ok(Film->retrieve('Goodbye Norma Jean'), "Fetch it back again");
+ }
+ my $film;
+ eval { $film = Film->retrieve('Goodbye Norma Jean') };
+ ok !$film, "It destroys itself";
+}
+
+SKIP: {
+ skip "Caching has been removed", 5
+ if Film->isa("DBIx::Class::CDBICompat::NoObjectIndex");
+
+ # my bad taste is your bad taste
+ my $btaste = Film->retrieve('Bad Taste');
+ my $btaste2 = Film->retrieve('Bad Taste');
+ is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste2),
+ "Retrieving twice gives ref to same object";
+
+ my ($btaste5) = Film->search(title=>'Bad Taste');
+ is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste5),
+ "Searching also gives ref to same object";
+
+ $btaste2->remove_from_object_index;
+ my $btaste3 = Film->retrieve('Bad Taste');
+ isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste3),
+ "Removing from object_index and retrieving again gives new object";
+
+ $btaste3->clear_object_index;
+ my $btaste4 = Film->retrieve('Bad Taste');
+ isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste4),
+ "Clearing cache and retrieving again gives new object";
+
+ $btaste=Film->insert({
+ Title => 'Bad Taste 2',
+ Director => 'Peter Jackson',
+ Rating => 'R',
+ NumExplodingSheep => 2,
+ });
+ $btaste2 = Film->retrieve('Bad Taste 2');
+ is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste2),
+ "Creating and retrieving gives ref to same object";
+
+}
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/02-Film.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/03-subclassing.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/03-subclassing.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/03-subclassing.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/03-subclassing.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,31 @@
+use strict;
+use Test::More;
+
+#----------------------------------------------------------------------
+# Make sure subclasses can be themselves subclassed
+#----------------------------------------------------------------------
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 6);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+INIT { @Film::Threat::ISA = qw/Film/; }
+
+ok(Film::Threat->db_Main->ping, 'subclass db_Main()');
+is_deeply [ sort Film::Threat->columns ], [ sort Film->columns ],
+ 'has the same columns';
+
+my $bt = Film->create_test_film;
+ok my $btaste = Film::Threat->retrieve('Bad Taste'), "subclass retrieve";
+isa_ok $btaste => "Film::Threat";
+isa_ok $btaste => "Film";
+is $btaste->Title, 'Bad Taste', 'subclass get()';
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/03-subclassing.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/04-lazy.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/04-lazy.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/04-lazy.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/04-lazy.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,184 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+use Test::Warn;
+
+#----------------------------------------------------------------------
+# Test lazy loading
+#----------------------------------------------------------------------
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 36);
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+ use Lazy;
+}
+
+is_deeply [ Lazy->columns('Primary') ], [qw/this/], "Pri";
+is_deeply [ sort Lazy->columns('Essential') ], [qw/opop this/], "Essential";
+is_deeply [ sort Lazy->columns('things') ], [qw/that this/], "things";
+is_deeply [ sort Lazy->columns('horizon') ], [qw/eep orp/], "horizon";
+is_deeply [ sort Lazy->columns('vertical') ], [qw/oop opop/], "vertical";
+is_deeply [ sort Lazy->columns('All') ], [qw/eep oop opop orp that this/], "All";
+
+{
+ my @groups = Lazy->__grouper->groups_for(Lazy->find_column('this'));
+ is_deeply [ sort @groups ], [sort qw/things Essential Primary/], "this (@groups)";
+}
+
+{
+ my @groups = Lazy->__grouper->groups_for(Lazy->find_column('that'));
+ is_deeply \@groups, [qw/things/], "that (@groups)";
+}
+
+Lazy->create({ this => 1, that => 2, oop => 3, opop => 4, eep => 5 });
+
+ok(my $obj = Lazy->retrieve(1), 'Retrieve by Primary');
+ok($obj->_attribute_exists('this'), "Gets primary");
+ok($obj->_attribute_exists('opop'), "Gets other essential");
+ok(!$obj->_attribute_exists('that'), "But other things");
+ok(!$obj->_attribute_exists('eep'), " nor eep");
+ok(!$obj->_attribute_exists('orp'), " nor orp");
+ok(!$obj->_attribute_exists('oop'), " nor oop");
+
+ok(my $val = $obj->eep, 'Fetch eep');
+ok($obj->_attribute_exists('orp'), 'Gets orp too');
+ok(!$obj->_attribute_exists('oop'), 'But still not oop');
+ok(!$obj->_attribute_exists('that'), 'nor that');
+
+{
+ Lazy->columns(All => qw/this that eep orp oop opop/);
+ ok(my $obj = Lazy->retrieve(1), 'Retrieve by Primary');
+ ok !$obj->_attribute_exists('oop'), " Don't have oop";
+ my $null = $obj->eep;
+ ok !$obj->_attribute_exists('oop'),
+ " Don't have oop - even after getting eep";
+}
+
+# Test contructor breaking.
+
+eval { # Need a hashref
+ Lazy->create(this => 10, that => 20, oop => 30, opop => 40, eep => 50);
+};
+ok($@, $@);
+
+eval { # False column
+ Lazy->create({ this => 10, that => 20, theother => 30 });
+};
+ok($@, $@);
+
+eval { # Multiple false columns
+ Lazy->create({ this => 10, that => 20, theother => 30, andanother => 40 });
+};
+ok($@, $@);
+
+
+warning_is {
+ Lazy->columns( TEMP => qw(that) );
+} "Declaring column that as TEMP but it already exists";
+
+# Test that create() and update() throws out columns that changed
+{
+ my $l = Lazy->create({
+ this => 99,
+ that => 2,
+ oop => 3,
+ opop => 4,
+ });
+
+ ok $l->db_Main->do(qq{
+ UPDATE @{[ $l->table ]}
+ SET oop = ?
+ WHERE this = ?
+ }, undef, 87, $l->this);
+
+ is $l->oop, 87;
+
+ $l->oop(32);
+ $l->update;
+
+ ok $l->db_Main->do(qq{
+ UPDATE @{[ $l->table ]}
+ SET oop = ?
+ WHERE this = ?
+ }, undef, 23, $l->this);
+
+ is $l->oop, 23;
+
+ $l->delete;
+}
+
+
+# Now again for inflated values
+SKIP: {
+ skip "Requires Date::Simple", 5 unless eval "use Date::Simple; 1; ";
+ Lazy->has_a(
+ orp => 'Date::Simple',
+ inflate => sub { Date::Simple->new($_[0] . '-01-01') },
+ deflate => 'format'
+ );
+
+ my $l = Lazy->create({
+ this => 89,
+ that => 2,
+ orp => 1998,
+ });
+
+ ok $l->db_Main->do(qq{
+ UPDATE @{[ $l->table ]}
+ SET orp = ?
+ WHERE this = ?
+ }, undef, 1987, $l->this);
+
+ is $l->orp, '1987-01-01';
+
+ $l->orp(2007);
+ is $l->orp, '2007-01-01'; # make sure it's inflated
+ $l->update;
+
+ ok $l->db_Main->do(qq{
+ UPDATE @{[ $l->table ]}
+ SET orp = ?
+ WHERE this = ?
+ }, undef, 1942, $l->this);
+
+ is $l->orp, '1942-01-01';
+
+ $l->delete;
+}
+
+
+# Test that a deleted object works
+{
+ Lazy->search()->delete_all;
+ my $l = Lazy->create({
+ this => 99,
+ that => 2,
+ oop => 3,
+ opop => 4,
+ });
+
+ # Delete the object without it knowing.
+ Lazy->db_Main->do(qq[
+ DELETE
+ FROM @{[ Lazy->table ]}
+ WHERE this = 99
+ ]);
+
+ $l->eep;
+
+ # The problem was when an object had an inflated object
+ # loaded. _flesh() would set _column_data to undef and
+ # get_column() would think nothing was there.
+ # I'm too lazy to set up the proper inflation test.
+ ok !exists $l->{_column_data}{orp};
+}
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/04-lazy.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/06-hasa.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/06-hasa.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/06-hasa.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/06-hasa.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,170 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 24);
+}
+
+ at YA::Film::ISA = 'Film';
+
+#local $SIG{__WARN__} = sub { };
+
+INIT {
+ use lib 't/cdbi/testlib';
+ use Film;
+ use Director;
+}
+
+Film->create_test_film;
+ok(my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste");
+ok(my $pj = $btaste->Director, "Bad taste has_a() director");
+ok(!ref($pj), ' ... which is not an object');
+
+ok(Film->has_a('Director' => 'Director'), "Link Director table");
+ok(
+ Director->create(
+ {
+ Name => 'Peter Jackson',
+ Birthday => -300000000,
+ IsInsane => 1
+ }
+ ),
+ 'create Director'
+);
+
+$btaste = Film->retrieve('Bad Taste');
+
+ok($pj = $btaste->Director, "Bad taste now has_a() director");
+isa_ok($pj => 'Director');
+is($pj->id, 'Peter Jackson', ' ... and is the correct director');
+
+# Oh no! Its Peter Jacksons even twin, Skippy! Born one minute after him.
+my $sj = Director->create(
+ {
+ Name => 'Skippy Jackson',
+ Birthday => (-300000000 + 60),
+ IsInsane => 1,
+ }
+);
+
+is($sj->id, 'Skippy Jackson', 'We have a new director');
+
+Film->has_a(CoDirector => 'Director');
+
+$btaste->CoDirector($sj);
+$btaste->update;
+is($btaste->CoDirector->Name, 'Skippy Jackson', 'He co-directed');
+is(
+ $btaste->Director->Name,
+ 'Peter Jackson',
+ "Didnt interfere with each other"
+);
+
+{ # Ensure search can take an object
+ my @films = Film->search(Director => $pj);
+ is @films, 1, "1 Film directed by $pj";
+ is $films[0]->id, "Bad Taste", "Bad Taste";
+}
+
+inheriting_hasa();
+
+{
+
+ # Skippy directs a film and Peter helps!
+ $sj = Director->retrieve('Skippy Jackson');
+ $pj = Director->retrieve('Peter Jackson');
+
+ fail_with_bad_object($sj, $btaste);
+ taste_bad($sj, $pj);
+}
+
+sub inheriting_hasa {
+ my $btaste = YA::Film->retrieve('Bad Taste');
+ is(ref($btaste->Director), 'Director', 'inheriting has_a()');
+ is(ref($btaste->CoDirector), 'Director', 'inheriting has_a()');
+ is($btaste->CoDirector->Name, 'Skippy Jackson', ' ... correctly');
+}
+
+sub taste_bad {
+ my ($dir, $codir) = @_;
+ my $tastes_bad = YA::Film->create(
+ {
+ Title => 'Tastes Bad',
+ Director => $dir,
+ CoDirector => $codir,
+ Rating => 'R',
+ NumExplodingSheep => 23
+ }
+ );
+ is($tastes_bad->_Director_accessor, 'Skippy Jackson', 'Director_accessor');
+ is($tastes_bad->Director->Name, 'Skippy Jackson', 'Director');
+ is($tastes_bad->CoDirector->Name, 'Peter Jackson', 'CoDirector');
+ is(
+ $tastes_bad->_CoDirector_accessor,
+ 'Peter Jackson',
+ 'CoDirector_accessor'
+ );
+}
+
+sub fail_with_bad_object {
+ my ($dir, $codir) = @_;
+ eval {
+ YA::Film->create(
+ {
+ Title => 'Tastes Bad',
+ Director => $dir,
+ CoDirector => $codir,
+ Rating => 'R',
+ NumExplodingSheep => 23
+ }
+ );
+ };
+ ok $@, $@;
+}
+
+package Foo;
+use base 'CDBase';
+__PACKAGE__->table('foo');
+__PACKAGE__->columns('All' => qw/ id fav /);
+# fav is a film
+__PACKAGE__->db_Main->do( qq{
+ CREATE TABLE foo (
+ id INTEGER,
+ fav VARCHAR(255)
+ )
+});
+
+
+package Bar;
+use base 'CDBase';
+__PACKAGE__->table('bar');
+__PACKAGE__->columns('All' => qw/ id fav /);
+# fav is a foo
+__PACKAGE__->db_Main->do( qq{
+ CREATE TABLE bar (
+ id INTEGER,
+ fav INTEGER
+ )
+});
+
+package main;
+Foo->has_a("fav" => "Film");
+Bar->has_a("fav" => "Foo");
+my $foo = Foo->create({ id => 6, fav => 'Bad Taste' });
+my $bar = Bar->create({ id => 2, fav => 6 });
+isa_ok($bar->fav, "Foo");
+isa_ok($foo->fav, "Film");
+
+{
+ my $foo;
+ Foo->add_trigger(after_create => sub { $foo = shift->fav });
+ my $gwh = Foo->create({ id => 93, fav => 'Good Will Hunting' });
+ isa_ok $foo, "Film", "Object in after_create trigger";
+}
+
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/06-hasa.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/08-inheritcols.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/08-inheritcols.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/08-inheritcols.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/08-inheritcols.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,25 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required')
+ : (tests=> 3);
+}
+
+package A;
+ at A::ISA = qw(DBIx::Class::CDBICompat);
+__PACKAGE__->columns(Primary => 'id');
+
+package A::B;
+ at A::B::ISA = 'A';
+__PACKAGE__->columns(All => qw(id b1));
+
+package A::C;
+ at A::C::ISA = 'A';
+__PACKAGE__->columns(All => qw(id c1 c2 c3));
+
+package main;
+is join (' ', sort A->columns), 'id', "A columns";
+is join (' ', sort A::B->columns), 'b1 id', "A::B columns";
+is join (' ', sort A::C->columns), 'c1 c2 c3 id', "A::C columns";
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/08-inheritcols.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/09-has_many.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/09-has_many.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/09-has_many.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/09-has_many.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,127 @@
+use strict;
+use Test::More;
+
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => 'Class::Trigger and DBIx::ContextualFetch required' if $@;
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 31);
+}
+
+
+use lib 't/cdbi/testlib';
+use Film;
+use Actor;
+Actor->has_a(Film => 'Film');
+Film->has_many(actors => 'Actor', { order_by => 'name' });
+is(Actor->primary_column, 'id', "Actor primary OK");
+
+ok(Actor->can('Salary'), "Actor table set-up OK");
+ok(Film->can('actors'), " and have a suitable method in Film");
+
+Film->create_test_film;
+
+ok(my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste");
+
+ok(
+ my $pvj = Actor->create(
+ {
+ Name => 'Peter Vere-Jones',
+ Film => undef,
+ Salary => '30_000', # For a voice!
+ }
+ ),
+ 'create Actor'
+);
+is $pvj->Name, "Peter Vere-Jones", "PVJ name ok";
+is $pvj->Film, undef, "No film";
+ok $pvj->set_Film($btaste), "Set film";
+$pvj->update;
+is $pvj->Film->id, $btaste->id, "Now film";
+{
+ my @actors = $btaste->actors;
+ is(@actors, 1, "Bad taste has one actor");
+ is($actors[0]->Name, $pvj->Name, " - the correct one");
+}
+
+my %pj_data = (
+ Name => 'Peter Jackson',
+ Salary => '0', # it's a labour of love
+);
+
+eval { my $pj = Film->add_to_actors(\%pj_data) };
+like $@, qr/class/, "add_to_actors must be object method";
+
+eval { my $pj = $btaste->add_to_actors(%pj_data) };
+like $@, qr/needs/, "add_to_actors takes hash";
+
+ok(
+ my $pj = $btaste->add_to_actors(
+ {
+ Name => 'Peter Jackson',
+ Salary => '0', # it's a labour of love
+ }
+ ),
+ 'add_to_actors'
+);
+is $pj->Name, "Peter Jackson", "PJ ok";
+is $pvj->Name, "Peter Vere-Jones", "PVJ still ok";
+
+{
+ my @actors = $btaste->actors;
+ is @actors, 2, " - so now we have 2";
+ is $actors[0]->Name, $pj->Name, "PJ first";
+ is $actors[1]->Name, $pvj->Name, "PVJ first";
+}
+
+eval {
+ my @actors = $btaste->actors(Name => $pj->Name);
+ is @actors, 1, "One actor from restricted (sorted) has_many";
+ is $actors[0]->Name, $pj->Name, "It's PJ";
+};
+is $@, '', "No errors";
+
+my $as = Actor->create(
+ {
+ Name => 'Arnold Schwarzenegger',
+ Film => 'Terminator 2',
+ Salary => '15_000_000'
+ }
+);
+
+eval { $btaste->actors($pj, $pvj, $as) };
+ok $@, $@;
+is($btaste->actors, 2, " - so we still only have 2 actors");
+
+my @bta_before = Actor->search(Film => 'Bad Taste');
+is(@bta_before, 2, "We have 2 actors in bad taste");
+ok($btaste->delete, "Delete bad taste");
+my @bta_after = Actor->search(Film => 'Bad Taste');
+is(@bta_after, 0, " - after deleting there are no actors");
+
+# While we're here, make sure Actors have unreadable mutators and
+# unwritable accessors
+
+eval { $as->Name("Paul Reubens") };
+ok $@, $@;
+eval { my $name = $as->set_Name };
+ok $@, $@;
+
+is($as->Name, 'Arnold Schwarzenegger', "Arnie's still Arnie");
+
+
+# Test infering of the foreign key of a has_many from an existing has_a
+{
+ use Thing;
+ use OtherThing;
+
+ Thing->has_a(that_thing => "OtherThing");
+ OtherThing->has_many(things => "Thing");
+
+ my $other_thing = OtherThing->create({ id => 1 });
+ Thing->create({ id => 1, that_thing => $other_thing });
+ Thing->create({ id => 2, that_thing => $other_thing });
+
+ is_deeply [sort map { $_->id } $other_thing->things], [1,2];
+}
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/09-has_many.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/11-triggers.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/11-triggers.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/11-triggers.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/11-triggers.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,66 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 13);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+sub create_trigger2 { ::ok(1, "Running create trigger 2"); }
+sub delete_trigger { ::ok(1, "Deleting " . shift->Title) }
+
+sub pre_up_trigger {
+ $_[0]->_attribute_set(numexplodingsheep => 1);
+ ::ok(1, "Running pre-update trigger");
+}
+sub pst_up_trigger { ::ok(1, "Running post-update trigger"); }
+
+sub default_rating { $_[0]->Rating(15); }
+
+Film->add_trigger(before_create => \&default_rating);
+Film->add_trigger(after_create => \&create_trigger2);
+Film->add_trigger(after_delete => \&delete_trigger);
+Film->add_trigger(before_update => \&pre_up_trigger);
+Film->add_trigger(after_update => \&pst_up_trigger);
+
+ok(
+ my $ver = Film->create({
+ title => 'La Double Vie De Veronique',
+ director => 'Kryzstof Kieslowski',
+
+ # rating => '15',
+ numexplodingsheep => 0,
+ }
+ ),
+ "Create Veronique"
+);
+
+is $ver->Rating, 15, "Default rating";
+is $ver->NumExplodingSheep, 0, "Original sheep count";
+ok $ver->Rating('12') && $ver->update, "Change the rating";
+is $ver->NumExplodingSheep, 1, "Updated object's sheep count";
+is + (
+ $ver->db_Main->selectall_arrayref(
+ 'SELECT numexplodingsheep FROM '
+ . $ver->table
+ . ' WHERE '
+ . $ver->primary_column . ' = '
+ . $ver->db_Main->quote($ver->id))
+)->[0]->[0], 1, "Updated database's sheep count";
+ok $ver->delete, "Delete";
+
+{
+ Film->add_trigger(before_create => sub {
+ my $self = shift;
+ ok !$self->_attribute_exists('title'), "PK doesn't auto-vivify";
+ });
+ Film->create({director => "Me"});
+}
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/11-triggers.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/12-filter.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/12-filter.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/12-filter.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/12-filter.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,181 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 50);
+}
+
+use lib 't/cdbi/testlib';
+use Actor;
+use Film;
+Film->has_many(actors => 'Actor');
+Actor->has_a('film' => 'Film');
+Actor->add_constructor(double_search => 'name = ? AND salary = ?');
+
+my $film = Film->create({ Title => 'MY Film' });
+my $film2 = Film->create({ Title => 'Another Film' });
+
+my @act = (
+ Actor->create(
+ {
+ name => 'Actor 1',
+ film => $film,
+ salary => 10,
+ }
+ ),
+ Actor->create(
+ {
+ name => 'Actor 2',
+ film => $film,
+ salary => 20,
+ }
+ ),
+ Actor->create(
+ {
+ name => 'Actor 3',
+ film => $film,
+ salary => 30,
+ }
+ ),
+ Actor->create(
+ {
+ name => 'Actor 4',
+ film => $film2,
+ salary => 50,
+ }
+ ),
+);
+
+eval {
+ my @actors = $film->actors(name => 'Actor 1');
+ is @actors, 1, "Got one actor from restricted has_many";
+ is $actors[0]->name, "Actor 1", "Correct name";
+};
+is $@, '', "No errors";
+
+{
+ my @actors = Actor->double_search("Actor 1", 10);
+ is @actors, 1, "Got one actor";
+ is $actors[0]->name, "Actor 1", "Correct name";
+}
+
+{
+ ok my @actors = Actor->salary_between(0, 100), "Range 0 - 100";
+ is @actors, 4, "Got all";
+}
+
+{
+ my @actors = Actor->salary_between(100, 200);
+ is @actors, 0, "None in Range 100 - 200";
+}
+
+{
+ ok my @actors = Actor->salary_between(0, 10), "Range 0 - 10";
+ is @actors, 1, "Got 1";
+ is $actors[0]->name, $act[0]->name, "Actor 1";
+}
+
+{
+ ok my @actors = Actor->salary_between(20, 30), "Range 20 - 20";
+ @actors = sort { $a->salary <=> $b->salary } @actors;
+ is @actors, 2, "Got 2";
+ is $actors[0]->name, $act[1]->name, "Actor 2";
+ is $actors[1]->name, $act[2]->name, "and Actor 3";
+}
+
+{
+ ok my @actors = Actor->search(Film => $film), "Search by object";
+ is @actors, 3, "3 actors in film 1";
+}
+
+#----------------------------------------------------------------------
+# Iterators
+#----------------------------------------------------------------------
+
+my $it_class = 'DBIx::Class::ResultSet';
+
+sub test_normal_iterator {
+ my $it = $film->actors;
+ isa_ok $it, $it_class;
+ is $it->count, 3, " - with 3 elements";
+ my $i = 0;
+ while (my $film = $it->next) {
+ is $film->name, $act[ $i++ ]->name, "Get $i";
+ }
+ ok !$it->next, "No more";
+ is $it->first->name, $act[0]->name, "Get first";
+}
+
+test_normal_iterator;
+{
+ Film->has_many(actor_ids => [ Actor => 'id' ]);
+ my $it = $film->actor_ids;
+ isa_ok $it, $it_class;
+ is $it->count, 3, " - with 3 elements";
+ my $i = 0;
+ while (my $film_id = $it->next) {
+ is $film_id, $act[ $i++ ]->id, "Get id $i";
+ }
+ ok !$it->next, "No more";
+ is $it->first, $act[0]->id, "Get first";
+}
+
+# make sure nothing gets clobbered;
+test_normal_iterator;
+
+SKIP: {
+ #skip "dbic iterators don't support slice yet", 12;
+
+
+{
+ my @acts = $film->actors->slice(1, 2);
+ is @acts, 2, "Slice gives 2 actor";
+ is $acts[0]->name, "Actor 2", "Actor 2";
+ is $acts[1]->name, "Actor 3", "and actor 3";
+}
+
+{
+ my @acts = $film->actors->slice(1);
+ is @acts, 1, "Slice of 1 actor";
+ is $acts[0]->name, "Actor 2", "Actor 2";
+}
+
+{
+ my @acts = $film->actors->slice(2, 8);
+ is @acts, 1, "Slice off the end";
+ is $acts[0]->name, "Actor 3", "Gets last actor only";
+}
+
+package Class::DBI::My::Iterator;
+
+use vars qw/@ISA/;
+
+ at ISA = ($it_class);
+
+sub slice { qw/fred barney/ }
+
+package main;
+
+Actor->iterator_class('Class::DBI::My::Iterator');
+
+delete $film->{related_resultsets};
+
+{
+ my @acts = $film->actors->slice(1, 2);
+ is @acts, 2, "Slice gives 2 results";
+ ok eq_set(\@acts, [qw/fred barney/]), "Fred and Barney";
+
+ ok $film->actors->delete_all, "Can delete via iterator";
+ is $film->actors, 0, "no actors left";
+
+ eval { $film->actors->delete_all };
+ is $@, '', "Deleting again does no harm";
+}
+
+} # end SKIP block
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/12-filter.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/13-constraint.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/13-constraint.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/13-constraint.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/13-constraint.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,121 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 23);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+sub valid_rating {
+ my $value = shift;
+ my $ok = grep $value eq $_, qw/U Uc PG 12 15 18/;
+ return $ok;
+}
+
+Film->add_constraint('valid rating', Rating => \&valid_rating);
+
+my %info = (
+ Title => 'La Double Vie De Veronique',
+ Director => 'Kryzstof Kieslowski',
+ Rating => '18',
+);
+
+{
+ local $info{Title} = "nonsense";
+ local $info{Rating} = 19;
+ eval { Film->create({%info}) };
+ ok $@, $@;
+ ok !Film->retrieve($info{Title}), "No film created";
+ is(Film->retrieve_all, 0, "So no films");
+}
+
+ok(my $ver = Film->create({%info}), "Can create with valid rating");
+is $ver->Rating, 18, "Rating 18";
+
+ok $ver->Rating(12), "Change to 12";
+ok $ver->update, "And update";
+is $ver->Rating, 12, "Rating now 12";
+
+eval {
+ $ver->Rating(13);
+ $ver->update;
+};
+ok $@, $@;
+is $ver->Rating, 12, "Rating still 12";
+ok $ver->delete, "Delete";
+
+# this threw an infinite loop in old versions
+Film->add_constraint('valid director', Director => sub { 1 });
+my $fred = Film->create({ Rating => '12' });
+
+# this test is a bit problematical because we don't supply a primary key
+# to the create() and the table doesn't use auto_increment or a sequence.
+ok $fred, "Got fred";
+
+{
+ ok +Film->constrain_column(rating => [qw/U PG 12 15 19/]),
+ "constraint_column";
+ my $narrower = eval { Film->create({ Rating => 'Uc' }) };
+ like $@, qr/fails.*constraint/, "Fails listref constraint";
+ my $ok = eval { Film->create({ Rating => 'U' }) };
+ is $@, '', "Can create with rating U";
+ SKIP: {
+ skip "No column objects", 2;
+ ok +Film->find_column('rating')->is_constrained, "Rating is constrained";
+ ok +Film->find_column('director')->is_constrained, "Director is not";
+ }
+}
+
+{
+ ok +Film->constrain_column(title => qr/The/), "constraint_column";
+ my $inferno = eval { Film->create({ Title => 'Towering Infero' }) };
+ like $@, qr/fails.*constraint/, "Can't create towering inferno";
+ my $the_inferno = eval { Film->create({ Title => 'The Towering Infero' }) };
+ is $@, '', "But can create THE towering inferno";
+}
+
+{
+
+ sub Film::_constrain_by_untaint {
+ my ($class, $col, $string, $type) = @_;
+ $class->add_constraint(
+ untaint => $col => sub {
+ my ($value, $self, $column_name, $changing) = @_;
+ $value eq "today" ? $changing->{$column_name} = "2001-03-03" : 0;
+ }
+ );
+ }
+ eval { Film->constrain_column(codirector => Untaint => 'date') };
+ is $@, '', 'Can constrain with untaint';
+ my $freeaa =
+ eval { Film->create({ title => "The Freaa", codirector => 'today' }) };
+ TODO: {
+ local $TODO = "no idea what this is supposed to do";
+ is $@, '', "Can create codirector";
+ is $freeaa && $freeaa->codirector, '2001-03-03', "Set the codirector";
+ }
+}
+
+__DATA__
+
+use CGI::Untaint;
+
+sub _constrain_by_untaint {
+ my ($class, $col, $string, $type) = @_;
+ $class->add_constraint(untaint => $col => sub {
+ my ($value, $self, $column_name, $changing) = @_;
+ my $h = CGI::Untaint->new({ %$changing });
+ return unless my $val = $h->extract("-as_$type" => $column_name);
+ $changing->{$column_name} = $val;
+ return 1;
+ });
+}
+
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/13-constraint.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/14-might_have.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/14-might_have.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/14-might_have.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/14-might_have.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,83 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 22);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+use Blurb;
+
+is(Blurb->primary_column, "title", "Primary key of Blurb = title");
+is_deeply [ Blurb->columns('Essential') ], [ Blurb->primary_column ], "Essential = Primary";
+
+eval { Blurb->retrieve(10) };
+is $@, "", "No problem retrieving non-existent Blurb";
+
+Film->might_have(info => Blurb => qw/blurb/);
+
+Film->create_test_film;
+
+{
+ ok my $bt = Film->retrieve('Bad Taste'), "Get Film";
+ isa_ok $bt, "Film";
+ is $bt->info, undef, "No blurb yet";
+ # bug where we couldn't write a class with a might_have that didn't_have
+ $bt->rating(16);
+ eval { $bt->update };
+ is $@, '', "No problems updating when don't have";
+ is $bt->rating, 16, "Updated OK";
+
+ is $bt->blurb, undef, "Bad taste has no blurb";
+ $bt->blurb("Wibble bar");
+ $bt->update;
+ is $bt->blurb, "Wibble bar", "And we can write the info";
+}
+
+{
+ my $bt = Film->retrieve('Bad Taste');
+ my $info = $bt->info;
+ isa_ok $info, 'Blurb';
+
+ is $bt->blurb, $info->blurb, "Blurb is the same as fetching the long way";
+ ok $bt->blurb("New blurb"), "We can set the blurb";
+ $bt->update;
+ is $bt->blurb, $info->blurb, "Blurb has been set";
+
+ $bt->rating(18);
+ eval { $bt->update };
+ is $@, '', "No problems updating when do have";
+ is $bt->rating, 18, "Updated OK";
+
+ # cascade delete?
+ {
+ my $blurb = Blurb->retrieve('Bad Taste');
+ isa_ok $blurb => "Blurb";
+ $bt->delete;
+ $blurb = Blurb->retrieve('Bad Taste');
+ is $blurb, undef, "Blurb has gone";
+ }
+
+}
+
+{
+ my $host = Film->create({ title => "Gwoemul" });
+ $host->blurb("Monsters are real.");
+ my $info = $host->info;
+ is $info->blurb, "Monsters are real.";
+
+ $host->discard_changes;
+ is $host->info->id, $info->id,
+ 'relationships still valid after discard_changes';
+
+ ok $host->info->delete;
+ $host->discard_changes;
+ ok !$host->info, 'relationships rechecked after discard_changes';
+}
\ No newline at end of file
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/14-might_have.t
___________________________________________________________________
Name: svn:mergeinfo
+
Added: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/15-accessor.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/15-accessor.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/15-accessor.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,268 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 75);
+}
+
+INIT {
+ #local $SIG{__WARN__} =
+ #sub { like $_[0], qr/clashes with built-in method/, $_[0] };
+ use lib 't/cdbi/testlib';
+ require Film;
+ require Actor;
+ require Director;
+
+ Actor->has_a(film => 'Film');
+ Film->has_a(director => 'Director');
+
+ sub Class::DBI::sheep { ok 0; }
+}
+
+sub Film::mutator_name {
+ my ($class, $col) = @_;
+ return "set_sheep" if lc $col eq "numexplodingsheep";
+ return $col;
+}
+
+sub Film::accessor_name {
+ my ($class, $col) = @_;
+ return "sheep" if lc $col eq "numexplodingsheep";
+ return $col;
+}
+
+sub Actor::accessor_name_for {
+ my ($class, $col) = @_;
+ return "movie" if lc $col eq "film";
+ return $col;
+}
+
+# This is a class with accessor_name_for() but no corresponding mutator_name_for()
+sub Director::accessor_name_for {
+ my($class, $col) = @_;
+ return "nutty_as_a_fruitcake" if lc $col eq "isinsane";
+ return $col;
+}
+
+my $data = {
+ Title => 'Bad Taste',
+ Director => 'Peter Jackson',
+ Rating => 'R',
+};
+
+eval {
+ my $data = { %$data };
+ $data->{NumExplodingSheep} = 1;
+ ok my $bt = Film->create($data), "Modified accessor - with column name";
+ isa_ok $bt, "Film";
+ is $bt->sheep, 1, 'sheep bursting violently';
+};
+is $@, '', "No errors";
+
+eval {
+ my $data = { %$data };
+ $data->{sheep} = 2;
+ ok my $bt = Film->create($data), "Modified accessor - with accessor";
+ isa_ok $bt, "Film";
+ is $bt->sheep, 2, 'sheep bursting violently';
+};
+is $@, '', "No errors";
+
+eval {
+ my $data = { %$data };
+ $data->{NumExplodingSheep} = 1;
+ ok my $bt = Film->find_or_create($data),
+ "find_or_create Modified accessor - find with column name";
+ isa_ok $bt, "Film";
+ is $bt->sheep, 1, 'sheep bursting violently';
+};
+is $@, '', "No errors";
+
+eval {
+ my $data = { %$data };
+ $data->{sheep} = 1;
+ ok my $bt = Film->find_or_create($data),
+ "find_or_create Modified accessor - find with accessor";
+ isa_ok $bt, "Film";
+ is $bt->sheep, 1, 'sheep bursting violently';
+};
+is $@, '', "No errors";
+
+TODO: { local $TODO = 'TODOifying failing tests, waiting for Schwern'; ok (1, 'remove me');
+eval {
+ my $data = { %$data };
+ $data->{NumExplodingSheep} = 3;
+ ok my $bt = Film->find_or_create($data),
+ "find_or_create Modified accessor - create with column name";
+ isa_ok $bt, "Film";
+ is $bt->sheep, 3, 'sheep bursting violently';
+};
+is $@, '', "No errors";
+
+eval {
+ my $data = { %$data };
+ $data->{sheep} = 4;
+ ok my $bt = Film->find_or_create($data),
+ "find_or_create Modified accessor - create with accessor";
+ isa_ok $bt, "Film";
+ is $bt->sheep, 4, 'sheep bursting violently';
+};
+is $@, '', "No errors";
+
+eval {
+ my @film = Film->search({ sheep => 1 });
+ is @film, 2, "Can search with modified accessor";
+};
+is $@, '', "No errors";
+
+}
+
+{
+
+ eval {
+ local $data->{set_sheep} = 1;
+ ok my $bt = Film->create($data), "Modified mutator - with mutator";
+ isa_ok $bt, "Film";
+ };
+ is $@, '', "No errors";
+
+ eval {
+ local $data->{NumExplodingSheep} = 1;
+ ok my $bt = Film->create($data), "Modified mutator - with column name";
+ isa_ok $bt, "Film";
+ };
+ is $@, '', "No errors";
+
+ eval {
+ local $data->{sheep} = 1;
+ ok my $bt = Film->create($data), "Modified mutator - with accessor";
+ isa_ok $bt, "Film";
+ };
+ is $@, '', "No errors";
+
+}
+
+{
+ my $p_data = {
+ name => 'Peter Jackson',
+ film => 'Bad Taste',
+ };
+ my $bt = Film->create($data);
+ my $ac = Actor->create($p_data);
+
+ ok !eval { my $f = $ac->film; 1 };
+ like $@, qr/film/, "no hasa film";
+
+ eval {
+ local $SIG{__WARN__} = sub {
+ warn @_ unless $_[0] =~ /Query returned more than one row/;
+ };
+ ok my $f = $ac->movie, "hasa movie";
+ isa_ok $f, "Film";
+ is $f->id, $bt->id, " - Bad Taste";
+ };
+ is $@, '', "No errors";
+
+ {
+ local $data->{Title} = "Another film";
+ my $film = Film->create($data);
+
+ eval { $ac->film($film) };
+ ok $@, $@;
+
+ eval { $ac->movie($film) };
+ ok $@, $@;
+
+ eval {
+ ok $ac->set_film($film), "Set movie through hasa";
+ $ac->update;
+ ok my $f = $ac->movie, "hasa movie";
+ isa_ok $f, "Film";
+ is $f->id, $film->id, " - Another Film";
+ };
+ is $@, '', "No problem";
+ }
+
+}
+
+
+# Make sure a class with an accessor_name() method has a similar mutator.
+{
+ my $aki = Director->create({
+ name => "Aki Kaurismaki",
+ });
+
+ $aki->nutty_as_a_fruitcake(1);
+ is $aki->nutty_as_a_fruitcake, 1,
+ "a custom accessor without a custom mutator is setable";
+ $aki->update;
+}
+
+{
+ Film->columns(TEMP => qw/nonpersistent/);
+ ok(Film->find_column('nonpersistent'), "nonpersistent is a column");
+ ok(!Film->has_real_column('nonpersistent'), " - but it's not real");
+
+ {
+ my $film = Film->create({ Title => "Veronique", nonpersistent => 42 });
+ is $film->title, "Veronique", "Title set OK";
+ is $film->nonpersistent, 42, "As is non persistent value";
+ $film->remove_from_object_index;
+ ok $film = Film->retrieve('Veronique'), "Re-retrieve film";
+ is $film->title, "Veronique", "Title still OK";
+ is $film->nonpersistent, undef, "Non persistent value gone";
+ ok $film->nonpersistent(40), "Can set it";
+ is $film->nonpersistent, 40, "And it's there again";
+ ok $film->update, "Commit the film";
+ is $film->nonpersistent, 40, "And it's still there";
+ }
+}
+
+{
+ is_deeply(
+ [Actor->columns('Essential')],
+ [Actor->columns('Primary')],
+ "Actor has no specific essential columns"
+ );
+ ok(Actor->find_column('nonpersistent'), "nonpersistent is a column");
+ ok(!Actor->has_real_column('nonpersistent'), " - but it's not real");
+ my $pj = eval { Actor->search(name => "Peter Jackson")->first };
+ is $@, '', "no problems retrieving actors";
+ isa_ok $pj => "Actor";
+}
+
+{
+ Film->autoupdate(1);
+ my $naked = Film->create({ title => 'Naked' });
+ my $sandl = Film->create({ title => 'Secrets and Lies' });
+
+ my $rating = 1;
+ my $update_failure = sub {
+ my $obj = shift;
+ eval { $obj->rating($rating++) };
+ return $@ =~ /read only/;
+ };
+
+ ok !$update_failure->($naked), "Can update Naked";
+ ok $naked->make_read_only, "Make Naked read only";
+ ok $update_failure->($naked), "Can't update Naked any more";
+ ok !$update_failure->($sandl), "But can still update Secrets and Lies";
+ my $july4 = eval { Film->create({ title => "4 Days in July" }) };
+ isa_ok $july4 => "Film", "And can still create new films";
+
+ ok(Film->make_read_only, "Make all Films read only");
+ ok $update_failure->($naked), "Still can't update Naked";
+ ok $update_failure->($sandl), "And can't update S&L any more";
+ eval { $july4->delete };
+ like $@, qr/read only/, "And can't delete 4 Days in July";
+ my $abigail = eval { Film->create({ title => "Abigail's Party" }) };
+ like $@, qr/read only/, "Or create new films";
+
+ $sandl->discard_changes;
+}
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/15-accessor.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/16-reserved.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/16-reserved.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/16-reserved.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/16-reserved.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,36 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 5);
+}
+
+use lib 't/cdbi/testlib';
+require Film;
+require Order;
+
+Film->has_many(orders => 'Order');
+Order->has_a(film => 'Film');
+
+Film->create_test_film;
+
+my $film = Film->retrieve('Bad Taste');
+isa_ok $film => 'Film';
+
+$film->add_to_orders({ orders => 10 });
+
+my $bto = (Order->search(film => 'Bad Taste'))[0];
+isa_ok $bto => 'Order';
+is $bto->orders, 10, "Correct number of orders";
+
+
+my $infilm = $bto->film;
+isa_ok $infilm, "Film";
+
+is $infilm->id, $film->id, "Orders hasa Film";
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/16-reserved.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/18-has_a.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/18-has_a.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/18-has_a.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/18-has_a.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,240 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 41);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+use Director;
+ at YA::Film::ISA = 'Film';
+
+Film->create_test_film;
+
+ok my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste";
+ok my $pj = $btaste->Director, "Bad taste has a director";
+ok !ref($pj), ' ... which is not an object';
+
+ok(Film->has_a('Director' => 'Director'), "Link Director table");
+ok(
+ Director->create({
+ Name => 'Peter Jackson',
+ Birthday => -300000000,
+ IsInsane => 1
+ }
+ ),
+ 'create Director'
+);
+
+{
+ ok $btaste = Film->retrieve('Bad Taste'), "Reretrieve Bad Taste";
+ ok $pj = $btaste->Director, "Bad taste now hasa() director";
+ isa_ok $pj => 'Director';
+ {
+ no warnings qw(redefine once);
+ local *Ima::DBI::st::execute =
+ sub { ::fail("Shouldn't need to query db"); };
+ is $pj->id, 'Peter Jackson', 'ID already stored';
+ }
+ ok $pj->IsInsane, "But we know he's insane";
+}
+
+# Oh no! Its Peter Jacksons even twin, Skippy! Born one minute after him.
+my $sj = Director->create({
+ Name => 'Skippy Jackson',
+ Birthday => (-300000000 + 60),
+ IsInsane => 1,
+ });
+
+{
+ eval { $btaste->Director($btaste) };
+ like $@, qr/Director/, "Can't set film as director";
+ is $btaste->Director->id, $pj->id, "PJ still the director";
+
+ # drop from cache so that next retrieve() is from db
+ $btaste->remove_from_object_index;
+}
+
+{ # Still inflated after update
+ my $btaste = Film->retrieve('Bad Taste');
+ isa_ok $btaste->Director, "Director";
+ $btaste->numexplodingsheep(17);
+ $btaste->update;
+ isa_ok $btaste->Director, "Director";
+
+ $btaste->Director('Someone Else');
+ $btaste->update;
+ isa_ok $btaste->Director, "Director";
+ is $btaste->Director->id, "Someone Else", "Can change director";
+}
+
+is $sj->id, 'Skippy Jackson', 'Create new director - Skippy';
+Film->has_a('CoDirector' => 'Director');
+{
+ eval { $btaste->CoDirector("Skippy Jackson") };
+ is $@, "", "Auto inflates";
+ isa_ok $btaste->CoDirector, "Director";
+ is $btaste->CoDirector->id, $sj->id, "To skippy";
+}
+
+$btaste->CoDirector($sj);
+$btaste->update;
+is($btaste->CoDirector->Name, 'Skippy Jackson', 'He co-directed');
+is(
+ $btaste->Director->Name,
+ 'Peter Jackson',
+ "Didnt interfere with each other"
+);
+
+{ # Inheriting hasa
+ my $btaste = YA::Film->retrieve('Bad Taste');
+ is(ref($btaste->Director), 'Director', 'inheriting hasa()');
+ is(ref($btaste->CoDirector), 'Director', 'inheriting hasa()');
+ is($btaste->CoDirector->Name, 'Skippy Jackson', ' ... correctly');
+}
+
+{
+ $sj = Director->retrieve('Skippy Jackson');
+ $pj = Director->retrieve('Peter Jackson');
+
+ my $fail;
+ eval {
+ $fail = YA::Film->create({
+ Title => 'Tastes Bad',
+ Director => $sj,
+ codirector => $btaste,
+ Rating => 'R',
+ NumExplodingSheep => 23
+ });
+ };
+ ok $@, "Can't have film as codirector: $@";
+ is $fail, undef, "We didn't get anything";
+
+ my $tastes_bad = YA::Film->create({
+ Title => 'Tastes Bad',
+ Director => $sj,
+ codirector => $pj,
+ Rating => 'R',
+ NumExplodingSheep => 23
+ });
+ is($tastes_bad->Director->Name, 'Skippy Jackson', 'Director');
+ is(
+ $tastes_bad->_director_accessor->Name,
+ 'Skippy Jackson',
+ 'director_accessor'
+ );
+ is($tastes_bad->codirector->Name, 'Peter Jackson', 'codirector');
+ is(
+ $tastes_bad->_codirector_accessor->Name,
+ 'Peter Jackson',
+ 'codirector_accessor'
+ );
+}
+
+SKIP: {
+ skip "Non-standard CDBI relationships not supported by compat", 9;
+ {
+
+ YA::Film->add_relationship_type(has_a => "YA::HasA");
+
+ package YA::HasA;
+ #use base 'Class::DBI::Relationship::HasA';
+
+ sub _inflator {
+ my $self = shift;
+ my $col = $self->accessor;
+ my $super = $self->SUPER::_inflator($col);
+
+ return $super
+ unless $col eq $self->class->find_column('Director');
+
+ return sub {
+ my $self = shift;
+ $self->_attribute_store($col, 'Ghostly Peter')
+ if $self->_attribute_exists($col)
+ and not defined $self->_attrs($col);
+ return &$super($self);
+ };
+ }
+ }
+ {
+
+ package Rating;
+
+ sub new {
+ my ($class, $mpaa, @details) = @_;
+ bless {
+ MPAA => $mpaa,
+ WHY => "@details"
+ }, $class;
+ }
+ sub mpaa { shift->{MPAA}; }
+ sub why { shift->{WHY}; }
+ }
+ local *Director::mapme = sub {
+ my ($class, $val) = @_;
+ $val =~ s/Skippy/Peter/;
+ $val;
+ };
+ no warnings 'once';
+ local *Director::sanity_check = sub { $_[0]->IsInsane ? undef: $_[0] };
+ YA::Film->has_a(
+ director => 'Director',
+ inflate => 'mapme',
+ deflate => 'sanity_check'
+ );
+ YA::Film->has_a(
+ rating => 'Rating',
+ inflate => sub {
+ my ($val, $parent) = @_;
+ my $sheep = $parent->find_column('NumexplodingSheep');
+ if ($parent->_attrs($sheep) || 0 > 20) {
+ return new Rating 'NC17', 'Graphic ovine violence';
+ } else {
+ return new Rating $val, 'Just because';
+ }
+ },
+ deflate => sub {
+ shift->mpaa;
+ });
+
+ my $tbad = YA::Film->retrieve('Tastes Bad');
+
+ isa_ok $tbad->Director, 'Director';
+ is $tbad->Director->Name, 'Peter Jackson', 'Director shuffle';
+ $tbad->Director('Skippy Jackson');
+ $tbad->update;
+ is $tbad->Director, 'Ghostly Peter', 'Sanity checked';
+
+ isa_ok $tbad->Rating, 'Rating';
+ is $tbad->Rating->mpaa, 'NC17', 'Rating bumped';
+ $tbad->Rating(new Rating 'NS17', 'Shaken sheep');
+ no warnings 'redefine';
+ local *Director::mapme = sub {
+ my ($class, $obj) = @_;
+ $obj->isa('Film') ? $obj->Director : $obj;
+ };
+
+ $pj->IsInsane(0);
+ $pj->update; # Hush warnings
+
+ ok $tbad->Director($btaste), 'Cross-class mapping';
+ is $tbad->Director, 'Peter Jackson', 'Yields PJ';
+ $tbad->update;
+
+ $tbad = Film->retrieve('Tastes Bad');
+ ok !ref($tbad->Rating), 'Unmagical rating';
+ is $tbad->Rating, 'NS17', 'but prior change stuck';
+}
+
+{ # Broken has_a declaration
+ eval { Film->has_a(driector => "Director") };
+ like $@, qr/driector/, "Sensible error from has_a with incorrect column: $@";
+}
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/18-has_a.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/19-set_sql.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/19-set_sql.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/19-set_sql.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/19-set_sql.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,132 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 20);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+use Actor;
+
+{ # Check __ESSENTIAL__ expansion (RT#13038)
+ my @cols = Film->columns('Essential');
+ is_deeply \@cols, ['title'], "1 Column in essential";
+ is +Film->transform_sql('__ESSENTIAL__'), 'title', '__ESSENTIAL__ expansion';
+
+ # This provides a more interesting test
+ Film->columns(Essential => qw(title rating));
+ is +Film->transform_sql('__ESSENTIAL__'), 'title, rating',
+ 'multi-col __ESSENTIAL__ expansion';
+}
+
+my $f1 = Film->create({ title => 'A', director => 'AA', rating => 'PG' });
+my $f2 = Film->create({ title => 'B', director => 'BA', rating => 'PG' });
+my $f3 = Film->create({ title => 'C', director => 'AA', rating => '15' });
+my $f4 = Film->create({ title => 'D', director => 'BA', rating => '18' });
+my $f5 = Film->create({ title => 'E', director => 'AA', rating => '18' });
+
+Film->set_sql(
+ pgs => qq{
+ SELECT __ESSENTIAL__
+ FROM __TABLE__
+ WHERE __TABLE__.rating = 'PG'
+ ORDER BY title DESC
+}
+);
+
+{
+ (my $sth = Film->sql_pgs())->execute;
+ my @pgs = Film->sth_to_objects($sth);
+ is @pgs, 2, "Execute our own SQL";
+ is $pgs[0]->id, $f2->id, "get F2";
+ is $pgs[1]->id, $f1->id, "and F1";
+}
+
+{
+ my @pgs = Film->search_pgs;
+ is @pgs, 2, "SQL creates search() method";
+ is $pgs[0]->id, $f2->id, "get F2";
+ is $pgs[1]->id, $f1->id, "and F1";
+};
+
+Film->set_sql(
+ rating => qq{
+ SELECT __ESSENTIAL__
+ FROM __TABLE__
+ WHERE rating = ?
+ ORDER BY title DESC
+}
+);
+
+{
+ my @pgs = Film->search_rating('18');
+ is @pgs, 2, "Can pass parameters to created search()";
+ is $pgs[0]->id, $f5->id, "F5";
+ is $pgs[1]->id, $f4->id, "and F4";
+};
+
+{
+ Film->set_sql(
+ by_id => qq{
+ SELECT __ESSENTIAL__
+ FROM __TABLE__
+ WHERE __IDENTIFIER__
+ }
+ );
+
+ my $film = Film->retrieve_all->first;
+ my @found = Film->search_by_id($film->id);
+ is @found, 1;
+ is $found[0]->id, $film->id;
+}
+
+
+{
+ Actor->has_a(film => "Film");
+ Film->set_sql(
+ namerate => qq{
+ SELECT __ESSENTIAL(f)__
+ FROM __TABLE(=f)__, __TABLE(Actor=a)__
+ WHERE __JOIN(a f)__
+ AND a.name LIKE ?
+ AND f.rating = ?
+ ORDER BY title
+ }
+ );
+
+ my $a1 = Actor->create({ name => "A1", film => $f1 });
+ my $a2 = Actor->create({ name => "A2", film => $f2 });
+ my $a3 = Actor->create({ name => "B1", film => $f1 });
+
+ my @apg = Film->search_namerate("A_", "PG");
+ is @apg, 2, "2 Films with A* that are PG";
+ is $apg[0]->title, "A", "A";
+ is $apg[1]->title, "B", "and B";
+}
+
+{ # join in reverse
+ Actor->has_a(film => "Film");
+ Film->set_sql(
+ ratename => qq{
+ SELECT __ESSENTIAL(f)__
+ FROM __TABLE(=f)__, __TABLE(Actor=a)__
+ WHERE __JOIN(f a)__
+ AND f.rating = ?
+ AND a.name LIKE ?
+ ORDER BY title
+ }
+ );
+
+ my @apg = Film->search_ratename(PG => "A_");
+ is @apg, 2, "2 Films with A* that are PG";
+ is $apg[0]->title, "A", "A";
+ is $apg[1]->title, "B", "and B";
+}
+
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/19-set_sql.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/21-iterator.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/21-iterator.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/21-iterator.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/21-iterator.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,96 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 37);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+my $it_class = "DBIx::Class::ResultSet";
+
+my @film = (
+ Film->create({ Title => 'Film 1' }),
+ Film->create({ Title => 'Film 2' }),
+ Film->create({ Title => 'Film 3' }),
+ Film->create({ Title => 'Film 4' }),
+ Film->create({ Title => 'Film 5' }),
+ Film->create({ Title => 'Film 6' }),
+);
+
+{
+ my $it1 = Film->retrieve_all;
+ isa_ok $it1, $it_class;
+
+ my $it2 = Film->retrieve_all;
+ isa_ok $it2, $it_class;
+
+ while (my $from1 = $it1->next) {
+ my $from2 = $it2->next;
+ is $from1->id, $from2->id, "Both iterators get $from1";
+ }
+}
+
+{
+ my $it = Film->retrieve_all;
+ is $it->first->title, "Film 1", "Film 1 first";
+ is $it->next->title, "Film 2", "Film 2 next";
+ is $it->first->title, "Film 1", "First goes back to 1";
+ is $it->next->title, "Film 2", "With 2 still next";
+ $it->reset;
+ is $it->next->title, "Film 1", "Reset brings us to film 1 again";
+ is $it->next->title, "Film 2", "And 2 is still next";
+}
+
+
+{
+ my $it = Film->retrieve_all;
+ my @slice = $it->slice(2,4);
+ is @slice, 3, "correct slice size (array)";
+ is $slice[0]->title, "Film 3", "Film 3 first";
+ is $slice[2]->title, "Film 5", "Film 5 last";
+}
+
+{
+ my $it = Film->retrieve_all;
+ my $slice = $it->slice(2,4);
+ isa_ok $slice, $it_class, "slice as iterator";
+ is $slice->count, 3,"correct slice size (array)";
+ is $slice->first->title, "Film 3", "Film 3 first";
+ is $slice->next->title, "Film 4", "Film 4 next";
+ is $slice->first->title, "Film 3", "First goes back to 3";
+ is $slice->next->title, "Film 4", "With 4 still next";
+ $slice->reset;
+ is $slice->next->title, "Film 3", "Reset brings us to film 3 again";
+ is $slice->next->title, "Film 4", "And 4 is still next";
+
+ # check if the original iterator still works
+ is $it->count, 6, "back to the original iterator, is of right size";
+ is $it->first->title, "Film 1", "Film 1 first";
+ is $it->next->title, "Film 2", "Film 2 next";
+ is $it->first->title, "Film 1", "First goes back to 1";
+ is $it->next->title, "Film 2", "With 2 still next";
+ is $it->next->title, "Film 3", "Film 3 is still in original Iterator";
+ $it->reset;
+ is $it->next->title, "Film 1", "Reset brings us to film 1 again";
+ is $it->next->title, "Film 2", "And 2 is still next";
+}
+
+{
+ my $it = Film->retrieve_all;
+ is $it, $it->count, "iterator returns count as a scalar";
+ ok $it, "iterator returns true when there are results";
+}
+
+{
+ my $it = Film->search( Title => "something which does not exist" );
+ is $it, 0;
+ ok !$it, "iterator returns false when no results";
+}
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/21-iterator.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/22-deflate_order.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/22-deflate_order.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/22-deflate_order.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/22-deflate_order.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,30 @@
+$| = 1;
+use strict;
+
+use Test::More;
+
+eval "use DBIx::Class::CDBICompat;";
+if ($@) {
+ plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
+ next;
+}
+
+eval { require Time::Piece::MySQL };
+plan skip_all => "Need Time::Piece::MySQL for this test" if $@;
+
+eval { require 't/cdbi/testlib/Log.pm' };
+plan skip_all => "Need MySQL for this test" if $@;
+
+plan tests => 2;
+
+package main;
+
+my $log = Log->insert( { message => 'initial message' } );
+ok eval { $log->datetime_stamp }, "Have datetime";
+diag $@ if $@;
+
+$log->message( 'a revised message' );
+$log->update;
+ok eval { $log->datetime_stamp }, "Have datetime after update";
+diag $@ if $@;
+
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/22-deflate_order.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/22-self_referential.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/22-self_referential.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/22-self_referential.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/22-self_referential.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,25 @@
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required') : (tests=> 2);
+}
+
+use strict;
+
+use lib 't/cdbi/testlib';
+use Actor;
+use ActorAlias;
+Actor->has_many( aliases => [ 'ActorAlias' => 'alias' ] );
+
+my $first = Actor->create( { Name => 'First' } );
+my $second = Actor->create( { Name => 'Second' } );
+
+ActorAlias->create( { actor => $first, alias => $second } );
+
+my @aliases = $first->aliases;
+
+is( scalar @aliases, 1, 'proper number of aliases' );
+is( $aliases[ 0 ]->name, 'Second', 'proper alias' );
+
+
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/22-self_referential.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/23-cascade.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/23-cascade.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/23-cascade.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/23-cascade.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,78 @@
+use strict;
+use Test::More;
+use Data::Dumper;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 12);
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+ use Film;
+ use Director;
+}
+
+{ # Cascade on delete
+ Director->has_many(nasties => 'Film');
+
+ my $dir = Director->insert({
+ name => "Lewis Teague",
+ });
+ my $kk = $dir->add_to_nasties({
+ Title => 'Alligator'
+ });
+ is $kk->director, $dir, "Director set OK";
+ is $dir->nasties, 1, "We have one nasty";
+
+ ok $dir->delete;
+ ok !Film->retrieve("Alligator"), "has_many cascade deletes by default";
+}
+
+
+# Two ways of saying not to cascade
+for my $args ({ no_cascade_delete => 1 }, { cascade => "None" }) {
+ Director->has_many(nasties => 'Film', $args);
+
+ my $dir = Director->insert({
+ name => "Lewis Teague",
+ });
+ my $kk = $dir->add_to_nasties({
+ Title => 'Alligator'
+ });
+ is $kk->director, $dir, "Director set OK";
+ is $dir->nasties, 1, "We have one nasty";
+
+ ok $dir->delete;
+ local $Data::Dumper::Terse = 1;
+ ok +Film->retrieve("Alligator"), 'has_many with ' . Dumper ($args);;
+ $kk->delete;
+}
+
+
+#{ # Fail on cascade
+# local $TODO = 'cascade => "Fail" unimplemented';
+#
+# Director->has_many(nasties => Film => { cascade => 'Fail' });
+#
+# my $dir = Director->insert({ name => "Nasty Noddy" });
+# my $kk = $dir->add_to_nasties({ Title => 'Killer Killers' });
+# is $kk->director, $dir, "Director set OK";
+# is $dir->nasties, 1, "We have one nasty";
+#
+# ok !eval { $dir->delete };
+# like $@, qr/1/, "Can't delete while films exist";
+#
+# my $rr = $dir->add_to_nasties({ Title => 'Revenge of the Revengers' });
+# ok !eval { $dir->delete };
+# like $@, qr/2/, "Still can't delete";
+#
+# $dir->nasties->delete_all;
+# ok eval { $dir->delete };
+# is $@, '', "Can delete once films are gone";
+#}
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/23-cascade.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/24-meta_info.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/24-meta_info.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/24-meta_info.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/24-meta_info.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,78 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
+ if $@;
+
+ plan skip_all => "Time::Piece required for this test"
+ unless eval { require Time::Piece };
+
+ plan tests => 12;
+}
+
+use Test::Warn;
+
+package Temp::DBI;
+use base qw(DBIx::Class::CDBICompat);
+Temp::DBI->columns(All => qw(id date));
+
+my $strptime_inflate = sub {
+ Time::Piece->strptime(shift, "%Y-%m-%d")
+};
+Temp::DBI->has_a(
+ date => 'Time::Piece',
+ inflate => $strptime_inflate
+);
+
+
+package Temp::Person;
+use base 'Temp::DBI';
+Temp::Person->table('people');
+Temp::Person->columns(Info => qw(name pet));
+Temp::Person->has_a( pet => 'Temp::Pet' );
+
+package Temp::Pet;
+use base 'Temp::DBI';
+Temp::Pet->table('pets');
+Temp::Pet->columns(Info => qw(name));
+Temp::Pet->has_many(owners => 'Temp::Person');
+
+package main;
+
+{
+ my $pn_meta = Temp::Person->meta_info('has_a');
+ is_deeply [sort keys %$pn_meta], [qw/date pet/], "Person has Date and Pet";
+}
+
+{
+ my $pt_meta = Temp::Pet->meta_info;
+ is_deeply [keys %{$pt_meta->{has_a}}], [qw/date/], "Pet has Date";
+ is_deeply [keys %{$pt_meta->{has_many}}], [qw/owners/], "And owners";
+}
+
+{
+ my $pet = Temp::Person->meta_info( has_a => 'pet' );
+ is $pet->class, 'Temp::Person';
+ is $pet->foreign_class, 'Temp::Pet';
+ is $pet->accessor, 'pet';
+ is $pet->name, 'has_a';
+}
+
+{
+ my $owners = Temp::Pet->meta_info( has_many => 'owners' );
+
+ is_deeply $owners->args, {
+ foreign_key => 'pet',
+ mapping => [],
+ };
+}
+
+{
+ my $date = Temp::Pet->meta_info( has_a => 'date' );
+ is $date->class, 'Temp::DBI';
+ is $date->foreign_class, 'Time::Piece';
+ is $date->accessor, 'date';
+ is $date->args->{inflate}, $strptime_inflate;
+}
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/24-meta_info.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/26-mutator.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/26-mutator.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/26-mutator.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/26-mutator.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,47 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
+ if $@;
+}
+
+BEGIN {
+ eval "use DBD::SQLite";
+ plan $@
+ ? (skip_all => 'needs DBD::SQLite for testing')
+ : (tests => 6);
+}
+
+use lib 't/cdbi/testlib';
+require Film;
+
+sub Film::accessor_name_for {
+ my ($class, $col) = @_;
+ return "sheep" if lc $col eq "numexplodingsheep";
+ return $col;
+}
+
+my $data = {
+ Title => 'Bad Taste',
+ Director => 'Peter Jackson',
+ Rating => 'R',
+};
+
+my $bt;
+eval {
+ my $data = $data;
+ $data->{sheep} = 1;
+ ok $bt = Film->insert($data), "Modified accessor - with
+accessor";
+ isa_ok $bt, "Film";
+};
+is $@, '', "No errors";
+
+eval {
+ ok $bt->sheep(2), 'Modified accessor, set';
+ ok $bt->update, 'Update';
+};
+is $@, '', "No errors";
+
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/26-mutator.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/30-pager.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/30-pager.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/30-pager.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/30-pager.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,52 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 6);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+my @film = (
+ Film->create({ Title => 'Film 1' }),
+ Film->create({ Title => 'Film 2' }),
+ Film->create({ Title => 'Film 3' }),
+ Film->create({ Title => 'Film 4' }),
+ Film->create({ Title => 'Film 5' }),
+);
+
+# first page
+my ( $pager, $it ) = Film->page(
+ {},
+ { rows => 3,
+ page => 1 }
+);
+
+is( $pager->entries_on_this_page, 3, "entries_on_this_page ok" );
+
+is( $pager->next_page, 2, "next_page ok" );
+
+is( $it->next->title, "Film 1", "iterator->next ok" );
+
+$it->next;
+$it->next;
+
+is( $it->next, undef, "next past end of page ok" );
+
+# second page
+( $pager, $it ) = Film->page(
+ {},
+ { rows => 3,
+ page => 2 }
+);
+
+is( $pager->entries_on_this_page, 2, "entries on second page ok" );
+
+is( $it->next->title, "Film 4", "second page first title ok" );
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/30-pager.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/68-inflate_has_a.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/68-inflate_has_a.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/68-inflate_has_a.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/68-inflate_has_a.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,67 @@
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => "Class::Trigger and DBIx::ContextualFetch required"
+ if $@;
+
+ eval { require DateTime };
+ plan skip_all => "Need DateTime for inflation tests" if $@;
+
+ eval { require Clone };
+ plan skip_all => "Need Clone for CDBICompat inflation tests" if $@;
+}
+
+plan tests => 6;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+DBICTest::Schema::CD->load_components(qw/CDBICompat::Relationships/);
+
+DBICTest::Schema::CD->has_a( 'year', 'DateTime',
+ inflate => sub { DateTime->new( year => shift ) },
+ deflate => sub { shift->year }
+);
+Class::C3->reinitialize;
+
+# inflation test
+my $cd = $schema->resultset("CD")->find(3);
+
+is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' );
+
+is( $cd->year->month, 1, 'inflated month ok' );
+
+# deflate test
+my $now = DateTime->now;
+$cd->year( $now );
+$cd->update;
+
+($cd) = $schema->resultset("CD")->search( year => $now->year );
+is( $cd->year->year, $now->year, 'deflate ok' );
+
+# re-test using alternate deflate syntax
+$schema->class("CD")->has_a( 'year', 'DateTime',
+ inflate => sub { DateTime->new( year => shift ) },
+ deflate => 'year'
+);
+
+# inflation test
+$cd = $schema->resultset("CD")->find(3);
+
+is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' );
+
+is( $cd->year->month, 1, 'inflated month ok' );
+
+# deflate test
+$now = DateTime->now;
+$cd->year( $now );
+$cd->update;
+
+($cd) = $schema->resultset("CD")->search( year => $now->year );
+is( $cd->year->year, $now->year, 'deflate ok' );
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/98-failure.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/98-failure.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/98-failure.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/98-failure.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,62 @@
+use strict;
+use Test::More;
+
+#----------------------------------------------------------------------
+# Test database failures
+#----------------------------------------------------------------------
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 7);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+Film->create_test_film;
+
+{
+ my $btaste = Film->retrieve('Bad Taste');
+ isa_ok $btaste, 'Film', "We have Bad Taste";
+ {
+ no warnings 'redefine';
+ local *DBIx::ContextualFetch::st::execute = sub { die "Database died" };
+ eval { $btaste->delete };
+ ::like $@, qr/Database died/s, "We failed";
+ }
+ my $still = Film->retrieve('Bad Taste');
+ isa_ok $btaste, 'Film', "We still have Bad Taste";
+}
+
+{
+ my $btaste = Film->retrieve('Bad Taste');
+ isa_ok $btaste, 'Film', "We have Bad Taste";
+ $btaste->numexplodingsheep(10);
+ {
+ no warnings 'redefine';
+ local *DBIx::ContextualFetch::st::execute = sub { die "Database died" };
+ eval { $btaste->update };
+ ::like $@, qr/Database died/s, "We failed";
+ }
+ $btaste->discard_changes;
+ my $still = Film->retrieve('Bad Taste');
+ isa_ok $btaste, 'Film', "We still have Bad Taste";
+ is $btaste->numexplodingsheep, 1, "with 1 sheep";
+}
+
+if (0) {
+ my $sheep = Film->maximum_value_of('numexplodingsheep');
+ is $sheep, 1, "1 exploding sheep";
+ {
+ local *DBIx::ContextualFetch::st::execute = sub { die "Database died" };
+ my $sheep = eval { Film->maximum_value_of('numexplodingsheep') };
+ ::like $@, qr/select.*Database died/s,
+ "Handle database death in single value select";
+ }
+}
+
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/98-failure.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/DeepAbstractSearch (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-DeepAbstractSearch)
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/DeepAbstractSearch
___________________________________________________________________
Name: svn:mergeinfo
+
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/DeepAbstractSearch/01_search.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-DeepAbstractSearch/01_search.t 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/DeepAbstractSearch/01_search.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -17,7 +17,7 @@
plan tests => 19;
}
-my $DB = "t/testdb";
+my $DB = "t/var/cdbi_testdb";
unlink $DB if -e $DB;
my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 0 });
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/abstract (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-abstract)
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/abstract
___________________________________________________________________
Name: svn:mergeinfo
+
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/abstract/search_where.t
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-abstract/search_where.t 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/abstract/search_where.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,5 +1,3 @@
-#!/usr/bin/perl -w
-
use Test::More;
use strict;
@@ -16,7 +14,7 @@
}
INIT {
- use lib 't/testlib';
+ use lib 't/cdbi/testlib';
use Film;
}
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/columns_as_hashes.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/columns_as_hashes.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/columns_as_hashes.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/columns_as_hashes.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,104 @@
+use strict;
+use Test::More;
+use Test::Warn;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : ('no_plan');
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+my $waves = Film->insert({
+ Title => "Breaking the Waves",
+ Director => 'Lars von Trier',
+ Rating => 'R'
+});
+
+local $ENV{DBIC_CDBICOMPAT_HASH_WARN} = 0;
+
+{
+ local $ENV{DBIC_CDBICOMPAT_HASH_WARN} = 1;
+
+ warnings_like {
+ my $rating = $waves->{rating};
+ $waves->Rating("PG");
+ is $rating, "R", 'evaluation of column value is not deferred';
+ } qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at \Q$0};
+
+ warnings_like {
+ is $waves->{title}, $waves->Title, "columns can be accessed as hashes";
+ } qr{^Column 'title' of 'Film/$waves' was fetched as a hash at\b};
+
+ $waves->Rating("G");
+
+ warnings_like {
+ is $waves->{rating}, "G", "updating via the accessor updates the hash";
+ } qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at\b};
+
+
+ warnings_like {
+ $waves->{rating} = "PG";
+ } qr{^Column 'rating' of 'Film/$waves' was stored as a hash at\b};
+
+ $waves->update;
+ my @films = Film->search( Rating => "PG", Title => "Breaking the Waves" );
+ is @films, 1, "column updated as hash was saved";
+}
+
+warning_is {
+ $waves->{rating}
+} '', 'DBIC_CDBICOMPAT_HASH_WARN controls warnings';
+
+
+{
+ $waves->rating("R");
+ $waves->update;
+
+ no warnings 'redefine';
+ local *Film::rating = sub {
+ return "wibble";
+ };
+
+ is $waves->{rating}, "R";
+}
+
+
+{
+ no warnings 'redefine';
+ no warnings 'once';
+ local *Actor::accessor_name_for = sub {
+ my($class, $col) = @_;
+ return "movie" if lc $col eq "film";
+ return $col;
+ };
+
+ require Actor;
+ Actor->has_a( film => "Film" );
+
+ my $actor = Actor->insert({
+ name => 'Emily Watson',
+ film => $waves,
+ });
+
+ ok !eval { $actor->film };
+ is $actor->{film}->id, $waves->id,
+ 'hash access still works despite lack of accessor';
+}
+
+
+# Emulate that Class::DBI inflates immediately
+SKIP: {
+ skip "Need MySQL to run this test", 3 unless eval { require MyFoo };
+
+ my $foo = MyFoo->insert({
+ name => 'Whatever',
+ tdate => '1949-02-01',
+ });
+ isa_ok $foo, 'MyFoo';
+
+ isa_ok $foo->{tdate}, 'Date::Simple';
+ is $foo->{tdate}->year, 1949;
+}
\ No newline at end of file
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/columns_as_hashes.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/columns_dont_override_custom_accessors.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/columns_dont_override_custom_accessors.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/columns_dont_override_custom_accessors.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/columns_dont_override_custom_accessors.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,32 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 5);
+}
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(TEMP => qw[foo bar]);
+ Thing->columns(All => qw[thing_id yarrow flower]);
+ sub foo { 42 }
+ sub yarrow { "hock" }
+}
+
+is_deeply( [sort Thing->columns("TEMP")],
+ [sort qw(foo bar)],
+ "TEMP columns set"
+);
+my $thing = Thing->construct(
+ { thing_id => 23, foo => "this", bar => "that" }
+);
+
+is( $thing->id, 23 );
+is( $thing->yarrow, "hock", 'custom accessor not overwritten by column' );
+is( $thing->foo, 42, 'custom routine not overwritten by temp column' );
+is( $thing->bar, "that", 'temp column accessor generated' );
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/columns_dont_override_custom_accessors.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/construct.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/construct.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/construct.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/construct.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,43 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 5);
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+ use Film;
+}
+
+{
+ Film->insert({
+ Title => "Breaking the Waves",
+ Director => 'Lars von Trier',
+ Rating => 'R'
+ });
+
+ my $film = Film->construct({
+ Title => "Breaking the Waves",
+ Director => 'Lars von Trier',
+ });
+
+ isa_ok $film, "Film";
+ is $film->title, "Breaking the Waves";
+ is $film->director, "Lars von Trier";
+ is $film->rating, "R",
+ "constructed objects can get missing data from the db";
+}
+
+{
+ package Foo;
+ use base qw(Film);
+ Foo->columns( TEMP => qw(temp_thing) );
+ my $film = Foo->construct({
+ temp_thing => 23
+ });
+
+ ::is $film->temp_thing, 23, "construct sets temp columns";
+}
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/construct.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/copy.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/copy.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/copy.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/copy.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,41 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 4);
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+}
+
+{
+ package # hide from PAUSE
+ MyFilm;
+
+ use base 'DBIx::Class::Test::SQLite';
+ use strict;
+
+ __PACKAGE__->set_table('Movies');
+ __PACKAGE__->columns(All => qw(id title));
+
+ sub create_sql {
+ return qq{
+ id INTEGER PRIMARY KEY AUTOINCREMENT,
+ title VARCHAR(255)
+ }
+ }
+}
+
+my $film = MyFilm->create({ title => "For Your Eyes Only" });
+ok $film->id;
+
+my $new_film = $film->copy;
+ok $new_film->id;
+isnt $new_film->id, $film->id, "copy() gets new primary key";
+
+$new_film = $film->copy(42);
+is $new_film->id, 42, "copy() with new id";
+
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/copy.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/early_column_heisenbug.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/early_column_heisenbug.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/early_column_heisenbug.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/early_column_heisenbug.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,28 @@
+use strict;
+
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : ('no_plan');
+}
+
+
+{
+ package Thing;
+ use base qw(DBIx::Class::CDBICompat);
+}
+
+{
+ package Stuff;
+ use base qw(DBIx::Class::CDBICompat);
+}
+
+# There was a bug where looking at a column group before any were
+# set would cause them to be shared across classes.
+is_deeply [Stuff->columns("Essential")], [];
+Thing->columns(Essential => qw(foo bar baz));
+is_deeply [Stuff->columns("Essential")], [];
+
+1;
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/early_column_heisenbug.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/has_many_loads_foreign_class.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/has_many_loads_foreign_class.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/has_many_loads_foreign_class.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/has_many_loads_foreign_class.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,37 @@
+use strict;
+use Test::More;
+
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => 'Class::Trigger and DBIx::ContextualFetch required' if $@;
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 3);
+}
+
+
+use lib 't/cdbi/testlib';
+use Director;
+
+# Test that has_many() will load the foreign class.
+ok !Class::Inspector->loaded( 'Film' );
+ok eval { Director->has_many( films => 'Film' ); 1; } || diag $@;
+
+my $shan_hua = Director->create({
+ Name => "Shan Hua",
+});
+
+my $inframan = Film->create({
+ Title => "Inframan",
+ Director => "Shan Hua",
+});
+my $guillotine2 = Film->create({
+ Title => "Flying Guillotine 2",
+ Director => "Shan Hua",
+});
+my $guillotine = Film->create({
+ Title => "Master of the Flying Guillotine",
+ Director => "Yu Wang",
+});
+
+is_deeply [sort $shan_hua->films], [sort $inframan, $guillotine2];
\ No newline at end of file
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/has_many_loads_foreign_class.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/hasa_without_loading.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/hasa_without_loading.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/hasa_without_loading.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/hasa_without_loading.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,21 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required')
+ : (tests=> 2);
+}
+
+package Foo;
+
+use base qw(DBIx::Class::CDBICompat);
+
+eval {
+ Foo->table("foo");
+ Foo->columns(Essential => qw(foo bar));
+ #Foo->has_a( bar => "This::Does::Not::Exist::Yet" );
+};
+#::is $@, '';
+::is(Foo->table, "foo");
+::is_deeply [sort map lc, Foo->columns], [sort map lc, qw(foo bar)];
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/hasa_without_loading.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/max_min_value_of.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/max_min_value_of.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/max_min_value_of.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/max_min_value_of.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,32 @@
+use strict;
+use Test::More;
+
+#----------------------------------------------------------------------
+# Test database failures
+#----------------------------------------------------------------------
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 2);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+Film->create({
+ title => "Bad Taste",
+ numexplodingsheep => 10,
+});
+
+Film->create({
+ title => "Evil Alien Conquerers",
+ numexplodingsheep => 2,
+});
+
+is( Film->maximum_value_of("numexplodingsheep"), 10 );
+is( Film->minimum_value_of("numexplodingsheep"), 2 );
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/max_min_value_of.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/mk_group_accessors.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/mk_group_accessors.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/mk_group_accessors.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/mk_group_accessors.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,69 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => 'Class::Trigger and DBIx::ContextualFetch required' if $@;
+
+ eval "use DBD::SQLite";
+ plan skip_all => 'needs DBD::SQLite for testing' if $@;
+
+ plan 'no_plan';
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+ require Film;
+}
+
+sub Film::get_test {
+ my $self = shift;
+ my $key = shift;
+ $self->{get_test}++;
+ return $self->{$key};
+}
+
+sub Film::set_test {
+ my($self, $key, $val) = @_;
+ $self->{set_test}++;
+ return $self->{$key} = $val;
+}
+
+
+my $film = Film->create({ Title => "No Wolf McQuade" });
+
+# Test mk_group_accessors() with a list of fields.
+{
+ Film->mk_group_accessors(test => qw(foo bar));
+ $film->foo(42);
+ is $film->foo, 42;
+
+ $film->bar(23);
+ is $film->bar, 23;
+}
+
+
+# An explicit accessor passed to mk_group_accessors should
+# ignore accessor/mutator_name_for.
+sub Film::accessor_name_for {
+ my($class, $col) = @_;
+ return "hlaglagh" if $col eq "wibble";
+ return $col;
+}
+
+sub Film::mutator_name_for {
+ my($class, $col) = @_;
+ return "hlaglagh" if $col eq "wibble";
+ return $col;
+}
+
+
+# Test with a mix of fields and field specs
+{
+ Film->mk_group_accessors(test => ("baz", [wibble_thing => "wibble"]));
+ $film->baz(42);
+ is $film->baz, 42;
+
+ $film->wibble_thing(23);
+ is $film->wibble_thing, 23;
+}
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/mk_group_accessors.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/multi_column_set.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/multi_column_set.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/multi_column_set.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/multi_column_set.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,25 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 3);
+}
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(TEMP => qw[foo bar baz]);
+ Thing->columns(All => qw[some real stuff]);
+}
+
+my $thing = Thing->construct({ foo => 23, some => 42, baz => 99 });
+$thing->set( foo => "wibble", some => "woosh" );
+is $thing->foo, "wibble";
+is $thing->some, "woosh";
+is $thing->baz, 99;
+
+$thing->discard_changes;
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/multi_column_set.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/object_cache.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/object_cache.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/object_cache.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/object_cache.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,82 @@
+use strict;
+use Test::More;
+$| = 1;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ }
+
+ eval "use DBD::SQLite";
+ plan skip_all => 'needs DBD::SQLite for testing' if $@;
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+ use Film;
+}
+
+plan skip_all => "Object cache is turned off"
+ if Film->isa("DBIx::Class::CDBICompat::NoObjectIndex");
+
+plan tests => 5;
+
+
+ok +Film->create({
+ Title => 'This Is Spinal Tap',
+ Director => 'Rob Reiner',
+ Rating => 'R',
+});
+
+{
+ my $film1 = Film->retrieve( "This Is Spinal Tap" );
+ my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+ $film1->Director("Marty DiBergi");
+ is $film2->Director, "Marty DiBergi", 'retrieve returns the same object';
+
+ $film1->discard_changes;
+}
+
+{
+ Film->nocache(1);
+
+ my $film1 = Film->retrieve( "This Is Spinal Tap" );
+ my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+ $film1->Director("Marty DiBergi");
+ is $film2->Director, "Rob Reiner",
+ 'caching turned off';
+
+ $film1->discard_changes;
+}
+
+{
+ Film->nocache(0);
+
+ my $film1 = Film->retrieve( "This Is Spinal Tap" );
+ my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+ $film1->Director("Marty DiBergi");
+ is $film2->Director, "Marty DiBergi",
+ 'caching back on';
+
+ $film1->discard_changes;
+}
+
+
+{
+ Film->nocache(1);
+
+ local $Class::DBI::Weaken_Is_Available = 0;
+
+ my $film1 = Film->retrieve( "This Is Spinal Tap" );
+ my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+ $film1->Director("Marty DiBergi");
+ is $film2->Director, "Rob Reiner",
+ 'CDBI::Weaken_Is_Available turns off all caching';
+
+ $film1->discard_changes;
+}
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/object_cache.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/retrieve_from_sql_with_limit.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/retrieve_from_sql_with_limit.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/retrieve_from_sql_with_limit.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/retrieve_from_sql_with_limit.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,25 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 3);
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+ use Film;
+}
+
+for my $title ("Bad Taste", "Braindead", "Forgotten Silver") {
+ Film->insert({ Title => $title, Director => 'Peter Jackson' });
+}
+
+Film->insert({ Title => "Transformers", Director => "Michael Bay"});
+
+{
+ my @films = Film->retrieve_from_sql(qq[director = "Peter Jackson" LIMIT 2]);
+ is @films, 2, "retrieve_from_sql with LIMIT";
+ is( $_->director, "Peter Jackson" ) for @films;
+}
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/retrieve_from_sql_with_limit.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/set_to_undef.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/set_to_undef.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/set_to_undef.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/set_to_undef.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,32 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
+ if $@;
+ plan skip_all => "DateTime required" unless eval { require DateTime };
+ plan tests => 2;
+}
+
+
+# Don't use Test::NoWarnings because of an unrelated DBD::SQLite warning.
+my @warnings;
+local $SIG{__WARN__} = sub {
+ push @warnings, @_;
+};
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(All => qw[thing_id this that date]);
+}
+
+my $thing = Thing->construct({ thing_id => 23, this => 42 });
+$thing->set( this => undef );
+is $thing->get( "this" ), undef, 'undef set';
+$thing->discard_changes;
+
+is @warnings, 0, 'no warnings';
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/set_to_undef.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/set_vs_DateTime.t (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-t/set_vs_DateTime.t)
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/set_vs_DateTime.t (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/set_vs_DateTime.t 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,30 @@
+use strict;
+use Test::More;
+use Test::Exception;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
+ if $@;
+ plan skip_all => "DateTime required" unless eval { require DateTime };
+ plan tests => 1;
+}
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(All => qw[thing_id this that date]);
+}
+
+my $thing = Thing->construct({ thing_id => 23, date => "01-02-1994" });
+my $date = DateTime->now;
+lives_ok {
+ $thing->set( date => $date );
+ $thing->set( date => $date );
+};
+
+
+
+$thing->discard_changes;
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/set_vs_DateTime.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/sweet (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi-sweet-t)
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/sweet
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib (from rev 5167, DBIx-Class/0.08/branches/rt_bug_41083/t/testlib)
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib
___________________________________________________________________
Name: svn:mergeinfo
+
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Actor.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/testlib/Actor.pm 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Actor.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,8 +1,6 @@
package # hide from PAUSE
Actor;
-BEGIN { unshift @INC, './t/testlib'; }
-
use strict;
use warnings;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/ActorAlias.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/testlib/ActorAlias.pm 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/ActorAlias.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,27 +1,25 @@
-package # hide from PAUSE
- ActorAlias;
-
-BEGIN { unshift @INC, './t/testlib'; }
-
-use strict;
-use warnings;
-
-use base 'DBIx::Class::Test::SQLite';
-
-__PACKAGE__->set_table( 'ActorAlias' );
-
-__PACKAGE__->columns( Primary => 'id' );
-__PACKAGE__->columns( All => qw/ actor alias / );
-__PACKAGE__->has_a( actor => 'Actor' );
-__PACKAGE__->has_a( alias => 'Actor' );
-
-sub create_sql {
- return qq{
- id INTEGER PRIMARY KEY,
- actor INTEGER,
- alias INTEGER
- }
-}
-
-1;
-
+package # hide from PAUSE
+ ActorAlias;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Test::SQLite';
+
+__PACKAGE__->set_table( 'ActorAlias' );
+
+__PACKAGE__->columns( Primary => 'id' );
+__PACKAGE__->columns( All => qw/ actor alias / );
+__PACKAGE__->has_a( actor => 'Actor' );
+__PACKAGE__->has_a( alias => 'Actor' );
+
+sub create_sql {
+ return qq{
+ id INTEGER PRIMARY KEY,
+ actor INTEGER,
+ alias INTEGER
+ }
+}
+
+1;
+
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Binary.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/testlib/Binary.pm 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Binary.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,8 +1,6 @@
package # hide from PAUSE
Binary;
-BEGIN { unshift @INC, './t/testlib'; }
-
use strict;
use base 'PgBase';
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Blurb.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/testlib/Blurb.pm 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Blurb.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,8 +1,6 @@
package # hide from PAUSE
Blurb;
-BEGIN { unshift @INC, './t/testlib'; }
-
use strict;
use base 'DBIx::Class::Test::SQLite';
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Director.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/testlib/Director.pm 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Director.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,8 +1,6 @@
package # hide from PAUSE
Director;
-BEGIN { unshift @INC, './t/testlib'; }
-
use strict;
use base 'DBIx::Class::Test::SQLite';
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Film.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/testlib/Film.pm 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Film.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,7 +1,6 @@
package # hide from PAUSE
Film;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'DBIx::Class::Test::SQLite';
use strict;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Lazy.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/testlib/Lazy.pm 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Lazy.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,7 +1,6 @@
package # hide from PAUSE
Lazy;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'DBIx::Class::Test::SQLite';
use strict;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Log.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/testlib/Log.pm 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Log.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,7 +1,6 @@
package # hide from PAUSE
Log;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'MyBase';
use strict;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/MyFilm.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/testlib/MyFilm.pm 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/MyFilm.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,7 +1,6 @@
package # hide from PAUSE
MyFilm;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'MyBase';
use MyStarLink;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/MyFoo.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/testlib/MyFoo.pm 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/MyFoo.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,7 +1,6 @@
package # hide from PAUSE
MyFoo;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'MyBase';
use strict;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/MyStar.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/testlib/MyStar.pm 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/MyStar.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,7 +1,6 @@
package # hide from PAUSE
MyStar;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'MyBase';
use strict;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/MyStarLink.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/testlib/MyStarLink.pm 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/MyStarLink.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,7 +1,6 @@
package # hide from PAUSE
MyStarLink;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'MyBase';
use strict;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/MyStarLinkMCPK.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/testlib/MyStarLinkMCPK.pm 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/MyStarLinkMCPK.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,7 +1,6 @@
package # hide from PAUSE
MyStarLinkMCPK;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'MyBase';
use MyStar;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Order.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/testlib/Order.pm 2008-11-20 12:45:48 UTC (rev 5167)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/cdbi/testlib/Order.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,8 +1,6 @@
package # hide from PAUSE
Order;
-BEGIN { unshift @INC, './t/testlib'; }
-
use strict;
use base 'DBIx::Class::Test::SQLite';
Added: DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBIC/DebugObj.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBIC/DebugObj.pm (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBIC/DebugObj.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,50 @@
+package DBIC::DebugObj;
+
+use strict;
+use warnings;
+
+use Class::C3;
+
+use base qw/DBIx::Class::Storage::Statistics Exporter Class::Accessor::Fast/;
+
+__PACKAGE__->mk_accessors( qw/dbictest_sql_ref dbictest_bind_ref/ );
+
+
+=head2 new(PKG, SQL_REF, BIND_REF, ...)
+
+Creates a new instance that on subsequent queries will store
+the generated SQL to the scalar pointed to by SQL_REF and bind
+values to the array pointed to by BIND_REF.
+
+=cut
+
+sub new {
+ my $pkg = shift;
+ my $sql_ref = shift;
+ my $bind_ref = shift;
+
+ my $self = $pkg->SUPER::new(@_);
+
+ $self->debugfh(undef);
+
+ $self->dbictest_sql_ref($sql_ref);
+ $self->dbictest_bind_ref($bind_ref || []);
+
+ return $self;
+}
+
+sub query_start {
+ my $self = shift;
+
+ (${$self->dbictest_sql_ref}, @{$self->dbictest_bind_ref}) = @_;
+}
+
+sub query_end { }
+
+sub txn_start { }
+
+sub txn_commit { }
+
+sub txn_rollback { }
+
+1;
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBIC/DebugObj.pm
___________________________________________________________________
Name: svn:eol-style
+ native
Added: DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBIC/SqlMakerTest.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBIC/SqlMakerTest.pm (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBIC/SqlMakerTest.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,160 @@
+package DBIC::SqlMakerTest;
+
+use strict;
+use warnings;
+
+use base qw/Test::Builder::Module Exporter/;
+
+our @EXPORT = qw/
+ &is_same_sql_bind
+ &eq_sql
+ &eq_bind
+/;
+
+
+{
+ package DBIC::SqlMakerTest::SQLATest;
+
+ # replacement for SQL::Abstract::Test if not available
+
+ use strict;
+ use warnings;
+
+ use base qw/Test::Builder::Module Exporter/;
+
+ use Scalar::Util qw(looks_like_number blessed reftype);
+ use Data::Dumper;
+ use Test::Builder;
+ use Test::Deep qw(eq_deeply);
+
+ our $tb = __PACKAGE__->builder;
+
+ sub is_same_sql_bind
+ {
+ my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
+
+ my $same_sql = eq_sql($sql1, $sql2);
+ my $same_bind = eq_bind($bind_ref1, $bind_ref2);
+
+ $tb->ok($same_sql && $same_bind, $msg);
+
+ if (!$same_sql) {
+ $tb->diag("SQL expressions differ\n"
+ . " got: $sql1\n"
+ . "expected: $sql2\n"
+ );
+ }
+ if (!$same_bind) {
+ $tb->diag("BIND values differ\n"
+ . " got: " . Dumper($bind_ref1)
+ . "expected: " . Dumper($bind_ref2)
+ );
+ }
+ }
+
+ sub eq_sql
+ {
+ my ($left, $right) = @_;
+
+ $left =~ s/\s+//g;
+ $right =~ s/\s+//g;
+
+ return $left eq $right;
+ }
+
+ sub eq_bind
+ {
+ my ($bind_ref1, $bind_ref2) = @_;
+
+ return eq_deeply($bind_ref1, $bind_ref2);
+ }
+}
+
+eval "use SQL::Abstract::Test;";
+if ($@ eq '') {
+ # SQL::Abstract::Test available
+
+ *is_same_sql_bind = \&SQL::Abstract::Test::is_same_sql_bind;
+ *eq_sql = \&SQL::Abstract::Test::eq_sql;
+ *eq_bind = \&SQL::Abstract::Test::eq_bind;
+} else {
+ # old SQL::Abstract
+
+ *is_same_sql_bind = \&DBIC::SqlMakerTest::SQLATest::is_same_sql_bind;
+ *eq_sql = \&DBIC::SqlMakerTest::SQLATest::eq_sql;
+ *eq_bind = \&DBIC::SqlMakerTest::SQLATest::eq_bind;
+}
+
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+DBIC::SqlMakerTest - Helper package for testing sql_maker component of DBIC
+
+=head1 SYNOPSIS
+
+ use Test::More;
+ use DBIC::SqlMakerTest;
+
+ my ($sql, @bind) = $schema->storage->sql_maker->select(%args);
+ is_same_sql_bind(
+ $sql, \@bind,
+ $expected_sql, \@expected_bind,
+ 'foo bar works'
+ );
+
+=head1 DESCRIPTION
+
+Exports functions that can be used to compare generated SQL and bind values.
+
+If L<SQL::Abstract::Test> (packaged in L<SQL::Abstract> versions 1.50 and
+above) is available, then it is used to perform the comparisons (all functions
+are delegated to id). Otherwise uses simple string comparison for the SQL
+statements and simple L<Data::Dumper>-like recursive stringification for
+comparison of bind values.
+
+
+=head1 FUNCTIONS
+
+=head2 is_same_sql_bind
+
+ is_same_sql_bind(
+ $given_sql, \@given_bind,
+ $expected_sql, \@expected_bind,
+ $test_msg
+ );
+
+Compares given and expected pairs of C<($sql, \@bind)>, and calls
+L<Test::Builder/ok> on the result, with C<$test_msg> as message.
+
+=head2 eq_sql
+
+ my $is_same = eq_sql($given_sql, $expected_sql);
+
+Compares the two SQL statements. Returns true IFF they are equivalent.
+
+=head2 eq_bind
+
+ my $is_same = eq_sql(\@given_bind, \@expected_bind);
+
+Compares two lists of bind values. Returns true IFF their values are the same.
+
+
+=head1 SEE ALSO
+
+L<SQL::Abstract::Test>, L<Test::More>, L<Test::Builder>.
+
+=head1 AUTHOR
+
+Norbert Buchmuller, <norbi at nix.hu>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2008 by Norbert Buchmuller.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
Property changes on: DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBIC/SqlMakerTest.pm
___________________________________________________________________
Name: svn:eol-style
+ native
Added: DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/BindType.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/BindType.pm (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/BindType.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,29 @@
+package # hide from PAUSE
+ DBICTest::Schema::BindType;
+
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table('bindtype_test');
+
+__PACKAGE__->add_columns(
+ 'id' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'bytea' => {
+ data_type => 'bytea',
+ is_nullable => 1,
+ },
+ 'blob' => {
+ data_type => 'blob',
+ is_nullable => 1,
+ },
+ 'clob' => {
+ data_type => 'clob',
+ is_nullable => 1,
+ },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/CD.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/CD.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/CD.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -67,10 +67,22 @@
join_type => 'left',
on_delete => 'SET NULL',
on_update => 'CASCADE',
+ },
+);
+#This second relationship was added to test the short-circuiting of pointless
+#queries provided by undef_on_null_fk. the relevant test in 66relationship.t
+__PACKAGE__->belongs_to('genre_inefficient', 'DBICTest::Schema::Genre',
+ { 'foreign.genreid' => 'self.genreid' },
+ {
+ join_type => 'left',
+ on_delete => 'SET NULL',
+ on_update => 'CASCADE',
+ undef_on_null_fk => 0,
},
);
+
#__PACKAGE__->add_relationship('genre', 'DBICTest::Schema::Genre',
# { 'foreign.genreid' => 'self.genreid' },
# { 'accessor' => 'single' }
Added: DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/Encoded.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/Encoded.pm (rev 0)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/Encoded.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -0,0 +1,39 @@
+package # hide from PAUSE
+ DBICTest::Schema::Encoded;
+
+use base 'DBIx::Class::Core';
+
+use strict;
+use warnings;
+
+__PACKAGE__->table('encoded');
+__PACKAGE__->add_columns(
+ 'id' => {
+ data_type => 'integer',
+ is_auto_increment => 1
+ },
+ 'encoded' => {
+ data_type => 'varchar',
+ size => 100,
+ is_nullable => 1,
+ },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+sub set_column {
+ my ($self, $col, $value) = @_;
+ if( $col eq 'encoded' ){
+ $value = reverse split '', $value;
+ }
+ $self->next::method($col, $value);
+}
+
+sub new {
+ my($self, $attr, @rest) = @_;
+ $attr->{encoded} = reverse split '', $attr->{encoded}
+ if defined $attr->{encoded};
+ return $self->next::method($attr, @rest);
+}
+
+1;
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/EventTZ.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/EventTZ.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema/EventTZ.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -10,7 +10,7 @@
__PACKAGE__->add_columns(
id => { data_type => 'integer', is_auto_increment => 1 },
- starts_at => { data_type => 'datetime', extra => { timezone => "America/Chicago" } },
+ starts_at => { data_type => 'datetime', extra => { timezone => "America/Chicago", locale => 'de_DE' } },
created_on => { data_type => 'timestamp', extra => { timezone => "America/Chicago", floating_tz_ok => 1 } },
);
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema.pm
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema.pm 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/lib/DBICTest/Schema.pm 2009-02-10 05:30:07 UTC (rev 5437)
@@ -8,6 +8,7 @@
__PACKAGE__->load_classes(qw/
Artist
SequenceTest
+ BindType
Employee
CD
FileColumn
@@ -39,10 +40,11 @@
'ArtistSubclass',
'Producer',
'CD_to_Producer',
+ 'Dummy', # this is a real result class we remove in the hook below
),
qw/SelfRefAlias TreeLike TwoKeyTreeLike Event EventTZ NoPrimaryKey/,
qw/Collection CollectionObject TypedObject Owners BooksInLibrary/,
- qw/ForceForeign/,
+ qw/ForceForeign Encoded/,
);
sub sqlt_deploy_hook {
Modified: DBIx-Class/0.08/branches/rt_bug_41083/t/lib/sqlite.sql
===================================================================
--- DBIx-Class/0.08/branches/rt_bug_41083/t/lib/sqlite.sql 2009-02-10 00:23:28 UTC (rev 5436)
+++ DBIx-Class/0.08/branches/rt_bug_41083/t/lib/sqlite.sql 2009-02-10 05:30:07 UTC (rev 5437)
@@ -1,6 +1,6 @@
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Mon Nov 17 02:53:11 2008
+-- Created on Sat Jan 17 19:40:47 2009
--
BEGIN TRANSACTION;
@@ -38,6 +38,17 @@
CREATE INDEX cd_artwork_idx_cd_id_cd_artwor ON cd_artwork (cd_id);
--
+-- Table: bindtype_test
+--
+CREATE TABLE bindtype_test (
+ id INTEGER PRIMARY KEY NOT NULL,
+ bytea blob,
+ blob blob,
+ clob clob
+);
+
+
+--
-- Table: bookmark
--
CREATE TABLE bookmark (
@@ -400,5 +411,12 @@
value varchar(100) NOT NULL
);
+--
+-- Table: encoded
+--
+CREATE TABLE encoded (
+ id INTEGER PRIMARY KEY NOT NULL,
+ encoded varchar(100) NOT NULL
+);
COMMIT;
More information about the Bast-commits
mailing list