[Bast-commits] r4291 - in DBIx-Class/0.09/trunk: . lib/DBIx
lib/DBIx/Class lib/DBIx/Class/CDBICompat
lib/DBIx/Class/InflateColumn lib/DBIx/Class/Manual
lib/DBIx/Class/Relationship lib/DBIx/Class/ResultSourceProxy
lib/DBIx/Class/Schema lib/DBIx/Class/Schema/Role
lib/DBIx/Class/Serialize 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/Role
lib/SQL/Translator/Parser/DBIx t t/cdbi-DeepAbstractSearch
t/cdbi-abstract t/cdbi-t t/lib t/lib/DBICNGTest
t/lib/DBICNGTest/Schema t/lib/DBICNGTest/Schema/Result
t/lib/DBICNGTest/Schema/ResultSet t/lib/DBICTest
t/lib/DBICTest/Schema t/testlib
matthewt at dev.catalyst.perl.org
matthewt at dev.catalyst.perl.org
Fri Apr 25 16:03:12 BST 2008
Author: matthewt
Date: 2008-04-25 16:03:12 +0100 (Fri, 25 Apr 2008)
New Revision: 4291
Added:
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/AbstractSearch.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Copy.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Iterator.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Relationship.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Relationships.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/SQLTransformer.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/AtQueryInterval.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/Job.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/QueryInterval.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/Role/
DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/Role/AtQueryInterval.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Role/
DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/TxnScopeGuard.pm
DBIx-Class/0.09/trunk/t/77prefetch.t
DBIx-Class/0.09/trunk/t/93storage_replication.t
DBIx-Class/0.09/trunk/t/98savepoints.t
DBIx-Class/0.09/trunk/t/99schema_roles.t
DBIx-Class/0.09/trunk/t/cdbi-DeepAbstractSearch/
DBIx-Class/0.09/trunk/t/cdbi-DeepAbstractSearch/01_search.t
DBIx-Class/0.09/trunk/t/cdbi-abstract/
DBIx-Class/0.09/trunk/t/cdbi-abstract/search_where.t
DBIx-Class/0.09/trunk/t/cdbi-t/08-inheritcols.t
DBIx-Class/0.09/trunk/t/cdbi-t/22-deflate_order.t
DBIx-Class/0.09/trunk/t/cdbi-t/23-cascade.t
DBIx-Class/0.09/trunk/t/cdbi-t/24-meta_info.t
DBIx-Class/0.09/trunk/t/cdbi-t/26-mutator.t
DBIx-Class/0.09/trunk/t/cdbi-t/columns_as_hashes.t
DBIx-Class/0.09/trunk/t/cdbi-t/columns_dont_override_custom_accessors.t
DBIx-Class/0.09/trunk/t/cdbi-t/construct.t
DBIx-Class/0.09/trunk/t/cdbi-t/copy.t
DBIx-Class/0.09/trunk/t/cdbi-t/early_column_heisenbug.t
DBIx-Class/0.09/trunk/t/cdbi-t/has_many_loads_foreign_class.t
DBIx-Class/0.09/trunk/t/cdbi-t/hasa_without_loading.t
DBIx-Class/0.09/trunk/t/cdbi-t/max_min_value_of.t
DBIx-Class/0.09/trunk/t/cdbi-t/multi_column_set.t
DBIx-Class/0.09/trunk/t/cdbi-t/object_cache.t
DBIx-Class/0.09/trunk/t/cdbi-t/retrieve_from_sql_with_limit.t
DBIx-Class/0.09/trunk/t/cdbi-t/set_to_undef.t
DBIx-Class/0.09/trunk/t/cdbi-t/set_vs_DateTime.t
DBIx-Class/0.09/trunk/t/dbh_do.t
DBIx-Class/0.09/trunk/t/deleting_many_to_many.t
DBIx-Class/0.09/trunk/t/discard_changes_in_DESTROY.t
DBIx-Class/0.09/trunk/t/lib/DBICNGTest/
DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema.pm
DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/
DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result.pm
DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result/
DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result/FriendList.pm
DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result/Gender.pm
DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result/Person.pm
DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/ResultSet.pm
DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/ResultSet/
DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/ResultSet/Person.pm
DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/LongColumns.pm
DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/SequenceTest.pm
DBIx-Class/0.09/trunk/t/lib/DBICTest/Stats.pm
DBIx-Class/0.09/trunk/t/lib/DBICTest/SyntaxErrorComponent3.pm
DBIx-Class/0.09/trunk/t/relationship_after_update.t
DBIx-Class/0.09/trunk/t/relationship_doesnt_exist.t
DBIx-Class/0.09/trunk/t/resultset_overload.t
Removed:
DBIx-Class/0.09/trunk/Build.PL
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/HasA.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/HasMany.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/MightHave.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm
Modified:
DBIx-Class/0.09/trunk/
DBIx-Class/0.09/trunk/Changes
DBIx-Class/0.09/trunk/Makefile.PL
DBIx-Class/0.09/trunk/lib/DBIx/Class.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/AccessorMapping.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ColumnCase.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Constructor.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/GetSet.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ImaDBI.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/LazyLoading.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Retrieve.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/TempColumns.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Triggers.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/DB.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/InflateColumn/File.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/Cookbook.pod
DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/FAQ.pod
DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/Intro.pod
DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/Joining.pod
DBIx-Class/0.09/trunk/lib/DBIx/Class/PK.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Relationship.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Relationship/Accessor.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Relationship/Base.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSet.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSource.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSourceHandle.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSourceProxy/Table.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Row.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/Versioned.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Serialize/Storable.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Oracle.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Pg.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Replication.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/SQLite.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/mysql.pm
DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/Statistics.pm
DBIx-Class/0.09/trunk/lib/SQL/Translator/Parser/DBIx/Class.pm
DBIx-Class/0.09/trunk/t/03podcoverage.t
DBIx-Class/0.09/trunk/t/18inserterror.t
DBIx-Class/0.09/trunk/t/61findnot.t
DBIx-Class/0.09/trunk/t/66relationship.t
DBIx-Class/0.09/trunk/t/72pg.t
DBIx-Class/0.09/trunk/t/73oracle.t
DBIx-Class/0.09/trunk/t/745db2.t
DBIx-Class/0.09/trunk/t/75limit.t
DBIx-Class/0.09/trunk/t/76joins.t
DBIx-Class/0.09/trunk/t/81transactions.t
DBIx-Class/0.09/trunk/t/84serialize.t
DBIx-Class/0.09/trunk/t/86sqlt.t
DBIx-Class/0.09/trunk/t/90ensure_class_loaded.t
DBIx-Class/0.09/trunk/t/94versioning.t
DBIx-Class/0.09/trunk/t/96file_column.t
DBIx-Class/0.09/trunk/t/96multi_create.t
DBIx-Class/0.09/trunk/t/cdbi-t/01-columns.t
DBIx-Class/0.09/trunk/t/cdbi-t/02-Film.t
DBIx-Class/0.09/trunk/t/cdbi-t/04-lazy.t
DBIx-Class/0.09/trunk/t/cdbi-t/06-hasa.t
DBIx-Class/0.09/trunk/t/cdbi-t/13-constraint.t
DBIx-Class/0.09/trunk/t/cdbi-t/14-might_have.t
DBIx-Class/0.09/trunk/t/cdbi-t/15-accessor.t
DBIx-Class/0.09/trunk/t/cdbi-t/19-set_sql.t
DBIx-Class/0.09/trunk/t/cdbi-t/21-iterator.t
DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema.pm
DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/CD.pm
DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/FileColumn.pm
DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/TwoKeys.pm
DBIx-Class/0.09/trunk/t/lib/DBICVersionNew.pm
DBIx-Class/0.09/trunk/t/testlib/Actor.pm
DBIx-Class/0.09/trunk/t/testlib/MyBase.pm
DBIx-Class/0.09/trunk/t/testlib/MyFoo.pm
DBIx-Class/0.09/trunk/t/testlib/PgBase.pm
Log:
r16979 at agaton (orig r4050): ash | 2008-02-10 17:31:27 +0000
Add txn_scope_guard method/object
r17297 at agaton (orig r4110): ash | 2008-02-28 19:33:59 +0000
Todo tests for txn_rollback and scope_guard
r17300 at agaton (orig r4113): ash | 2008-03-01 12:17:54 +0000
Fix versioning test so it works with SQLT 0.09.
r17301 at agaton (orig r4114): ash | 2008-03-04 12:06:34 +0000
is_deferrable patch from Debolaz
r17306 at agaton (orig r4119): teejay | 2008-03-04 19:29:45 +0000
Applied fixes to replication connect_info method
r17307 at agaton (orig r4120): teejay | 2008-03-04 19:31:32 +0000
Applied fixes to replication connect_info method
r17308 at agaton (orig r4121): teejay | 2008-03-04 20:18:45 +0000
works but shouldn't
r17319 at agaton (orig r4122): teejay | 2008-03-04 20:41:32 +0000
roughly DTRT - please to be making less awful
r17323 at agaton (orig r4126): captainL | 2008-03-05 00:07:45 +0000
r3439 at luke-mbp (orig r3680): captainL | 2007-08-15 13:56:57 +0100
new branch for ::Versioned enhancements
r3503 at luke-mbp (orig r3681): captainL | 2007-08-15 14:29:01 +0100
created ->get_db_version and moved all overridable stuff to do_upgrade
r3955 at luke-mbp (orig r3682): captainL | 2007-08-15 23:29:57 +0100
tests are a mess, but Versioned.pm should work now
r3956 at luke-mbp (orig r3683): captainL | 2007-08-16 00:45:32 +0100
moved upgrade file reading into upgrade from _on_connect
r3958 at luke-mbp (orig r3689): captainL | 2007-08-21 12:56:31 +0100
works well, we now just require a nice way to deploy the SchemaVersions table
r3959 at luke-mbp (orig r3692): captainL | 2007-08-21 17:58:17 +0100
determines parser from dbh driver name and gives parser the dbh from schema to connect
r4213 at luke-mbp (orig r3831): captainL | 2007-10-23 13:18:13 +0100
fixed versioning test and checked db and schema versions are not equal before upgrading
r4214 at luke-mbp (orig r3832): captainL | 2007-10-23 15:08:46 +0100
changed constraint and index generation to be consistent with DB defaults
r4215 at luke-mbp (orig r3833): captainL | 2007-10-23 15:40:47 +0100
added entry to Changes
r4283 at luke-mbp (orig r3838): captainL | 2007-10-24 21:42:22 +0100
fixed broken regex when reading sql files
r5785 at luke-mbp (orig r3891): ash | 2007-11-24 22:17:41 +0000
Change diffing code to use $sqlt_schema. Sort tables in parser
r5786 at luke-mbp (orig r3892): captainL | 2007-11-25 16:26:57 +0000
upgrade will only produce a diff between the DB and the DBIC schema if explicitly requested
r5824 at luke-mbp (orig r4012): ash | 2008-02-01 19:33:00 +0000
Fallback to SQL->SQL to diff for old producers
r5825 at luke-mbp (orig r4014): castaway | 2008-02-01 23:01:26 +0000
Sanitise filename of sqlite backup file
r5830 at luke-mbp (orig r4047): captainL | 2008-02-09 15:26:50 +0000
sanified layout of Versioned.pm and documented changes
r6828 at luke-mbp (orig r4075): ash | 2008-02-13 13:26:10 +0000
Fix typo
r6831 at luke-mbp (orig r4078): captainL | 2008-02-14 00:27:14 +0000
fixed versioned loading split bug
r6846 at luke-mbp (orig r4103): captainL | 2008-02-27 15:11:21 +0000
increased sqlt rev dep
r6847 at luke-mbp (orig r4104): captainL | 2008-02-27 15:12:12 +0000
fixed behaviour or is_foreign_key_constraint and unique index names
r6848 at luke-mbp (orig r4105): captainL | 2008-02-28 10:28:31 +0000
changed versioning table from SchemaVersions to dbix_class_schema_versions with transition ability
r6849 at luke-mbp (orig r4106): captainL | 2008-02-28 10:54:28 +0000
hack bugfix for sqlt_type weirdness
r6850 at luke-mbp (orig r4107): captainL | 2008-02-28 16:11:44 +0000
cleaned up get_db_version
r6851 at luke-mbp (orig r4108): captainL | 2008-02-28 16:41:19 +0000
lowercased column names of versions table
r6852 at luke-mbp (orig r4109): captainL | 2008-02-28 16:59:04 +0000
removed startup comment if no action required
r6862 at luke-mbp (orig r4123): captainL | 2008-03-04 23:14:23 +0000
improved docs and added env var to skip version checks on connect
r6864 at luke-mbp (orig r4125): captainL | 2008-03-04 23:28:21 +0000
manual merge for deferrable changes from trunk
r17324 at agaton (orig r4127): captainL | 2008-03-05 10:38:19 +0000
added entry in Changes for versioning branch
r17355 at agaton (orig r4143): castaway | 2008-03-06 23:26:08 +0000
Random pod/doc pokage
r17397 at agaton (orig r4157): marcus | 2008-03-10 09:50:47 +0000
proper skip
r17401 at agaton (orig r4161): matthewt | 2008-03-11 03:03:50 +0000
r10429 at agaton (orig r3609): matthewt | 2007-07-27 01:28:35 +0100
created cdbicompat integration branch
r10431 at agaton (orig r3611): matthewt | 2007-07-27 06:14:35 +0100
initial merge of Schwern's CDBICompat work, with many thanks
r10432 at agaton (orig r3612): matthewt | 2007-07-27 06:16:18 +0100
and my tradditional collection of missing add commands
r14008 at agaton (orig r3715): schwern | 2007-08-31 10:17:21 +0100
r32768 at windhund: schwern | 2007-08-10 02:54:30 -0700
Document that we're doing AbstractSearch, too
Split out the customization recepie a bit.
Document some limitations.
r14009 at agaton (orig r3716): schwern | 2007-08-31 10:17:41 +0100
r32769 at windhund: schwern | 2007-08-10 02:56:14 -0700
Pull in some tests from CDBI 3.16 that already work.
Try to fix some issues with the testlibs.
r14010 at agaton (orig r3717): schwern | 2007-08-31 10:18:11 +0100
r32849 at windhund: schwern | 2007-08-31 01:39:19 -0700
Add POD to new CDBICompat modules so they pass POD coverage.
r14011 at agaton (orig r3718): schwern | 2007-08-31 10:18:27 +0100
r32850 at windhund: schwern | 2007-08-31 01:39:40 -0700
$schema isn't defined if the test is skipped.
r15165 at agaton (orig r3938): schwern | 2008-01-16 07:57:37 +0000
r52284 at windhund: schwern | 2008-01-15 18:23:19 -0800
Allow CDBI objects to be accessed like hashes as people tend to do for
performance reasons.
r15166 at agaton (orig r3939): schwern | 2008-01-16 07:57:57 +0000
r52285 at windhund: schwern | 2008-01-15 23:56:23 -0800
mst pointed out that my $val = $obj->{col}; $obj->col(23); print $val; will reflect the change because of the deferring. Using a tied scalar as the value is much, much simpler.
r15168 at agaton (orig r3941): schwern | 2008-01-16 10:17:55 +0000
r52290 at windhund: schwern | 2008-01-16 02:17:30 -0800
freeze/thaw/dclone as functions can't be made to reliably work. I'll
have to change the calling code in my app.
r15179 at agaton (orig r3952): schwern | 2008-01-17 21:32:12 +0000
r52302 at windhund: schwern | 2008-01-17 13:31:44 -0800
Make freeze/thaw and dclone work as functions on CDBICompat objects.
r15180 at agaton (orig r3953): schwern | 2008-01-17 23:57:56 +0000
r52305 at windhund: schwern | 2008-01-17 15:57:39 -0800
Make the hash-key warning dependent on DBIC_CDBICOMPAT_HASH_WARN because
boy is it annoying!
r17034 at agaton (orig r4051): schwern | 2008-02-12 10:32:43 +0000
r54475 at windhund: schwern | 2008-02-11 19:17:45 -0800
Original tests from Class::DBI::Plugin::DeepAbstractSearch
r17035 at agaton (orig r4052): schwern | 2008-02-12 10:32:57 +0000
r54476 at windhund: schwern | 2008-02-11 19:21:42 -0800
Test "like" in search_where()
r17036 at agaton (orig r4053): schwern | 2008-02-12 10:33:11 +0000
r54480 at windhund: schwern | 2008-02-12 02:27:53 -0800
Not going to do DeepAbstractSearch after all.
r17037 at agaton (orig r4054): schwern | 2008-02-12 10:33:26 +0000
r54481 at windhund: schwern | 2008-02-12 02:29:30 -0800
Remove stray $DB::single
r17038 at agaton (orig r4055): schwern | 2008-02-12 10:33:49 +0000
r54482 at windhund: schwern | 2008-02-12 02:32:29 -0800
Merge HasA, HasMany and MightHave into one file, Relationships, for easier
development.
Implement meta_info() and emulate the basic CDBI::Relationship object.
r17043 at agaton (orig r4060): schwern | 2008-02-13 02:34:42 +0000
r54488 at windhund: schwern | 2008-02-12 18:33:57 -0800
Fix the POD coverage test.
r17044 at agaton (orig r4061): schwern | 2008-02-13 03:26:46 +0000
r54494 at windhund: schwern | 2008-02-12 19:16:29 -0800
When emulating $obj->{column} do not call any custom column method, just
access the data directly with get/set_column().
r17045 at agaton (orig r4062): schwern | 2008-02-13 03:26:57 +0000
r54495 at windhund: schwern | 2008-02-12 19:20:26 -0800
Localize the warning tests.
r17046 at agaton (orig r4063): schwern | 2008-02-13 03:27:15 +0000
r54496 at windhund: schwern | 2008-02-12 19:26:10 -0800
Hash access no works despite lack of existing accessor method.
r17047 at agaton (orig r4064): schwern | 2008-02-13 03:46:35 +0000
r54500 at windhund: schwern | 2008-02-12 19:46:17 -0800
Emulate that Class::DBI inflates immediately
r17048 at agaton (orig r4065): schwern | 2008-02-13 07:14:31 +0000
r54502 at windhund: schwern | 2008-02-12 23:14:09 -0800
Emulate that CDBI throws out all changed columns and reloads them on
request in case the database modifies the new value (say, via a trigger)
r17049 at agaton (orig r4066): schwern | 2008-02-13 07:21:44 +0000
r54504 at windhund: schwern | 2008-02-12 23:16:34 -0800
Remove the big, out of date list of CDBICompat components
Document the limits of CDBI::Relationship support
r17050 at agaton (orig r4067): schwern | 2008-02-13 07:21:57 +0000
r54505 at windhund: schwern | 2008-02-12 23:21:28 -0800
Document the relationship declaration limitation.
r17051 at agaton (orig r4068): schwern | 2008-02-13 07:23:25 +0000
r54508 at windhund: schwern | 2008-02-12 23:22:51 -0800
POD mistake.
r17052 at agaton (orig r4069): schwern | 2008-02-13 09:07:03 +0000
r54510 at windhund: schwern | 2008-02-13 00:51:47 -0800
Fix update() so it throws out inflated values, too
r17053 at agaton (orig r4070): schwern | 2008-02-13 09:07:17 +0000
r54511 at windhund: schwern | 2008-02-13 01:04:38 -0800
Quiet a warning
r17054 at agaton (orig r4071): schwern | 2008-02-13 09:07:34 +0000
r54512 at windhund: schwern | 2008-02-13 01:06:42 -0800
Test that DateTime objects can safely be updated twice (which is what triggers
the equality check).
Remove the stringification to shield broken equality since DateTime seems
to work.
This also shuts up a warning in GetSet when you set to an undef value.
Test that.
Change from bitwise xor to regular xor since bitwise is overkill and nobody
knows what ^ is.
r17055 at agaton (orig r4072): schwern | 2008-02-13 09:12:09 +0000
r54516 at windhund: schwern | 2008-02-13 01:11:54 -0800
Fix the test to skip if MyFoo won't load.
r17056 at agaton (orig r4073): schwern | 2008-02-13 09:41:44 +0000
r54518 at windhund: schwern | 2008-02-13 01:41:26 -0800
Fix create() in the same way as update() so it throws out the new values and
reloads them from the database on demand.
r17057 at agaton (orig r4074): schwern | 2008-02-13 10:14:50 +0000
r54520 at windhund: schwern | 2008-02-13 02:14:34 -0800
Forgot to set up the relationship between Actor and Film. Turns it out
was working because create() was holding onto the given values but once
we changed it to throw them out it (properly) broke.
r17059 at agaton (orig r4076): schwern | 2008-02-14 00:10:53 +0000
r54522 at windhund: schwern | 2008-02-13 16:10:06 -0800
Emulate $CDBI::Weaken_Not_Available and CDBI::Plugin::NoCache
r17060 at agaton (orig r4077): schwern | 2008-02-14 00:11:08 +0000
r54523 at windhund: schwern | 2008-02-13 16:10:33 -0800
Expand the CDBICompat docs to show of it's features, the fact that you're
getting DBIC objects and to be more oriented towards CDBI users.
r17062 at agaton (orig r4079): schwern | 2008-02-14 09:43:47 +0000
r54531 at windhund: schwern | 2008-02-14 01:43:24 -0800
Put the stringification back, older versions of DateTime string equality are
still broken. But don't bother to stringify anything that's not a reference.
r17063 at agaton (orig r4080): schwern | 2008-02-14 12:24:30 +0000
r54534 at windhund: schwern | 2008-02-14 03:57:52 -0800
cascade delete test from Class-DBI 3.0.17
r17064 at agaton (orig r4081): schwern | 2008-02-14 12:24:45 +0000
r54535 at windhund: schwern | 2008-02-14 04:23:57 -0800
Implement cascade => "None"
r17145 at agaton (orig r4092): schwern | 2008-02-21 08:37:02 +0000
r54549 at windhund: schwern | 2008-02-21 00:34:10 -0800
Add in a warning if a column is declared as TEMP but it's already declared
real.
r17147 at agaton (orig r4094): schwern | 2008-02-24 09:12:46 +0000
Ensure that has_many() loads the foreign class.
r17148 at agaton (orig r4095): schwern | 2008-02-24 09:13:30 +0000
r54553 at windhund: schwern | 2008-02-21 21:04:31 -0800
The infinite loop with sub DESTROY { $_[0]->discard_changes } is a DBIC
thing.
r17149 at agaton (orig r4096): schwern | 2008-02-24 09:27:17 +0000
r54591 at windhund: schwern | 2008-02-24 01:20:41 -0800
Greatly speed up result_source_instance() and all the many things which
use it by eliminating the calls to $self->result_class.
r17150 at agaton (orig r4097): schwern | 2008-02-24 09:27:31 +0000
r54592 at windhund: schwern | 2008-02-24 01:22:57 -0800
Fix the pod coverage failure.
r17151 at agaton (orig r4098): schwern | 2008-02-24 09:27:49 +0000
r54593 at windhund: schwern | 2008-02-24 01:24:55 -0800
Fix the DESTROY/discard_changes() infinite recursion at the DBIC level.
r17152 at agaton (orig r4099): schwern | 2008-02-24 09:44:17 +0000
r54597 at windhund: schwern | 2008-02-24 01:43:58 -0800
Add NoObjectIndex which turns the live object index off and removes all the
hooks in insert and such, but retains stub indexing methods so as not to
break code.
r17153 at agaton (orig r4100): schwern | 2008-02-24 09:46:04 +0000
r54599 at windhund: schwern | 2008-02-24 01:45:49 -0800
Remove the now redudant ObjIndexStubs.
Fix pod coverage.
r17357 at agaton (orig r4145): schwern | 2008-03-07 16:04:34 +0000
Fix the merge with txn_scope_guard() and put the necessary =cut in.
r17358 at agaton (orig r4146): schwern | 2008-03-07 16:05:35 +0000
Fix the skip for DBD::Multi
r17359 at agaton (orig r4147): schwern | 2008-03-07 16:08:41 +0000
r54601 at windhund: schwern | 2008-02-24 11:13:43 +0100
Make meta_info() 'args' work.
r17360 at agaton (orig r4148): schwern | 2008-03-07 16:09:00 +0000
r54993 at windhund: schwern | 2008-03-04 10:29:45 +0100
Wrap columns() in an array ref for better is_deeply() diagnostics.
r17398 at agaton (orig r4158): schwern | 2008-03-11 00:38:09 +0000
No reason to store an empty hash ref for each column
r17399 at agaton (orig r4159): schwern | 2008-03-11 01:18:49 +0000
Fixed a heisenbug where looking at a column group would cause it to be shared.
r17402 at agaton (orig r4162): matthewt | 2008-03-11 03:12:33 +0000
moving t/cdbi-t/hasa_without_loading.t to CDBICompat makes it fail, can't leave it using CDBI so have temporarily skipped the test that fails
r17403 at agaton (orig r4163): matthewt | 2008-03-11 03:15:09 +0000
moved t/cdbi-t/08-inheritcols.t to use CDBICompat
r17404 at agaton (orig r4164): matthewt | 2008-03-11 03:19:20 +0000
fix Date::Simple req in t/cdbi-t/04-lazy.t
r17426 at agaton (orig r4168): ash | 2008-03-11 14:29:33 +0000
Fix depend on Time::Piece for cdbi
r17427 at agaton (orig r4169): ash | 2008-03-11 14:38:10 +0000
test to make sure the errors in components of resultset classes are reported right.
r17428 at agaton (orig r4170): ash | 2008-03-11 15:03:34 +0000
Fix errors from resultset components (and move tests into t/90ensure_class_loaded since its testing same sort of things)
r17429 at agaton (orig r4171): ash | 2008-03-11 15:10:50 +0000
Make throw_exception in RS a bit more forgiving too
r17442 at agaton (orig r4174): matthewt | 2008-03-11 20:40:12 +0000
r15081 at agaton (orig r3854): plu | 2007-11-06 21:16:17 +0000
new branch: svn copy 0.08/trunk 0.08/branches/oracle_sequence
r15082 at agaton (orig r3855): plu | 2007-11-06 21:52:30 +0000
added new schema for testing oracle sequence
r15083 at agaton (orig r3856): plu | 2007-11-06 21:53:35 +0000
load new schema ArtistOracle
r15084 at agaton (orig r3857): plu | 2007-11-06 21:54:38 +0000
documentation extended
r15085 at agaton (orig r3858): plu | 2007-11-06 21:56:44 +0000
update row object after storage has run the insert statement. So the row contains the automatically fetched nextval of the oracle sequence.
r15086 at agaton (orig r3859): plu | 2007-11-06 21:57:44 +0000
fetch nextval from sequence for insert
r15087 at agaton (orig r3860): plu | 2007-11-06 21:58:42 +0000
added tests for oracle sequence nextval
r15088 at agaton (orig r3861): plu | 2007-11-07 17:16:44 +0000
renamed schema ArtistOracle to SequenceTest since it won't be oracle specific anymore
r15089 at agaton (orig r3862): plu | 2007-11-07 17:19:10 +0000
moved sequence relatied insert code from DBI::Oracle::Generic to DBI so it'll work for other storage engines too
r15090 at agaton (orig r3863): plu | 2007-11-07 17:20:31 +0000
added code to fetch sequence nextval
r15091 at agaton (orig r3864): plu | 2007-11-07 17:20:53 +0000
fixed sequence auto nextval tests
r15144 at agaton (orig r3917): castaway | 2008-01-03 20:44:14 +0000
Apply patch from billisdog to ensure we rebless to the correct class before fetching sequence data
r17454 at agaton (orig r4186): schwern | 2008-03-12 21:29:58 +0000
Fix lazy loading when the object has been deleted
r17455 at agaton (orig r4187): schwern | 2008-03-13 18:49:57 +0000
Test the behavior of construct() with temp columns.
r17456 at agaton (orig r4188): schwern | 2008-03-13 18:50:32 +0000
Test lazy loading with a deleted object.
r17457 at agaton (orig r4189): schwern | 2008-03-13 18:52:14 +0000
Make Class::DBI::Plugin::DeepAbstractSearch work.
This required reordering the relationship declarations in the tests to fit
the limitations of CDBICompat. Also fixing the behavior of sth_to_objects()
and transform_sql().
r17458 at agaton (orig r4190): schwern | 2008-03-13 18:54:22 +0000
Document that DeepAbstractSearch will work.
r17459 at agaton (orig r4191): schwern | 2008-03-13 19:03:40 +0000
Fix podcoverage test for the new SQLTransformer.pm
r17460 at agaton (orig r4192): schwern | 2008-03-13 19:04:13 +0000
Make this test depend on having DeepAbstractSearch installed.
r17461 at agaton (orig r4193): schwern | 2008-03-13 19:06:48 +0000
Detabify
r17464 at agaton (orig r4196): schwern | 2008-03-14 01:32:02 +0000
Fix the skip condition.
r17465 at agaton (orig r4197): schwern | 2008-03-14 01:41:32 +0000
Move the code to create accessors out of ColumnCase and into ColumnGroups.
This allows one to remove ColumnCase without effecting other features.
r17466 at agaton (orig r4198): schwern | 2008-03-14 01:50:05 +0000
Move code having to do with adding columns out of ColumnCase.
r17467 at agaton (orig r4199): schwern | 2008-03-14 02:01:20 +0000
Move has_a() code out of ColumnCase. That should be the last of it.
r17468 at agaton (orig r4200): schwern | 2008-03-14 03:16:36 +0000
Improve add_constructor() support to handle ORDER BY and LIMIT with newlines in
the SQL
r17469 at agaton (orig r4201): schwern | 2008-03-14 03:17:12 +0000
Reorder the accessor_name_for() check to get the more likely one first to
squeeze a little performance out maybe.
r17470 at agaton (orig r4202): schwern | 2008-03-14 03:27:47 +0000
Better emulation of add_constructor, unfortunately also slower.
r17658 at agaton (orig r4204): schwern | 2008-03-14 22:50:04 +0000
A little performance hack to speed up efficiency. Internal checks that the
resultset is defined would make a SQL COUNT happen.
r17659 at agaton (orig r4205): schwern | 2008-03-15 03:01:57 +0000
Add missing method to NoObjectIndex.
r17660 at agaton (orig r4206): schwern | 2008-03-15 04:55:30 +0000
Eliminate expensive calls to can() in some very hot portions of the code by
allowing dbh_do() to take a method name.
$obj->$method_name() is about 50% faster then $obj->can($method_name)->().
r17661 at agaton (orig r4207): schwern | 2008-03-15 05:00:56 +0000
Forgot to require Test::Warn
r17662 at agaton (orig r4208): schwern | 2008-03-15 05:01:47 +0000
Reduce the number of times $self->_dbh is called inside dbh_do() to speed
up that hot bit of code.
r17663 at agaton (orig r4209): schwern | 2008-03-15 05:08:34 +0000
Missing requires of Test::NoWarnings
r17664 at agaton (orig r4210): ilmari | 2008-03-15 05:20:13 +0000
$dbh->doe doesn't take (Raise|Print)Error attributes, use eval {} instead.
r17665 at agaton (orig r4211): ilmari | 2008-03-15 05:26:05 +0000
Eliminate remaining uses of $self->dbh_do($self->can(...), ...) now that dbh_do can take a method name
r17666 at agaton (orig r4212): schwern | 2008-03-15 07:13:01 +0000
Simplify and speed up the accessor_name_for() code.
r17667 at agaton (orig r4213): ash | 2008-03-17 21:46:07 +0000
Fix is_deferrable and respcet sqltargs properly
r17668 at agaton (orig r4214): ash | 2008-03-17 21:56:47 +0000
Fix test to reflect correct default state for deferrable constraints in SQL::T
r17669 at agaton (orig r4215): ash | 2008-03-19 22:31:31 +0000
Tests for error propogation of multi create errors
r17670 at agaton (orig r4216): wreis | 2008-03-22 14:28:43 +0000
pod fixes
r17678 at agaton (orig r4224): matthewt | 2008-03-24 18:01:14 +0000
r17672 at agaton (orig r4218): gphat | 2008-03-23 23:42:04 +0000
Merge 0.09's savepoint branch
r17679 at agaton (orig r4225): matthewt | 2008-03-24 18:01:18 +0000
r17673 at agaton (orig r4219): gphat | 2008-03-23 23:52:13 +0000
Remove unnecessary passing of $self->dbh as a separate param to savepoint methods
r17680 at agaton (orig r4226): matthewt | 2008-03-24 18:01:23 +0000
r17674 at agaton (orig r4220): debolaz | 2008-03-24 03:14:15 +0000
Initial commit of auto_savepoint + some fixes
r17681 at agaton (orig r4227): matthewt | 2008-03-24 18:01:26 +0000
r17675 at agaton (orig r4221): debolaz | 2008-03-24 03:50:43 +0000
Document the auto_savepoint option for connect_info
r17682 at agaton (orig r4228): matthewt | 2008-03-24 18:01:30 +0000
r17676 at agaton (orig r4222): debolaz | 2008-03-24 03:54:07 +0000
Fix typo.
r17683 at agaton (orig r4229): matthewt | 2008-03-24 18:01:33 +0000
r17677 at agaton (orig r4223): debolaz | 2008-03-24 05:08:51 +0000
Mention savepoint support in Changes
r17686 at agaton (orig r4232): matthewt | 2008-03-24 19:21:20 +0000
r15147 at agaton (orig r3920): semifor | 2008-01-07 19:06:05 +0000
Restore InflateColumn::File functionality.
r17689 at agaton (orig r4235): matthewt | 2008-03-24 19:26:17 +0000
r16863 at agaton (orig r4026): oyse | 2008-02-05 08:55:39 +0000
Initial import of storage class for MS Acccess
r17690 at agaton (orig r4236): matthewt | 2008-03-24 19:26:20 +0000
r17354 at agaton (orig r4142): oyse | 2008-03-06 11:32:12 +0000
Added the function bind_attributes_by_data_type to cope with the 'Invalid precision value' bug on MEMO columns.
Added documentation for the 'Invalid precision value' bug.
r17692 at agaton (orig r4238): debolaz | 2008-03-25 02:19:26 +0000
Various fun things.
DONE:
* We now maintain a stack for savepoints.
* Most savepoint tests are now in a separate test file.
* Arguments to svp_* methods are now optional.
* We throw exceptions instead of warn on many places.
* gphat++
TODO:
* Document all this.
r17693 at agaton (orig r4239): debolaz | 2008-03-25 02:33:50 +0000
And document the last changes
r17694 at agaton (orig r4240): debolaz | 2008-03-25 04:03:32 +0000
Back all savepoint tests out of (mysql|pg).t
There's not a dire need to have them there, the only thing they
would be testing are the ->_svp_* methods on Storage, which are
tested in 98savepoints.t anyway.
I kept the changes in 72pg.t that was neccesary for it to run
to completion though.
r17695 at agaton (orig r4241): schwern | 2008-03-26 00:38:28 +0000
CDBICompat::Relationships uses Clone. Make CDBICompat not load without it
so the tests skip if it's not there.
Also improve the message to only show what's missing.
r17708 at agaton (orig r4242): matthewt | 2008-03-26 21:23:16 +0000
fix pod fail
r17748 at agaton (orig r4243): wreis | 2008-03-26 22:23:39 +0000
added search_related_rs at resultset
r17749 at agaton (orig r4244): wreis | 2008-03-27 02:35:48 +0000
fixed typos
r18031 at agaton (orig r4247): ash | 2008-04-01 12:22:15 +0100
Removing since Build.PL is not longer supported in modern M::I
r18032 at agaton (orig r4248): ash | 2008-04-01 13:01:16 +0100
Constraint/index name fix from rdj
r18033 at agaton (orig r4249): ash | 2008-04-01 15:10:31 +0100
Missing file
r18036 at agaton (orig r4252): tomboh | 2008-04-09 10:28:32 +0100
As of revision 4232, DBIx::Class uses Path::Class. Add this module to
DBIx::Class's dependencies.
r18037 at agaton (orig r4253): tomboh | 2008-04-09 12:18:46 +0100
Fix a typo.
r18041 at agaton (orig r4257): dwc | 2008-04-11 22:25:26 +0100
Add warnings for non-unique find usage and improve explicit key attr handling in find (zby)
r18056 at agaton (orig r4272): castaway | 2008-04-16 21:57:22 +0100
Documentation updates from omega, carbon
r18057 at agaton (orig r4273): jnapiorkowski | 2008-04-17 14:41:17 +0100
- added tests to replication to make sure dbd::multi fails over when a dtabase is forcible disconnected
- updated DBIC::DBI::Replication so that in addition to a dsn string, you can pass a preexisting database handle.
r18058 at agaton (orig r4274): jnapiorkowski | 2008-04-17 14:55:11 +0100
removed pointless debugging module
r18087 at agaton (orig r4275): jnapiorkowski | 2008-04-18 23:22:41 +0100
querycounter role, test for that and a new schema hierarchy for additional Moose related development
r18089 at agaton (orig r4277): matthewt | 2008-04-20 16:41:09 +0100
fix loading checks
r18090 at agaton (orig r4278): matthewt | 2008-04-20 17:12:14 +0100
add TODO on constraint check
r18122 at agaton (orig r4279): ribasushi | 2008-04-20 19:44:16 +0100
Split prefetch related tests from 76joins.t
r18123 at agaton (orig r4280): ribasushi | 2008-04-20 19:48:28 +0100
TODO tests for multiple same level has_many's
Currenty both exception checks pass - should fail until the code is in place
r18124 at agaton (orig r4281): ribasushi | 2008-04-20 23:18:28 +0100
Add a proxy deploy_statements() method executable directly on $schema instead of $schema->storage
r18125 at agaton (orig r4282): jnapiorkowski | 2008-04-22 20:18:08 +0100
added role for the at query interval run job system
r18132 at agaton (orig r4289): matthewt | 2008-04-23 20:47:31 +0100
todo test from zby for set_from_related
r18135 at agaton (orig r4290): debolaz | 2008-04-24 10:04:15 +0100
Fix PAUSE indexing of packages
Property changes on: DBIx-Class/0.09/trunk
___________________________________________________________________
Name: svk:merge
- 168d5346-440b-0410-b799-f706be625ff1:/DBIx-Class-current:2207
462d4d0c-b505-0410-bf8e-ce8f877b3390:/local/bast/DBIx-Class:3159
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/on_disconnect_do:3694
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/trunk:4024
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-C3:318
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-current:2222
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-joins:173
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-resultset:570
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/datetime:1716
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/find_compat:1855
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/find_unique_query_fixes:2142
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/inflate:1988
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/many_to_many:2025
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/re_refactor_bugfix:1944
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/reorganize_tests:1827
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/resultset-new-refactor:1766
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/resultset_2_electric_boogaloo:2175
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/resultset_cleanup:2102
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/sqlt_tests_refactor:2043
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/trunk/DBIx-Class:3606
fe160bb6-dc1c-0410-9f2b-d64a711b54a5:/local/DBIC-trunk-0.08:10510
+ 168d5346-440b-0410-b799-f706be625ff1:/DBIx-Class-current:2207
462d4d0c-b505-0410-bf8e-ce8f877b3390:/local/bast/DBIx-Class:3159
9c88509d-e914-0410-b01c-b9530614cbfe:/local/DBIx-Class:32260
9c88509d-e914-0410-b01c-b9530614cbfe:/local/DBIx-Class-CDBICompat:54993
9c88509d-e914-0410-b01c-b9530614cbfe:/vendor/DBIx-Class:31122
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/cdbicompat_integration:4160
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/file_column:3920
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/on_disconnect_do:3694
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/oracle_sequence:4173
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/savepoints:4223
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/storage-ms-access:4142
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/versioned_enhancements:4125
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/trunk:4290
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-C3:318
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-current:2222
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-joins:173
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-resultset:570
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/datetime:1716
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/find_compat:1855
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/find_unique_query_fixes:2142
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/inflate:1988
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/many_to_many:2025
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/re_refactor_bugfix:1944
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/reorganize_tests:1827
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/resultset-new-refactor:1766
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/resultset_2_electric_boogaloo:2175
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/resultset_cleanup:2102
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/sqlt_tests_refactor:2043
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/trunk/DBIx-Class:3606
fe160bb6-dc1c-0410-9f2b-d64a711b54a5:/local/DBIC-trunk-0.08:10510
Deleted: DBIx-Class/0.09/trunk/Build.PL
===================================================================
--- DBIx-Class/0.09/trunk/Build.PL 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/Build.PL 2008-04-25 15:03:12 UTC (rev 4291)
@@ -1,3 +0,0 @@
-# Dear Distribution Packager. This use of require is intentional.
-# Module::Install detects Build.PL usage and acts accordingly.
-require 'Makefile.PL';
Modified: DBIx-Class/0.09/trunk/Changes
===================================================================
--- DBIx-Class/0.09/trunk/Changes 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/Changes 2008-04-25 15:03:12 UTC (rev 4291)
@@ -1,5 +1,20 @@
Revision history for DBIx::Class
+ - is_deferable support on relations used by the SQL::Translator
+ parser (Anders Nor Berle)
+ - Refactored DBIx::Class::Schema::Versioned
+ - Syntax errors from resultset components are now reported correctly
+ - sqltargs respected correctly in deploy et al.
+ - Added support for savepoints, and using them automatically in
+ nested transactions if auto_savepoint is set in connect_info.
+ - Changed naming scheme for constraints and keys in the sqlt parser;
+ names should now be consistent and collision-free.
+ - Improve handling of explicit key attr in ResultSet::find (zby)
+ - Add warnings for non-unique ResultSet::find queries (zby)
+
+0.08010 2008-03-01 10:30
+ - Fix t/94versioning.t so it passes with latest SQL::Translator
+
0.08009 2008-01-20 13:30
- Made search_rs smarter about when to preserve the cache to fix
mm prefetch usage
Modified: DBIx-Class/0.09/trunk/Makefile.PL
===================================================================
--- DBIx-Class/0.09/trunk/Makefile.PL 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/Makefile.PL 2008-04-25 15:03:12 UTC (rev 4291)
@@ -18,12 +18,16 @@
requires 'Class::Accessor::Grouped' => 0.05002;
requires 'JSON::Any' => 1.00;
requires 'Scope::Guard' => 0.03;
+requires 'Digest::SHA1' => 2.00;
+requires 'Path::Class' => 0;
# Perl 5.8.0 doesn't have utf8::is_utf8()
requires 'Encode' => 0 if ($] <= 5.008000);
build_requires 'DBD::SQLite' => 1.13;
build_requires 'Test::Builder' => 0.33;
+build_requires 'Test::Warn' => 0.08;
+build_requires 'Test::NoWarnings' => 0.08;
install_script 'script/dbicadmin';
@@ -33,6 +37,8 @@
if( -e 'inc/.author' ) {
build_requires 'DBIx::ContextualFetch';
build_requires 'Class::Trigger';
+ build_requires 'Time::Piece';
+
system('pod2text lib/DBIx/Class.pm > README');
}
@@ -41,3 +47,28 @@
auto_install;
WriteAll;
+
+
+if ($Module::Install::AUTHOR) {
+ # Need to do this _after_ WriteAll else it looses track of them
+ Meta->{values}{build_requires} = [ grep {
+ $_->[0] !~ /
+ DBIx::ContextualFetch |
+ Class::Trigger |
+ Time::Piece
+ /x;
+ } @{Meta->{values}{build_requires}} ];
+
+ my @scalar_keys = Module::Install::Metadata::Meta_TupleKeys();
+ sub Module::Install::Metadata::Meta_TupleKeys {
+ return @scalar_keys, 'resources';
+ }
+ Meta->{values}{resources} = [
+ [ 'MailingList', 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class' ],
+ [ 'IRC', 'irc://irc.perl.org/#dbix-class' ],
+ ];
+ Meta->write;
+}
+
+
+
Added: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/AbstractSearch.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/AbstractSearch.pm (rev 0)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/AbstractSearch.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,37 @@
+package # hide form PAUSE
+ DBIx::Class::CDBICompat::AbstractSearch;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::AbstractSearch
+
+=head1 SYNOPSIS
+
+See DBIx::Class::CDBICompat for directions for use.
+
+=head1 DESCRIPTION
+
+Emulates L<Class::DBI::AbstractSearch>.
+
+=cut
+
+# The keys are mostly the same.
+my %cdbi2dbix = (
+ limit => 'rows',
+);
+
+sub search_where {
+ my $class = shift;
+ my $where = (ref $_[0]) ? $_[0] : { @_ };
+ my $attr = (ref $_[0]) ? $_[1] : {};
+
+ # Translate the keys
+ $attr->{$cdbi2dbix{$_}} = delete $attr->{$_} for keys %cdbi2dbix;
+
+ return $class->resultset_instance->search($where, $attr);
+}
+
+1;
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/AccessorMapping.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/AccessorMapping.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/AccessorMapping.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -6,18 +6,15 @@
sub mk_group_accessors {
my ($class, $group, @cols) = @_;
- unless ($class->can('accessor_name') || $class->can('mutator_name')) {
- return $class->next::method($group => @cols);
- }
+
foreach my $col (@cols) {
- my $ro_meth = ($class->can('accessor_name')
- ? $class->accessor_name($col)
- : $col);
- my $wo_meth = ($class->can('mutator_name')
- ? $class->mutator_name($col)
- : $col);
- #warn "$col $ro_meth $wo_meth";
- if ($ro_meth eq $wo_meth) {
+ my $ro_meth = $class->accessor_name_for($col);
+ my $wo_meth = $class->mutator_name_for($col);
+
+ # warn "class: $class / col: $col / ro: $ro_meth / wo: $wo_meth\n";
+ if ($ro_meth eq $wo_meth or # they're the same
+ $wo_meth eq $col) # or only the accessor is custom
+ {
$class->next::method($group => [ $ro_meth => $col ]);
} else {
$class->mk_group_ro_accessors($group => [ $ro_meth => $col ]);
@@ -26,18 +23,35 @@
}
}
+
+sub accessor_name_for {
+ my ($class, $column) = @_;
+ if ($class->can('accessor_name')) {
+ return $class->accessor_name($column)
+ }
+
+ return $column;
+}
+
+sub mutator_name_for {
+ my ($class, $column) = @_;
+ if ($class->can('mutator_name')) {
+ return $class->mutator_name($column)
+ }
+
+ return $column;
+}
+
+
sub new {
my ($class, $attrs, @rest) = @_;
$class->throw_exception( "create needs a hashref" ) unless ref $attrs eq 'HASH';
foreach my $col ($class->columns) {
- if ($class->can('accessor_name')) {
- my $acc = $class->accessor_name($col);
+ my $acc = $class->accessor_name_for($col);
$attrs->{$col} = delete $attrs->{$acc} if exists $attrs->{$acc};
- }
- if ($class->can('mutator_name')) {
- my $mut = $class->mutator_name($col);
+
+ my $mut = $class->mutator_name_for($col);
$attrs->{$col} = delete $attrs->{$mut} if exists $attrs->{$mut};
- }
}
return $class->next::method($attrs, @rest);
}
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ColumnCase.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ColumnCase.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ColumnCase.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -13,15 +13,16 @@
sub add_columns {
my ($class, @cols) = @_;
- $class->mk_group_accessors(column => @cols);
- $class->result_source_instance->add_columns(map lc, @cols);
+ return $class->result_source_instance->add_columns(map lc, @cols);
}
sub has_a {
- my ($class, $col, @rest) = @_;
- $class->next::method(lc($col), @rest);
- $class->mk_group_accessors('inflated_column' => $col);
- return 1;
+ my($self, $col, @rest) = @_;
+
+ $self->_declare_has_a(lc $col, @rest);
+ $self->_mk_inflated_column_accessor($col);
+
+ return 1;
}
sub has_many {
@@ -79,20 +80,16 @@
return \%new_query;
}
-sub _mk_group_accessors {
- my ($class, $type, $group, @fields) = @_;
- #warn join(', ', map { ref $_ ? (@$_) : ($_) } @fields);
- my @extra;
- foreach (@fields) {
- my ($acc, $field) = ref $_ ? @$_ : ($_, $_);
- #warn "$acc ".lc($acc)." $field";
- next if defined &{"${class}::${acc}"};
- push(@extra, [ lc $acc => $field ]);
- }
- return $class->next::method($type, $group,
- @fields, @extra);
+sub _deploy_accessor {
+ my($class, $name, $accessor) = @_;
+
+ return if $class->_has_custom_accessor($name);
+
+ $class->next::method(lc $name => $accessor);
+ return $class->next::method($name => $accessor);
}
+
sub new {
my ($class, $attrs, @rest) = @_;
my %att;
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ColumnGroups.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ColumnGroups.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -4,6 +4,8 @@
use strict;
use warnings;
+use Storable 'dclone';
+
use base qw/DBIx::Class::Row/;
__PACKAGE__->mk_classdata('_column_groups' => { });
@@ -12,6 +14,8 @@
my $proto = shift;
my $class = ref $proto || $proto;
my $group = shift || "All";
+ $class->_init_result_source_instance();
+
$class->_add_column_group($group => @_) if @_;
return $class->all_columns if $group eq "All";
return $class->primary_column if $group eq "Primary";
@@ -20,35 +24,108 @@
sub _add_column_group {
my ($class, $group, @cols) = @_;
+ $class->mk_group_accessors(column => @cols);
$class->add_columns(@cols);
$class->_register_column_group($group => @cols);
}
+sub add_columns {
+ my ($class, @cols) = @_;
+ $class->result_source_instance->add_columns(@cols);
+}
+
sub _register_column_group {
my ($class, $group, @cols) = @_;
- my $groups = { %{$class->_column_groups} };
+ # Must do a complete deep copy else column groups
+ # might accidentally be shared.
+ my $groups = dclone $class->_column_groups;
if ($group eq 'Primary') {
$class->set_primary_key(@cols);
- $groups->{'Essential'}{$_} ||= {} for @cols;
+ $groups->{'Essential'}{$_} ||= 1 for @cols;
}
if ($group eq 'All') {
unless (exists $class->_column_groups->{'Primary'}) {
- $groups->{'Primary'}{$cols[0]} = {};
+ $groups->{'Primary'}{$cols[0]} = 1;
$class->set_primary_key($cols[0]);
}
unless (exists $class->_column_groups->{'Essential'}) {
- $groups->{'Essential'}{$cols[0]} = {};
+ $groups->{'Essential'}{$cols[0]} = 1;
}
}
- $groups->{$group}{$_} ||= {} for @cols;
+ $groups->{$group}{$_} ||= 1 for @cols;
$class->_column_groups($groups);
}
+# CDBI will never overwrite an accessor, but it only uses one
+# accessor for all column types. DBIC uses many different
+# accessor types so, for example, if you declare a column()
+# and then a has_a() for that same column it must overwrite.
+#
+# To make this work CDBICompat has decide if an accessor
+# method was put there by itself and only then overwrite.
+{
+ my %our_accessors;
+
+ sub _has_custom_accessor {
+ my($class, $name) = @_;
+
+ no strict 'refs';
+ my $existing_accessor = *{$class .'::'. $name}{CODE};
+ return $existing_accessor && !$our_accessors{$existing_accessor};
+ }
+
+ sub _deploy_accessor {
+ my($class, $name, $accessor) = @_;
+
+ return if $class->_has_custom_accessor($name);
+
+ {
+ no strict 'refs';
+ no warnings 'redefine';
+ *{$class .'::'. $name} = $accessor;
+ }
+
+ $our_accessors{$accessor}++;
+
+ return 1;
+ }
+}
+
+sub _mk_group_accessors {
+ my ($class, $type, $group, @fields) = @_;
+
+ # So we don't have to do lots of lookups inside the loop.
+ my $maker = $class->can($type) unless ref $type;
+
+ # warn "$class $type $group\n";
+ foreach my $field (@fields) {
+ if( $field eq 'DESTROY' ) {
+ carp("Having a data accessor named DESTROY in ".
+ "'$class' is unwise.");
+ }
+
+ my $name = $field;
+
+ ($name, $field) = @$field if ref $field;
+
+ my $accessor = $class->$maker($group, $field);
+ my $alias = "_${name}_accessor";
+
+ # warn " $field $alias\n";
+ {
+ no strict 'refs';
+
+ $class->_deploy_accessor($name, $accessor);
+ $class->_deploy_accessor($alias, $accessor);
+ }
+ }
+}
+
sub all_columns { return shift->result_source_instance->columns; }
sub primary_column {
@@ -57,6 +134,10 @@
return wantarray ? @pri : $pri[0];
}
+sub _essential {
+ return shift->columns("Essential");
+}
+
sub find_column {
my ($class, $col) = @_;
return $col if $class->has_column($col);
Added: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm (rev 0)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,105 @@
+package
+ DBIx::Class::CDBICompat::ColumnsAsHash;
+
+use strict;
+use warnings;
+
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::ColumnsAsHash
+
+=head1 SYNOPSIS
+
+See DBIx::Class::CDBICompat for directions for use.
+
+=head1 DESCRIPTION
+
+Emulates the I<undocumnted> behavior of Class::DBI where the object can be accessed as a hash of columns. This is often used as a performance hack.
+
+ my $column = $row->{column};
+
+=head2 Differences from Class::DBI
+
+If C<DBIC_CDBICOMPAT_HASH_WARN> is true it will warn when a column is accessed as a hash key.
+
+=cut
+
+sub new {
+ my $class = shift;
+
+ my $new = $class->next::method(@_);
+
+ $new->_make_columns_as_hash;
+
+ return $new;
+}
+
+sub inflate_result {
+ my $class = shift;
+
+ my $new = $class->next::method(@_);
+
+ $new->_make_columns_as_hash;
+
+ return $new;
+}
+
+
+sub _make_columns_as_hash {
+ my $self = shift;
+
+ for my $col ($self->columns) {
+ if( exists $self->{$col} ) {
+ warn "Skipping mapping $col to a hash key because it exists";
+ }
+
+ tie $self->{$col}, 'DBIx::Class::CDBICompat::Tied::ColumnValue',
+ $self, $col;
+ }
+}
+
+
+package DBIx::Class::CDBICompat::Tied::ColumnValue;
+
+use Carp;
+use Scalar::Util qw(weaken isweak);
+
+
+sub TIESCALAR {
+ my($class, $obj, $col) = @_;
+ my $self = [$obj, $col];
+ weaken $self->[0];
+
+ return bless $self, $_[0];
+}
+
+sub FETCH {
+ my $self = shift;
+ my($obj, $col) = @$self;
+
+ my $class = ref $obj;
+ my $id = $obj->id;
+ carp "Column '$col' of '$class/$id' was fetched as a hash"
+ if $ENV{DBIC_CDBICOMPAT_HASH_WARN};
+
+ return $obj->column_info($col)->{_inflate_info}
+ ? $obj->get_inflated_column($col)
+ : $obj->get_column($col);
+}
+
+sub STORE {
+ my $self = shift;
+ my($obj, $col) = @$self;
+
+ my $class = ref $obj;
+ my $id = $obj->id;
+ carp "Column '$col' of '$class/$id' was stored as a hash"
+ if $ENV{DBIC_CDBICOMPAT_HASH_WARN};
+
+ return $obj->column_info($col)->{_inflate_info}
+ ? $obj->set_inflated_column($col => shift)
+ : $obj->set_column($col => shift);
+}
+
+1;
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Constructor.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Constructor.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Constructor.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -1,17 +1,30 @@
package # hide from PAUSE
DBIx::Class::CDBICompat::Constructor;
+use base qw(DBIx::Class::CDBICompat::ImaDBI);
+
use strict;
use warnings;
+use Carp;
+
+__PACKAGE__->set_sql(Retrieve => <<'');
+SELECT __ESSENTIAL__
+FROM __TABLE__
+WHERE %s
+
sub add_constructor {
- my ($class, $meth, $sql) = @_;
- $class = ref $class if ref $class;
- no strict 'refs';
- *{"${class}::${meth}"} =
- sub {
- my ($class, @args) = @_;
- return $class->search_literal($sql, @args);
+ my ($class, $method, $fragment) = @_;
+ return croak("constructors needs a name") unless $method;
+
+ no strict 'refs';
+ my $meth = "$class\::$method";
+ return carp("$method already exists in $class")
+ if *$meth{CODE};
+
+ *$meth = sub {
+ my $self = shift;
+ $self->sth_to_objects($self->sql_Retrieve($fragment), \@_);
};
}
Added: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Copy.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Copy.pm (rev 0)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Copy.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,36 @@
+package # hide from PAUSE
+ DBIx::Class::CDBICompat::Copy;
+
+use strict;
+use warnings;
+
+use Carp;
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::Copy
+
+=head1 SYNOPSIS
+
+See DBIx::Class::CDBICompat for directions for use.
+
+=head1 DESCRIPTION
+
+Emulates C<<Class::DBI->copy($new_id)>>.
+
+=cut
+
+
+# CDBI's copy will take an id in addition to a hash ref.
+sub copy {
+ my($self, $arg) = @_;
+ return $self->next::method($arg) if ref $arg;
+
+ my @primary_columns = $self->primary_columns;
+ croak("Need hash-ref to edit copied column values")
+ if @primary_columns > 1;
+
+ return $self->next::method({ $primary_columns[0] => $arg });
+}
+
+1;
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/GetSet.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/GetSet.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/GetSet.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -16,7 +16,17 @@
}
sub set {
- return shift->set_column(@_);
+ my($self, %data) = @_;
+
+ # set_columns() is going to do a string comparison before setting.
+ # This breaks on DateTime objects (whose comparison is arguably broken)
+ # so we stringify anything first.
+ for my $key (keys %data) {
+ next unless ref $data{$key};
+ $data{$key} = "$data{$key}";
+ }
+
+ return shift->set_columns(\%data);
}
1;
Deleted: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/HasA.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/HasA.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/HasA.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -1,46 +0,0 @@
-package # hide from PAUSE
- DBIx::Class::CDBICompat::HasA;
-
-use strict;
-use warnings;
-
-sub has_a {
- my ($self, $col, $f_class, %args) = @_;
- $self->throw_exception( "No such column ${col}" ) unless $self->has_column($col);
- $self->ensure_class_loaded($f_class);
- if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a
- if (!ref $args{'inflate'}) {
- my $meth = $args{'inflate'};
- $args{'inflate'} = sub { $f_class->$meth(shift); };
- }
- if (!ref $args{'deflate'}) {
- my $meth = $args{'deflate'};
- $args{'deflate'} = sub { shift->$meth; };
- }
- $self->inflate_column($col, \%args);
- return 1;
- }
-
- $self->belongs_to($col, $f_class);
- return 1;
-}
-
-sub search {
- my $self = shift;
- my $attrs = {};
- if (@_ > 1 && ref $_[$#_] eq 'HASH') {
- $attrs = { %{ pop(@_) } };
- }
- my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift)
- : {@_})
- : undef());
- if (ref $where eq 'HASH') {
- foreach my $key (keys %$where) { # has_a deflation hack
- $where->{$key} = ''.$where->{$key}
- if eval { $where->{$key}->isa('DBIx::Class') };
- }
- }
- $self->next::method($where, $attrs);
-}
-
-1;
Deleted: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/HasMany.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/HasMany.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/HasMany.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -1,46 +0,0 @@
-package # hide from PAUSE
- DBIx::Class::CDBICompat::HasMany;
-
-use strict;
-use warnings;
-
-sub has_many {
- my ($class, $rel, $f_class, $f_key, $args) = @_;
-
- my @f_method;
-
- if (ref $f_class eq 'ARRAY') {
- ($f_class, @f_method) = @$f_class;
- }
-
- if (ref $f_key eq 'HASH' && !$args) { $args = $f_key; undef $f_key; };
-
- $args ||= {};
- if (delete $args->{no_cascade_delete}) {
- $args->{cascade_delete} = 0;
- }
-
- if( !$f_key and !@f_method ) {
- my $f_source = $f_class->result_source_instance;
- ($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class }
- $f_source->relationships;
- }
-
- $class->next::method($rel, $f_class, $f_key, $args);
-
- if (@f_method) {
- no strict 'refs';
- no warnings 'redefine';
- my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; };
- *{"${class}::${rel}"} =
- sub {
- my $rs = shift->search_related($rel => @_);
- $rs->{attrs}{record_filter} = $post_proc;
- return (wantarray ? $rs->all : $rs);
- };
- return 1;
- }
-
-}
-
-1;
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ImaDBI.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ImaDBI.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ImaDBI.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -7,8 +7,11 @@
use base qw/DBIx::Class/;
+__PACKAGE__->mk_classdata('sql_transformer_class' =>
+ 'DBIx::Class::CDBICompat::SQLTransformer');
+
__PACKAGE__->mk_classdata('_transform_sql_handler_order'
- => [ qw/TABLE ESSENTIAL JOIN/ ] );
+ => [ qw/TABLE ESSENTIAL JOIN IDENTIFIER/ ] );
__PACKAGE__->mk_classdata('_transform_sql_handlers' =>
{
@@ -24,9 +27,15 @@
'ESSENTIAL' =>
sub {
my ($self, $class, $data) = @_;
- return join(' ', $class->columns('Essential')) unless $data;
- return join(' ', $self->{_classes}{$data}->columns('Essential'));
+ $class = $data ? $self->{_classes}{$data} : $class;
+ return join(', ', $class->columns('Essential'));
},
+ 'IDENTIFIER' =>
+ sub {
+ my ($self, $class, $data) = @_;
+ $class = $data ? $self->{_classes}{$data} : $class;
+ return join ' AND ', map "$_ = ?", $class->primary_columns;
+ },
'JOIN' =>
sub {
my ($self, $class, $data) = @_;
@@ -82,30 +91,32 @@
sub {
my ($class, @args) = @_;
my $sth = $class->$meth;
- $sth->execute(@args);
- return $class->sth_to_objects($sth);
+ return $class->sth_to_objects($sth, \@args);
};
}
}
sub sth_to_objects {
- my ($class, $sth) = @_;
+ my ($class, $sth, $execute_args) = @_;
+
+ $sth->execute(@$execute_args);
+
my @ret;
while (my $row = $sth->fetchrow_hashref) {
push(@ret, $class->inflate_result($class->result_source_instance, $row));
}
+
return @ret;
}
sub transform_sql {
my ($class, $sql, @args) = @_;
- my $attrs = { };
- foreach my $key (@{$class->_transform_sql_handler_order}) {
- my $h = $class->_transform_sql_handlers->{$key};
- $sql =~ s/__$key(?:\(([^\)]+)\))?__/$h->($attrs, $class, $1)/eg;
- }
- #warn $sql;
- return sprintf($sql, @args);
+
+ my $tclass = $class->sql_transformer_class;
+ $class->ensure_class_loaded($tclass);
+ my $t = $tclass->new($class, $sql, @args);
+
+ return sprintf($t->sql, $t->args);
}
package
Added: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Iterator.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Iterator.pm (rev 0)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Iterator.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,52 @@
+package DBIx::Class::CDBICompat::Iterator;
+
+use strict;
+use warnings;
+
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::Iterator
+
+=head1 SYNOPSIS
+
+See DBIx::Class::CDBICompat for directions for use.
+
+=head1 DESCRIPTION
+
+Emulates the extra behaviors of the Class::DBI search iterator.
+
+=head2 Differences from DBIx::Class result set
+
+The CDBI iterator returns true if there were any results, false otherwise. The DBIC result set always returns true.
+
+=cut
+
+
+sub _init_result_source_instance {
+ my $class = shift;
+
+ my $table = $class->next::method(@_);
+ $table->resultset_class("DBIx::Class::CDBICompat::Iterator::ResultSet");
+
+ return $table;
+}
+
+
+
+package DBIx::Class::CDBICompat::Iterator::ResultSet;
+
+use strict;
+use warnings;
+
+use base qw(DBIx::Class::ResultSet);
+
+sub _bool {
+ # Performance hack so internal checks whether the result set
+ # exists won't do a SQL COUNT.
+ return 1 if caller =~ /^DBIx::Class::/;
+
+ return $_[0]->count;
+}
+
+1;
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/LazyLoading.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/LazyLoading.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/LazyLoading.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -11,6 +11,47 @@
return $rs;
}
+
+# Emulate that CDBI throws out all changed columns and reloads them on
+# request in case the database modifies the new value (say, via a trigger)
+sub update {
+ my $self = shift;
+
+ my @dirty_columns = keys %{$self->{_dirty_columns}};
+
+ my $ret = $self->next::method(@_);
+ $self->_clear_column_data(@dirty_columns);
+
+ return $ret;
+}
+
+
+# And again for create
+sub create {
+ my $class = shift;
+ my($data) = @_;
+
+ my @columns = keys %$data;
+
+ my $obj = $class->next::method(@_);
+ return $obj unless defined $obj;
+
+ my %primary_cols = map { $_ => 1 } $class->primary_columns;
+ my @data_cols = grep !$primary_cols{$_}, @columns;
+ $obj->_clear_column_data(@data_cols);
+
+ return $obj;
+}
+
+
+sub _clear_column_data {
+ my $self = shift;
+
+ delete $self->{_column_data}{$_} for @_;
+ delete $self->{_inflated_column}{$_} for @_;
+}
+
+
sub get_column {
my ($self, $col) = @_;
if ((ref $self) && (!exists $self->{'_column_data'}{$col})
@@ -22,6 +63,28 @@
$self->next::method(@_[1..$#_]);
}
+# CDBI does not explicitly declare auto increment columns, so
+# we just clear out our primary columns before copying.
+sub copy {
+ my($self, $changes) = @_;
+
+ for my $col ($self->primary_columns) {
+ $changes->{$col} = undef unless exists $changes->{$col};
+ }
+
+ return $self->next::method($changes);
+}
+
+sub discard_changes {
+ my($self) = shift;
+
+ delete $self->{_column_data}{$_} for $self->is_changed;
+ delete $self->{_dirty_columns};
+ delete $self->{_relationship_data};
+
+ return $self;
+}
+
sub _ident_cond {
my ($class) = @_;
return join(" AND ", map { "$_ = ?" } $class->primary_columns);
@@ -40,7 +103,9 @@
# $self->ident_condition);
# Not sure why the first one works and this doesn't :(
my @val = $cursor->next;
-#warn "Flesh: ".join(', ', @want, '=>', @val);
+
+ return unless @val; # object must have been deleted from the database
+
foreach my $w (@want) {
$self->{'_column_data'}{$w} = shift @val;
}
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -12,6 +12,21 @@
__PACKAGE__->mk_classdata('live_object_index' => { });
__PACKAGE__->mk_classdata('live_object_init_count' => { });
+# Caching is on by default, but a classic CDBI hack to turn it off is to
+# set this variable false.
+$Class::DBI::Weaken_Is_Available = 1
+ unless defined $Class::DBI::Weaken_Is_Available;
+__PACKAGE__->mk_classdata('__nocache' => 0);
+
+sub nocache {
+ my $class = shift;
+
+ return $class->__nocache(@_) if @_;
+
+ return 1 if $Class::DBI::Weaken_Is_Available == 0;
+ return $class->__nocache;
+}
+
# Ripped from Class::DBI 0.999, all credit due to Tony Bowden for this code,
# all blame due to me for whatever bugs I introduced porting it.
@@ -30,11 +45,15 @@
delete @$live{ keys %$live };
}
+
# And now the fragments to tie it in to DBIx::Class::Table
sub insert {
my ($self, @rest) = @_;
$self->next::method(@rest);
+
+ return $self if $self->nocache;
+
# Because the insert will die() if it can't insert into the db (or should)
# we can be sure the object *was* inserted if we got this far. In which
# case, given primary keys are unique and ID only returns a
@@ -55,6 +74,9 @@
sub inflate_result {
my ($class, @rest) = @_;
my $new = $class->next::method(@rest);
+
+ return $new if $new->nocache;
+
if (my $key = $new->ID) {
#warn "Key $key";
my $live = $class->live_object_index;
@@ -67,16 +89,4 @@
return $new;
}
-sub discard_changes {
- my ($self) = @_;
- if (my $key = $self->ID) {
- $self->remove_from_object_index;
- my $ret = $self->next::method;
- $self->live_object_index->{$key} = $self if $self->in_storage;
- return $ret;
- } else {
- return $self->next::method;
- }
-}
-
1;
Deleted: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/MightHave.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/MightHave.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/MightHave.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -1,17 +0,0 @@
-package # hide from PAUSE
- DBIx::Class::CDBICompat::MightHave;
-
-use strict;
-use warnings;
-
-sub might_have {
- my ($class, $rel, $f_class, @columns) = @_;
- if (ref $columns[0] || !defined $columns[0]) {
- return $class->next::method($rel, $f_class, @columns);
- } else {
- return $class->next::method($rel, $f_class, undef,
- { proxy => \@columns });
- }
-}
-
-1;
Added: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm (rev 0)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,34 @@
+package # hide from PAUSE
+ DBIx::Class::CDBICompat::NoObjectIndex;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::NoObjectIndex
+
+=head1 SYNOPSIS
+
+ Part of CDBICompat
+
+=head1 DESCRIPTION
+
+Defines empty methods for object indexing. They do nothing.
+
+Using NoObjectIndex instead of LiveObjectIndex and nocache(1) is a little
+faster because it removes code from the object insert and retrieve chains.
+
+=cut
+
+sub nocache { return 1 }
+
+sub purge_object_index_every {}
+
+sub purge_dead_from_object_index {}
+
+sub remove_from_object_index {}
+
+sub clear_object_index {}
+
+1;
Deleted: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -1,11 +0,0 @@
-package # hide from PAUSE
- DBIx::Class::CDBICompat::ObjIndexStubs;
-
-use strict;
-use warnings;
-
-sub remove_from_object_index { }
-
-sub clear_object_index { }
-
-1;
Added: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Relationship.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Relationship.pm (rev 0)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Relationship.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,42 @@
+package
+ DBIx::Class::CDBICompat::Relationship;
+
+use strict;
+use warnings;
+
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::Relationship
+
+=head1 DESCRIPTION
+
+Emulate the Class::DBI::Relationship object returned from C<meta_info()>.
+
+=cut
+
+my %method2key = (
+ name => 'type',
+ class => 'self_class',
+ accessor => 'accessor',
+ foreign_class => 'class',
+ args => 'args',
+);
+
+sub new {
+ my($class, $args) = @_;
+
+ return bless $args, $class;
+}
+
+for my $method (keys %method2key) {
+ my $key = $method2key{$method};
+ my $code = sub {
+ $_[0]->{$key};
+ };
+
+ no strict 'refs';
+ *{$method} = $code;
+}
+
+1;
Added: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Relationships.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Relationships.pm (rev 0)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Relationships.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,202 @@
+package # hide from PAUSE
+ DBIx::Class::CDBICompat::Relationships;
+
+use strict;
+use warnings;
+
+use base qw/Class::Data::Inheritable/;
+
+use Clone;
+use DBIx::Class::CDBICompat::Relationship;
+
+__PACKAGE__->mk_classdata('__meta_info' => {});
+
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::Relationships
+
+=head1 DESCRIPTION
+
+Emulate C<has_a>, C<has_many>, C<might_have> and C<meta_info>.
+
+=cut
+
+sub has_a {
+ my($self, $col, @rest) = @_;
+
+ $self->_declare_has_a($col, @rest);
+ $self->_mk_inflated_column_accessor($col);
+
+ return 1;
+}
+
+
+sub _declare_has_a {
+ my ($self, $col, $f_class, %args) = @_;
+ $self->throw_exception( "No such column ${col}" )
+ unless $self->has_column($col);
+ $self->ensure_class_loaded($f_class);
+
+ my $rel_info;
+
+ if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a
+ if (!ref $args{'inflate'}) {
+ my $meth = $args{'inflate'};
+ $args{'inflate'} = sub { $f_class->$meth(shift); };
+ }
+ if (!ref $args{'deflate'}) {
+ my $meth = $args{'deflate'};
+ $args{'deflate'} = sub { shift->$meth; };
+ }
+ $self->inflate_column($col, \%args);
+
+ $rel_info = {
+ class => $f_class
+ };
+ }
+ else {
+ $self->belongs_to($col, $f_class);
+ $rel_info = $self->result_source_instance->relationship_info($col);
+ }
+
+ $rel_info->{args} = \%args;
+
+ $self->_extend_meta(
+ has_a => $col,
+ $rel_info
+ );
+
+ return 1;
+}
+
+sub _mk_inflated_column_accessor {
+ my($class, $col) = @_;
+
+ return $class->mk_group_accessors('inflated_column' => $col);
+}
+
+sub has_many {
+ my ($class, $rel, $f_class, $f_key, $args) = @_;
+
+ my @f_method;
+
+ if (ref $f_class eq 'ARRAY') {
+ ($f_class, @f_method) = @$f_class;
+ }
+
+ if (ref $f_key eq 'HASH' && !$args) { $args = $f_key; undef $f_key; };
+
+ $args ||= {};
+ my $cascade = delete $args->{cascade} || '';
+ if (delete $args->{no_cascade_delete} || $cascade eq 'None') {
+ $args->{cascade_delete} = 0;
+ }
+ elsif( $cascade eq 'Delete' ) {
+ $args->{cascade_delete} = 1;
+ }
+ elsif( length $cascade ) {
+ warn "Unemulated cascade option '$cascade' in $class->has_many($rel => $f_class)";
+ }
+
+ if( !$f_key and !@f_method ) {
+ $class->ensure_class_loaded($f_class);
+ my $f_source = $f_class->result_source_instance;
+ ($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class }
+ $f_source->relationships;
+ }
+
+ $class->next::method($rel, $f_class, $f_key, $args);
+
+ my $rel_info = $class->result_source_instance->relationship_info($rel);
+ $args->{mapping} = \@f_method;
+ $args->{foreign_key} = $f_key;
+ $rel_info->{args} = $args;
+
+ $class->_extend_meta(
+ has_many => $rel,
+ $rel_info
+ );
+
+ if (@f_method) {
+ no strict 'refs';
+ no warnings 'redefine';
+ my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; };
+ *{"${class}::${rel}"} =
+ sub {
+ my $rs = shift->search_related($rel => @_);
+ $rs->{attrs}{record_filter} = $post_proc;
+ return (wantarray ? $rs->all : $rs);
+ };
+ return 1;
+ }
+
+}
+
+
+sub might_have {
+ my ($class, $rel, $f_class, @columns) = @_;
+
+ my $ret;
+ if (ref $columns[0] || !defined $columns[0]) {
+ $ret = $class->next::method($rel, $f_class, @columns);
+ } else {
+ $ret = $class->next::method($rel, $f_class, undef,
+ { proxy => \@columns });
+ }
+
+ my $rel_info = $class->result_source_instance->relationship_info($rel);
+ $rel_info->{args}{import} = \@columns;
+
+ $class->_extend_meta(
+ might_have => $rel,
+ $rel_info
+ );
+
+ return $ret;
+}
+
+
+sub _extend_meta {
+ my ($class, $type, $rel, $val) = @_;
+ my %hash = %{ Clone::clone($class->__meta_info || {}) };
+
+ $val->{self_class} = $class;
+ $val->{type} = $type;
+ $val->{accessor} = $rel;
+
+ $hash{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val);
+ $class->__meta_info(\%hash);
+}
+
+
+sub meta_info {
+ my ($class, $type, $rel) = @_;
+ my $meta = $class->__meta_info;
+ return $meta unless $type;
+
+ my $type_meta = $meta->{$type};
+ return $type_meta unless $rel;
+ return $type_meta->{$rel};
+}
+
+
+sub search {
+ my $self = shift;
+ my $attrs = {};
+ if (@_ > 1 && ref $_[$#_] eq 'HASH') {
+ $attrs = { %{ pop(@_) } };
+ }
+ my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift)
+ : {@_})
+ : undef());
+ if (ref $where eq 'HASH') {
+ foreach my $key (keys %$where) { # has_a deflation hack
+ $where->{$key} = ''.$where->{$key}
+ if eval { $where->{$key}->isa('DBIx::Class') };
+ }
+ }
+ $self->next::method($where, $attrs);
+}
+
+1;
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Retrieve.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Retrieve.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Retrieve.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -47,12 +47,35 @@
sub retrieve_from_sql {
my ($class, $cond, @rest) = @_;
+
$cond =~ s/^\s*WHERE//i;
- $class->search_literal($cond, @rest);
+
+ if( $cond =~ s/\bLIMIT (\d+)\s*$//i ) {
+ push @rest, { rows => $1 };
+ }
+
+ return $class->search_literal($cond, @rest);
}
+sub construct {
+ my $class = shift;
+ my $obj = $class->resultset_instance->new_result(@_);
+ $obj->in_storage(1);
+
+ return $obj;
+}
+
sub retrieve_all { shift->search }
sub count_all { shift->count }
- # Contributed by Numa. No test for this though.
+sub maximum_value_of {
+ my($class, $col) = @_;
+ return $class->resultset_instance->get_column($col)->max;
+}
+
+sub minimum_value_of {
+ my($class, $col) = @_;
+ return $class->resultset_instance->get_column($col)->min;
+}
+
1;
Added: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/SQLTransformer.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/SQLTransformer.pm (rev 0)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/SQLTransformer.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,104 @@
+package DBIx::Class::CDBICompat::SQLTransformer;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::SQLTransformer - Transform SQL
+
+=head1 DESCRIPTION
+
+This is a copy of L<Class::DBI::SQL::Transformer> from Class::DBI 3.0.17.
+It is here so we can be compatible with L<Class::DBI> without having it
+installed.
+
+=cut
+
+sub new {
+ my ($me, $caller, $sql, @args) = @_;
+ bless {
+ _caller => $caller,
+ _sql => $sql,
+ _args => [@args],
+ _transformed => 0,
+ } => $me;
+}
+
+sub sql {
+ my $self = shift;
+ $self->_do_transformation if !$self->{_transformed};
+ return $self->{_transformed_sql};
+}
+
+sub args {
+ my $self = shift;
+ $self->_do_transformation if !$self->{_transformed};
+ return @{ $self->{_transformed_args} };
+}
+
+sub _expand_table {
+ my $self = shift;
+ my ($class, $alias) = split /=/, shift, 2;
+ my $caller = $self->{_caller};
+ my $table = $class ? $class->table : $caller->table;
+ $self->{cmap}{ $alias || $table } = $class || ref $caller || $caller;
+ ($alias ||= "") &&= " $alias";
+ return $table . $alias;
+}
+
+sub _expand_join {
+ my $self = shift;
+ my $joins = shift;
+ my @table = split /\s+/, $joins;
+
+ my $caller = $self->{_caller};
+ my %tojoin = map { $table[$_] => $table[ $_ + 1 ] } 0 .. $#table - 1;
+ my @sql;
+ while (my ($t1, $t2) = each %tojoin) {
+ my ($c1, $c2) = map $self->{cmap}{$_}
+ || $caller->_croak("Don't understand table '$_' in JOIN"), ($t1, $t2);
+
+ my $join_col = sub {
+ my ($c1, $c2) = @_;
+ my $meta = $c1->meta_info('has_a');
+ my ($col) = grep $meta->{$_}->foreign_class eq $c2, keys %$meta;
+ $col;
+ };
+
+ my $col = $join_col->($c1 => $c2) || do {
+ ($c1, $c2) = ($c2, $c1);
+ ($t1, $t2) = ($t2, $t1);
+ $join_col->($c1 => $c2);
+ };
+
+ $caller->_croak("Don't know how to join $c1 to $c2") unless $col;
+ push @sql, sprintf " %s.%s = %s.%s ", $t1, $col, $t2, $c2->primary_column;
+ }
+ return join " AND ", @sql;
+}
+
+sub _do_transformation {
+ my $me = shift;
+ my $sql = $me->{_sql};
+ my @args = @{ $me->{_args} };
+ my $caller = $me->{_caller};
+
+ $sql =~ s/__TABLE\(?(.*?)\)?__/$me->_expand_table($1)/eg;
+ $sql =~ s/__JOIN\((.*?)\)__/$me->_expand_join($1)/eg;
+ $sql =~ s/__ESSENTIAL__/join ", ", $caller->_essential/eg;
+ $sql =~
+ s/__ESSENTIAL\((.*?)\)__/join ", ", map "$1.$_", $caller->_essential/eg;
+ if ($sql =~ /__IDENTIFIER__/) {
+ my $key_sql = join " AND ", map "$_=?", $caller->primary_columns;
+ $sql =~ s/__IDENTIFIER__/$key_sql/g;
+ }
+
+ $me->{_transformed_sql} = $sql;
+ $me->{_transformed_args} = [@args];
+ $me->{_transformed} = 1;
+ return 1;
+}
+
+1;
+
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/TempColumns.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/TempColumns.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/TempColumns.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -5,41 +5,70 @@
use warnings;
use base qw/DBIx::Class/;
+use Carp;
+
__PACKAGE__->mk_classdata('_temp_columns' => { });
sub _add_column_group {
my ($class, $group, @cols) = @_;
- if ($group eq 'TEMP') {
- $class->_register_column_group($group => @cols);
- $class->mk_group_accessors('temp' => @cols);
- my %tmp = %{$class->_temp_columns};
- $tmp{$_} = 1 for @cols;
- $class->_temp_columns(\%tmp);
- } else {
- return $class->next::method($group, @cols);
+
+ return $class->next::method($group, @cols) unless $group eq 'TEMP';
+
+ my %new_cols = map { $_ => 1 } @cols;
+ my %tmp_cols = %{$class->_temp_columns};
+
+ for my $existing_col ( grep $new_cols{$_}, $class->columns ) {
+ # Already been declared TEMP
+ next if $tmp_cols{$existing_col};
+
+ carp "Declaring column $existing_col as TEMP but it already exists";
}
+
+ $class->_register_column_group($group => @cols);
+ $class->mk_group_accessors('temp' => @cols);
+
+ $class->_temp_columns({ %tmp_cols, %new_cols });
}
sub new {
my ($class, $attrs, @rest) = @_;
- my %temp;
- foreach my $key (keys %$attrs) {
- $temp{$key} = delete $attrs->{$key} if $class->_temp_columns->{$key};
- }
+
+ my $temp = $class->_extract_temp_data($attrs);
+
my $new = $class->next::method($attrs, @rest);
- foreach my $key (keys %temp) {
- $new->set_temp($key, $temp{$key});
- }
+
+ $new->set_temp($_, $temp->{$_}) for keys %$temp;
+
return $new;
}
+sub _extract_temp_data {
+ my($self, $data) = @_;
+ my %temp;
+ foreach my $key (keys %$data) {
+ $temp{$key} = delete $data->{$key} if $self->_temp_columns->{$key};
+ }
+
+ return \%temp;
+}
+
sub find_column {
my ($class, $col, @rest) = @_;
return $col if $class->_temp_columns->{$col};
return $class->next::method($col, @rest);
}
+sub set {
+ my($self, %data) = @_;
+
+ my $temp_data = $self->_extract_temp_data(\%data);
+
+ $self->set_temp($_, $temp_data->{$_}) for keys %$temp_data;
+
+ return $self->next::method(%data);
+}
+
sub get_temp {
my ($self, $column) = @_;
$self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Triggers.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Triggers.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat/Triggers.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -7,6 +7,9 @@
sub insert {
my $self = shift;
+
+ return $self->create(@_) unless ref $self;
+
$self->call_trigger('before_create');
$self->next::method(@_);
$self->call_trigger('after_create');
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/CDBICompat.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -5,17 +5,25 @@
use base qw/DBIx::Class::Core DBIx::Class::DB/;
use Carp::Clan qw/^DBIx::Class/;
-eval {
- require Class::Trigger;
- require DBIx::ContextualFetch;
-};
-croak "Class::Trigger and DBIx::ContextualFetch is required for CDBICompat" if $@;
+# Modules CDBICompat needs that DBIx::Class does not.
+my @Extra_Modules = qw(
+ Class::Trigger
+ DBIx::ContextualFetch
+ Clone
+);
+
+my @didnt_load;
+for my $module (@Extra_Modules) {
+ push @didnt_load, $module unless eval qq{require $module};
+}
+croak("@{[ join ', ', @didnt_load ]} are missing and are required for CDBICompat")
+ if @didnt_load;
+
__PACKAGE__->load_own_components(qw/
Constraints
Triggers
ReadOnly
- GetSet
LiveObjectIndex
AttributeAPI
Stringify
@@ -23,16 +31,20 @@
Constructor
AccessorMapping
ColumnCase
- HasA
- HasMany
- MightHave
+ Relationships
+ Copy
LazyLoading
AutoUpdate
TempColumns
+ GetSet
Retrieve
Pager
ColumnGroups
- ImaDBI/);
+ ColumnsAsHash
+ AbstractSearch
+ ImaDBI
+ Iterator
+/);
#DBIx::Class::ObjIndexStubs
1;
@@ -43,17 +55,47 @@
=head1 SYNOPSIS
- use base qw/DBIx::Class/;
- __PACKAGE__->load_components(qw/CDBICompat Core DB/);
+ package My::CDBI;
+ use base qw/DBIx::Class::CDBICompat/;
+ ...continue as Class::DBI...
+
=head1 DESCRIPTION
DBIx::Class features a fully featured compatibility layer with L<Class::DBI>
-to ease transition for existing CDBI users. In fact, this class is just a
-receipe containing all the features emulated. If you like, you can choose
-which features to emulate by building your own class and loading it like
-this:
+and some common plugins to ease transition for existing CDBI users.
+This is not a wrapper or subclass of DBIx::Class but rather a series of plugins. The result being that even though you're using the Class::DBI emulation layer you are still getting DBIx::Class objects. You can use all DBIx::Class features and methods via CDBICompat. This allows you to take advantage of DBIx::Class features without having to rewrite your CDBI code.
+
+
+=head2 Plugins
+
+CDBICompat is good enough that many CDBI plugins will work with CDBICompat, but many of the plugin features are better done with DBIx::Class methods.
+
+=head3 Class::DBI::AbstractSearch
+
+C<search_where()> is fully emulated using DBIC's search. Aside from emulation there's no reason to use C<search_where()>.
+
+=head3 Class::DBI::Plugin::NoCache
+
+C<nocache> is fully emulated.
+
+=head3 Class::DBI::Sweet
+
+The features of CDBI::Sweet are better done using DBIC methods which are almost exactly the same. It even uses L<Data::Page>.
+
+=head3 Class::DBI::Plugin::DeepAbstractSearch
+
+This plugin will work, but it is more efficiently done using DBIC's native search facilities. The major difference is that DBIC will not infer the join for you, you have to tell it the join tables.
+
+
+=head2 Choosing Features
+
+In fact, this class is just a receipe containing all the features emulated.
+If you like, you can choose which features to emulate by building your
+own class and loading it like this:
+
+ package My::DB;
__PACKAGE__->load_own_components(qw/CDBICompat/);
this will automatically load the features included in My::DB::CDBICompat,
@@ -68,59 +110,60 @@
CDBICompat::MightHave
/);
-=head1 COMPONENTS
-=over 4
+=head1 LIMITATIONS
-=item AccessorMapping
+=head2 Unimplemented
-=item AttributeAPI
+The following methods and classes are not emulated, maybe in the future.
-=item AutoUpdate
+=over 4
-Allows you to turn on automatic updates for column values.
+=item Class::DBI::Query
-=item ColumnCase
+Deprecated in Class::DBI.
-=item ColumnGroups
+=item Class::DBI::Column
-=item Constraints
+Not documented in Class::DBI. CDBICompat's columns() returns a plain string, not an object.
-=item Constructor
+=item data_type()
-=item DestroyWarning
+Undocumented CDBI method.
-=item GetSet
+=back
-=item HasA
+=head2 Limited Support
-=item HasMany
+The following elements of Class::DBI have limited support.
-=item ImaDBI
+=over 4
-=item LazyLoading
+=item Class::DBI::Relationship
-=item LiveObjectIndex
+The semi-documented Class::DBI::Relationship objects returned by C<meta_info($type, $col)> are mostly emulated except for their C<args> method.
-The live object index tries to ensure there is only one version of a object
-in the perl interpreter.
+=item Relationships
-=item MightHave
+Relationships between tables (has_a, has_many...) must be delcared after all tables in the relationship have been declared. Thus the usual CDBI idiom of declaring columns and relationships for each class together will not work. They must instead be done like so:
-=item ObjIndexStubs
+ package Foo;
+ use base qw(Class::DBI);
+
+ Foo->table("foo");
+ Foo->columns( All => qw(this that bar) );
-=item ReadOnly
+ package Bar;
+ use base qw(Class::DBI);
+
+ Bar->table("bar");
+ Bar->columns( All => qw(up down) );
-=item Retrieve
+ # Now that Foo and Bar are declared it is safe to declare a
+ # relationship between them
+ Foo->has_a( bar => "Bar" );
-=item Stringify
-=item TempColumns
-
-=item Triggers
-
-=item PassThrough
-
=back
=head1 AUTHORS
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/DB.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/DB.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/DB.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -150,35 +150,26 @@
=cut
+__PACKAGE__->mk_classdata('_result_source_instance' => []);
+
sub result_source_instance {
my $class = shift;
$class = ref $class || $class;
-
- __PACKAGE__->mk_classdata(qw/_result_source_instance/)
- unless __PACKAGE__->can('_result_source_instance');
-
- return $class->_result_source_instance(@_) if @_;
+ return $class->_result_source_instance([$_[0], $class]) if @_;
- my $source = $class->_result_source_instance;
- return {} unless Scalar::Util::blessed($source);
+ my($source, $result_class) = @{$class->_result_source_instance};
+ return unless Scalar::Util::blessed($source);
- if ($source->result_class ne $class) {
- # Remove old source instance so we dont get deep recursion
- #$DB::single = 1;
- # Need to set it to a non-undef value so that it doesn't just fallback to
- # a parent class's _result_source_instance
- #$class->_result_source_instance({});
- #$class->table($class);
- #$source = $class->_result_source_instance;
+ if ($result_class ne $class) { # new class
+ # Give this new class it's own source and register it.
- $DB::single = 1;
$source = $source->new({
%$source,
source_name => $class,
result_class => $class
} );
- $class->_result_source_instance($source);
+ $class->_result_source_instance([$source, $class]);
if (my $coderef = $class->can('schema_instance')) {
$coderef->($class)->register_class($class, $class);
}
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/InflateColumn/File.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/InflateColumn/File.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/InflateColumn/File.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -5,112 +5,102 @@
use base 'DBIx::Class';
use File::Path;
use File::Copy;
-use IO::File;
+use Path::Class;
__PACKAGE__->load_components(qw/InflateColumn/);
-
sub register_column {
- my ($self, $column, $info, @rest) = @_;
- $self->next::method($column, $info, @rest);
- return unless defined($info->{is_file_column});
- $self->inflate_column(
- $column =>
- {
- inflate => sub {
+ my ($self, $column, $info, @rest) = @_;
+ $self->next::method($column, $info, @rest);
+ return unless defined($info->{is_file_column});
+
+ $self->inflate_column($column => {
+ inflate => sub {
my ($value, $obj) = @_;
- #$self->_inflate_file_column;
- },
- deflate => sub {
+ $obj->_inflate_file_column($column, $value);
+ },
+ deflate => sub {
my ($value, $obj) = @_;
- #my ( $file, @column_names ) = $self->_load_file_column_information;
- #$self->_save_file_column( $file, $self, @column_names );
- },
- }
- );
+ $obj->_save_file_column($column, $value);
+ },
+ });
}
+sub _file_column_file {
+ my ($self, $column, $filename) = @_;
+ my $column_info = $self->column_info($column);
+
+ return unless $column_info->{is_file_column};
+
+ my $id = $self->id || $self->throw_exception(
+ 'id required for filename generation'
+ );
+
+ $filename ||= $self->$column->{filename};
+ return Path::Class::file(
+ $column_info->{file_column_path}, $id, $filename,
+ );
+}
+
sub delete {
my ( $self, @rest ) = @_;
- my @column_names = $self->columns;
- for (@column_names) {
+ for ( $self->columns ) {
if ( $self->column_info($_)->{is_file_column} ) {
- my $path =
- File::Spec->catdir( $self->column_info($_)->{file_column_path},
- $self->id );
- rmtree( [$path], 0, 0 );
+ rmtree( [$self->_file_column_file($_)->dir], 0, 0 );
+ last; # if we've deleted one, we've deleted them all
}
}
- my $ret = $self->next::method(@rest);
-
- return $ret;
+ return $self->next::method(@rest);
}
-sub _inflate_file_column {
+sub insert {
my $self = shift;
-
- my @column_names = $self->columns;
- for(@column_names) {
+
+ # cache our file columns so we can write them to the fs
+ # -after- we have a PK
+ my %file_column;
+ for ( $self->columns ) {
if ( $self->column_info($_)->{is_file_column} ) {
- # make sure everything checks out
- unless (defined $self->$_) {
- # if something is wrong set it to undef
- $self->$_(undef);
- next;
- }
- my $fs_file =
- File::Spec->catfile( $self->column_info($_)->{file_column_path},
- $self->id, $self->$_ );
- $self->$_({handle => new IO::File($fs_file, "r"), filename => $self->$_});
+ $file_column{$_} = $self->$_;
+ $self->store_column($_ => $self->$_->{filename});
}
}
+
+ $self->next::method(@_);
+
+ # write the files to the fs
+ while ( my ($col, $file) = each %file_column ) {
+ $self->_save_file_column($col, $file);
+ }
+
+ return $self;
}
-sub _load_file_column_information {
- my $self = shift;
- my $file;
- my @column_names;
+sub _inflate_file_column {
+ my ( $self, $column, $value ) = @_;
- @column_names = $self->columns;
- for (@column_names) {
- if ( $self->column_info($_)->{is_file_column} ) {
- # make sure everything checks out
- unless ((defined $self->$_) ||
- (defined $self->$_->{filename} && defined $self->$_->{handle})) {
- # if something is wrong set it to undef
- $self->$_(undef);
- next;
- }
- $file->{$_} = $self->$_;
- $self->$_( $self->$_->{filename} );
- }
- }
+ my $fs_file = $self->_file_column_file($column, $value);
- return ( $file, @column_names );
+ return { handle => $fs_file->open('r'), filename => $value };
}
sub _save_file_column {
- my ( $self, $file, $ret, @column_names ) = @_;
+ my ( $self, $column, $value ) = @_;
- for (@column_names) {
- if ( $ret->column_info($_)->{is_file_column} ) {
- next unless (defined $ret->$_);
- my $file_path =
- File::Spec->catdir( $ret->column_info($_)->{file_column_path},
- $ret->id );
- mkpath [$file_path];
-
- my $outfile =
- File::Spec->catfile( $file_path, $file->{$_}->{filename} );
- File::Copy::copy( $file->{$_}->{handle}, $outfile );
-
- $self->_file_column_callback($file->{$_},$ret,$_);
- }
- }
+ return unless ref $value;
+
+ my $fs_file = $self->_file_column_file($column, $value->{filename});
+ mkpath [$fs_file->dir];
+
+ File::Copy::copy($value->{handle}, $fs_file);
+
+ $self->_file_column_callback($value, $self, $column);
+
+ return $value->{filename};
}
=head1 NAME
@@ -186,9 +176,7 @@
=cut
-sub _file_column_callback {
- my ($self,$file,$ret,$target) = @_;
-}
+sub _file_column_callback {}
=head1 AUTHOR
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/Cookbook.pod
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/Cookbook.pod 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/Cookbook.pod 2008-04-25 15:03:12 UTC (rev 4291)
@@ -1123,7 +1123,7 @@
Add the L<DBIx::Class::Schema::Versioned> schema component to your
Schema class. This will add a new table to your database called
-C<SchemaVersions> which will keep track of which version is installed
+C<dbix_class_schema_vesion> which will keep track of which version is installed
and warn if the user trys to run a newer schema version than the
database thinks it has.
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/FAQ.pod
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/FAQ.pod 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/FAQ.pod 2008-04-25 15:03:12 UTC (rev 4291)
@@ -338,7 +338,7 @@
inserted key, you can tell it the name of the sequence in the
C<column_info> supplied with C<add_columns>.
- ->add_columns({ id => { sequence => 'mysequence' } });
+ ->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
=item .. insert many rows of data efficiently?
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/Intro.pod
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/Intro.pod 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/Intro.pod 2008-04-25 15:03:12 UTC (rev 4291)
@@ -13,14 +13,16 @@
Here are a few simple tips that will help you get your bearings with
DBIx::Class.
-=head2 Tables become ResultSources
+=head2 Tables become Result classes
-DBIx::Class needs to know what your Table structure looks like. You do that by
-defining L<DBIx::Class::ResultSource>s. Each table gets a ResultSource, which
-defines the Columns it has, along with any Relationships it has to other tables.
-(And oh, so much more besides) The important thing to understand:
+DBIx::Class needs to know what your Table structure looks like. You
+do that by defining Result classes. Result classes are defined by
+calling methods proxied to L<DBIx::Class::ResultSource>. Each Result
+class defines one Table, which defines the Columns it has, along with
+any Relationships it has to other tables. (And oh, so much more
+besides) The important thing to understand:
- A ResultSource == Table
+ A Result class == Table
(most of the time, but just bear with my simplification)
@@ -62,6 +64,11 @@
Setting up a ResultSet does not execute the query; retrieving
the data does.
+=head2 Search results are returned as Rows
+
+Rows of the search from the database are blessed into
+L<DBIx::Class::Row> objects.
+
=head1 SETTING UP DBIx::Class
Let's look at how you can set and use your first native L<DBIx::Class> tree.
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/Joining.pod
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/Joining.pod 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Manual/Joining.pod 2008-04-25 15:03:12 UTC (rev 4291)
@@ -101,7 +101,7 @@
=head2 Across multiple relations
For simplicity in the example above, the C<Artist> was shown as a
-simple text firld in the C<Tracks> table, in reality, you'll want to
+simple text field in the C<Tracks> table, in reality, you'll want to
have the artists in their own table as well, thus to fetch the
complete set of data we'll need to join to the Artist table too.
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/PK.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/PK.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/PK.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -39,14 +39,21 @@
my ($self) = @_;
delete $self->{_dirty_columns};
return unless $self->in_storage; # Don't reload if we aren't real!
- my ($reload) = $self->result_source->resultset->find
- (map { $self->$_ } $self->primary_columns);
+
+ my $reload = $self->result_source->resultset->find(
+ map { $self->$_ } $self->primary_columns
+ );
unless ($reload) { # If we got deleted in the mean-time
$self->in_storage(0);
return $self;
}
- delete @{$self}{keys %$self};
- @{$self}{keys %$reload} = values %$reload;
+
+ %$self = %$reload;
+
+ # Avoid a possible infinite loop with
+ # sub DESTROY { $_[0]->discard_changes }
+ bless $reload, 'Do::Not::Exist';
+
return $self;
}
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Relationship/Accessor.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Relationship/Accessor.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Relationship/Accessor.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -36,7 +36,7 @@
$class->inflate_column($rel,
{ inflate => sub {
my ($val, $self) = @_;
- return $self->find_or_create_related($rel, {}, {});
+ return $self->find_or_new_related($rel, {}, {});
},
deflate => sub {
my ($val, $self) = @_;
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Relationship/Base.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Relationship/Base.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Relationship/Base.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -109,6 +109,13 @@
should, set this attribute to a true or false value to override the detection
of when to create constraints.
+=item is_deferrable
+
+Tells L<SQL::Translator> that the foreign key constraint it creates should be
+deferrable. In other words, the user may request that the constraint be ignored
+until the end of the transaction. Currently, only the PostgreSQL producer
+actually supports this.
+
=back
=head2 register_relationship
@@ -201,7 +208,7 @@
( $objects_rs ) = $rs->search_related_rs('relname', $cond, $attrs);
This method works exactly the same as search_related, except that
-it garauntees a restultset, even in list context.
+it guarantees a restultset, even in list context.
=cut
@@ -288,7 +295,8 @@
sub find_or_new_related {
my $self = shift;
- return $self->find_related(@_) || $self->new_related(@_);
+ my $obj = $self->find_related(@_);
+ return defined $obj ? $obj : $self->new_related(@_);
}
=head2 find_or_create_related
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Relationship.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Relationship.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Relationship.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -60,6 +60,7 @@
my $fred = $schema->resultset('Author')->find({ Name => 'Fred' });
my $fredsbooks = $schema->resultset('Book')->search({ Author => $fred->ID });
+
With a has_many relationship called "books" on Author (see below for details),
we can do this instead:
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSet.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSet.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSet.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -3,8 +3,8 @@
use strict;
use warnings;
use overload
- '0+' => \&count,
- 'bool' => sub { 1; },
+ '0+' => "count",
+ 'bool' => "_bool",
fallback => 1;
use Carp::Clan qw/^DBIx::Class/;
use Data::Page;
@@ -51,6 +51,10 @@
__PACKAGE__->belongs_to(artist => 'MyApp::Schema::Artist');
1;
+=head1 OVERLOADING
+
+If a resultset is used as a number it returns the C<count()>. However, if it is used as a boolean it is always true. So if you want to check if a result set has any results use C<if $rs != 0>. C<if $rs> will always be true.
+
=head1 METHODS
=head2 new
@@ -328,11 +332,15 @@
If the C<key> is specified as C<primary>, it searches only on the primary key.
If no C<key> is specified, it searches on all unique constraints defined on the
-source, including the primary key.
+source for which column data is provided, including the primary key.
If your table does not have a primary key, you B<must> provide a value for the
C<key> attribute matching one of the unique constraints on the source.
+Note: If your query does not return only one row, a warning is generated:
+
+ Query returned more than one row
+
See also L</find_or_create> and L</update_or_create>. For information on how to
declare unique constraints, see
L<DBIx::Class::ResultSource/add_unique_constraint>.
@@ -384,25 +392,46 @@
@{$input_query}{@keys} = values %related;
}
- my @unique_queries = $self->_unique_queries($input_query, $attrs);
# Build the final query: Default to the disjunction of the unique queries,
# but allow the input query in case the ResultSet defines the query or the
# user is abusing find
my $alias = exists $attrs->{alias} ? $attrs->{alias} : $self->{attrs}{alias};
- my $query = @unique_queries
- ? [ map { $self->_add_alias($_, $alias) } @unique_queries ]
- : $self->_add_alias($input_query, $alias);
+ my $query;
+ if (exists $attrs->{key}) {
+ my @unique_cols = $self->result_source->unique_constraint_columns($attrs->{key});
+ my $unique_query = $self->_build_unique_query($input_query, \@unique_cols);
+ $query = $self->_add_alias($unique_query, $alias);
+ }
+ else {
+ my @unique_queries = $self->_unique_queries($input_query, $attrs);
+ $query = @unique_queries
+ ? [ map { $self->_add_alias($_, $alias) } @unique_queries ]
+ : $self->_add_alias($input_query, $alias);
+ }
# Run the query
if (keys %$attrs) {
my $rs = $self->search($query, $attrs);
- return keys %{$rs->_resolved_attrs->{collapse}} ? $rs->next : $rs->single;
+ if (keys %{$rs->_resolved_attrs->{collapse}}) {
+ my $row = $rs->next;
+ carp "Query returned more than one row" if $rs->next;
+ return $row;
+ }
+ else {
+ return $rs->single;
+ }
}
else {
- return keys %{$self->_resolved_attrs->{collapse}}
- ? $self->search($query)->next
- : $self->single($query);
+ if (keys %{$self->_resolved_attrs->{collapse}}) {
+ my $rs = $self->search($query);
+ my $row = $rs->next;
+ carp "Query returned more than one row" if $rs->next;
+ return $row;
+ }
+ else {
+ return $self->single($query);
+ }
}
}
@@ -492,6 +521,17 @@
return shift->related_resultset(shift)->search(@_);
}
+=head2 search_related_rs
+
+This method works exactly the same as search_related, except that
+it guarantees a restultset, even in list context.
+
+=cut
+
+sub search_related_rs {
+ return shift->related_resultset(shift)->search_rs(@_);
+}
+
=head2 cursor
=over 4
@@ -996,6 +1036,10 @@
return $count;
}
+sub _bool {
+ return 1;
+}
+
=head2 count_literal
=over 4
@@ -2124,7 +2168,12 @@
sub throw_exception {
my $self=shift;
- $self->_source_handle->schema->throw_exception(@_);
+ if (ref $self && $self->_source_handle->schema) {
+ $self->_source_handle->schema->throw_exception(@_)
+ } else {
+ croak(@_);
+ }
+
}
# XXX: FIXME: Attributes docs need clearing up
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSource.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSource.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSource.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -143,6 +143,12 @@
will attempt to retrieve the name of the sequence from the database
automatically.
+=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
+trigger to get the nextval, you have to set sequence as well.
+
=item extra
This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSourceHandle.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSourceHandle.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSourceHandle.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -3,6 +3,7 @@
use strict;
use warnings;
use Storable;
+use Carp;
use base qw/DBIx::Class/;
@@ -77,7 +78,8 @@
my $to_serialize = { %$self };
- delete $to_serialize->{schema};
+ my $class = $self->schema->class($self->source_moniker);
+ $to_serialize->{schema} = $class;
return (Storable::freeze($to_serialize));
}
@@ -93,7 +95,17 @@
sub STORABLE_thaw {
my ($self, $cloning,$ice) = @_;
%$self = %{ Storable::thaw($ice) };
- $self->{schema} = $thaw_schema;
+
+ my $class = delete $self->{schema};
+ if( $thaw_schema ) {
+ $self->{schema} = $thaw_schema;
+ }
+ else {
+ my $rs = $class->result_source_instance;
+ $self->{schema} = $rs->schema if $rs;
+ }
+
+ carp "Unable to restore schema" unless $self->{schema};
}
=head1 AUTHOR
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSourceProxy/Table.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSourceProxy/Table.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/ResultSourceProxy/Table.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -12,6 +12,42 @@
__PACKAGE__->mk_classdata('table_alias'); # FIXME: Doesn't actually do
# anything yet!
+sub _init_result_source_instance {
+ my $class = shift;
+
+ $class->mk_classdata('result_source_instance')
+ unless $class->can('result_source_instance');
+
+ my $table = $class->result_source_instance;
+ my $class_has_table_instance = ($table and $table->result_class eq $class);
+ return $table if $class_has_table_instance;
+
+ if( $table ) {
+ $table = $class->table_class->new({
+ %$table,
+ result_class => $class,
+ source_name => undef,
+ schema => undef
+ });
+ }
+ else {
+ $table = $class->table_class->new({
+ name => undef,
+ result_class => $class,
+ source_name => undef,
+ });
+ }
+
+ $class->result_source_instance($table);
+
+ if ($class->can('schema_instance')) {
+ $class =~ m/([^:]+)$/;
+ $class->schema_instance->register_class($class, $class);
+ }
+
+ return $table;
+}
+
=head1 NAME
DBIx::Class::ResultSourceProxy::Table - provides a classdata table
@@ -47,7 +83,7 @@
unless (ref $table) {
$table = $class->table_class->new({
$class->can('result_source_instance') ?
- %{$class->result_source_instance} : (),
+ %{$class->result_source_instance||{}} : (),
name => $table,
result_class => $class,
source_name => undef,
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Row.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Row.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Row.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -50,7 +50,9 @@
my ($class, $attrs) = @_;
$class = ref $class if ref $class;
- my $new = { _column_data => {} };
+ my $new = {
+ _column_data => {},
+ };
bless $new, $class;
if (my $handle = delete $attrs->{-source_handle}) {
@@ -138,6 +140,9 @@
an entirely new object into the database, use C<create> (see
L<DBIx::Class::ResultSet/create>).
+To fetch an uninserted row object, call
+L<new|DBIx::Class::ResultSet/new> on a resultset.
+
This will also insert any uninserted, related objects held inside this
one, see L<DBIx::Class::ResultSet/create> for more details.
@@ -159,12 +164,10 @@
%{$self->{_inflated_column} || {}});
if(!$self->{_rel_in_storage}) {
- $source->storage->txn_begin;
# The guard will save us if we blow out of this scope via die
+ $rollback_guard = $source->storage->txn_scope_guard;
- $rollback_guard = Scope::Guard->new(sub { $source->storage->txn_rollback });
-
## Should all be in relationship_data, but we need to get rid of the
## 'filter' reltype..
## These are the FK rels, need their IDs for the insert.
@@ -206,7 +209,8 @@
}
}
- $source->storage->insert($source, { $self->get_columns });
+ my $updated_cols = $source->storage->insert($source, { $self->get_columns });
+ $self->set_columns($updated_cols);
## PK::Auto
my @auto_pri = grep {
@@ -246,8 +250,7 @@
}
}
}
- $source->storage->txn_commit;
- $rollback_guard->dismiss;
+ $rollback_guard->commit;
}
$self->in_storage(1);
@@ -262,8 +265,14 @@
$obj->in_storage; # Get value
$obj->in_storage(1); # Set value
-Indicates whether the object exists as a row in the database or not
+Indicates whether the object exists as a row in the database or
+not. This is set to true when L<DBIx::Class::ResultSet/find>,
+L<DBIx::Class::ResultSet/create> or L<DBIx::Class::ResultSet/insert>
+are used.
+Creating a row object using L<DBIx::Class::ResultSet/new>, or calling
+L</delete> on one, sets it to false.
+
=cut
sub in_storage {
@@ -356,11 +365,12 @@
my $val = $obj->get_column($col);
-Gets a column value from a row object. Does not do any queries; the column
-must have already been fetched from the database and stored in the object. If
-there is an inflated value stored that has not yet been deflated, it is deflated
-when the method is invoked.
+Returns a raw column value from the row object, if it has already
+been fetched from the database or set by an accessor.
+If an L<inflated value|DBIx::Class::InflateColumn> has been set, it
+will be deflated and returned.
+
=cut
sub get_column {
@@ -397,7 +407,7 @@
my %data = $obj->get_columns;
-Does C<get_column>, for all column values at once.
+Does C<get_column>, for all loaded column values at once.
=cut
@@ -428,9 +438,10 @@
=head2 get_inflated_columns
- my $inflated_data = $obj->get_inflated_columns;
+ my %inflated_data = $obj->get_inflated_columns;
-Similar to get_columns but objects are returned for inflated columns instead of their raw non-inflated values.
+Similar to get_columns but objects are returned for inflated columns
+instead of their raw non-inflated values.
=cut
@@ -446,9 +457,13 @@
$obj->set_column($col => $val);
-Sets a column value. If the new value is different from the old one,
+Sets a raw column value. If the new value is different from the old one,
the column is marked as dirty for when you next call $obj->update.
+If passed an object or reference, this will happily attempt store the
+value, and a later insert/update will try and stringify/numify as
+appropriate.
+
=cut
sub set_column {
@@ -458,7 +473,11 @@
my $old = $self->get_column($column);
my $ret = $self->store_column(@_);
$self->{_dirty_columns}{$column} = 1
- if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
+ if (defined $old xor defined $ret) || (defined $old && $old ne $ret);
+
+ # XXX clear out the relation cache for this column
+ delete $self->{related_resultsets}{$column};
+
return $ret;
}
@@ -662,7 +681,8 @@
$obj->update_or_insert
-Updates the object if it's already in the db, else inserts it.
+Updates the object if it's already in the database, according to
+L</in_storage>, else inserts it.
=head2 insert_or_update
Added: DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/AtQueryInterval.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/AtQueryInterval.pm (rev 0)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/AtQueryInterval.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,91 @@
+package DBIx::Class::Schema::AtQueryInterval;
+
+use Moose;
+
+=head1 NAME
+
+DBIx::Class::Schema::Role::AtQueryInterval; Defines a job control interval.
+
+=head1 SYNOPSIS
+
+The following example shows how to define a job control interval and assign it
+to a particular L<DBIx::Class::Schema::Job> for a L<DBIx::Class::Schema>
+
+ my $job = DBIx::Class::Schema->new(runs => sub { print 'did job'});
+ my $interval = DBIx::Class::Schema::Interval->new(every => 10);
+
+ if($interval->matches($query_count)) {
+ print "I indentified the query count as matching";
+ }
+
+ ## $schema->isa(DBIx::Class::Schema);
+ $schema->create_and_add_at_query_intervals($interval => $job);
+
+=head1 DESCRIPTION
+
+An AtQueryInterval is a plan object that will execute a certain
+
+=head1 ATTRIBUTES
+
+This package defines the following attributes.
+
+=head2 job (DBIx::Class::Schema::Job)
+
+This is the job which will run at the specified query interval
+
+=cut
+
+has 'job' => (
+ is=>'ro',
+ isa=>'DBIx::Class::Schema::Job',
+ required=>1,
+ handles=>['execute'],
+);
+
+
+=head2 interval (Int)
+
+This is the interval we are watching for
+
+=cut
+
+has 'interval' => (
+ is=>'ro',
+ isa=>'DBIx::Class::Schema::QueryInterval',
+ required=>1,
+ handles=>['matches'],
+);
+
+
+=head1 METHODS
+
+This module defines the following methods.
+
+=head2 execute_if_matches ($query_count, @args)
+
+Does the $query_count match the defined interval? Returns a Boolean.
+
+=cut
+
+sub execute_if_matches {
+ my ($self, $query_count, @args) = @_;
+ if($self->matches($query_count)) {
+ return $self->execute(@args);
+ } else {
+ return;
+ }
+}
+
+
+=head1 AUTHORS
+
+See L<DBIx::Class> for more information regarding authors.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+
+1;
\ No newline at end of file
Added: DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/Job.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/Job.pm (rev 0)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/Job.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,92 @@
+package DBIx::Class::Schema::Job;
+
+use Moose;
+use Moose::Util::TypeConstraints;
+
+=head1 NAME
+
+DBIx::Class::Schema::Job; A job associated with a Schema
+
+=head1 SYNOPSIS
+
+The following example creates a new job and then executes it.
+
+ my $job = DBIx::Class::Schema->new(runs => sub { print 'did job'});
+ $job->execute; # 'did job' -> STDOUT
+
+=head1 DESCRIPTION
+
+This is a base class intended to hold code that get's executed by the schema
+according to rules known to the schema. Subclassers may wish to override how
+the L</runs> attribute is defined in order to create custom behavior.
+
+=head1 SUBTYPES
+
+This package defines the following subtypes
+
+=head2 Handler
+
+A coderef based type that the job runs when L</execute> is called.
+
+=cut
+
+subtype 'DBIx::Class::Schema::Job::Handler'
+ => as 'CodeRef';
+
+coerce 'DBIx::Class::Schema::Job::Handler'
+ => from 'Str'
+ => via {
+ my $handler_method = $_;
+ sub {
+ my $job = shift @_;
+ my $target = shift @_;
+ $target->$handler_method($job, @_);
+ };
+ };
+
+=head1 ATTRIBUTES
+
+This package defines the following attributes.
+
+=head2 runs
+
+This is a coderef which is de-reffed by L</execute> and is passed the job object
+(ie $self), and any additional arguments passed to L</execute>
+
+=cut
+
+has 'runs' => (
+ is=>'ro',
+ isa=>'DBIx::Class::Schema::Job::Handler',
+ coerce=>1,
+ required=>1,
+);
+
+
+=head1 METHODS
+
+This module defines the following methods.
+
+=head2 execute ($schema, $query_interval)
+
+Method called by the L<DBIx::Class::Schema> when it wants a given job to run.
+
+=cut
+
+sub execute {
+ return $_[0]->runs->(@_);
+}
+
+
+=head1 AUTHORS
+
+See L<DBIx::Class> for more information regarding authors.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+
+1;
\ No newline at end of file
Added: DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/QueryInterval.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/QueryInterval.pm (rev 0)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/QueryInterval.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,93 @@
+package DBIx::Class::Schema::QueryInterval;
+
+use Moose;
+
+=head1 NAME
+
+DBIx::Class::Schema::Role::QueryInterval; Defines a job control interval.
+
+=head1 SYNOPSIS
+
+The following example shows how to define a job control interval and assign it
+to a particular L<DBIx::Class::Schema::Job> for a L<DBIx::Class::Schema>
+
+ my $job = DBIx::Class::Schema->new(runs => sub { print 'did job'});
+ my $interval = DBIx::Class::Schema::Interval->new(every => 10);
+
+ if($interval->matches($query_count)) {
+ print "I indentified the query count as matching";
+ }
+
+ ## $schema->isa(DBIx::Class::Schema);
+ $schema->create_and_add_at_query_intervals($interval => $job);
+
+=head1 DESCRIPTION
+
+A Query Interval defines a reoccuring period based on the query count from a
+given offset. For example, you can define a query interval of 10 queries
+with an offset of 1 query. This interval identifies query number 11, 21, 31,
+and so on.
+
+=head1 ATTRIBUTES
+
+This package defines the following attributes.
+
+=head2 every (Int)
+
+This is the 'size' of the gap identifying a query as matching a particular
+interval. Think, "I match every X queries".
+
+=cut
+
+has 'every' => (
+ is=>'ro',
+ isa=>'Int',
+ required=>1,
+);
+
+
+=head2 offset (Int)
+
+This is a number of queries from the start of all queries to offset the match
+counting mechanism. This is basically added to the L</every> attribute to
+identify a query as matching the interval we wish to define.
+
+=cut
+
+has 'offset' => (
+ is=>'ro',
+ isa=>'Int',
+ required=>1,
+ default=>0,
+);
+
+
+=head1 METHODS
+
+This module defines the following methods.
+
+=head2 matches ($query_count)
+
+Does the $query_count match the defined interval? Returns a Boolean.
+
+=cut
+
+sub matches {
+ my ($self, $query_count) = @_;
+ my $offset_count = $query_count - $self->offset;
+ return $offset_count % $self->every ? 0:1;
+}
+
+
+=head1 AUTHORS
+
+See L<DBIx::Class> for more information regarding authors.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+
+1;
\ No newline at end of file
Added: DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/Role/AtQueryInterval.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/Role/AtQueryInterval.pm (rev 0)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/Role/AtQueryInterval.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,271 @@
+package DBIx::Class::Schema::Role::AtQueryInterval;
+
+use Moose::Role;
+use MooseX::AttributeHelpers;
+use DBIx::Class::Schema::Job;
+use DBIx::Class::Schema::QueryInterval;
+use DBIx::Class::Schema::AtQueryInterval;
+
+=head1 NAME
+
+DBIx::Class::Schema::Role::AtQueryInterval; Execute code at query intervals
+
+=head1 SYNOPSIS
+
+The follow will execute the 'do_something' method each and every 10 queries,
+excute a subref each 20 queries, and do both each 30 queries. This first
+example is the long, hard way.
+
+ ## ISA DBIx::Class::Schema::Job
+
+ my $job1 = $schema->create_job(
+ runs => 'do_something',
+ );
+
+ my $job2 = $schema->create_job(
+ runs => sub {warn 'queries counted'},
+ );
+
+
+ ## ISA DBIx::Class::Schema::QueryInterval
+
+ my $interval_10 = $schema->create_query_interval(every => 10);
+ my $interval_20 = $schema->create_query_interval(every => 20);
+ my $interval_30 = $schema->create_query_interval(every => 30);
+
+
+ ## USA DBIx::Class::Schema::AtQueryInterval
+
+ my $at1 = $schema->create_at_query_interval(
+ interval => $interval_10, job => $job1,
+ );
+
+ my $at2 = $schema->create_at_query_interval(
+ interval => $interval_20, job => $job2,
+ );
+
+ my $at3 = $schema->create_at_query_interval(
+ interval => $interval_30, job=>$job1,
+ );
+
+ my $at4 = $schema->create_at_query_interval(
+ interval => $interval_30, job=>$job2,
+ );
+
+ $schema->query_intervals([$1, $at2, $at3, $at4]);
+
+Or you can take the express trip (assuming you are not creating any custom
+Query Intervals, Jobs, etc.) Notice that this method allows jobs to be defined
+as an arrayref to make it easier to defined multiple jobs for a given interval.
+
+In order to perform the needed object instantiation, this class will use the
+methods 'query_interval_class', 'job_class' and 'at_query_interval_class'.
+
+ $schema->create_and_add_at_query_intervals(
+ {every => 10} => {
+ runs => 'do_something',
+ },
+ {every => 20} => {
+ runs => sub {
+ warn 'queries counted';
+ },
+ },
+ {every => 30} => [
+ {runs => 'do_something'},
+ {runs => sub{
+ warn 'queries counted';
+ }},
+ ],
+ );
+
+All the above sit in a DBIx::Class::Schema that consumes the proper roles and
+defines a function which receives three arguments:
+
+ sub do_something {
+ my ($job, $schema, $at_query_interval) = @_;
+ }
+
+=head1 DESCRIPTION
+
+Sometime you'd like to perform certain housekeeping activities at preset query
+intervals. For example, every 100 queries you want to update a reporting table
+that contains denormalized information. This role allows you to assign a
+scalar containing the name of a method in your schema class, an anonymous sub,
+or an arrayref of either to a particular interval.
+
+=head1 ATTRIBUTES
+
+This package defines the following attributes.
+
+=head2 query_interval_class
+
+The default class used to create an interval class from a hash of initializing
+information.
+
+=cut
+
+has 'query_interval_class' => (
+ is=>'ro',
+ isa=>'ClassName',
+ required=>1,
+ default=>'DBIx::Class::Schema::QueryInterval',
+ handles=> {
+ 'create_query_interval' => 'new',
+ },
+);
+
+
+=head2 job_class
+
+The default class used to create an job class from a hash of initializing
+information.
+
+=cut
+
+has 'job_class' => (
+ is=>'ro',
+ isa=>'ClassName',
+ required=>1,
+ default=>'DBIx::Class::Schema::Job',
+ handles=> {
+ 'create_job' => 'new',
+ },
+);
+
+
+=head2 at_query_interval_class
+
+The default class used to create an job class from a hash of initializing
+information.
+
+=cut
+
+has 'at_query_interval_class' => (
+ is=>'ro',
+ isa=>'ClassName',
+ required=>1,
+ default=>'DBIx::Class::Schema::AtQueryInterval',
+ handles=> {
+ 'create_at_query_interval' => 'new',
+ },
+);
+
+
+=head2 at_query_intervals
+
+This is an arrayref of L<DBIx::Class::Schema::AtQueryInterval> objects which
+holds all the jobs that need to be run at the given interval.
+
+=cut
+
+has 'at_query_intervals' => (
+ is=>'rw',
+ metaclass => 'Collection::Array',
+ auto_deref => 1,
+ isa=>'ArrayRef[DBIx::Class::Schema::AtQueryInterval]',
+ provides => {
+ push => 'add_at_query_interval',
+ },
+);
+
+
+=head1 METHODS
+
+This module defines the following methods.
+
+=head2 execute_jobs_at_query_interval ($int)
+
+Execute all the jobs which match the given interval
+
+=cut
+
+sub execute_jobs_at_query_interval {
+ my ($self, $query_count, @args) = @_;
+ my @responses;
+ foreach my $at ($self->at_query_intervals) {
+ push @responses,
+ $at->execute_if_matches($query_count, $self, @args);
+ }
+ return @responses;
+}
+
+
+=head2 create_and_add_at_query_intervals (%definitions)
+
+Uses the shortcut method shown above to quickly build a plan from a simple perl
+array of hashes.
+
+=cut
+
+sub create_and_add_at_query_intervals {
+ my ($self, @definitions) = @_;
+ while (@definitions) {
+ my $interval = $self->normalize_query_interval(shift @definitions);
+ my @jobs = $self->normalize_to_jobs(shift @definitions);
+ foreach my $job (@jobs) {
+ my $at = $self->create_at_query_interval(interval=>$interval, job=>$job);
+ $self->add_at_query_interval($at);
+ }
+ }
+}
+
+
+=head2 normalize_query_interval ($hash||$obj)
+
+Given an argument, make sure it's a L<DBIx::Class::Schema::QueryInterval>,
+coercing it if neccessary.
+
+=cut
+
+sub normalize_query_interval {
+ my ($self, $arg) = @_;
+ if(blessed $arg && $arg->isa('DBIx::Class::Schema::QueryInterval')) {
+ return $arg;
+ } else {
+ return $self->create_query_interval($arg);
+ }
+}
+
+=head2 normalize_to_jobs ($hash||$obj||$arrayref)
+
+Incoming jobs need to be normalized to an array, so that we can handle adding
+multiple jobs per interval.
+
+=cut
+
+sub normalize_to_jobs {
+ my ($self, $arg) = @_;
+ my @jobs = ref $arg eq 'ARRAY' ? @$arg : ($arg);
+ return map {$self->normalize_job($_)} @jobs;
+}
+
+
+=head2 normalize_job ($hash||$obj)
+
+Given an argument, make sure it's a L<DBIx::Class::Schema::Job>,
+coercing it if neccessary.
+
+=cut
+
+sub normalize_job {
+ my ($self, $arg) = @_;
+ if(blessed $arg && $arg->isa('DBIx::Class::Schema::Job')) {
+ return $arg;
+ } else {
+ return $self->create_job($arg);
+ }
+}
+
+
+=head1 AUTHORS
+
+See L<DBIx::Class> for more information regarding authors.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+
+1;
\ No newline at end of file
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/Versioned.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/Versioned.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema/Versioned.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -1,42 +1,120 @@
-package DBIx::Class::Version::Table;
+package # Hide from PAUSE
+ DBIx::Class::Version::Table;
use base 'DBIx::Class';
use strict;
use warnings;
__PACKAGE__->load_components(qw/ Core/);
-__PACKAGE__->table('SchemaVersions');
+__PACKAGE__->table('dbix_class_schema_versions');
__PACKAGE__->add_columns
- ( 'Version' => {
+ ( 'version' => {
'data_type' => 'VARCHAR',
'is_auto_increment' => 0,
'default_value' => undef,
'is_foreign_key' => 0,
- 'name' => 'Version',
+ 'name' => 'version',
'is_nullable' => 0,
'size' => '10'
},
- 'Installed' => {
+ 'installed' => {
'data_type' => 'VARCHAR',
'is_auto_increment' => 0,
'default_value' => undef,
'is_foreign_key' => 0,
- 'name' => 'Installed',
+ 'name' => 'installed',
'is_nullable' => 0,
'size' => '20'
},
);
+__PACKAGE__->set_primary_key('version');
+
+package # Hide from PAUSE
+ DBIx::Class::Version::TableCompat;
+use base 'DBIx::Class';
+__PACKAGE__->load_components(qw/ Core/);
+__PACKAGE__->table('SchemaVersions');
+
+__PACKAGE__->add_columns
+ ( 'Version' => {
+ 'data_type' => 'VARCHAR',
+ },
+ 'Installed' => {
+ 'data_type' => 'VARCHAR',
+ },
+ );
__PACKAGE__->set_primary_key('Version');
-package DBIx::Class::Version;
+package # Hide from PAUSE
+ DBIx::Class::Version;
use base 'DBIx::Class::Schema';
use strict;
use warnings;
__PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');
+package # Hide from PAUSE
+ DBIx::Class::VersionCompat;
+use base 'DBIx::Class::Schema';
+use strict;
+use warnings;
+__PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat');
+
+
# ---------------------------------------------------------------------------
+
+=head1 NAME
+
+DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
+
+=head1 SYNOPSIS
+
+ package Library::Schema;
+ use base qw/DBIx::Class::Schema/;
+ # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
+ __PACKAGE__->load_classes(qw/CD Book DVD/);
+
+ __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
+ __PACKAGE__->upgrade_directory('/path/to/upgrades/');
+ __PACKAGE__->backup_directory('/path/to/backups/');
+
+
+=head1 DESCRIPTION
+
+This module is a component designed to extend L<DBIx::Class::Schema>
+classes, to enable them to upgrade to newer schema layouts. To use this
+module, you need to have called C<create_ddl_dir> on your Schema to
+create your upgrade files to include with your delivery.
+
+A table called I<dbix_class_schema_versions> is created and maintained by the
+module. This contains two fields, 'Version' and 'Installed', which
+contain each VERSION of your Schema, and the date+time it was installed.
+
+The actual upgrade is called manually by calling C<upgrade> on your
+schema object. Code is run at connect time to determine whether an
+upgrade is needed, if so, a warning "Versions out of sync" is
+produced.
+
+So you'll probably want to write a script which generates your DDLs and diffs
+and another which executes the upgrade.
+
+NB: At the moment, only SQLite and MySQL are supported. This is due to
+spotty behaviour in the SQL::Translator producers, please help us by
+them.
+
+=head1 METHODS
+
+=head2 upgrade_directory
+
+Use this to set the directory your upgrade files are stored in.
+
+=head2 backup_directory
+
+Use this to set the directory you want your backups stored in.
+
+=cut
+
package DBIx::Class::Schema::Versioned;
use strict;
@@ -48,7 +126,18 @@
__PACKAGE__->mk_classdata('_filedata');
__PACKAGE__->mk_classdata('upgrade_directory');
__PACKAGE__->mk_classdata('backup_directory');
+__PACKAGE__->mk_classdata('do_backup');
+__PACKAGE__->mk_classdata('do_diff_on_init');
+=head2 schema_version
+
+Returns the current schema class' $VERSION; does -not- use $schema->VERSION
+since that varies in results depending on if version.pm is installed, and if
+so the perl or XS versions. If you want this to change, bug the version.pm
+author to make vpp and vxs behave the same.
+
+=cut
+
sub schema_version {
my ($self) = @_;
my $class = ref($self)||$self;
@@ -60,97 +149,24 @@
return $version;
}
-sub connection {
- my $self = shift;
- $self->next::method(@_);
- $self->_on_connect;
- return $self;
-}
+=head2 get_db_version
-sub _on_connect
-{
- my ($self) = @_;
- my $vschema = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
- my $vtable = $vschema->resultset('Table');
- my $pversion;
+Returns the version that your database is currently at. This is determined by the values in the
+dbix_class_schema_versions table that $self->upgrade writes to.
- if(!$self->_source_exists($vtable))
- {
-# $vschema->storage->debug(1);
- $vschema->storage->ensure_connected();
- $vschema->deploy();
- $pversion = 0;
- }
- else
- {
- my $psearch = $vtable->search(undef,
- { select => [
- { 'max' => 'Installed' },
- ],
- as => ['maxinstall'],
- })->first;
- $pversion = $vtable->search({ Installed => $psearch->get_column('maxinstall'),
- })->first;
- $pversion = $pversion->Version if($pversion);
- }
-# warn("Previous version: $pversion\n");
- if($pversion eq $self->schema_version)
- {
- warn "This version is already installed\n";
- return 1;
- }
+=cut
-## use IC::DT?
+sub get_db_version
+{
+ my ($self, $rs) = @_;
- if(!$pversion)
- {
- $vtable->create({ Version => $self->schema_version,
- Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
- });
- ## If we let the user do this, where does the Version table get updated?
- warn "No previous version found, calling deploy to install this version.\n";
- $self->deploy();
- return 1;
- }
-
- my $file = $self->ddl_filename(
- $self->storage->sqlt_type,
- $self->upgrade_directory,
- $self->schema_version
- );
- if(!$file)
- {
- # No upgrade path between these two versions
- return 1;
- }
-
- $file = $self->ddl_filename(
- $self->storage->sqlt_type,
- $self->upgrade_directory,
- $self->schema_version,
- $pversion,
- );
-# $file =~ s/@{[ $self->schema_version ]}/"${pversion}-" . $self->schema_version/e;
- if(!-f $file)
- {
- warn "Upgrade not possible, no upgrade file found ($file)\n";
- return;
- }
-
- my $fh;
- open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
- my @data = split(/;\n/, join('', <$fh>));
- close($fh);
- @data = grep { $_ && $_ !~ /^-- / } @data;
- @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data;
-
- $self->_filedata(\@data);
-
- ## Don't do this yet, do only on command?
- ## If we do this later, where does the Version table get updated??
- warn "Versions out of sync. This is " . $self->schema_version .
- ", your database contains version $pversion, please call upgrade on your Schema.\n";
-# $self->upgrade($pversion, $self->schema_version);
+ my $vtable = $self->{vschema}->resultset('Table');
+ my $version = 0;
+ eval {
+ my $stamp = $vtable->get_column('installed')->max;
+ $version = $vtable->search({ installed => $stamp })->first->version;
+ };
+ return $version;
}
sub _source_exists
@@ -165,6 +181,17 @@
return 1;
}
+=head2 backup
+
+This is an overwritable method which is called just before the upgrade, to
+allow you to make a backup of the database. Per default this method attempts
+to call C<< $self->storage->backup >>, to run the standard backup on each
+database type.
+
+This method should return the name of the backup file, if appropriate..
+
+=cut
+
sub backup
{
my ($self) = @_;
@@ -172,126 +199,155 @@
$self->storage->backup($self->backup_directory());
}
-sub upgrade
-{
- my ($self) = @_;
+# is this just a waste of time? if not then merge with DBI.pm
+sub _create_db_to_schema_diff {
+ my $self = shift;
- ## overridable sub, per default just run all the commands.
+ my %driver_to_db_map = (
+ 'mysql' => 'MySQL'
+ );
- $self->backup();
+ my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}};
+ unless ($db) {
+ print "Sorry, this is an unsupported DB\n";
+ return;
+ }
- $self->run_upgrade(qr/create/i);
- $self->run_upgrade(qr/alter table .*? add/i);
- $self->run_upgrade(qr/alter table .*? (?!drop)/i);
- $self->run_upgrade(qr/alter table .*? drop/i);
- $self->run_upgrade(qr/drop/i);
-# $self->run_upgrade(qr//i);
+ eval 'require SQL::Translator "0.09"';
+ if ($@) {
+ $self->throw_exception("SQL::Translator 0.09 required");
+ }
- my $vschema = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
- my $vtable = $vschema->resultset('Table');
- $vtable->create({ Version => $self->schema_version,
- Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
- });
-}
+ my $db_tr = SQL::Translator->new({
+ add_drop_table => 1,
+ parser => 'DBI',
+ parser_args => { dbh => $self->storage->dbh }
+ });
+ $db_tr->producer($db);
+ my $dbic_tr = SQL::Translator->new;
+ $dbic_tr->parser('SQL::Translator::Parser::DBIx::Class');
+ $dbic_tr = $self->storage->configure_sqlt($dbic_tr, $db);
+ $dbic_tr->data($self);
+ $dbic_tr->producer($db);
-sub run_upgrade
-{
- my ($self, $stm) = @_;
-# print "Reg: $stm\n";
- my @statements = grep { $_ =~ $stm } @{$self->_filedata};
-# print "Statements: ", join("\n", @statements), "\n";
- $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
+ $db_tr->schema->name('db_schema');
+ $dbic_tr->schema->name('dbic_schema');
- for (@statements)
+ # is this really necessary?
+ foreach my $tr ($db_tr, $dbic_tr) {
+ my $data = $tr->data;
+ $tr->parser->($tr, $$data);
+ }
+
+ my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db,
+ $dbic_tr->schema, $db,
+ { ignore_constraint_names => 1, ignore_index_names => 1, caseopt => 1 });
+
+ my $filename = $self->ddl_filename(
+ $db,
+ $self->upgrade_directory,
+ $self->schema_version,
+ 'PRE',
+ );
+ my $file;
+ if(!open($file, ">$filename"))
{
- $self->storage->debugobj->query_start($_) if $self->storage->debug;
- $self->storage->dbh->do($_) or warn "SQL was:\n $_";
- $self->storage->debugobj->query_end($_) if $self->storage->debug;
+ $self->throw_exception("Can't open $filename for writing ($!)");
+ next;
}
+ print $file $diff;
+ close($file);
- return 1;
+ print "WARNING: There may be differences between your DB and your DBIC schema. Please review and if necessary run the SQL in $filename to sync your DB.\n";
}
-1;
+=head2 upgrade
-=head1 NAME
+Call this to attempt to upgrade your database from the version it is at to the version
+this DBIC schema is at.
-DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
+It requires an SQL diff file to exist in $schema->upgrade_directory, normally you will
+have created this using $schema->create_ddl_dir.
-=head1 SYNOPSIS
+=cut
- package Library::Schema;
- use base qw/DBIx::Class::Schema/;
- # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
- __PACKAGE__->load_classes(qw/CD Book DVD/);
+sub upgrade
+{
+ my ($self) = @_;
+ my $db_version = $self->get_db_version();
- __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
- __PACKAGE__->upgrade_directory('/path/to/upgrades/');
- __PACKAGE__->backup_directory('/path/to/backups/');
+ # db unversioned
+ unless ($db_version) {
+ # set version in dbix_class_schema_versions table, can't actually upgrade as we don 't know what version the DB is at
+ $self->_create_db_to_schema_diff() if ($self->do_diff_on_init);
- sub backup
- {
- my ($self) = @_;
- # my special backup process
+ # create versions table and version row
+ $self->{vschema}->deploy;
+ $self->_set_db_version;
+ return;
}
- sub upgrade
- {
- my ($self) = @_;
+ # db and schema at same version. do nothing
+ if ($db_version eq $self->schema_version) {
+ print "Upgrade not necessary\n";
+ return;
+ }
- ## overridable sub, per default just runs all the commands.
+ # strangely the first time this is called can
+ # differ to subsequent times. so we call it
+ # here to be sure.
+ # XXX - just fix it
+ $self->storage->sqlt_type;
+
+ my $upgrade_file = $self->ddl_filename(
+ $self->storage->sqlt_type,
+ $self->upgrade_directory,
+ $self->schema_version,
+ $db_version,
+ );
- $self->run_upgrade(qr/create/i);
- $self->run_upgrade(qr/alter table .*? add/i);
- $self->run_upgrade(qr/alter table .*? (?!drop)/i);
- $self->run_upgrade(qr/alter table .*? drop/i);
- $self->run_upgrade(qr/drop/i);
- $self->run_upgrade(qr//i);
+ unless (-f $upgrade_file) {
+ warn "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
+ return;
}
-=head1 DESCRIPTION
+ # backup if necessary then apply upgrade
+ $self->_filedata($self->_read_sql_file($upgrade_file));
+ $self->backup() if($self->do_backup);
+ $self->txn_do(sub { $self->do_upgrade() });
-This module is a component designed to extend L<DBIx::Class::Schema>
-classes, to enable them to upgrade to newer schema layouts. To use this
-module, you need to have called C<create_ddl_dir> on your Schema to
-create your upgrade files to include with your delivery.
+ # set row in dbix_class_schema_versions table
+ $self->_set_db_version;
+}
-A table called I<SchemaVersions> is created and maintained by the
-module. This contains two fields, 'Version' and 'Installed', which
-contain each VERSION of your Schema, and the date+time it was installed.
+sub _set_db_version {
+ my $self = shift;
-If you would like to influence which levels of version change need
-upgrades in your Schema, you can override the method C<ddl_filename>
-in L<DBIx::Class::Schema>. Return a false value if there is no upgrade
-path between the two versions supplied. By default, every change in
-your VERSION is regarded as needing an upgrade.
+ my $vtable = $self->{vschema}->resultset('Table');
+ $vtable->create({ version => $self->schema_version,
+ installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
+ });
-The actual upgrade is called manually by calling C<upgrade> on your
-schema object. Code is run at connect time to determine whether an
-upgrade is needed, if so, a warning "Versions out of sync" is
-produced.
+}
-NB: At the moment, SQLite upgrading is rather spotty, as SQL::Translator::Diff
-returns SQL statements that SQLite does not support.
+sub _read_sql_file {
+ my $self = shift;
+ my $file = shift || return;
+ my $fh;
+ open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
+ my @data = split(/\n/, join('', <$fh>));
+ @data = grep(!/^--/, @data);
+ @data = split(/;/, join('', @data));
+ close($fh);
+ @data = grep { $_ && $_ !~ /^-- / } @data;
+ @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data;
+ return \@data;
+}
-=head1 METHODS
+=head2 do_upgrade
-=head2 backup
-
-This is an overwritable method which is called just before the upgrade, to
-allow you to make a backup of the database. Per default this method attempts
-to call C<< $self->storage->backup >>, to run the standard backup on each
-database type.
-
-This method should return the name of the backup file, if appropriate.
-
-C<backup> is called from C<upgrade>, make sure you call it, if you write your
-own <upgrade> method.
-
-=head2 upgrade
-
This is an overwritable method used to run your upgrade. The freeform method
allows you to run your upgrade any way you please, you can call C<run_upgrade>
any number of times to run the actual SQL commands, and in between you can
@@ -299,6 +355,22 @@
commands, then migrate your data from old to new tables/formats, then
issue the DROP commands when you are finished.
+Will run the whole file as it is by default.
+
+=cut
+
+sub do_upgrade
+{
+ my ($self) = @_;
+
+ ## overridable sub, per default just run all the commands.
+ $self->run_upgrade(qr/create/i);
+ $self->run_upgrade(qr/alter table .*? add/i);
+ $self->run_upgrade(qr/alter table .*? (?!drop)/i);
+ $self->run_upgrade(qr/alter table .*? drop/i);
+ $self->run_upgrade(qr/drop/i);
+}
+
=head2 run_upgrade
$self->run_upgrade(qr/create/i);
@@ -306,23 +378,94 @@
Runs a set of SQL statements matching a passed in regular expression. The
idea is that this method can be called any number of times from your
C<upgrade> method, running whichever commands you specify via the
-regex in the parameter.
+regex in the parameter. Probably won't work unless called from the overridable
+do_upgrade method.
-=head2 upgrade_directory
+=cut
-Use this to set the directory your upgrade files are stored in.
+sub run_upgrade
+{
+ my ($self, $stm) = @_;
-=head2 backup_directory
+ return unless ($self->_filedata);
+ my @statements = grep { $_ =~ $stm } @{$self->_filedata};
+ $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
-Use this to set the directory you want your backups stored in.
+ for (@statements)
+ {
+ $self->storage->debugobj->query_start($_) if $self->storage->debug;
+ $self->storage->dbh->do($_) or warn "SQL was:\n $_";
+ $self->storage->debugobj->query_end($_) if $self->storage->debug;
+ }
-=head2 schema_version
+ return 1;
+}
-Returns the current schema class' $VERSION; does -not- use $schema->VERSION
-since that varies in results depending on if version.pm is installed, and if
-so the perl or XS versions. If you want this to change, bug the version.pm
-author to make vpp and vxs behave the same.
+=head2 connection
-=head1 AUTHOR
+Overloaded method. This checks the DBIC schema version against the DB version and
+warns if they are not the same or if the DB is unversioned. It also provides
+compatibility between the old versions table (SchemaVersions) and the new one
+(dbix_class_schema_versions).
+To avoid the checks on connect, set the env var DBIC_NO_VERSION_CHECK. This can be
+useful for scripts.
+
+=cut
+
+sub connection {
+ my $self = shift;
+ $self->next::method(@_);
+ $self->_on_connect;
+ return $self;
+}
+
+sub _on_connect
+{
+ my ($self) = @_;
+ $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
+ my $vtable = $self->{vschema}->resultset('Table');
+
+ # check for legacy versions table and move to new if exists
+ my $vschema_compat = DBIx::Class::VersionCompat->connect(@{$self->storage->connect_info()});
+ unless ($self->_source_exists($vtable)) {
+ my $vtable_compat = $vschema_compat->resultset('TableCompat');
+ if ($self->_source_exists($vtable_compat)) {
+ $self->{vschema}->deploy;
+ map { $vtable->create({ installed => $_->Installed, version => $_->Version }) } $vtable_compat->all;
+ $self->storage->dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
+ }
+ }
+
+ # useful when connecting from scripts etc
+ return if ($ENV{DBIC_NO_VERSION_CHECK});
+
+ my $pversion = $self->get_db_version();
+
+ if($pversion eq $self->schema_version)
+ {
+# warn "This version is already installed\n";
+ return 1;
+ }
+
+ if(!$pversion)
+ {
+ warn "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
+ return 1;
+ }
+
+ warn "Versions out of sync. This is " . $self->schema_version .
+ ", your database contains version $pversion, please call upgrade on your Schema.\n";
+}
+
+1;
+
+
+=head1 AUTHORS
+
Jess Robinson <castaway at desert-island.demon.co.uk>
+Luke Saunders <luke at shadowcatsystems.co.uk>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Schema.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -734,6 +734,21 @@
$self->storage->txn_do(@_);
}
+=head2 txn_scope_guard
+
+Runs C<txn_scope_guard> on the schema's storage.
+
+=cut
+
+sub txn_scope_guard {
+ my $self = shift;
+
+ $self->storage or $self->throw_exception
+ ('txn_scope_guard called on $schema without storage');
+
+ $self->storage->txn_scope_guard(@_);
+}
+
=head2 txn_begin
Begins a transaction (does nothing if AutoCommit is off). Equivalent to
@@ -785,6 +800,57 @@
$self->storage->txn_rollback;
}
+=head2 svp_begin
+
+Creates a new savepoint (does nothing outside a transaction).
+Equivalent to calling $schema->storage->svp_begin. See
+L<DBIx::Class::Storage::DBI/"svp_begin"> for more information.
+
+=cut
+
+sub svp_begin {
+ my ($self, $name) = @_;
+
+ $self->storage or $self->throw_exception
+ ('svp_begin called on $schema without storage');
+
+ $self->storage->svp_begin($name);
+}
+
+=head2 svp_release
+
+Releases a savepoint (does nothing outside a transaction).
+Equivalent to calling $schema->storage->svp_release. See
+L<DBIx::Class::Storage::DBI/"svp_release"> for more information.
+
+=cut
+
+sub svp_release {
+ my ($self, $name) = @_;
+
+ $self->storage or $self->throw_exception
+ ('svp_release called on $schema without storage');
+
+ $self->storage->svp_release($name);
+}
+
+=head2 svp_rollback
+
+Rollback to a savepoint (does nothing outside a transaction).
+Equivalent to calling $schema->storage->svp_rollback. See
+L<DBIx::Class::Storage::DBI/"svp_rollback"> for more information.
+
+=cut
+
+sub svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->storage or $self->throw_exception
+ ('svp_rollback called on $schema without storage');
+
+ $self->storage->svp_rollback($name);
+}
+
=head2 clone
=over 4
@@ -972,6 +1038,30 @@
$self->storage->deploy($self, undef, $sqltargs, $dir);
}
+=head2 deployment_statements
+
+=over 4
+
+=item Arguments: $rdbms_type
+
+=back
+
+Returns the SQL statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
+C<$rdbms_type> provides the DBI database driver name for which the SQL
+statements are produced. If not supplied, the type of the current schema storage
+will be used.
+
+=cut
+
+sub deployment_statements {
+ my ($self, $rdbms_type) = @_;
+
+ $self->throw_exception("Can't generate deployment statements without a storage")
+ if not $self->storage;
+
+ $self->storage->deployment_statements($self, $rdbms_type);
+}
+
=head2 create_ddl_dir (EXPERIMENTAL)
=over 4
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Serialize/Storable.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Serialize/Storable.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Serialize/Storable.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -4,14 +4,19 @@
use Storable;
sub STORABLE_freeze {
- my ($self,$cloning) = @_;
+ my ($self, $cloning) = @_;
my $to_serialize = { %$self };
+
delete $to_serialize->{result_source};
+ delete $to_serialize->{related_resultsets};
+ delete $to_serialize->{_inflated_column};
+
return (Storable::freeze($to_serialize));
}
sub STORABLE_thaw {
- my ($self,$cloning,$serialized) = @_;
+ my ($self, $cloning, $serialized) = @_;
+
%$self = %{ Storable::thaw($serialized) };
$self->result_source($self->result_source_instance)
if $self->can('result_source_instance');
Added: DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm (rev 0)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,129 @@
+package DBIx::Class::Storage::DBI::ODBC::ACCESS;
+use strict;
+use warnings;
+
+use Data::Dump qw( dump );
+
+use DBI;
+use base qw/DBIx::Class::Storage::DBI/;
+
+my $ERR_MSG_START = __PACKAGE__ . ' failed: ';
+
+sub insert {
+ my $self = shift;
+ my ( $source, $to_insert ) = @_;
+
+ my $bind_attributes = $self->source_bind_attributes( $source );
+ my ( undef, $sth ) = $self->_execute( 'insert' => [], $source, $bind_attributes, $to_insert );
+
+ #store the identity here since @@IDENTITY is connection global and this prevents
+ #possibility that another insert to a different table overwrites it for this resultsource
+ my $identity = 'SELECT @@IDENTITY';
+ my $max_sth = $self->{ _dbh }->prepare( $identity )
+ or $self->throw_exception( $ERR_MSG_START . $self->{ _dbh }->errstr() );
+ $max_sth->execute() or $self->throw_exception( $ERR_MSG_START . $max_sth->errstr );
+
+ my $row = $max_sth->fetchrow_arrayref()
+ or $self->throw_exception( $ERR_MSG_START . "$identity did not return any result." );
+
+ $self->{ last_pk }->{ $source->name() } = $row;
+
+ return $to_insert;
+}
+
+sub last_insert_id {
+ my $self = shift;
+ my ( $result_source ) = @_;
+
+ return @{ $self->{ last_pk }->{ $result_source->name() } };
+}
+
+sub bind_attribute_by_data_type {
+ my $self = shift;
+
+ my ( $data_type ) = @_;
+
+ return { TYPE => $data_type } if $data_type == DBI::SQL_LONGVARCHAR;
+
+ return;
+}
+
+sub sqlt_type { 'ACCESS' }
+
+1;
+
+=head1 NAME
+
+DBIx::Class::Storage::ODBC::ACCESS - Support specific to MS Access over ODBC
+
+=head1 WARNING
+
+I am not a DBI, DBIx::Class or MS Access guru. Use this module with that in
+mind.
+
+This module is currently considered alpha software and can change without notice.
+
+=head1 DESCRIPTION
+
+This class implements support specific to Microsoft Access over ODBC.
+
+It is loaded automatically by by DBIx::Class::Storage::DBI::ODBC when it
+detects a MS Access back-end.
+
+=head1 SUPPORTED VERSIONS
+
+This module have currently only been tested on MS Access 2003 using the Jet 4.0 engine.
+
+As far as my knowledge it should work on MS Access 2000 or later, but that have not been tested.
+Information about support for different version of MS Access is welcome.
+
+=head1 IMPLEMENTATION NOTES
+
+MS Access supports the @@IDENTITY function for retriving the id of the latest inserted row.
+@@IDENTITY is global to the connection, so to support the possibility of getting the last inserted
+id for different tables, the insert() function stores the inserted id on a per table basis.
+last_insert_id() then just returns the stored value.
+
+=head1 KNOWN ACCESS PROBLEMS
+
+=over
+
+=item Invalid precision value
+
+This error message is received when trying to store more than 255 characters in a MEMO field.
+The problem is (to my knowledge) an error in the MS Access ODBC driver. The problem is fixed
+by setting the C<data_type> of the column to C<SQL_LONGVARCHAR> in C<add_columns>.
+C<SQL_LONGVARCHAR> is a constant in the C<DBI> module.
+
+=back
+
+=head1 IMPLEMENTED FUNCTIONS
+
+=head2 bind_attribute_by_data_type
+
+This function currently supports the SQL_LONGVARCHAR column type.
+
+=head2 insert
+
+=head2 last_insert_id
+
+=head2 sqlt_type
+
+=head1 BUGS
+
+Most likely. Bug reports are welcome.
+
+=head1 AUTHORS
+
+Øystein Torget C<< <oystein.torget at dnv.com> >>
+
+=head1 COPYRIGHT
+
+You may distribute this code under the same terms as Perl itself.
+
+Det Norske Veritas AS (DNV)
+
+http://www.dnv.com
+
+=cut
+
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -52,8 +52,8 @@
=head1 NAME
-DBIx::Class::Storage::ODBC::Microsoft_SQL_Server - Support specific to
-Microsoft SQL Server over ODBC
+DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server - Support specific
+to Microsoft SQL Server over ODBC
=head1 DESCRIPTION
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -12,6 +12,7 @@
# In your table classes
__PACKAGE__->load_components(qw/PK::Auto Core/);
+ __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
__PACKAGE__->set_primary_key('id');
__PACKAGE__->sequence('mysequence');
@@ -30,11 +31,14 @@
# __PACKAGE__->load_components(qw/PK::Auto/);
sub _dbh_last_insert_id {
- my ($self, $dbh, $source, $col) = @_;
- my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
- my $sql = 'SELECT ' . $seq . '.currval FROM DUAL';
- my ($id) = $dbh->selectrow_array($sql);
- return $id;
+ my ($self, $dbh, $source, @columns) = @_;
+ my @ids = ();
+ foreach my $col (@columns) {
+ my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
+ my $id = $self->_sequence_fetch( 'currval', $seq );
+ push @ids, $id;
+ }
+ return @ids;
}
sub _dbh_get_autoinc_seq {
@@ -59,6 +63,12 @@
$self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
}
+sub _sequence_fetch {
+ my ( $self, $type, $seq ) = @_;
+ my ($id) = $self->dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
+ return $id;
+}
+
=head2 get_autoinc_seq
Returns the sequence name for an autoincrement column
@@ -68,7 +78,7 @@
sub get_autoinc_seq {
my ($self, $source, $col) = @_;
- $self->dbh_do($self->can('_dbh_get_autoinc_seq'), $source, $col);
+ $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
}
=head2 columns_info_for
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -8,7 +8,8 @@
__PACKAGE__->sql_maker_class('DBIC::SQL::Abstract::Oracle');
BEGIN {
- package DBIC::SQL::Abstract::Oracle;
+ package # Hide from PAUSE
+ DBIC::SQL::Abstract::Oracle;
use base qw( DBIC::SQL::Abstract );
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Oracle.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Oracle.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Oracle.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -25,7 +25,20 @@
}
}
+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.09/trunk/lib/DBIx/Class/Storage/DBI/Pg.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Pg.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Pg.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -24,7 +24,7 @@
$self->throw_exception("could not fetch primary key for " . $source->name . ", could not "
. "get autoinc sequence for $col (check that table and column specifications are correct "
. "and in the correct case)") unless defined $seq;
- $self->dbh_do($self->can('_dbh_last_insert_id'), $seq);
+ $self->dbh_do('_dbh_last_insert_id', $seq);
}
sub _dbh_get_autoinc_seq {
@@ -49,7 +49,7 @@
my ($schema,$table) = $source->name =~ /^(.+)\.(.+)$/ ? ($1,$2)
: (undef,$source->name);
- $self->dbh_do($self->can('_dbh_get_autoinc_seq'), $schema, $table, @pri);
+ $self->dbh_do('_dbh_get_autoinc_seq', $schema, $table, @pri);
}
sub sqlt_type {
@@ -73,6 +73,30 @@
}
}
+sub _sequence_fetch {
+ my ( $self, $type, $seq ) = @_;
+ my ($id) = $self->dbh->selectrow_array("SELECT nextval('${seq}')");
+ return $id;
+}
+
+sub _svp_begin {
+ my ($self, $name) = @_;
+
+ $self->dbh->pg_savepoint($name);
+}
+
+sub _svp_release {
+ my ($self, $name) = @_;
+
+ $self->dbh->pg_release($name);
+}
+
+sub _svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->dbh->pg_rollback_to($name);
+}
+
1;
=head1 NAME
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Replication.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Replication.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Replication.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -21,6 +21,8 @@
[ "dbi:mysql:database=test;hostname=master", "username", "password", { AutoCommit => 1 } ], # master
[ "dbi:mysql:database=test;hostname=slave1", "username", "password", { priority => 10 } ], # slave1
[ "dbi:mysql:database=test;hostname=slave2", "username", "password", { priority => 10 } ], # slave2
+ [ $dbh, '','', {priority=>10}], # add in a preexisting database handle
+ [ sub { DBI->connect }, '', '', {priority=>10}], # DBD::Multi will call this coderef for connects
<...>,
{ limit_dialect => 'LimitXY' } # If needed, see below
] );
@@ -83,15 +85,24 @@
$global_options = ref $info->[-1] eq 'HASH' ? pop( @$info ) : {};
if( ref( $options = $info->[0]->[-1] ) eq 'HASH' ) {
# Local options present in dsn, merge them with global options
- map { $global_options->{$_} = $options->{$_} } keys %$options;
- pop @{$info->[0]};
+ map { $global_options->{$_} = $options->{$_} } keys %$options;
+ pop @{$info->[0]};
}
# We need to copy-pass $global_options, since connect_info clears it while
# processing options
- $self->write_source->connect_info( [ @{$info->[0]}, { %$global_options } ] );
+ $self->write_source->connect_info( @{$info->[0]}, { %$global_options } );
- @dsns = map { ($_->[3]->{priority} || 10) => $_ } @{$info}[1..@$info-1];
+ ## allow either a DSN string or an already connect $dbh. Just remember if
+ ## you use the $dbh option then DBD::Multi has no idea how to reconnect in
+ ## the event of a failure.
+
+ @dsns = map {
+ ## if the first element in the arrayhash is a ref, make that the value
+ my $db = ref $_->[0] ? $_->[0] : $_;
+ ($_->[3]->{priority} || 10) => $db;
+ } @{$info->[0]}[1..@{$info->[0]}-1];
+
$global_options->{dsns} = \@dsns;
$self->read_source->connect_info( [ 'dbi:Multi:', undef, undef, { %$global_options } ] );
Added: DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm (rev 0)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,81 @@
+package DBIx::Class::Storage::DBI::Role::QueryCounter;
+
+use Moose::Role;
+requires '_query_start';
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Role::QueryCounter; Role to add a query counter
+
+=head1 SYNOPSIS
+
+ my $query_count = $schema->storage->query_count;
+
+=head1 DESCRIPTION
+
+Each time the schema does a query, increment the counter.
+
+=head1 ATTRIBUTES
+
+This package defines the following attributes.
+
+head2 _query_count
+
+Is the attribute holding the current query count. It defines a public reader
+called 'query_count' which you can use to access the total number of queries
+that DBIC has run since connection.
+
+=cut
+
+has '_query_count' => (
+ reader=>'query_count',
+ writer=>'_set_query_count',
+ isa=>'Int',
+ required=>1,
+ default=>0,
+);
+
+
+=head1 METHODS
+
+This module defines the following methods.
+
+=head2 _query_start
+
+override on the method so that we count the queries.
+
+=cut
+
+around '_query_start' => sub {
+ my ($_query_start, $self, @args) = @_;
+ $self->_increment_query_count;
+ return $self->$_query_start(@args);
+};
+
+
+=head2 _increment_query_count
+
+Used internally. You won't need this unless you enjoy messing with the query
+count.
+
+=cut
+
+sub _increment_query_count {
+ my $self = shift @_;
+ my $current = $self->query_count;
+ $self->_set_query_count(++$current);
+}
+
+
+=head1 AUTHORS
+
+See L<DBIx::Class> for more information regarding authors.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+
+1;
\ No newline at end of file
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/SQLite.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/SQLite.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/SQLite.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -33,7 +33,7 @@
# my $dbfile = file($dbname);
my ($vol, $dbdir, $file) = File::Spec->splitpath($dbname);
# my $file = $dbfile->basename();
- $file = strftime("%y%m%d%h%M%s", localtime()) . $file;
+ $file = strftime("%Y-%m-%d-%H_%M_%S", localtime()) . $file;
$file = "B$file" while(-f $file);
mkdir($dir) unless -f $dir;
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/mysql.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/mysql.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI/mysql.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -16,6 +16,24 @@
return 'MySQL';
}
+sub _svp_begin {
+ my ($self, $name) = @_;
+
+ $self->dbh->do("SAVEPOINT $name");
+}
+
+sub _svp_release {
+ my ($self, $name) = @_;
+
+ $self->dbh->do("RELEASE SAVEPOINT $name");
+}
+
+sub _svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->dbh->do("ROLLBACK TO SAVEPOINT $name")
+}
+
1;
=head1 NAME
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/DBI.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -5,6 +5,7 @@
use strict;
use warnings;
+use Carp::Clan qw/^DBIx::Class/;
use DBI;
use SQL::Abstract::Limit;
use DBIx::Class::Storage::DBI::Cursor;
@@ -14,7 +15,8 @@
__PACKAGE__->mk_group_accessors('simple' =>
qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts
_conn_pid _conn_tid disable_sth_caching on_connect_do
- on_disconnect_do transaction_depth unsafe _dbh_autocommit/
+ on_disconnect_do transaction_depth unsafe _dbh_autocommit
+ auto_savepoint savepoints/
);
__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
@@ -24,7 +26,8 @@
BEGIN {
-package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
+package # Hide from PAUSE
+ DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
use base qw/SQL::Abstract::Limit/;
@@ -327,6 +330,7 @@
$new->transaction_depth(0);
$new->_sql_maker_opts({});
+ $new->{savepoints} = [];
$new->{_in_dbh_do} = 0;
$new->{_dbh_gen} = 0;
@@ -429,6 +433,12 @@
especially if you set a C<HandleError> handler that suppresses exceptions
and/or disable C<RaiseError>.
+=item auto_savepoint
+
+If this option is true, L<DBIx::Class> will use savepoints when nesting
+transactions, making it possible to recover from failure in the inner
+transaction without having to abort all outer transactions.
+
=back
These options can be mixed in with your other L<DBI> connection attributes,
@@ -442,16 +452,16 @@
Another Important Note:
DBIC can do some wonderful magic with handling exceptions,
-disconnections, and transactions when you use C<AutoCommit => 1>
+disconnections, and transactions when you use C<< AutoCommit => 1 >>
combined with C<txn_do> for transaction support.
-If you set C<AutoCommit => 0> in your connect info, then you are always
+If you set C<< AutoCommit => 0 >> in your connect info, then you are always
in an assumed transaction between commits, and you're telling us you'd
like to manage that manually. A lot of DBIC's magic protections
go away. We can't protect you from exceptions due to database
disconnects because we don't know anything about how to restart your
transactions. You're on your own for handling all sorts of exceptional
-cases if you choose the C<AutoCommit => 0> path, just as you would
+cases if you choose the C<< AutoCommit => 0 >> path, just as you would
be with raw DBI.
Examples:
@@ -516,6 +526,7 @@
$last_info = { %$last_info }; # so delete is non-destructive
my @storage_option = qw(
on_connect_do on_disconnect_do disable_sth_caching unsafe cursor_class
+ auto_savepoint
);
for my $storage_opt (@storage_option) {
if(my $value = delete $last_info->{$storage_opt}) {
@@ -544,9 +555,10 @@
=head2 dbh_do
-Arguments: $subref, @extra_coderef_args?
+Arguments: ($subref | $method_name), @extra_coderef_args?
-Execute the given subref using the new exception-based connection management.
+Execute the given $subref or $method_name using the new exception-based
+connection management.
The first two arguments will be the storage object that C<dbh_do> was called
on and a database handle to use. Any additional arguments will be passed
@@ -574,12 +586,11 @@
sub dbh_do {
my $self = shift;
- my $coderef = shift;
+ my $code = shift;
- ref $coderef eq 'CODE' or $self->throw_exception
- ('$coderef must be a CODE reference');
+ my $dbh = $self->_dbh;
- return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do}
+ return $self->$code($dbh, @_) if $self->{_in_dbh_do}
|| $self->{transaction_depth};
local $self->{_in_dbh_do} = 1;
@@ -588,16 +599,20 @@
my $want_array = wantarray;
eval {
- $self->_verify_pid if $self->_dbh;
- $self->_populate_dbh if !$self->_dbh;
+ $self->_verify_pid if $dbh;
+ if( !$dbh ) {
+ $self->_populate_dbh;
+ $dbh = $self->_dbh;
+ }
+
if($want_array) {
- @result = $coderef->($self, $self->_dbh, @_);
+ @result = $self->$code($dbh, @_);
}
elsif(defined $want_array) {
- $result[0] = $coderef->($self, $self->_dbh, @_);
+ $result[0] = $self->$code($dbh, @_);
}
else {
- $coderef->($self, $self->_dbh, @_);
+ $self->$code($dbh, @_);
}
};
@@ -609,7 +624,7 @@
# We were not connected - reconnect and retry, but let any
# exception fall right through this time
$self->_populate_dbh;
- $coderef->($self, $self->_dbh, @_);
+ $self->$code($self->_dbh, @_);
}
# This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
@@ -622,7 +637,7 @@
ref $coderef eq 'CODE' or $self->throw_exception
('$coderef must be a CODE reference');
- return $coderef->(@_) if $self->{transaction_depth};
+ return $coderef->(@_) if $self->{transaction_depth} && ! $self->auto_savepoint;
local $self->{_in_dbh_do} = 1;
@@ -763,6 +778,8 @@
return $self->_sql_maker;
}
+sub _rebless {}
+
sub _populate_dbh {
my ($self) = @_;
my @info = @{$self->_dbi_connect_info || []};
@@ -776,7 +793,7 @@
my $driver = $self->_dbh->{Driver}->{Name};
if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
bless $self, "DBIx::Class::Storage::DBI::${driver}";
- $self->_rebless() if $self->can('_rebless');
+ $self->_rebless();
}
}
@@ -861,7 +878,91 @@
$dbh;
}
+sub svp_begin {
+ my ($self, $name) = @_;
+ $name = $self->_svp_generate_name
+ unless defined $name;
+
+ $self->throw_exception ("You can't use savepoints outside a transaction")
+ if $self->{transaction_depth} == 0;
+
+ $self->throw_exception ("Your Storage implementation doesn't support savepoints")
+ unless $self->can('_svp_begin');
+
+ push @{ $self->{savepoints} }, $name;
+
+ $self->debugobj->svp_begin($name) if $self->debug;
+
+ return $self->_svp_begin($name);
+}
+
+sub svp_release {
+ my ($self, $name) = @_;
+
+ $self->throw_exception ("You can't use savepoints outside a transaction")
+ if $self->{transaction_depth} == 0;
+
+ $self->throw_exception ("Your Storage implementation doesn't support savepoints")
+ unless $self->can('_svp_release');
+
+ if (defined $name) {
+ $self->throw_exception ("Savepoint '$name' does not exist")
+ unless grep { $_ eq $name } @{ $self->{savepoints} };
+
+ # Dig through the stack until we find the one we are releasing. This keeps
+ # the stack up to date.
+ my $svp;
+
+ do { $svp = pop @{ $self->{savepoints} } } while $svp ne $name;
+ } else {
+ $name = pop @{ $self->{savepoints} };
+ }
+
+ $self->debugobj->svp_release($name) if $self->debug;
+
+ return $self->_svp_release($name);
+}
+
+sub svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->throw_exception ("You can't use savepoints outside a transaction")
+ if $self->{transaction_depth} == 0;
+
+ $self->throw_exception ("Your Storage implementation doesn't support savepoints")
+ unless $self->can('_svp_rollback');
+
+ if (defined $name) {
+ # If they passed us a name, verify that it exists in the stack
+ unless(grep({ $_ eq $name } @{ $self->{savepoints} })) {
+ $self->throw_exception("Savepoint '$name' does not exist!");
+ }
+
+ # Dig through the stack until we find the one we are releasing. This keeps
+ # the stack up to date.
+ while(my $s = pop(@{ $self->{savepoints} })) {
+ last if($s eq $name);
+ }
+ # Add the savepoint back to the stack, as a rollback doesn't remove the
+ # named savepoint, only everything after it.
+ push(@{ $self->{savepoints} }, $name);
+ } else {
+ # We'll assume they want to rollback to the last savepoint
+ $name = $self->{savepoints}->[-1];
+ }
+
+ $self->debugobj->svp_rollback($name) if $self->debug;
+
+ return $self->_svp_rollback($name);
+}
+
+sub _svp_generate_name {
+ my ($self) = @_;
+
+ return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
+}
+
sub txn_begin {
my $self = shift;
$self->ensure_connected();
@@ -872,6 +973,8 @@
# we should reconnect on begin_work
# for AutoCommit users
$self->dbh->begin_work;
+ } elsif ($self->auto_savepoint) {
+ $self->svp_begin;
}
$self->{transaction_depth}++;
}
@@ -887,7 +990,9 @@
if $self->_dbh_autocommit;
}
elsif($self->{transaction_depth} > 1) {
- $self->{transaction_depth}--
+ $self->{transaction_depth}--;
+ $self->svp_release
+ if $self->auto_savepoint;
}
}
@@ -904,6 +1009,10 @@
}
elsif($self->{transaction_depth} > 1) {
$self->{transaction_depth}--;
+ if ($self->auto_savepoint) {
+ $self->svp_rollback;
+ $self->svp_release;
+ }
}
else {
die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
@@ -1010,7 +1119,7 @@
sub _execute {
my $self = shift;
- $self->dbh_do($self->can('_dbh_execute'), @_)
+ $self->dbh_do('_dbh_execute', @_)
}
sub insert {
@@ -1019,6 +1128,17 @@
my $ident = $source->from;
my $bind_attributes = $self->source_bind_attributes($source);
+ foreach my $col ( $source->columns ) {
+ if ( !defined $to_insert->{$col} ) {
+ my $col_info = $source->column_info($col);
+
+ if ( $col_info->{auto_nextval} ) {
+ $self->ensure_connected;
+ $to_insert->{$col} = $self->_sequence_fetch( 'nextval', $col_info->{sequence} || $self->_dbh_get_autoinc_seq($self->dbh, $source) );
+ }
+ }
+ }
+
$self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
return $to_insert;
@@ -1122,6 +1242,9 @@
} else {
$self->throw_exception("rows attribute must be positive if present")
if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
+
+ # MySQL actually recommends this approach. I cringe.
+ $attrs->{rows} = 2**48 if not defined $attrs->{rows} and defined $attrs->{offset};
push @args, $attrs->{rows}, $attrs->{offset};
}
@@ -1164,6 +1287,7 @@
my $self = shift;
my ($rv, $sth, @bind) = $self->_select(@_);
my @row = $sth->fetchrow_array;
+ carp "Query returned more than one row" if $sth->fetchrow_array;
# Need to call finish() to work round broken DBDs
$sth->finish();
return @row;
@@ -1198,7 +1322,7 @@
sub sth {
my ($self, $sql) = @_;
- $self->dbh_do($self->can('_dbh_sth'), $sql);
+ $self->dbh_do('_dbh_sth', $sql);
}
sub _dbh_columns_info_for {
@@ -1260,7 +1384,7 @@
sub columns_info_for {
my ($self, $table) = @_;
- $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
+ $self->dbh_do('_dbh_columns_info_for', $table);
}
=head2 last_insert_id
@@ -1277,7 +1401,7 @@
sub last_insert_id {
my $self = shift;
- $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
+ $self->dbh_do('_dbh_last_insert_id', @_);
}
=head2 sqlt_type
@@ -1329,21 +1453,20 @@
$version ||= $schema->VERSION || '1.x';
$sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
- $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.08: '}
+ $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.09: '}
. $self->_check_sqlt_message . q{'})
if !$self->_check_sqlt_version;
- my $sqlt = SQL::Translator->new({
-# debug => 1,
- add_drop_table => 1,
- });
+ my $sqlt = SQL::Translator->new( $sqltargs );
+
+ $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
+ my $sqlt_schema = $sqlt->translate({ data => $schema }) or die $sqlt->error;
+
foreach my $db (@$databases)
{
$sqlt->reset();
- $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
-# $sqlt->parser_args({'DBIx::Class' => $schema);
$sqlt = $self->configure_sqlt($sqlt, $db);
- $sqlt->data($schema);
+ $sqlt->{schema} = $sqlt_schema;
$sqlt->producer($db);
my $file;
@@ -1351,23 +1474,22 @@
if(-e $filename)
{
warn("$filename already exists, skipping $db");
- next;
- }
-
- my $output = $sqlt->translate;
- if(!$output)
- {
- warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
- next;
- }
- if(!open($file, ">$filename"))
- {
- $self->throw_exception("Can't open $filename for writing ($!)");
+ next unless ($preversion);
+ } else {
+ my $output = $sqlt->translate;
+ if(!$output)
+ {
+ warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
next;
- }
- print $file $output;
- close($file);
-
+ }
+ if(!open($file, ">$filename"))
+ {
+ $self->throw_exception("Can't open $filename for writing ($!)");
+ next;
+ }
+ print $file $output;
+ close($file);
+ }
if($preversion)
{
require SQL::Translator::Diff;
@@ -1379,36 +1501,7 @@
warn("No previous schema file found ($prefilename)");
next;
}
- #### We need to reparse the SQLite file we just wrote, so that
- ## Diff doesnt get all confoosed, and Diff is *very* confused.
- ## FIXME: rip Diff to pieces!
-# my $target_schema = $sqlt->schema;
-# unless ( $target_schema->name ) {
-# $target_schema->name( $filename );
-# }
- my @input;
- push @input, {file => $prefilename, parser => $db};
- push @input, {file => $filename, parser => $db};
- my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
- my $file = $_->{'file'};
- my $parser = $_->{'parser'};
- my $t = SQL::Translator->new;
- $t->debug( 0 );
- $t->trace( 0 );
- $t->parser( $parser ) or die $t->error;
- my $out = $t->translate( $file ) or die $t->error;
- my $schema = $t->schema;
- unless ( $schema->name ) {
- $schema->name( $file );
- }
- ($schema, $parser);
- } @input;
-
- my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
- $target_schema, $db,
- {}
- );
my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
if(-e $difffile)
@@ -1416,6 +1509,43 @@
warn("$difffile already exists, skipping");
next;
}
+
+ my $source_schema;
+ {
+ my $t = SQL::Translator->new($sqltargs);
+ $t->debug( 0 );
+ $t->trace( 0 );
+ $t->parser( $db ) or die $t->error;
+ $t = $self->configure_sqlt($t, $db);
+ my $out = $t->translate( $prefilename ) or die $t->error;
+ $source_schema = $t->schema;
+ unless ( $source_schema->name ) {
+ $source_schema->name( $prefilename );
+ }
+ }
+
+ # The "new" style of producers have sane normalization and can support
+ # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
+ # And we have to diff parsed SQL against parsed SQL.
+ my $dest_schema = $sqlt_schema;
+
+ unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
+ my $t = SQL::Translator->new($sqltargs);
+ $t->debug( 0 );
+ $t->trace( 0 );
+ $t->parser( $db ) or die $t->error;
+ $t = $self->configure_sqlt($t, $db);
+ my $out = $t->translate( $filename ) or die $t->error;
+ $dest_schema = $t->schema;
+ $dest_schema->name( $filename )
+ unless $dest_schema->name;
+ }
+
+ $DB::single = 1;
+ my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
+ $dest_schema, $db,
+ $sqltargs
+ );
if(!open $file, ">$difffile")
{
$self->throw_exception("Can't write to $difffile ($!)");
@@ -1479,7 +1609,7 @@
return join('', @rows);
}
- $self->throw_exception(q{Can't deploy without SQL::Translator 0.08: '}
+ $self->throw_exception(q{Can't deploy without SQL::Translator 0.09: '}
. $self->_check_sqlt_message . q{'})
if !$self->_check_sqlt_version;
@@ -1564,9 +1694,9 @@
my $_check_sqlt_message; # private
sub _check_sqlt_version {
return $_check_sqlt_version if defined $_check_sqlt_version;
- eval 'use SQL::Translator 0.08';
- $_check_sqlt_message = $@ ? $@ : '';
- $_check_sqlt_version = $@ ? 0 : 1;
+ eval 'use SQL::Translator "0.09"';
+ $_check_sqlt_message = $@ || '';
+ $_check_sqlt_version = !$@;
}
sub _check_sqlt_message {
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/Statistics.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/Statistics.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/Statistics.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -108,6 +108,39 @@
$self->print("COMMIT\n");
}
+=head2 svp_begin
+
+Called when a savepoint is created.
+
+=cut
+sub svp_begin {
+ my ($self, $name) = @_;
+
+ $self->print("SAVEPOINT $name\n");
+}
+
+=head2 svp_release
+
+Called when a savepoint is released.
+
+=cut
+sub svp_release {
+ my ($self, $name) = @_;
+
+ $self->print("RELEASE SAVEPOINT $name\n");
+}
+
+=head2 svp_rollback
+
+Called when rolling back to a savepoint.
+
+=cut
+sub svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->print("ROLLBACK TO SAVEPOINT $name\n");
+}
+
=head2 query_start
Called before a query is executed. The first argument is the SQL string being
Added: DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/TxnScopeGuard.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/TxnScopeGuard.pm (rev 0)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage/TxnScopeGuard.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,96 @@
+package # Hide from pause for now - till we get it working
+ DBIx::Class::Storage::TxnScopeGuard;
+
+use strict;
+use warnings;
+
+sub new {
+ my ($class, $storage) = @_;
+
+ $storage->txn_begin;
+ bless [ 0, $storage ], ref $class || $class;
+}
+
+sub commit {
+ my $self = shift;
+
+ $self->[1]->txn_commit;
+ $self->[0] = 1;
+}
+
+sub DESTROY {
+ my ($dismiss, $storage) = @{$_[0]};
+
+ return if $dismiss;
+
+ my $exception = $@;
+
+ $DB::single = 1;
+
+ local $@;
+ eval { $storage->txn_rollback };
+ my $rollback_exception = $@;
+ if($rollback_exception) {
+ my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
+
+ $storage->throw_exception(
+ "Transaction aborted: ${exception}. "
+ . "Rollback failed: ${rollback_exception}"
+ ) unless $rollback_exception =~ /$exception_class/;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBIx::Class::Storage::TxnScopeGuard
+
+=head1 SYNOPSIS
+
+ sub foo {
+ my ($self, $schema) = @_;
+
+ my $guard = $schema->txn_scope_guard;
+
+ # Multiple database operations here
+
+ $guard->commit;
+ }
+
+=head1 DESCRIPTION
+
+An object that behaves much like L<Scope::Guard>, but hardcoded to do the
+right thing with transactions in DBIx::Class.
+
+=head1 METHODS
+
+=head2 new
+
+Creating an instance of this class will start a new transaction. Expects a
+L<DBIx::Class::Storage> object as its only argument.
+
+=head2 commit
+
+Commit the transaction, and stop guarding the scope. If this method is not
+called (i.e. an exception is thrown) and this object goes out of scope then
+the transaction is rolled back.
+
+=cut
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema/txn_scope_guard>.
+
+=head1 AUTHOR
+
+Ash Berlin, 2008.
+
+Insipred by L<Scope::Guard> by chocolateboy.
+
+This module is free software. It may be used, redistributed and/or modified
+under the same terms as Perl itself.
+
+=cut
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class/Storage.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -8,6 +8,7 @@
use Scalar::Util qw/weaken/;
use Carp::Clan qw/^DBIx::Class/;
use IO::File;
+use DBIx::Class::Storage::TxnScopeGuard;
__PACKAGE__->mk_group_accessors('simple' => qw/debug debugobj schema/);
__PACKAGE__->mk_group_accessors('inherited' => 'cursor_class');
@@ -261,6 +262,53 @@
sub txn_rollback { die "Virtual method!" }
+=head2 svp_begin
+
+Arguments: $savepoint_name?
+
+Created a new savepoint using the name provided as argument. If no name
+is provided, a random name will be used.
+
+=cut
+
+sub svp_begin { die "Virtual method!" }
+
+=head2 svp_release
+
+Arguments: $savepoint_name?
+
+Release the savepoint provided as argument. If none is provided,
+release the savepoint created most recently. This will implicitly
+release all savepoints created after the one explicitly released as well.
+
+=cut
+
+sub svp_release { die "Virtual method!" }
+
+=head2 svp_rollback
+
+Arguments: $savepoint_name?
+
+Rollback to the savepoint provided as argument. If none is provided,
+rollback to the savepoint created most recently. This will implicitly
+release all savepoints created after the savepoint we rollback to.
+
+=cut
+
+sub svp_rollback { die "Virtual method!" }
+
+=for comment
+
+=head2 txn_scope_guard
+
+Return an object that does stuff.
+
+=cut
+
+sub txn_scope_guard {
+ return DBIx::Class::Storage::TxnScopeGuard->new($_[0]);
+}
+
=head2 sql_maker
Returns a C<sql_maker> object - normally an object of class
@@ -421,7 +469,8 @@
=head1 SEE ALSO
-L<DBIx::Class::Storage::DBI> - reference storage inplementation using SQL::Abstract and DBI.
+L<DBIx::Class::Storage::DBI> - reference storage implementation using
+SQL::Abstract and DBI.
=head1 AUTHORS
Modified: DBIx-Class/0.09/trunk/lib/DBIx/Class.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/DBIx/Class.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/DBIx/Class.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -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.08009';
+$VERSION = '0.08010';
sub MODIFY_CODE_ATTRIBUTES {
my ($class,$code, at attrs) = @_;
@@ -218,6 +218,8 @@
da5id: David Jack Olrik <djo at cpan.org>
+debolaz: Anders Nor Berle <berle at cpan.org>
+
dkubb: Dan Kubb <dan.kubb-cpan at onautopilot.com>
dnm: Justin Wheeler <jwheeler at datademons.com>
@@ -266,6 +268,8 @@
quicksilver: Jules Bean
+rdj: Ryan D Johnson <ryan at innerfence.com>
+
sc_: Just Another Perl Hacker
scotty: Scotty Allen <scotty at scottyallen.com>
@@ -274,6 +278,8 @@
sszabo: Stephan Szabo <sszabo at bigpanda.com>
+teejay : Aaron Trevena <teejay at cpan.org>
+
Todd Lipcon
Tom Hukins
Modified: DBIx-Class/0.09/trunk/lib/SQL/Translator/Parser/DBIx/Class.pm
===================================================================
--- DBIx-Class/0.09/trunk/lib/SQL/Translator/Parser/DBIx/Class.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/lib/SQL/Translator/Parser/DBIx/Class.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -9,12 +9,12 @@
use strict;
use warnings;
-use vars qw($DEBUG $VERSION @EXPORT_OK);
+use vars qw($DEBUG @EXPORT_OK);
$DEBUG = 0 unless defined $DEBUG;
-$VERSION = sprintf "%d.%02d", q$Revision 1.0$ =~ /(\d+)\.(\d+)/;
use Exporter;
use Data::Dumper;
+use Digest::SHA1 qw( sha1_hex );
use SQL::Translator::Utils qw(debug normalize_name);
use base qw(Exporter);
@@ -30,26 +30,25 @@
sub parse {
my ($tr, $data) = @_;
my $args = $tr->parser_args;
- my $dbixschema = $args->{'DBIx::Schema'} || $data;
- $dbixschema ||= $args->{'package'};
+ my $dbicschema = $args->{'DBIx::Class::Schema'} || $args->{"DBIx::Schema"} ||$data;
+ $dbicschema ||= $args->{'package'};
my $limit_sources = $args->{'sources'};
- die 'No DBIx::Schema' unless ($dbixschema);
- if (!ref $dbixschema) {
- eval "use $dbixschema;";
- die "Can't load $dbixschema ($@)" if($@);
+ die 'No DBIx::Class::Schema' unless ($dbicschema);
+ if (!ref $dbicschema) {
+ eval "use $dbicschema;";
+ die "Can't load $dbicschema ($@)" if($@);
}
my $schema = $tr->schema;
my $table_no = 0;
-# print Dumper($dbixschema->registered_classes);
+ $schema->name( ref($dbicschema) . " v" . ($dbicschema->VERSION || '1.x'))
+ unless ($schema->name);
- #foreach my $tableclass ($dbixschema->registered_classes)
-
my %seen_tables;
- my @monikers = $dbixschema->sources;
+ my @monikers = sort $dbicschema->sources;
if ($limit_sources) {
my $ref = ref $limit_sources || '';
die "'sources' parameter must be an array or hash ref" unless $ref eq 'ARRAY' || ref eq 'HASH';
@@ -67,8 +66,9 @@
foreach my $moniker (sort @monikers)
{
- my $source = $dbixschema->source($moniker);
+ my $source = $dbicschema->source($moniker);
+ # Its possible to have multiple DBIC source using same table
next if $seen_tables{$source->name}++;
my $table = $schema->add_table(
@@ -96,14 +96,28 @@
$table->primary_key($source->primary_columns);
my @primary = $source->primary_columns;
+ foreach my $field (@primary) {
+ my $index = $table->add_index(
+ name => $field,
+ fields => [$field],
+ type => 'NORMAL',
+ );
+ }
my %unique_constraints = $source->unique_constraints;
- foreach my $uniq (keys %unique_constraints) {
+ foreach my $uniq (sort keys %unique_constraints) {
if (!$source->compare_relationship_keys($unique_constraints{$uniq}, \@primary)) {
$table->add_constraint(
type => 'unique',
- name => "$uniq",
+ name => _create_unique_symbol($uniq),
fields => $unique_constraints{$uniq}
);
+
+ my $index = $table->add_index(
+ name => _create_unique_symbol(join('_', @{$unique_constraints{$uniq}})),
+ fields => $unique_constraints{$uniq},
+ type => 'NORMAL',
+ );
+
}
}
@@ -139,6 +153,8 @@
$on_update = $otherrelationship->{'attrs'}->{cascade_copy} ? 'CASCADE' : '';
}
+ my $is_deferrable = $rel_info->{attrs}{is_deferrable};
+
# Make sure we dont create the same foreign key constraint twice
my $key_test = join("\x00", @keys);
@@ -148,24 +164,38 @@
# If the sets are different, then we assume it's a foreign key from
# us to another table.
# OR: If is_foreign_key_constraint attr is explicity set (or set to false) on the relation
- if ( ! exists $created_FK_rels{$rel_table}->{$key_test} &&
- ( exists $rel_info->{attrs}{is_foreign_key_constraint} ?
- $rel_info->{attrs}{is_foreign_key_constraint} :
- !$source->compare_relationship_keys(\@keys, \@primary)
- )
- )
- {
- $created_FK_rels{$rel_table}->{$key_test} = 1;
- $table->add_constraint(
- type => 'foreign_key',
- name => "fk_$keys[0]",
- fields => \@keys,
- reference_fields => \@refkeys,
- reference_table => $rel_table,
- on_delete => $on_delete,
- on_update => $on_update
- );
+ next if ( exists $created_FK_rels{$rel_table}->{$key_test} );
+ if ( exists $rel_info->{attrs}{is_foreign_key_constraint}) {
+ # not is this attr set to 0 but definitely if set to 1
+ next unless ($rel_info->{attrs}{is_foreign_key_constraint});
+ } else {
+ # not if might have
+ # next if ($rel_info->{attrs}{accessor} eq 'single' && exists $rel_info->{attrs}{join_type} && uc($rel_info->{attrs}{join_type}) eq 'LEFT');
+ # not sure about this one
+ next if $source->compare_relationship_keys(\@keys, \@primary);
}
+
+ $created_FK_rels{$rel_table}->{$key_test} = 1;
+ if (scalar(@keys)) {
+ $table->add_constraint(
+ type => 'foreign_key',
+ name => _create_unique_symbol($table->name
+ . '_fk_'
+ . join('_', @keys)),
+ fields => \@keys,
+ reference_fields => \@refkeys,
+ reference_table => $rel_table,
+ on_delete => $on_delete,
+ on_update => $on_update,
+ (defined $is_deferrable ? ( deferrable => $is_deferrable ) : ()),
+ );
+
+ my $index = $table->add_index(
+ name => _create_unique_symbol(join('_', @keys)),
+ fields => \@keys,
+ type => 'NORMAL',
+ );
+ }
}
}
@@ -174,12 +204,38 @@
}
}
- if ($dbixschema->can('sqlt_deploy_hook')) {
- $dbixschema->sqlt_deploy_hook($schema);
+ if ($dbicschema->can('sqlt_deploy_hook')) {
+ $dbicschema->sqlt_deploy_hook($schema);
}
return 1;
}
+# TODO - is there a reasonable way to pass configuration?
+# Default of 64 comes from mysql's limit.
+our $MAX_SYMBOL_LENGTH ||= 64;
+our $COLLISION_TAG_LENGTH ||= 8;
+
+# -------------------------------------------------------------------
+# $resolved_name = _create_unique_symbol($desired_name)
+#
+# If desired_name is really long, it will be truncated in a way that
+# has a high probability of leaving it unique.
+# -------------------------------------------------------------------
+sub _create_unique_symbol {
+ my $desired_name = shift;
+ return $desired_name if length $desired_name <= $MAX_SYMBOL_LENGTH;
+
+ my $truncated_name = substr $desired_name, 0, $MAX_SYMBOL_LENGTH - $COLLISION_TAG_LENGTH - 1;
+
+ # Hex isn't the most space-efficient, but it skirts around allowed
+ # charset issues
+ my $digest = sha1_hex($desired_name);
+ my $collision_tag = substr $digest, 0, $COLLISION_TAG_LENGTH;
+
+ return $truncated_name
+ . '_'
+ . $collision_tag;
+}
+
1;
-
Modified: DBIx-Class/0.09/trunk/t/03podcoverage.t
===================================================================
--- DBIx-Class/0.09/trunk/t/03podcoverage.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/03podcoverage.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -32,12 +32,21 @@
]
},
'DBIx::Class::CDBICompat::AccessorMapping' => { skip => 1 },
+ 'DBIx::Class::CDBICompat::AbstractSearch' => {
+ ignore => [qw(search_where)]
+ },
'DBIx::Class::CDBICompat::AttributeAPI' => { skip => 1 },
'DBIx::Class::CDBICompat::AutoUpdate' => { skip => 1 },
+ 'DBIx::Class::CDBICompat::ColumnsAsHash' => {
+ ignore => [qw(inflate_result new update)]
+ },
'DBIx::Class::CDBICompat::ColumnCase' => { skip => 1 },
'DBIx::Class::CDBICompat::ColumnGroups' => { skip => 1 },
'DBIx::Class::CDBICompat::Constraints' => { skip => 1 },
'DBIx::Class::CDBICompat::Constructor' => { skip => 1 },
+ 'DBIx::Class::CDBICompat::Copy' => {
+ ignore => [qw(copy)]
+ },
'DBIx::Class::CDBICompat::DestroyWarning' => { skip => 1 },
'DBIx::Class::CDBICompat::GetSet' => { skip => 1 },
'DBIx::Class::CDBICompat::HasA' => { skip => 1 },
@@ -46,10 +55,13 @@
'DBIx::Class::CDBICompat::LazyLoading' => { skip => 1 },
'DBIx::Class::CDBICompat::LiveObjectIndex' => { skip => 1 },
'DBIx::Class::CDBICompat::MightHave' => { skip => 1 },
- 'DBIx::Class::CDBICompat::ObjIndexStubs' => { skip => 1 },
+ 'DBIx::Class::CDBICompat::NoObjectIndex' => { skip => 1 },
'DBIx::Class::CDBICompat::Pager' => { skip => 1 },
'DBIx::Class::CDBICompat::ReadOnly' => { skip => 1 },
+ 'DBIx::Class::CDBICompat::Relationship' => { skip => 1 },
+ 'DBIx::Class::CDBICompat::Relationships' => { skip => 1 },
'DBIx::Class::CDBICompat::Retrieve' => { skip => 1 },
+ 'DBIx::Class::CDBICompat::SQLTransformer' => { skip => 1 },
'DBIx::Class::CDBICompat::Stringify' => { skip => 1 },
'DBIx::Class::CDBICompat::TempColumns' => { skip => 1 },
'DBIx::Class::CDBICompat::Triggers' => { skip => 1 },
Modified: DBIx-Class/0.09/trunk/t/18inserterror.t
===================================================================
--- DBIx-Class/0.09/trunk/t/18inserterror.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/18inserterror.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -7,19 +7,23 @@
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 3 );
+ : ( tests => 4 );
}
use lib qw(t/lib);
use_ok( 'DBICTest' );
-
use_ok( 'DBICTest::Schema' );
+my $schema = DBICTest->init_schema;
{
my $warnings;
local $SIG{__WARN__} = sub { $warnings .= $_[0] };
- eval { DBICTest::CD->create({ title => 'vacation in antarctica' }) };
+ eval {
+ $schema->resultset('CD')
+ ->create({ title => 'vacation in antarctica' })
+ };
+ like $@, qr/NULL/; # as opposed to some other error
ok( $warnings !~ /uninitialized value/, "No warning from Storage" );
}
Modified: DBIx-Class/0.09/trunk/t/61findnot.t
===================================================================
--- DBIx-Class/0.09/trunk/t/61findnot.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/61findnot.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -2,12 +2,13 @@
use warnings;
use Test::More;
+use Test::Warn;
use lib qw(t/lib);
use DBICTest;
my $schema = DBICTest->init_schema();
-plan tests => 17;
+plan tests => 20;
my $art = $schema->resultset("Artist")->find(4);
ok(!defined($art), 'Find on primary id: artist not found');
@@ -44,3 +45,18 @@
@cd = $cd->single;
cmp_ok(@cd, '==', 1, 'Return something even in array context');
ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
+
+$cd = $schema->resultset("CD")->first;
+my $artist_rs = $schema->resultset("Artist")->search({ artistid => $cd->artist->artistid });
+$art = $artist_rs->find({ name => 'some other name' }, { key => 'primary' });
+ok($art, 'Artist found by key in the resultset');
+
+$artist_rs = $schema->resultset("Artist");
+warning_is {
+ $artist_rs->find({}, { key => 'primary' })
+} "DBIx::Class::ResultSet::find(): Query returned more than one row", "Non-unique find generated a cursor inexhaustion warning";
+
+$artist_rs = $schema->resultset("Artist")->search({}, { prefetch => 'cds' });
+warning_is {
+ $artist_rs->find({}, { key => 'primary' })
+} "DBIx::Class::ResultSet::find(): Query returned more than one row", "Non-unique find generated a cursor inexhaustion warning";
Modified: DBIx-Class/0.09/trunk/t/66relationship.t
===================================================================
--- DBIx-Class/0.09/trunk/t/66relationship.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/66relationship.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -7,7 +7,7 @@
my $schema = DBICTest->init_schema();
-plan tests => 62;
+plan tests => 63;
# has_a test
my $cd = $schema->resultset("CD")->find(4);
@@ -66,6 +66,13 @@
ok( !defined($track->cd), 'set_from_related with undef ok');
+TODO: {
+ local $TODO = 'accessing $object->rel and set_from_related';
+ my $track = $schema->resultset("Track")->new( {} );
+ $track->cd;
+ $track->set_from_related( cd => $cd );
+ ok ($track->cd, 'set_from_related ok after using the accessor' );
+};
# update_from_related, the same as set_from_related, but it calls update afterwards
$track = $schema->resultset("Track")->create( {
Modified: DBIx-Class/0.09/trunk/t/72pg.t
===================================================================
--- DBIx-Class/0.09/trunk/t/72pg.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/72pg.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -27,7 +27,7 @@
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 => 16;
+plan tests => 32;
DBICTest::Schema->load_classes( 'Casecheck' );
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
@@ -46,8 +46,13 @@
my $dbh = $schema->storage->dbh;
$schema->source("Artist")->name("testschema.artist");
+$schema->source("SequenceTest")->name("testschema.sequence_test");
$dbh->do("CREATE SCHEMA testschema;");
$dbh->do("CREATE TABLE testschema.artist (artistid serial PRIMARY KEY, name VARCHAR(100), charfield CHAR(10));");
+$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');
# This is in Core now, but it's here just to test that it doesn't break
@@ -176,10 +181,28 @@
});
}
+SKIP: {
+ skip "Oracle Auto-PK tests are broken", 16;
+
+ # test auto increment using sequences WITHOUT triggers
+ for (1..5) {
+ my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
+ is($st->pkid1, $_, "Oracle Auto-PK without trigger: First primary key");
+ is($st->pkid2, $_ + 9, "Oracle Auto-PK without trigger: Second primary key");
+ is($st->nonpkid, $_ + 19, "Oracle Auto-PK without trigger: Non-primary key");
+ }
+ my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
+ is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually");
+}
+
END {
if($dbh) {
$dbh->do("DROP TABLE testschema.artist;");
$dbh->do("DROP TABLE testschema.casecheck;");
+ $dbh->do("DROP TABLE testschema.sequence_test;");
+ $dbh->do("DROP SEQUENCE pkid1_seq");
+ $dbh->do("DROP SEQUENCE pkid2_seq");
+ $dbh->do("DROP SEQUENCE nonpkid_seq");
$dbh->do("DROP SCHEMA testschema;");
}
}
Modified: DBIx-Class/0.09/trunk/t/73oracle.t
===================================================================
--- DBIx-Class/0.09/trunk/t/73oracle.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/73oracle.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -8,10 +8,11 @@
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test. ' .
- 'Warning: This test drops and creates tables called \'artist\', \'cd\' and \'track\''
+ 'Warning: This test drops and creates tables called \'artist\', \'cd\', \'track\' and \'sequence_test\''.
+ ' as well as following sequences: \'pkid1_seq\', \'pkid2_seq\' and \'nonpkid_seq\''
unless ($dsn && $user && $pass);
-plan tests => 7;
+plan tests => 23;
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
@@ -19,16 +20,25 @@
eval {
$dbh->do("DROP SEQUENCE artist_seq");
+ $dbh->do("DROP SEQUENCE pkid1_seq");
+ $dbh->do("DROP SEQUENCE pkid2_seq");
+ $dbh->do("DROP SEQUENCE nonpkid_seq");
$dbh->do("DROP TABLE artist");
+ $dbh->do("DROP TABLE sequence_test");
$dbh->do("DROP TABLE cd");
$dbh->do("DROP TABLE track");
};
$dbh->do("CREATE SEQUENCE artist_seq START WITH 1 MAXVALUE 999999 MINVALUE 0");
+$dbh->do("CREATE SEQUENCE pkid1_seq START WITH 1 MAXVALUE 999999 MINVALUE 0");
+$dbh->do("CREATE SEQUENCE pkid2_seq START WITH 10 MAXVALUE 999999 MINVALUE 0");
+$dbh->do("CREATE SEQUENCE nonpkid_seq START WITH 20 MAXVALUE 999999 MINVALUE 0");
$dbh->do("CREATE TABLE artist (artistid NUMBER(12), name VARCHAR(255))");
+$dbh->do("CREATE TABLE sequence_test (pkid1 NUMBER(12), pkid2 NUMBER(12), nonpkid NUMBER(12), name VARCHAR(255))");
$dbh->do("CREATE TABLE cd (cdid NUMBER(12), artist NUMBER(12), title VARCHAR(255), year VARCHAR(4))");
$dbh->do("CREATE TABLE track (trackid NUMBER(12), cd NUMBER(12), position NUMBER(12), title VARCHAR(255), last_updated_on DATE)");
$dbh->do("ALTER TABLE artist ADD (CONSTRAINT artist_pk PRIMARY KEY (artistid))");
+$dbh->do("ALTER TABLE sequence_test ADD (CONSTRAINT sequence_test_constraint PRIMARY KEY (pkid1, pkid2))");
$dbh->do(qq{
CREATE OR REPLACE TRIGGER artist_insert_trg
BEFORE INSERT ON artist
@@ -95,11 +105,25 @@
is( scalar @results, 1, "Group by with limit OK" );
}
+# test auto increment using sequences WITHOUT triggers
+for (1..5) {
+ my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
+ is($st->pkid1, $_, "Oracle Auto-PK without trigger: First primary key");
+ is($st->pkid2, $_ + 9, "Oracle Auto-PK without trigger: Second primary key");
+ is($st->nonpkid, $_ + 19, "Oracle Auto-PK without trigger: Non-primary key");
+}
+my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
+is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually");
+
# clean up our mess
END {
if($dbh) {
$dbh->do("DROP SEQUENCE artist_seq");
+ $dbh->do("DROP SEQUENCE pkid1_seq");
+ $dbh->do("DROP SEQUENCE pkid2_seq");
+ $dbh->do("DROP SEQUENCE nonpkid_seq");
$dbh->do("DROP TABLE artist");
+ $dbh->do("DROP TABLE sequence_test");
$dbh->do("DROP TABLE cd");
$dbh->do("DROP TABLE track");
}
Modified: DBIx-Class/0.09/trunk/t/745db2.t
===================================================================
--- DBIx-Class/0.09/trunk/t/745db2.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/745db2.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -18,7 +18,7 @@
my $dbh = $schema->storage->dbh;
-$dbh->do("DROP TABLE artist", { RaiseError => 0, PrintError => 0 });
+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));");
Modified: DBIx-Class/0.09/trunk/t/75limit.t
===================================================================
--- DBIx-Class/0.09/trunk/t/75limit.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/75limit.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -9,8 +9,8 @@
BEGIN {
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 9);
-}
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 10);
+}
# test LIMIT
my $it = $schema->resultset("CD")->search( {},
@@ -51,6 +51,15 @@
);
is( $cds[0]->title, "Spoonful of bees", "software offset ok" );
+
+ at cds = $schema->resultset("CD")->search( {},
+ {
+ offset => 2,
+ order_by => 'year' }
+);
+is( $cds[0]->title, "Spoonful of bees", "offset with no limit" );
+
+
# based on a failing criteria submitted by waswas
# requires SQL::Abstract >= 1.20
$it = $schema->resultset("CD")->search(
Modified: DBIx-Class/0.09/trunk/t/76joins.t
===================================================================
--- DBIx-Class/0.09/trunk/t/76joins.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/76joins.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -16,7 +16,7 @@
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 64 );
+ : ( tests => 16 );
}
# figure out if we've got a version of sqlite that is older than 3.2.6, in
@@ -157,315 +157,3 @@
is($rs->first->name, 'We Are Goth', 'Correct record returned');
-# bug in 0.07000 caused attr (join/prefetch) to be modifed by search
-# so we check the search & attr arrays are not modified
-my $search = { 'artist.name' => 'Caterwauler McCrae' };
-my $attr = { prefetch => [ qw/artist liner_notes/ ],
- order_by => 'me.cdid' };
-my $search_str = Dumper($search);
-my $attr_str = Dumper($attr);
-
-$rs = $schema->resultset("CD")->search($search, $attr);
-
-is(Dumper($search), $search_str, 'Search hash untouched after search()');
-is(Dumper($attr), $attr_str, 'Attribute hash untouched after search()');
-cmp_ok($rs + 0, '==', 3, 'Correct number of records returned');
-
-my $queries = 0;
-$schema->storage->debugcb(sub { $queries++; });
-$schema->storage->debug(1);
-
-my @cd = $rs->all;
-
-is($cd[0]->title, 'Spoonful of bees', 'First record returned ok');
-
-ok(!defined $cd[0]->liner_notes, 'No prefetch for NULL LEFT join');
-
-is($cd[1]->{_relationship_data}{liner_notes}->notes, 'Buy Whiskey!', 'Prefetch for present LEFT JOIN');
-
-is(ref $cd[1]->liner_notes, 'DBICTest::LinerNotes', 'Prefetch returns correct class');
-
-is($cd[2]->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'Prefetch on parent object ok');
-
-is($queries, 1, 'prefetch ran only 1 select statement');
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
-
-# test for partial prefetch via columns attr
-my $cd = $schema->resultset('CD')->find(1,
- {
- columns => [qw/title artist.name/],
- join => { 'artist' => {} }
- }
-);
-ok(eval { $cd->artist->name eq 'Caterwauler McCrae' }, 'single related column prefetched');
-
-# start test for nested prefetch SELECT count
-$queries = 0;
-$schema->storage->debugcb(sub { $queries++ });
-$schema->storage->debug(1);
-
-$rs = $schema->resultset('Tag')->search(
- {},
- {
- prefetch => { cd => 'artist' }
- }
-);
-
-my $tag = $rs->first;
-
-is( $tag->cd->title, 'Spoonful of bees', 'step 1 ok for nested prefetch' );
-
-is( $tag->cd->artist->name, 'Caterwauler McCrae', 'step 2 ok for nested prefetch');
-
-# count the SELECTs
-#$selects++ if /SELECT(?!.*WHERE 1=0.*)/;
-is($queries, 1, 'nested prefetch ran exactly 1 select statement (excluding column_info)');
-
-$queries = 0;
-
-is($tag->search_related('cd')->search_related('artist')->first->name,
- 'Caterwauler McCrae',
- 'chained belongs_to->belongs_to search_related ok');
-
-is($queries, 0, 'chained search_related after belontgs_to->belongs_to prefetch ran no queries');
-
-$queries = 0;
-
-$cd = $schema->resultset('CD')->find(1, { prefetch => 'artist' });
-
-is($cd->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'artist prefetched correctly on find');
-
-is($queries, 1, 'find with prefetch ran exactly 1 select statement (excluding column_info)');
-
-$queries = 0;
-
-$schema->storage->debugcb(sub { $queries++; });
-
-$cd = $schema->resultset('CD')->find(1, { prefetch => { cd_to_producer => 'producer' } });
-
-is($cd->producers->first->name, 'Matt S Trout', 'many_to_many accessor ok');
-
-is($queries, 1, 'many_to_many accessor with nested prefetch ran exactly 1 query');
-
-$queries = 0;
-
-my $producers = $cd->search_related('cd_to_producer')->search_related('producer');
-
-is($producers->first->name, 'Matt S Trout', 'chained many_to_many search_related ok');
-
-is($queries, 0, 'chained search_related after many_to_many prefetch ran no queries');
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
-
-$rs = $schema->resultset('Tag')->search(
- {},
- {
- join => { cd => 'artist' },
- prefetch => { cd => 'artist' }
- }
-);
-
-cmp_ok( $rs->count, '>=', 0, 'nested prefetch does not duplicate joins' );
-
-my ($artist) = $schema->resultset("Artist")->search({ 'cds.year' => 2001 },
- { order_by => 'artistid DESC', join => 'cds' });
-
-is($artist->name, 'Random Boy Band', "Join search by object ok");
-
-my @cds = $schema->resultset("CD")->search({ 'liner_notes.notes' => 'Buy Merch!' },
- { join => 'liner_notes' });
-
-cmp_ok(scalar @cds, '==', 1, "Single CD retrieved via might_have");
-
-is($cds[0]->title, "Generic Manufactured Singles", "Correct CD retrieved");
-
-my @artists = $schema->resultset("Artist")->search({ 'tags.tag' => 'Shiny' },
- { join => { 'cds' => 'tags' } });
-
-cmp_ok( @artists, '==', 2, "two-join search ok" );
-
-$rs = $schema->resultset("CD")->search(
- {},
- { group_by => [qw/ title me.cdid /] }
-);
-
-SKIP: {
- skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
- if $is_broken_sqlite;
- cmp_ok( $rs->count, '==', 5, "count() ok after group_by on main pk" );
-}
-
-cmp_ok( scalar $rs->all, '==', 5, "all() returns same count as count() after group_by on main pk" );
-
-$rs = $schema->resultset("CD")->search(
- {},
- { join => [qw/ artist /], group_by => [qw/ artist.name /] }
-);
-
-SKIP: {
- skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
- if $is_broken_sqlite;
- cmp_ok( $rs->count, '==', 3, "count() ok after group_by on related column" );
-}
-
-$rs = $schema->resultset("Artist")->search(
- {},
- { join => [qw/ cds /], group_by => [qw/ me.name /], having =>{ 'MAX(cds.cdid)'=> \'< 5' } }
-);
-
-cmp_ok( $rs->all, '==', 2, "results ok after group_by on related column with a having" );
-
-$rs = $rs->search( undef, { having =>{ 'count(*)'=> \'> 2' }});
-
-cmp_ok( $rs->all, '==', 1, "count() ok after group_by on related column with a having" );
-
-$rs = $schema->resultset("Artist")->search(
- { 'cds.title' => 'Spoonful of bees',
- 'cds_2.title' => 'Forkful of bees' },
- { join => [ 'cds', 'cds' ] });
-
-SKIP: {
- skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
- if $is_broken_sqlite;
- cmp_ok($rs->count, '==', 1, "single artist returned from multi-join");
-}
-
-is($rs->next->name, 'Caterwauler McCrae', "Correct artist returned");
-
-$cd = $schema->resultset('Artist')->first->create_related('cds',
- {
- title => 'Unproduced Single',
- year => 2007
-});
-
-my $left_join = $schema->resultset('CD')->search(
- { 'me.cdid' => $cd->cdid },
- { prefetch => { cd_to_producer => 'producer' } }
-);
-
-cmp_ok($left_join, '==', 1, 'prefetch with no join record present');
-
-$queries = 0;
-$schema->storage->debugcb(sub { $queries++ });
-$schema->storage->debug(1);
-
-my $tree_like =
- $schema->resultset('TreeLike')->find(4,
- { join => { parent => { parent => 'parent' } },
- prefetch => { parent => { parent => 'parent' } } });
-
-is($tree_like->name, 'quux', 'Bottom of tree ok');
-$tree_like = $tree_like->parent;
-is($tree_like->name, 'baz', 'First level up ok');
-$tree_like = $tree_like->parent;
-is($tree_like->name, 'bar', 'Second level up ok');
-$tree_like = $tree_like->parent;
-is($tree_like->name, 'foo', 'Third level up ok');
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
-
-cmp_ok($queries, '==', 1, 'Only one query run');
-
-$tree_like = $schema->resultset('TreeLike')->search({'me.id' => 1});
-$tree_like = $tree_like->search_related('children')->search_related('children')->search_related('children')->first;
-is($tree_like->name, 'quux', 'Tree search_related ok');
-
-$tree_like = $schema->resultset('TreeLike')->search_related('children',
- { 'children.id' => 2, 'children_2.id' => 3 },
- { prefetch => { children => 'children' } }
- )->first;
-is(eval { $tree_like->children->first->children->first->name }, 'quux',
- 'Tree search_related with prefetch ok');
-
-$tree_like = eval { $schema->resultset('TreeLike')->search(
- { 'children.id' => 2, 'children_2.id' => 5 },
- { join => [qw/children children/] }
- )->search_related('children', { 'children_4.id' => 6 }, { prefetch => 'children' }
- )->first->children->first; };
-is(eval { $tree_like->name }, 'fong', 'Tree with multiple has_many joins ok');
-
-# test that collapsed joins don't get a _2 appended to the alias
-
-my $sql = '';
-$schema->storage->debugcb(sub { $sql = $_[1] });
-$schema->storage->debug(1);
-
-eval {
- my $row = $schema->resultset('Artist')->search_related('cds', undef, {
- join => 'tracks',
- prefetch => 'tracks',
- })->search_related('tracks')->first;
-};
-
-like( $sql, qr/^SELECT tracks_2\.trackid/, "join not collapsed for search_related" );
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
-
-$rs = $schema->resultset('Artist');
-$rs->create({ artistid => 4, name => 'Unknown singer-songwriter' });
-$rs->create({ artistid => 5, name => 'Emo 4ever' });
- at artists = $rs->search(undef, { prefetch => 'cds', order_by => 'artistid' });
-is(scalar @artists, 5, 'has_many prefetch with adjacent empty rows ok');
-
-# -------------
-#
-# Tests for multilevel has_many prefetch
-
-# artist resultsets - with and without prefetch
-my $art_rs = $schema->resultset('Artist');
-my $art_rs_pr = $art_rs->search(
- {},
- {
- join => [ { cds => ['tracks'] } ],
- prefetch => [ { cds => ['tracks'] } ],
- cache => 1 # last test needs this
- }
-);
-
-# This test does the same operation twice - once on a
-# set of items fetched from the db with no prefetch of has_many rels
-# The second prefetches 2 levels of has_many
-# We check things are the same by comparing the name or title
-# we build everything into a hash structure and compare the one
-# from each rs to see what differs
-
-sub make_hash_struc {
- my $rs = shift;
-
- my $struc = {};
- foreach my $art ( $rs->all ) {
- foreach my $cd ( $art->cds ) {
- foreach my $track ( $cd->tracks ) {
- $struc->{ $art->name }{ $cd->title }{ $track->title }++;
- }
- }
- }
- return $struc;
-}
-
-$queries = 0;
-$schema->storage->debugcb(sub { $queries++ });
-$schema->storage->debug(1);
-
-my $prefetch_result = make_hash_struc($art_rs_pr);
-
-is($queries, 1, 'nested prefetch across has_many->has_many ran exactly 1 query');
-
-my $nonpre_result = make_hash_struc($art_rs);
-
-is_deeply( $prefetch_result, $nonpre_result,
- 'Compare 2 level prefetch result to non-prefetch result' );
-
-$queries = 0;
-
-is($art_rs_pr->search_related('cds')->search_related('tracks')->first->title,
- 'Fowlin',
- 'chained has_many->has_many search_related ok'
- );
-
-is($queries, 0, 'chained search_related after has_many->has_many prefetch ran no queries');
Added: DBIx-Class/0.09/trunk/t/77prefetch.t
===================================================================
--- DBIx-Class/0.09/trunk/t/77prefetch.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/77prefetch.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,411 @@
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use Data::Dumper;
+
+my $schema = DBICTest->init_schema();
+
+my $orig_debug = $schema->storage->debug;
+
+use IO::File;
+
+BEGIN {
+ eval "use DBD::SQLite";
+ plan $@
+ ? ( skip_all => 'needs DBD::SQLite for testing' )
+ : ( tests => 56 );
+}
+
+# figure out if we've got a version of sqlite that is older than 3.2.6, in
+# which case COUNT(DISTINCT()) doesn't work
+my $is_broken_sqlite = 0;
+my ($sqlite_major_ver,$sqlite_minor_ver,$sqlite_patch_ver) =
+ split /\./, $schema->storage->dbh->get_info(18);
+if( $schema->storage->dbh->get_info(17) eq 'SQLite' &&
+ ( ($sqlite_major_ver < 3) ||
+ ($sqlite_major_ver == 3 && $sqlite_minor_ver < 2) ||
+ ($sqlite_major_ver == 3 && $sqlite_minor_ver == 2 && $sqlite_patch_ver < 6) ) ) {
+ $is_broken_sqlite = 1;
+}
+
+# bug in 0.07000 caused attr (join/prefetch) to be modifed by search
+# so we check the search & attr arrays are not modified
+my $search = { 'artist.name' => 'Caterwauler McCrae' };
+my $attr = { prefetch => [ qw/artist liner_notes/ ],
+ order_by => 'me.cdid' };
+my $search_str = Dumper($search);
+my $attr_str = Dumper($attr);
+
+my $rs = $schema->resultset("CD")->search($search, $attr);
+
+is(Dumper($search), $search_str, 'Search hash untouched after search()');
+is(Dumper($attr), $attr_str, 'Attribute hash untouched after search()');
+cmp_ok($rs + 0, '==', 3, 'Correct number of records returned');
+
+my $queries = 0;
+$schema->storage->debugcb(sub { $queries++; });
+$schema->storage->debug(1);
+
+my @cd = $rs->all;
+
+is($cd[0]->title, 'Spoonful of bees', 'First record returned ok');
+
+ok(!defined $cd[0]->liner_notes, 'No prefetch for NULL LEFT join');
+
+is($cd[1]->{_relationship_data}{liner_notes}->notes, 'Buy Whiskey!', 'Prefetch for present LEFT JOIN');
+
+is(ref $cd[1]->liner_notes, 'DBICTest::LinerNotes', 'Prefetch returns correct class');
+
+is($cd[2]->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'Prefetch on parent object ok');
+
+is($queries, 1, 'prefetch ran only 1 select statement');
+
+$schema->storage->debug($orig_debug);
+$schema->storage->debugobj->callback(undef);
+
+# test for partial prefetch via columns attr
+my $cd = $schema->resultset('CD')->find(1,
+ {
+ columns => [qw/title artist.name/],
+ join => { 'artist' => {} }
+ }
+);
+ok(eval { $cd->artist->name eq 'Caterwauler McCrae' }, 'single related column prefetched');
+
+# start test for nested prefetch SELECT count
+$queries = 0;
+$schema->storage->debugcb(sub { $queries++ });
+$schema->storage->debug(1);
+
+$rs = $schema->resultset('Tag')->search(
+ {},
+ {
+ prefetch => { cd => 'artist' }
+ }
+);
+
+my $tag = $rs->first;
+
+is( $tag->cd->title, 'Spoonful of bees', 'step 1 ok for nested prefetch' );
+
+is( $tag->cd->artist->name, 'Caterwauler McCrae', 'step 2 ok for nested prefetch');
+
+# count the SELECTs
+#$selects++ if /SELECT(?!.*WHERE 1=0.*)/;
+is($queries, 1, 'nested prefetch ran exactly 1 select statement (excluding column_info)');
+
+$queries = 0;
+
+is($tag->search_related('cd')->search_related('artist')->first->name,
+ 'Caterwauler McCrae',
+ 'chained belongs_to->belongs_to search_related ok');
+
+is($queries, 0, 'chained search_related after belontgs_to->belongs_to prefetch ran no queries');
+
+$queries = 0;
+
+$cd = $schema->resultset('CD')->find(1, { prefetch => 'artist' });
+
+is($cd->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'artist prefetched correctly on find');
+
+is($queries, 1, 'find with prefetch ran exactly 1 select statement (excluding column_info)');
+
+$queries = 0;
+
+$schema->storage->debugcb(sub { $queries++; });
+
+$cd = $schema->resultset('CD')->find(1, { prefetch => { cd_to_producer => 'producer' } });
+
+is($cd->producers->first->name, 'Matt S Trout', 'many_to_many accessor ok');
+
+is($queries, 1, 'many_to_many accessor with nested prefetch ran exactly 1 query');
+
+$queries = 0;
+
+my $producers = $cd->search_related('cd_to_producer')->search_related('producer');
+
+is($producers->first->name, 'Matt S Trout', 'chained many_to_many search_related ok');
+
+is($queries, 0, 'chained search_related after many_to_many prefetch ran no queries');
+
+$schema->storage->debug($orig_debug);
+$schema->storage->debugobj->callback(undef);
+
+$rs = $schema->resultset('Tag')->search(
+ {},
+ {
+ join => { cd => 'artist' },
+ prefetch => { cd => 'artist' }
+ }
+);
+
+cmp_ok( $rs->count, '>=', 0, 'nested prefetch does not duplicate joins' );
+
+my ($artist) = $schema->resultset("Artist")->search({ 'cds.year' => 2001 },
+ { order_by => 'artistid DESC', join => 'cds' });
+
+is($artist->name, 'Random Boy Band', "Join search by object ok");
+
+my @cds = $schema->resultset("CD")->search({ 'liner_notes.notes' => 'Buy Merch!' },
+ { join => 'liner_notes' });
+
+cmp_ok(scalar @cds, '==', 1, "Single CD retrieved via might_have");
+
+is($cds[0]->title, "Generic Manufactured Singles", "Correct CD retrieved");
+
+my @artists = $schema->resultset("Artist")->search({ 'tags.tag' => 'Shiny' },
+ { join => { 'cds' => 'tags' } });
+
+cmp_ok( @artists, '==', 2, "two-join search ok" );
+
+$rs = $schema->resultset("CD")->search(
+ {},
+ { group_by => [qw/ title me.cdid /] }
+);
+
+SKIP: {
+ skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
+ if $is_broken_sqlite;
+ cmp_ok( $rs->count, '==', 5, "count() ok after group_by on main pk" );
+}
+
+cmp_ok( scalar $rs->all, '==', 5, "all() returns same count as count() after group_by on main pk" );
+
+$rs = $schema->resultset("CD")->search(
+ {},
+ { join => [qw/ artist /], group_by => [qw/ artist.name /] }
+);
+
+SKIP: {
+ skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
+ if $is_broken_sqlite;
+ cmp_ok( $rs->count, '==', 3, "count() ok after group_by on related column" );
+}
+
+$rs = $schema->resultset("Artist")->search(
+ {},
+ { join => [qw/ cds /], group_by => [qw/ me.name /], having =>{ 'MAX(cds.cdid)'=> \'< 5' } }
+);
+
+cmp_ok( $rs->all, '==', 2, "results ok after group_by on related column with a having" );
+
+$rs = $rs->search( undef, { having =>{ 'count(*)'=> \'> 2' }});
+
+cmp_ok( $rs->all, '==', 1, "count() ok after group_by on related column with a having" );
+
+$rs = $schema->resultset("Artist")->search(
+ { 'cds.title' => 'Spoonful of bees',
+ 'cds_2.title' => 'Forkful of bees' },
+ { join => [ 'cds', 'cds' ] });
+
+SKIP: {
+ skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
+ if $is_broken_sqlite;
+ cmp_ok($rs->count, '==', 1, "single artist returned from multi-join");
+}
+
+is($rs->next->name, 'Caterwauler McCrae', "Correct artist returned");
+
+$cd = $schema->resultset('Artist')->first->create_related('cds',
+ {
+ title => 'Unproduced Single',
+ year => 2007
+});
+
+my $left_join = $schema->resultset('CD')->search(
+ { 'me.cdid' => $cd->cdid },
+ { prefetch => { cd_to_producer => 'producer' } }
+);
+
+cmp_ok($left_join, '==', 1, 'prefetch with no join record present');
+
+$queries = 0;
+$schema->storage->debugcb(sub { $queries++ });
+$schema->storage->debug(1);
+
+my $tree_like =
+ $schema->resultset('TreeLike')->find(4,
+ { join => { parent => { parent => 'parent' } },
+ prefetch => { parent => { parent => 'parent' } } });
+
+is($tree_like->name, 'quux', 'Bottom of tree ok');
+$tree_like = $tree_like->parent;
+is($tree_like->name, 'baz', 'First level up ok');
+$tree_like = $tree_like->parent;
+is($tree_like->name, 'bar', 'Second level up ok');
+$tree_like = $tree_like->parent;
+is($tree_like->name, 'foo', 'Third level up ok');
+
+$schema->storage->debug($orig_debug);
+$schema->storage->debugobj->callback(undef);
+
+cmp_ok($queries, '==', 1, 'Only one query run');
+
+$tree_like = $schema->resultset('TreeLike')->search({'me.id' => 1});
+$tree_like = $tree_like->search_related('children')->search_related('children')->search_related('children')->first;
+is($tree_like->name, 'quux', 'Tree search_related ok');
+
+$tree_like = $schema->resultset('TreeLike')->search_related('children',
+ { 'children.id' => 2, 'children_2.id' => 3 },
+ { prefetch => { children => 'children' } }
+ )->first;
+is(eval { $tree_like->children->first->children->first->name }, 'quux',
+ 'Tree search_related with prefetch ok');
+
+$tree_like = eval { $schema->resultset('TreeLike')->search(
+ { 'children.id' => 2, 'children_2.id' => 5 },
+ { join => [qw/children children/] }
+ )->search_related('children', { 'children_4.id' => 6 }, { prefetch => 'children' }
+ )->first->children->first; };
+is(eval { $tree_like->name }, 'fong', 'Tree with multiple has_many joins ok');
+
+# test that collapsed joins don't get a _2 appended to the alias
+
+my $sql = '';
+$schema->storage->debugcb(sub { $sql = $_[1] });
+$schema->storage->debug(1);
+
+eval {
+ my $row = $schema->resultset('Artist')->search_related('cds', undef, {
+ join => 'tracks',
+ prefetch => 'tracks',
+ })->search_related('tracks')->first;
+};
+
+like( $sql, qr/^SELECT tracks_2\.trackid/, "join not collapsed for search_related" );
+
+$schema->storage->debug($orig_debug);
+$schema->storage->debugobj->callback(undef);
+
+$rs = $schema->resultset('Artist');
+$rs->create({ artistid => 4, name => 'Unknown singer-songwriter' });
+$rs->create({ artistid => 5, name => 'Emo 4ever' });
+ at artists = $rs->search(undef, { prefetch => 'cds', order_by => 'artistid' });
+is(scalar @artists, 5, 'has_many prefetch with adjacent empty rows ok');
+
+# -------------
+#
+# Tests for multilevel has_many prefetch
+
+# artist resultsets - with and without prefetch
+my $art_rs = $schema->resultset('Artist');
+my $art_rs_pr = $art_rs->search(
+ {},
+ {
+ join => [ { cds => ['tracks'] } ],
+ prefetch => [ { cds => ['tracks'] } ],
+ cache => 1 # last test needs this
+ }
+);
+
+# This test does the same operation twice - once on a
+# set of items fetched from the db with no prefetch of has_many rels
+# The second prefetches 2 levels of has_many
+# We check things are the same by comparing the name or title
+# we build everything into a hash structure and compare the one
+# from each rs to see what differs
+
+sub make_hash_struc {
+ my $rs = shift;
+
+ my $struc = {};
+ foreach my $art ( $rs->all ) {
+ foreach my $cd ( $art->cds ) {
+ foreach my $track ( $cd->tracks ) {
+ $struc->{ $art->name }{ $cd->title }{ $track->title }++;
+ }
+ }
+ }
+ return $struc;
+}
+
+$queries = 0;
+$schema->storage->debugcb(sub { $queries++ });
+$schema->storage->debug(1);
+
+my $prefetch_result = make_hash_struc($art_rs_pr);
+
+is($queries, 1, 'nested prefetch across has_many->has_many ran exactly 1 query');
+
+my $nonpre_result = make_hash_struc($art_rs);
+
+is_deeply( $prefetch_result, $nonpre_result,
+ 'Compare 2 level prefetch result to non-prefetch result' );
+
+$queries = 0;
+
+is($art_rs_pr->search_related('cds')->search_related('tracks')->first->title,
+ 'Fowlin',
+ 'chained has_many->has_many search_related ok'
+ );
+
+is($queries, 0, 'chained search_related after has_many->has_many prefetch ran no queries');
+
+
+TODO: {
+ local $TODO = 'Prefetch of multiple has_many rels at the same level (currently must die to protect the clueless git)';
+ use DBIx::Class::ResultClass::HashRefInflator;
+
+ #( 1 -> M + M )
+ my $cd_rs = $schema->resultset('CD')->search ({ 'me.title' => 'Forkful of bees' });
+ my $pr_cd_rs = $cd_rs->search ({}, {
+ prefetch => [qw/tracks tags/],
+ });
+
+ my $tracks_rs = $cd_rs->first->tracks;
+ my $tracks_count = $tracks_rs->count;
+
+ my ($pr_tracks_rs, $pr_tracks_count);
+
+ $queries = 0;
+ $schema->storage->debugcb(sub { $queries++ });
+ $schema->storage->debug(1);
+ eval {
+ $pr_tracks_rs = $pr_cd_rs->first->tracks;
+ $pr_tracks_count = $pr_tracks_rs->count;
+ };
+ ok(! $@, 'exception on attempt to prefetch several same level has_many\'s (1 -> M + M)');
+ is($queries, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query');
+
+ is($pr_tracks_count, $tracks_count, 'equal count of prefetched relations over several same level has_many\'s (1 -> M + M)');
+
+ for ($pr_tracks_rs, $tracks_rs) {
+ $_->result_class ('DBIx::Class::ResultClass::HashRefInflator');
+ }
+
+ is_deeply ([$pr_tracks_rs->all], [$tracks_rs->all], 'same structure returned with and without prefetch over several same level has_many\'s (1 -> M + M)');
+
+ #( M -> 1 -> M + M )
+ my $note_rs = $schema->resultset('LinerNotes')->search ({ notes => 'Buy Whiskey!' });
+ my $pr_note_rs = $note_rs->search ({}, {
+ prefetch => {
+ cd => [qw/tags tracks/]
+ },
+ });
+
+ my $tags_rs = $note_rs->first->cd->tags;
+ my $tags_count = $tags_rs->count;
+
+ my ($pr_tags_rs, $pr_tags_count);
+
+ $queries = 0;
+ $schema->storage->debugcb(sub { $queries++ });
+ $schema->storage->debug(1);
+ eval {
+ $pr_tags_rs = $pr_note_rs->first->cd->tags;
+ $pr_tags_count = $pr_tags_rs->count;
+ };
+ ok(! $@, 'exception on attempt to prefetch several same level has_many\'s (M -> 1 -> M + M)');
+ is($queries, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query');
+
+ is($pr_tags_count, $tags_count, 'equal count of prefetched relations over several same level has_many\'s (M -> 1 -> M + M)');
+
+ for ($pr_tags_rs, $tags_rs) {
+ $_->result_class ('DBIx::Class::ResultClass::HashRefInflator');
+ }
+
+ is_deeply ([$pr_tags_rs->all], [$tags_rs->all], 'same structure returned with and without prefetch over several same level has_many\'s (M -> 1 -> M + M)');
+};
Modified: DBIx-Class/0.09/trunk/t/81transactions.t
===================================================================
--- DBIx-Class/0.09/trunk/t/81transactions.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/81transactions.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -2,12 +2,13 @@
use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
my $schema = DBICTest->init_schema();
-plan tests => 54;
+plan tests => 67;
my $code = sub {
my ($artist, @cd_titles) = @_;
@@ -236,3 +237,99 @@
my $err = $@;
ok(($err eq ''), 'Pre-connection nested transactions.');
}
+
+# Test txn_rollback with nested
+{
+ local $TODO = "Work out how this should work";
+ my $local_schema = DBICTest->init_schema();
+
+ my $artist_rs = $local_schema->resultset('Artist');
+ throws_ok {
+
+ $local_schema->txn_begin;
+ $artist_rs->create({ name => 'Test artist rollback 1'});
+ $local_schema->txn_begin;
+ is($local_schema->storage->transaction_depth, 2, "Correct transaction depth");
+ $artist_rs->create({ name => 'Test artist rollback 2'});
+ $local_schema->txn_rollback;
+ } qr/Not sure what this should be.... something tho/, "Rolled back okay";
+ is($local_schema->storage->transaction_depth, 0, "Correct transaction depth");
+
+ ok(!$artist_rs->find({ name => 'Test artist rollback 1'}), "Test Artist not created")
+ || $artist_rs->find({ name => 'Test artist rollback 1'})->delete;
+}
+
+# Test txn_scope_guard
+{
+ local $TODO = "Work out how this should work";
+ my $schema = DBICTest->init_schema();
+
+ is($schema->storage->transaction_depth, 0, "Correct transaction depth");
+ my $artist_rs = $schema->resultset('Artist');
+ throws_ok {
+ my $guard = $schema->txn_scope_guard;
+
+
+ $artist_rs->create({
+ name => 'Death Cab for Cutie',
+ made_up_column => 1,
+ });
+
+ $guard->commit;
+ } qr/No such column made_up_column.*?line 16/, "Error propogated okay";
+
+ ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+
+ my $inner_exception;
+ eval {
+ outer($schema, 1);
+ };
+ is($@, $inner_exception, "Nested exceptions propogated");
+
+ ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+
+
+ eval {
+ # The 0 arg says done die, just let the scope guard go out of scope
+ # forcing a txn_rollback to happen
+ outer($schema, 0);
+ };
+ is($@, "Not sure what we want here, but something", "Rollback okay");
+
+ ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+
+ sub outer {
+ my ($schema) = @_;
+
+ my $guard = $schema->txn_scope_guard;
+ $schema->resultset('Artist')->create({
+ name => 'Death Cab for Cutie',
+ });
+ inner(@_);
+ $guard->commit;
+ }
+
+ sub inner {
+ my ($schema, $fatal) = @_;
+ my $guard = $schema->txn_scope_guard;
+
+ my $artist = $artist_rs->find({ name => 'Death Cab for Cutie' });
+
+ is($schema->storage->transaction_depth, 2, "Correct transaction depth");
+ undef $@;
+ eval {
+ $artist->cds->create({
+ title => 'Plans',
+ year => 2005,
+ $fatal ? ( foo => 'bar' ) : ()
+ });
+ };
+ if ($@) {
+ # Record what got thrown so we can test it propgates out properly.
+ $inner_exception = $@;
+ die $@;
+ }
+
+ # See what happens if we dont $guard->commit;
+ }
+}
Modified: DBIx-Class/0.09/trunk/t/84serialize.t
===================================================================
--- DBIx-Class/0.09/trunk/t/84serialize.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/84serialize.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -4,29 +4,57 @@
use Test::More;
use lib qw(t/lib);
use DBICTest;
-use Storable;
+use Storable qw(dclone freeze thaw);
my $schema = DBICTest->init_schema();
-plan tests => 6;
+my %stores = (
+ dclone_method => sub { return $schema->dclone($_[0]) },
+ dclone_func => sub { return dclone($_[0]) },
+ "freeze/thaw_method" => sub {
+ my $ice = $schema->freeze($_[0]);
+ return $schema->thaw($ice);
+ },
+ "freeze/thaw_func" => sub {
+ thaw(freeze($_[0]));
+ },
+);
-my $artist = $schema->resultset('Artist')->find(1);
+plan tests => (7 * keys %stores);
-{
- my $copy = $schema->dclone($artist);
- is_deeply($copy, $artist, "dclone row object works");
- eval { $copy->discard_changes };
- ok( !$@, "discard_changes okay" );
- is($copy->id, $artist->id, "IDs still match ");
-}
+for my $name (keys %stores) {
+ my $store = $stores{$name};
-{
- my $ice = $schema->freeze($artist);
- my $copy = $schema->thaw($ice);
- is_deeply($copy, $artist, 'dclone row object works');
+ my $artist = $schema->resultset('Artist')->find(1);
+
+ # Test that the procedural versions will work if there's a registered
+ # schema as with CDBICompat objects and that the methods work
+ # without.
+ if( $name =~ /func/ ) {
+ $artist->result_source_instance->schema($schema);
+ DBICTest::CD->result_source_instance->schema($schema);
+ }
+ else {
+ $artist->result_source_instance->schema(undef);
+ DBICTest::CD->result_source_instance->schema(undef);
+ }
- eval { $copy->discard_changes };
- ok( !$@, "discard_changes okay" );
- is($copy->id, $artist->id, "IDs still okay");
+ my $copy = eval { $store->($artist) };
+ is_deeply($copy, $artist, "serialize row object works: $name");
+
+ # Test that an object with a related_resultset can be serialized.
+ my @cds = $artist->related_resultset("cds");
+
+ ok $artist->{related_resultsets}, 'has key: related_resultsets';
+
+ $copy = eval { $store->($artist) };
+ for my $key (keys %$artist) {
+ next if $key eq 'related_resultsets';
+ next if $key eq '_inflated_column';
+ is_deeply($copy->{$key}, $artist->{$key},
+ qq[serialize with related_resultset "$key"]);
+ }
+
+ ok eval { $copy->discard_changes; 1 } or diag $@;
+ is($copy->id, $artist->id, "IDs still match ");
}
-
Modified: DBIx-Class/0.09/trunk/t/86sqlt.t
===================================================================
--- DBIx-Class/0.09/trunk/t/86sqlt.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/86sqlt.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -10,7 +10,7 @@
my $schema = DBICTest->init_schema;
-plan tests => 60;
+plan tests => 160;
my $translator = SQL::Translator->new(
parser_args => {
@@ -40,15 +40,17 @@
twokeys => [
{
'display' => 'twokeys->cd',
+ 'name' => 'twokeys_fk_cd', 'index_name' => 'cd',
'selftable' => 'twokeys', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 0,
},
{
'display' => 'twokeys->artist',
+ 'name' => 'twokeys_fk_artist', 'index_name' => 'artist',
'selftable' => 'twokeys', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
@@ -56,16 +58,18 @@
fourkeys_to_twokeys => [
{
'display' => 'fourkeys_to_twokeys->twokeys',
+ 'name' => 'fourkeys_to_twokeys_fk_t_cd_t_artist', 'index_name' => 't_cd_t_artist',
'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'twokeys',
'selfcols' => ['t_artist', 't_cd'], 'foreigncols' => ['artist', 'cd'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
{
- 'display' => 'fourkeys_to_twokeys->fourkeys',
+ 'display' => 'fourkeys_to_twokeys->fourkeys', 'index_name' => 'f_foo_f_goodbye_f_hello_f_bar',
+ 'name' => 'fourkeys_to_twokeys_fk_f_foo_f_goodbye_f_hello_f_bar',
'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'fourkeys',
'selfcols' => [qw(f_foo f_bar f_hello f_goodbye)],
'foreigncols' => [qw(foo bar hello goodbye)],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
@@ -73,15 +77,17 @@
cd_to_producer => [
{
'display' => 'cd_to_producer->cd',
+ 'name' => 'cd_to_producer_fk_cd', 'index_name' => 'cd',
'selftable' => 'cd_to_producer', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
{
'display' => 'cd_to_producer->producer',
+ 'name' => 'cd_to_producer_fk_producer', 'index_name' => 'producer',
'selftable' => 'cd_to_producer', 'foreigntable' => 'producer',
'selfcols' => ['producer'], 'foreigncols' => ['producerid'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 1,
},
],
@@ -89,15 +95,17 @@
self_ref_alias => [
{
'display' => 'self_ref_alias->self_ref for self_ref',
+ 'name' => 'self_ref_alias_fk_self_ref', 'index_name' => 'self_ref',
'selftable' => 'self_ref_alias', 'foreigntable' => 'self_ref',
'selfcols' => ['self_ref'], 'foreigncols' => ['id'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
{
'display' => 'self_ref_alias->self_ref for alias',
+ 'name' => 'self_ref_alias_fk_alias', 'index_name' => 'alias',
'selftable' => 'self_ref_alias', 'foreigntable' => 'self_ref',
'selfcols' => ['alias'], 'foreigncols' => ['id'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 1,
},
],
@@ -105,9 +113,10 @@
cd => [
{
'display' => 'cd->artist',
+ 'name' => 'cd_fk_artist', 'index_name' => 'artist',
'selftable' => 'cd', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
@@ -115,15 +124,17 @@
artist_undirected_map => [
{
'display' => 'artist_undirected_map->artist for id1',
+ 'name' => 'artist_undirected_map_fk_id1', 'index_name' => 'id1',
'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist',
'selfcols' => ['id1'], 'foreigncols' => ['artistid'],
- on_delete => 'CASCADE', on_update => '',
+ on_delete => 'CASCADE', on_update => '', deferrable => 1,
},
{
'display' => 'artist_undirected_map->artist for id2',
+ 'name' => 'artist_undirected_map_fk_id2', 'index_name' => 'id2',
'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist',
'selfcols' => ['id2'], 'foreigncols' => ['artistid'],
- on_delete => 'CASCADE', on_update => '',
+ on_delete => 'CASCADE', on_update => '', deferrable => 1,
},
],
@@ -131,9 +142,10 @@
track => [
{
'display' => 'track->cd',
+ 'name' => 'track_fk_cd', 'index_name' => 'cd',
'selftable' => 'track', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
@@ -141,9 +153,10 @@
treelike => [
{
'display' => 'treelike->treelike for parent',
+ 'name' => 'treelike_fk_parent', 'index_name' => 'parent',
'selftable' => 'treelike', 'foreigntable' => 'treelike',
'selfcols' => ['parent'], 'foreigncols' => ['id'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
@@ -151,9 +164,10 @@
twokeytreelike => [
{
'display' => 'twokeytreelike->twokeytreelike for parent1,parent2',
+ 'name' => 'twokeytreelike_fk_parent1_parent2', 'index_name' => 'parent1_parent2',
'selftable' => 'twokeytreelike', 'foreigntable' => 'twokeytreelike',
'selfcols' => ['parent1', 'parent2'], 'foreigncols' => ['id1','id2'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 1,
},
],
@@ -161,9 +175,10 @@
tags => [
{
'display' => 'tags->cd',
+ 'name' => 'tags_fk_cd', 'index_name' => 'cd',
'selftable' => 'tags', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
@@ -171,21 +186,52 @@
bookmark => [
{
'display' => 'bookmark->link',
+ 'name' => 'bookmark_fk_link', 'index_name' => 'link',
'selftable' => 'bookmark', 'foreigntable' => 'link',
'selfcols' => ['link'], 'foreigncols' => ['id'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 1,
},
],
# ForceForeign
forceforeign => [
{
'display' => 'forceforeign->artist',
+ 'name' => 'forceforeign_fk_artist', 'index_name' => 'artist',
'selftable' => 'forceforeign', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artist_id'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 1,
},
],
+ # LongColumns
+ long_columns => [
+ {
+ 'display' => 'long_columns->owner',
+ 'name' => 'long_columns_fk_64_character_column_aaaaaaaaaaaaaaaaaaa_1ca973e2',
+ 'index_name' => '64_character_column_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa',
+ 'selftable' => 'long_columns', 'foreigntable' => 'long_columns',
+ 'selfcols' => ['64_character_column_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa'],
+ 'foreigncols' => ['lcid'],
+ on_delete => '', on_update => '', deferrable => 1,
+ },
+ {
+ 'display' => 'long_columns->owner2',
+ 'name' => 'long_columns_fk_32_character_column_aaaaaaaaaaaa_32_cha_6060a8f3',
+ 'index_name' => '32_character_column_aaaaaaaaaaaa_32_character_column_bb_30f7a7fe',
+ 'selftable' => 'long_columns', 'foreigntable' => 'long_columns',
+ 'selfcols' => ['32_character_column_bbbbbbbbbbbb', '32_character_column_aaaaaaaaaaaa'],
+ 'foreigncols' => ['32_character_column_aaaaaaaaaaaa', '32_character_column_bbbbbbbbbbbb'],
+ on_delete => '', on_update => '', deferrable => 1,
+ },
+ {
+ 'display' => 'long_columns->owner3',
+ 'name' => 'long_columns_fk_16_character_col',
+ 'index_name' => '16_character_col',
+ 'selftable' => 'long_columns', 'foreigntable' => 'long_columns',
+ 'selfcols' => ['16_character_col'], 'foreigncols' => ['8_char_c'],
+ on_delete => '', on_update => '', deferrable => 1,
+ },
+ ],
);
my %unique_constraints = (
@@ -193,6 +239,7 @@
cd => [
{
'display' => 'cd artist and title unique',
+ 'name' => 'cd_artist_title',
'table' => 'cd', 'cols' => ['artist', 'title'],
},
],
@@ -201,14 +248,39 @@
producer => [
{
'display' => 'producer name unique',
+ 'name' => 'prod_name', # explicit name
'table' => 'producer', 'cols' => ['name'],
},
],
+ long_columns => [
+ {
+ 'display' => 'long but not quite truncated unique',
+ 'name' => 'long_columns_16_character_col_32_character_column_aaaaaaaaaaaa',
+ 'table' => 'long_columns', 'cols' => [qw( 32_character_column_aaaaaaaaaaaa 16_character_col )],
+ },
+ {
+ 'display' => 'multi column truncated unique',
+ 'name' => 'long_columns_8_char_c_16_character_col_32_character_col_ee4a438c',
+ 'table' => 'long_columns', 'cols' => [qw( 32_character_column_aaaaaaaaaaaa 16_character_col 8_char_c )],
+ },
+ {
+ 'display' => 'different multi column truncated unique with same base',
+ 'name' => 'long_columns_8_char_c_16_character_col_32_character_col_c5dbc7a7',
+ 'table' => 'long_columns', 'cols' => [qw( 32_character_column_bbbbbbbbbbbb 16_character_col 8_char_c )],
+ },
+ {
+ 'display' => 'single column truncated unique',
+ 'name' => 'long_columns_64_character_column_aaaaaaaaaaaaaaaaaaaaaa_095dc664',
+ 'table' => 'long_columns', 'cols' => ['64_character_column_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa'],
+ },
+ ],
+
# TwoKeyTreeLike
twokeytreelike => [
{
'display' => 'twokeytreelike name unique',
+ 'name' => 'tktlnameunique', # explicit name
'table' => 'twokeytreelike', 'cols' => ['name'],
},
],
@@ -218,6 +290,7 @@
# employee => [
# {
# 'display' => 'employee position and group_id unique',
+# 'name' => 'position_group',
# 'table' => 'employee', cols => ['position', 'group_id'],
# },
# ],
@@ -264,6 +337,7 @@
'UNIQUE', $expected_constraint->{table}, $expected_constraint->{cols},
);
ok( defined($constraint), "UNIQUE constraint matching `$desc' found" );
+ test_unique($expected_constraint, $constraint);
}
}
@@ -355,8 +429,23 @@
sub test_fk {
my ($expected, $got) = @_;
my $desc = $expected->{display};
+ is( $got->name, $expected->{name},
+ "name parameter correct for `$desc'" );
is( $got->on_delete, $expected->{on_delete},
"on_delete parameter correct for `$desc'" );
is( $got->on_update, $expected->{on_update},
"on_update parameter correct for `$desc'" );
+ is( $got->deferrable, $expected->{deferrable},
+ "is_deferrable parameter correct for `$desc'" );
+
+ my $index = get_index( $got->table, { fields => $expected->{selfcols} } );
+ ok( defined $index, "index exists for `$desc'" );
+ is( $index->name, $expected->{index_name}, "index has correct name for `$desc'" );
}
+
+sub test_unique {
+ my ($expected, $got) = @_;
+ my $desc = $expected->{display};
+ is( $got->name, $expected->{name},
+ "name parameter correct for `$desc'" );
+}
Modified: DBIx-Class/0.09/trunk/t/90ensure_class_loaded.t
===================================================================
--- DBIx-Class/0.09/trunk/t/90ensure_class_loaded.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/90ensure_class_loaded.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -13,7 +13,7 @@
my $schema = DBICTest->init_schema();
-plan tests => 19;
+plan tests => 20;
# Test ensure_class_found
ok( $schema->ensure_class_found('DBIx::Class::Schema'),
@@ -72,4 +72,16 @@
'load_optional_class(DBICTest::SyntaxErrorComponent2) threw ok' );
}
+
+eval {
+ package Fake::ResultSet;
+
+ use base 'DBIx::Class::ResultSet';
+
+ __PACKAGE__->load_components('+DBICTest::SyntaxErrorComponent3');
+};
+
+# Make sure the errors in components of resultset classes are reported right.
+like($@, qr!\Qsyntax error at t/lib/DBICTest/SyntaxErrorComponent3.pm!, "Errors from RS components reported right");
+
1;
Added: DBIx-Class/0.09/trunk/t/93storage_replication.t
===================================================================
--- DBIx-Class/0.09/trunk/t/93storage_replication.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/93storage_replication.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,265 @@
+use strict;
+use warnings;
+use lib qw(t/lib);
+use Test::More;
+
+BEGIN {
+ eval "use DBD::Multi";
+ plan $@
+ ? ( skip_all => 'needs DBD::Multi for testing' )
+ : ( tests => 18 );
+}
+
+## ----------------------------------------------------------------------------
+## Build a class to hold all our required testing data and methods.
+## ----------------------------------------------------------------------------
+
+TESTSCHEMACLASS: {
+
+ package DBIx::Class::DBI::Replication::TestReplication;
+
+ use DBI;
+ use DBICTest;
+ use File::Copy;
+
+ ## Create a constructor
+
+ sub new {
+ my $class = shift @_;
+ my %params = @_;
+
+ my $self = bless {
+ db_paths => $params{db_paths},
+ dsns => $class->init_dsns(%params),
+ schema=>$class->init_schema,
+ }, $class;
+
+ $self->connect;
+ return $self;
+ }
+
+ ## get the DSNs. We build this up from the list of file paths
+
+ sub init_dsns {
+ my $class = shift @_;
+ my %params = @_;
+ my $db_paths = $params{db_paths};
+
+ my @dsn = map {
+ "dbi:SQLite:${_}";
+ } @$db_paths;
+
+ return \@dsn;
+ }
+
+ ## get the Schema and set the replication storage type
+
+ sub init_schema {
+ my $class = shift @_;
+ my $schema = DBICTest->init_schema();
+ $schema->storage_type( '::DBI::Replication' );
+
+ return $schema;
+ }
+
+ ## connect the Schema
+
+ sub connect {
+ my $self = shift @_;
+ my ($master, @slaves) = @{$self->{dsns}};
+ my @connections = ([$master, '','', {AutoCommit=>1, PrintError=>0}]);
+ my @slavesob;
+
+ foreach my $slave (@slaves)
+ {
+ my $dbh = shift @{$self->{slaves}}
+ || DBI->connect($slave,"","",{PrintError=>0, PrintWarn=>0});
+
+ push @connections,
+ [$dbh, '','',{priority=>10}];
+
+ push @slavesob,
+ $dbh;
+ }
+
+ ## Keep track of the created slave databases
+ $self->{slaves} = \@slavesob;
+
+ $self
+ ->{schema}
+ ->connect([
+ @connections,
+ {limit_dialect => 'LimitXY'}
+ ]);
+ }
+
+ ## replication
+
+ sub replicate {
+ my $self = shift @_;
+ my ($master, @slaves) = @{$self->{db_paths}};
+
+ foreach my $slave (@slaves) {
+ copy($master, $slave);
+ }
+ }
+
+ ## Cleanup afer ourselves.
+
+ sub cleanup {
+ my $self = shift @_;
+ my ($master, @slaves) = @{$self->{db_paths}};
+
+ foreach my $slave (@slaves) {
+ unlink $slave;
+ }
+ }
+
+ ## Force a reconnection
+
+ sub reconnect {
+ my $self = shift @_;
+ my $schema = $self->connect;
+ $self->{schema} = $schema;
+ return $schema;
+ }
+}
+
+## ----------------------------------------------------------------------------
+## Create an object and run some tests
+## ----------------------------------------------------------------------------
+
+my %params = (
+ db_paths => [
+ "t/var/DBIxClass.db",
+ "t/var/DBIxClass_slave1.db",
+ "t/var/DBIxClass_slave2.db",
+ ],
+);
+
+ok my $replicate = DBIx::Class::DBI::Replication::TestReplication->new(%params)
+ => 'Created a replication object';
+
+isa_ok $replicate->{schema}
+ => 'DBIx::Class::Schema';
+
+## Add some info to the database
+
+$replicate
+ ->{schema}
+ ->populate('Artist', [
+ [ qw/artistid name/ ],
+ [ 4, "Ozric Tentacles"],
+ ]);
+
+## Make sure all the slaves have the table definitions
+
+$replicate->replicate;
+
+## Make sure we can read the data.
+
+ok my $artist1 = $replicate->{schema}->resultset('Artist')->find(4)
+ => 'Created Result';
+
+isa_ok $artist1
+ => 'DBICTest::Artist';
+
+is $artist1->name, 'Ozric Tentacles'
+ => 'Found expected name for first result';
+
+## Add some new rows that only the master will have This is because
+## we overload any type of write operation so that is must hit the master
+## database.
+
+use Fcntl qw (:flock);
+
+my $master_path = $replicate->{db_paths}->[0];
+open LOCKFILE, ">>$master_path"
+ or die "Cannot open $master_path";
+flock(LOCKFILE, LOCK_EX);
+
+$replicate
+ ->{schema}
+ ->populate('Artist', [
+ [ qw/artistid name/ ],
+ [ 5, "Doom's Children"],
+ [ 6, "Dead On Arrival"],
+ [ 7, "Watergate"],
+ ]);
+
+## Reconnect the database
+$replicate->reconnect;
+
+## Alright, the database 'cluster' is not in a consistent state. When we do
+## a read now we expect bad news
+
+is $replicate->{schema}->resultset('Artist')->find(5), undef
+ => 'read after disconnect fails because it uses slave 1 which we have neglected to "replicate" yet';
+
+## Make sure all the slaves have the table definitions
+$replicate->replicate;
+
+## Should find some data now
+
+ok my $artist2 = $replicate->{schema}->resultset('Artist')->find(5)
+ => 'Sync succeed';
+
+isa_ok $artist2
+ => 'DBICTest::Artist';
+
+is $artist2->name, "Doom's Children"
+ => 'Found expected name for first result';
+
+## What happens when we delete one of the slaves?
+
+ok my $slave1 = @{$replicate->{slaves}}[0]
+ => 'Got Slave1';
+
+ok $slave1->disconnect
+ => 'disconnected slave1';
+
+$replicate->reconnect;
+
+ok my $artist3 = $replicate->{schema}->resultset('Artist')->find(6)
+ => 'Still finding stuff.';
+
+isa_ok $artist3
+ => 'DBICTest::Artist';
+
+is $artist3->name, "Dead On Arrival"
+ => 'Found expected name for first result';
+
+## Let's delete all the slaves
+
+ok my $slave2 = @{$replicate->{slaves}}[1]
+ => 'Got Slave2';
+
+ok $slave2->disconnect
+ => 'Disconnected slave2';
+
+$replicate->reconnect;
+
+## We expect an error now, since all the slaves are dead
+
+eval {
+ $replicate->{schema}->resultset('Artist')->find(4)->name;
+};
+
+ok $@ => 'Got error when trying to find artistid 4';
+
+## This should also be an error
+
+eval {
+ my $artist4 = $replicate->{schema}->resultset('Artist')->find(7);
+};
+
+ok $@ => 'Got read errors after everything failed';
+
+## Delete the old database files
+$replicate->cleanup;
+
+
+
+
+
+
Modified: DBIx-Class/0.09/trunk/t/94versioning.t
===================================================================
--- DBIx-Class/0.09/trunk/t/94versioning.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/94versioning.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -3,71 +3,83 @@
use warnings;
use Test::More;
use File::Spec;
+use File::Copy;
+#warn "$dsn $user $pass";
+my ($dsn, $user, $pass);
+
BEGIN {
- eval "use DBD::SQLite; use SQL::Translator 0.08;";
+ ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
+
+ plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'
+ unless ($dsn);
+
+
+ eval "use DBD::mysql; use SQL::Translator 0.08;";
plan $@
- ? ( skip_all => 'needs DBD::SQLite and SQL::Translator 0.08 for testing' )
- : ( tests => 6 );
+ ? ( skip_all => 'needs DBD::mysql and SQL::Translator 0.08 for testing' )
+ : ( tests => 13 );
}
+my $version_table_name = 'dbix_class_schema_versions';
+my $old_table_name = 'SchemaVersions';
+
use lib qw(t/lib);
-
use_ok('DBICVersionOrig');
-my $db_file = "t/var/versioning.db";
-unlink($db_file) if -e $db_file;
-unlink($db_file . "-journal") if -e $db_file . "-journal";
-mkdir("t/var") unless -d "t/var";
-unlink('t/var/DBICVersion-Schema-1.0-SQLite.sql');
+my $schema_orig = DBICVersion::Schema->connect($dsn, $user, $pass);
+eval { $schema_orig->storage->dbh->do('drop table ' . $version_table_name) };
+eval { $schema_orig->storage->dbh->do('drop table ' . $old_table_name) };
-my $schema_orig = DBICVersion::Schema->connect(
- "dbi:SQLite:$db_file",
- undef,
- undef,
- { AutoCommit => 1 },
-);
-# $schema->storage->ensure_connected();
+is($schema_orig->ddl_filename('MySQL', 't/var', '1.0'), File::Spec->catfile('t', 'var', 'DBICVersion-Schema-1.0-MySQL.sql'), 'Filename creation working');
+unlink('t/var/DBICVersion-Schema-1.0-MySQL.sql') if (-e 't/var/DBICVersion-Schema-1.0-MySQL.sql');
+$schema_orig->create_ddl_dir('MySQL', undef, 't/var');
-is($schema_orig->ddl_filename('SQLite', 't/var', '1.0'), File::Spec->catfile('t', 'var', 'DBICVersion-Schema-1.0-SQLite.sql'), 'Filename creation working');
-$schema_orig->create_ddl_dir('SQLite', undef, 't/var');
+ok(-f 't/var/DBICVersion-Schema-1.0-MySQL.sql', 'Created DDL file');
+$schema_orig->deploy({ add_drop_table => 1 });
+$schema_orig->upgrade();
-ok(-f 't/var/DBICVersion-Schema-1.0-SQLite.sql', 'Created DDL file');
-## do this here or let Versioned.pm do it?
-# $schema->deploy();
-
-my $tvrs = $schema_orig->resultset('Table');
+my $tvrs = $schema_orig->{vschema}->resultset('Table');
is($schema_orig->_source_exists($tvrs), 1, 'Created schema from DDL file');
eval "use DBICVersionNew";
-my $schema_new = DBICVersion::Schema->connect(
- "dbi:SQLite:$db_file",
- undef,
- undef,
- { AutoCommit => 1 },
-);
+{
+ unlink('t/var/DBICVersion-Schema-2.0-MySQL.sql');
+ unlink('t/var/DBICVersion-Schema-1.0-2.0-MySQL.sql');
-unlink('t/var/DBICVersion-Schema-2.0-SQLite.sql');
-unlink('t/var/DBICVersion-Schema-1.0-2.0-SQLite.sql');
-$schema_new->create_ddl_dir('SQLite', undef, 't/var', '1.0');
-ok(-f 't/var/DBICVersion-Schema-1.0-2.0-SQLite.sql', 'Created DDL upgrade file');
+ my $schema_upgrade = DBICVersion::Schema->connect($dsn, $user, $pass);
+ is($schema_upgrade->get_db_version(), '1.0', 'get_db_version ok');
+ is($schema_upgrade->schema_version, '2.0', 'schema version ok');
+ $schema_upgrade->create_ddl_dir('MySQL', '2.0', 't/var', '1.0');
+ ok(-f 't/var/DBICVersion-Schema-1.0-2.0-MySQL.sql', 'Created DDL file');
+ $schema_upgrade->upgrade();
+ is($schema_upgrade->get_db_version(), '2.0', 'db version number upgraded');
-## create new to pick up filedata for upgrade files we just made (on_connect)
-my $schema_upgrade = DBICVersion::Schema->connect(
- "dbi:SQLite:$db_file",
- undef,
- undef,
- { AutoCommit => 1 },
-);
+ eval {
+ $schema_upgrade->storage->dbh->do('select NewVersionName from TestVersion');
+ };
+ is($@, '', 'new column created');
+}
-## do this here or let Versioned.pm do it?
-$schema_upgrade->upgrade();
-$tvrs = $schema_upgrade->resultset('Table');
-is($schema_upgrade->_source_exists($tvrs), 1, 'Upgraded schema from DDL file');
+{
+ my $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
+ eval {
+ $schema_version->storage->dbh->do('select * from ' . $version_table_name);
+ };
+ is($@, '', 'version table exists');
-unlink($db_file) if -e $db_file;
-unlink($db_file . "-journal") if -e $db_file . "-journal";
-unlink('t/var/DBICVersion-Schema-1.0-SQLite.sql');
-unlink('t/var/DBICVersion-Schema-2.0-SQLite.sql');
-unlink('t/var/DBICVersion-Schema-1.0-2.0-SQLite.sql');
-unlink(<t/var/backup/*>);
+ eval {
+ $schema_version->storage->dbh->do("DROP TABLE IF EXISTS $old_table_name");
+ $schema_version->storage->dbh->do("RENAME TABLE $version_table_name TO $old_table_name");
+ };
+ is($@, '', 'versions table renamed to old style table');
+
+ $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
+ is($schema_version->get_db_version, '2.0', 'transition from old table name to new okay');
+
+ eval {
+ $schema_version->storage->dbh->do('select * from ' . $old_table_name);
+ };
+ ok($@, 'old version table gone');
+
+}
Modified: DBIx-Class/0.09/trunk/t/96file_column.t
===================================================================
--- DBIx-Class/0.09/trunk/t/96file_column.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/96file_column.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -5,11 +5,63 @@
use lib qw(t/lib);
use DBICTest;
use IO::File;
+use File::Compare;
+use Path::Class qw/file/;
my $schema = DBICTest->init_schema();
-plan tests => 1;
+plan tests => 9;
-my $fh = new IO::File('t/96file_column.t','r');
-eval { $schema->resultset('FileColumn')->create({file => {handle => $fh, filename =>'96file_column.t'}})};
-cmp_ok($@,'eq','','FileColumn checking if file handled properly.');
+my $rs = $schema->resultset('FileColumn');
+my $fname = '96file_column.t';
+my $source_file = file('t', $fname);
+my $fh = $source_file->open('r') or die "failed to open $source_file: $!\n";
+my $fc = eval {
+ $rs->create({ file => { handle => $fh, filename => $fname } })
+};
+is ( $@, '', 'created' );
+
+$fh->close;
+
+my $storage = file(
+ $fc->column_info('file')->{file_column_path},
+ $fc->id,
+ $fc->file->{filename},
+);
+ok ( -e $storage, 'storage exists' );
+
+# read it back
+$fc = $rs->find({ id => $fc->id });
+
+is ( $fc->file->{filename}, $fname, 'filename matches' );
+ok ( compare($storage, $source_file) == 0, 'file contents matches' );
+
+# update
+my $new_fname = 'File.pm';
+my $new_source_file = file(qw/lib DBIx Class InflateColumn File.pm/);
+my $new_storage = file(
+ $fc->column_info('file')->{file_column_path},
+ $fc->id,
+ $new_fname,
+);
+$fh = $new_source_file->open('r') or die "failed to open $new_source_file: $!\n";
+
+$fc->file({ handle => $fh, filename => $new_fname });
+$fc->update;
+
+TODO: {
+ local $TODO = 'design change required';
+ ok ( ! -e $storage, 'old storage does not exist' );
+};
+
+ok ( -e $new_storage, 'new storage exists' );
+
+# read it back
+$fc = $rs->find({ id => $fc->id });
+
+is ( $fc->file->{filename}, $new_fname, 'new filname matches' );
+ok ( compare($new_storage, $new_source_file) == 0, 'new content matches' );
+
+$fc->delete;
+
+ok ( ! -e $storage, 'storage deleted' );
Modified: DBIx-Class/0.09/trunk/t/96multi_create.t
===================================================================
--- DBIx-Class/0.09/trunk/t/96multi_create.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/96multi_create.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -194,3 +194,13 @@
my $new_cd = $schema->resultset("CD")->create($new_cd_hashref);
is($new_cd->artist->id, 17, 'new id retained okay');
+
+
+# Make sure exceptions from errors in created rels propogate
+eval {
+ my $t = $schema->resultset("Track")->new({});
+ $t->cd($t->new_related('cd', { artist => undef } ) );
+ $t->{_rel_in_storage} = 0;
+ $t->insert;
+};
+like($@, qr/cd.artist may not be NULL/, "Exception propogated properly");
Added: DBIx-Class/0.09/trunk/t/98savepoints.t
===================================================================
--- DBIx-Class/0.09/trunk/t/98savepoints.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/98savepoints.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,155 @@
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::Stats;
+
+my ($create_sql, $dsn, $user, $pass);
+
+if (exists $ENV{DBICTEST_PG_DSN}) {
+ ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
+
+ $create_sql = "CREATE TABLE artist (artistid serial PRIMARY KEY, name VARCHAR(100), charfield CHAR(10))";
+} elsif (exists $ENV{DBICTEST_MYSQL_DSN}) {
+ ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
+
+ $create_sql = "CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(255), charfield CHAR(10)) ENGINE=InnoDB";
+} else {
+ plan skip_all => 'Set DBICTEST_(PG|MYSQL)_DSN _USER and _PASS if you want to run savepoint tests';
+}
+
+plan tests => 16;
+
+my $schema = DBICTest::Schema->connect ($dsn,$user,$pass,{ auto_savepoint => 1 });
+
+my $stats = DBICTest::Stats->new;
+
+$schema->storage->debugobj($stats);
+
+$schema->storage->debug(1);
+
+$schema->storage->dbh->do ($create_sql);
+
+$schema->resultset('Artist')->create({ name => 'foo' });
+
+$schema->txn_begin;
+
+my $arty = $schema->resultset('Artist')->find(1);
+
+my $name = $arty->name;
+
+# First off, test a generated savepoint name
+$schema->svp_begin;
+
+cmp_ok($stats->{'SVP_BEGIN'}, '==', 1, 'Statistics svp_begin tickled');
+
+$arty->update({ name => 'Jheephizzy' });
+
+$arty->discard_changes;
+
+cmp_ok($arty->name, 'eq', 'Jheephizzy', 'Name changed');
+
+# Rollback the generated name
+# Active: 0
+$schema->svp_rollback;
+
+cmp_ok($stats->{'SVP_ROLLBACK'}, '==', 1, 'Statistics svp_rollback tickled');
+
+$arty->discard_changes;
+
+cmp_ok($arty->name, 'eq', $name, 'Name rolled back');
+
+$arty->update({ name => 'Jheephizzy'});
+
+# Active: 0 1
+$schema->svp_begin('testing1');
+
+$arty->update({ name => 'yourmom' });
+
+# Active: 0 1 2
+$schema->svp_begin('testing2');
+
+$arty->update({ name => 'gphat' });
+$arty->discard_changes;
+cmp_ok($arty->name, 'eq', 'gphat', 'name changed');
+# Active: 0 1 2
+# Rollback doesn't DESTROY the savepoint, it just rolls back to the value
+# at it's conception
+$schema->svp_rollback('testing2');
+$arty->discard_changes;
+cmp_ok($arty->name, 'eq', 'yourmom', 'testing2 reverted');
+
+# Active: 0 1 2 3
+$schema->svp_begin('testing3');
+$arty->update({ name => 'coryg' });
+# Active: 0 1 2 3 4
+$schema->svp_begin('testing4');
+$arty->update({ name => 'watson' });
+
+# Release 3, which implicitly releases 4
+# Active: 0 1 2
+$schema->svp_release('testing3');
+$arty->discard_changes;
+cmp_ok($arty->name, 'eq', 'watson', 'release left data');
+# This rolls back savepoint 2
+# Active: 0 1 2
+$schema->svp_rollback;
+$arty->discard_changes;
+cmp_ok($arty->name, 'eq', 'yourmom', 'rolled back to 2');
+
+# Rollback the original savepoint, taking us back to the beginning, implicitly
+# rolling back savepoint 1 and 2
+$schema->svp_rollback('savepoint_0');
+$arty->discard_changes;
+cmp_ok($arty->name, 'eq', 'foo', 'rolled back to start');
+
+$schema->txn_commit;
+
+# And now to see if txn_do will behave correctly
+
+$schema->txn_do (sub {
+ $schema->txn_do (sub {
+ $arty->name ('Muff');
+
+ $arty->update;
+ });
+
+ eval {
+ $schema->txn_do (sub {
+ $arty->name ('Moff');
+
+ $arty->update;
+
+ $arty->discard_changes;
+
+ is($arty->name,'Moff','Value updated in nested transaction');
+
+ $schema->storage->dbh->do ("GUARANTEED TO PHAIL");
+ });
+ };
+
+ ok ($@,'Nested transaction failed (good)');
+
+ $arty->discard_changes;
+
+ is($arty->name,'Muff','auto_savepoint rollback worked');
+
+ $arty->name ('Miff');
+
+ $arty->update;
+ });
+
+$arty->discard_changes;
+
+is($arty->name,'Miff','auto_savepoint worked');
+
+cmp_ok($stats->{'SVP_BEGIN'},'==',7,'Correct number of savepoints created');
+
+cmp_ok($stats->{'SVP_RELEASE'},'==',3,'Correct number of savepoints released');
+
+cmp_ok($stats->{'SVP_ROLLBACK'},'==',5,'Correct number of savepoint rollbacks');
+
+END { $schema->storage->dbh->do ("DROP TABLE artist") if defined $schema }
+
Added: DBIx-Class/0.09/trunk/t/99schema_roles.t
===================================================================
--- DBIx-Class/0.09/trunk/t/99schema_roles.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/99schema_roles.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,189 @@
+use strict;
+use warnings;
+use lib qw(t/lib);
+use Test::More;
+
+BEGIN {
+ eval "use Moose";
+ plan $@
+ ? ( skip_all => 'needs Moose for testing' )
+ : ( tests => 35 );
+}
+
+=head1 NAME
+
+DBICNGTest::Schema::ResultSet:Person; Example Resultset
+
+=head1 DESCRIPTION
+
+Tests for the various Schema roles you can either use or apply
+
+=head1 TESTS
+
+=head2 initialize database
+
+create a schema and setup
+
+=cut
+
+use_ok 'DBICNGTest::Schema';
+
+ok my $db_file = Path::Class::File->new(qw/t var DBIxClassNG.db/)
+ => 'created a path for the test database';
+
+unlink $db_file;
+
+ok my $schema = DBICNGTest::Schema->connect_and_setup($db_file)
+ => 'Created a good Schema';
+
+is ref $schema->source('Person'), 'DBIx::Class::ResultSource::Table'
+ => 'Found Expected Person Source';
+
+is $schema->resultset('Person')->count, 5
+ => 'Got the correct number of people';
+
+is $schema->resultset('Gender')->count, 3
+ => 'Got the correct number of genders';
+
+
+=head2 check query counter
+
+Test the query counter role
+
+=cut
+
+use_ok 'DBIx::Class::Storage::DBI::Role::QueryCounter';
+DBIx::Class::Storage::DBI::Role::QueryCounter->meta->apply($schema->storage);
+
+is $schema->storage->query_count, 0
+ => 'Query Count is zero';
+
+is $schema->resultset('Person')->find(1)->name, 'john'
+ => 'Found John!';
+
+is $schema->resultset('Person')->find(2)->name, 'dan'
+ => 'Found Dan!';
+
+is $schema->storage->query_count, 2
+ => 'Query Count is two';
+
+
+=head2 check at query interval
+
+Test the role for associating events with a given query interval
+
+=cut
+
+use_ok 'DBIx::Class::Schema::Role::AtQueryInterval';
+DBIx::Class::Schema::Role::AtQueryInterval->meta->apply($schema);
+
+ok my $job1 = $schema->create_job(runs=>sub { 'hello'})
+ => 'Created a job';
+
+is $job1->execute, 'hello',
+ => 'Got expected information from the job';
+
+ok my $job2 = $schema->create_job(runs=>'job_handler_echo')
+ => 'Created a job';
+
+is $job2->execute($schema, 'hello1'), 'hello1',
+ => 'Got expected information from the job';
+
+ok my $interval1 = $schema->create_query_interval(every=>10)
+ => 'Created a interval';
+
+ok $interval1->matches(10)
+ => 'correctly matched 10';
+
+ok $interval1->matches(20)
+ => 'correctly matched 20';
+
+ok !$interval1->matches(22)
+ => 'correctly didnt matched 22';
+
+ok my $interval2 = $schema->create_query_interval(every=>10, offset=>2)
+ => 'Created a interval';
+
+ok $interval2->matches(12)
+ => 'correctly matched 12';
+
+ok $interval2->matches(22)
+ => 'correctly matched 22';
+
+ok !$interval2->matches(25)
+ => 'correctly didnt matched 25';
+
+ok my $at = $schema->create_at_query_interval(interval=>$interval2, job=>$job2)
+ => 'created the at query interval object';
+
+is $at->execute_if_matches(32, $schema, 'hello2'), 'hello2'
+ => 'Got correct return';
+
+ok $schema->at_query_intervals([$at])
+ => 'added job to run at a given interval';
+
+is_deeply [$schema->execute_jobs_at_query_interval(42, 'hello4')], ['hello4']
+ => 'got expected job return value';
+
+=head2 create jobs via express method
+
+Using the express method, build a bunch of jobs
+
+=cut
+
+ok my @ats = $schema->create_and_add_at_query_intervals(
+
+ {every => 10} => {
+ runs => sub {10},
+ },
+ {every => 20} => {
+ runs => sub {20},
+ },
+ {every => 30} => {
+ runs => sub {30},
+ },
+ {every => 101} => [
+ {runs => sub {101.1}},
+ {runs => sub {101.2}},
+ ],
+
+) => 'created express method at query intervals';
+
+
+is_deeply [$schema->execute_jobs_at_query_interval(10)], [10]
+ => 'Got Expected return for 10';
+
+is_deeply [$schema->execute_jobs_at_query_interval(12, 'hello5')], ['hello5']
+ => 'Got Expected return for 12';
+
+is_deeply [$schema->execute_jobs_at_query_interval(20)], [10,20]
+ => 'Got Expected return for 20';
+
+is_deeply [$schema->execute_jobs_at_query_interval(30)], [10,30]
+ => 'Got Expected return for 30';
+
+is_deeply [$schema->execute_jobs_at_query_interval(60)], [10,20,30]
+ => 'Got Expected return for 60';
+
+is_deeply [$schema->execute_jobs_at_query_interval(101)], [101.1,101.2]
+ => 'Got Expected return for 101';
+
+
+=head2 cleanup
+
+Cleanup after ourselves
+
+=cut
+
+unlink $db_file;
+
+
+=head1 AUTHORS
+
+See L<DBIx::Class> for more information regarding authors.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
\ No newline at end of file
Added: DBIx-Class/0.09/trunk/t/cdbi-DeepAbstractSearch/01_search.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-DeepAbstractSearch/01_search.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-DeepAbstractSearch/01_search.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,295 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ plan skip_all => 'needs DBD::SQLite for testing'
+ unless eval { require DBD::SQLite };
+
+ plan skip_all => 'needs Class::DBI::Plugin::DeepAbstractSearch'
+ unless eval { require Class::DBI::Plugin::DeepAbstractSearch };
+
+ plan tests => 19;
+}
+
+my $DB = "t/testdb";
+unlink $DB if -e $DB;
+
+my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 0 });
+
+package Music::DBI;
+use base qw(DBIx::Class::CDBICompat);
+use Class::DBI::Plugin::DeepAbstractSearch;
+__PACKAGE__->connection(@DSN);
+
+my $sql = <<'SQL_END';
+
+---------------------------------------
+-- Artists
+---------------------------------------
+CREATE TABLE artists (
+ id INTEGER NOT NULL PRIMARY KEY,
+ name VARCHAR(32)
+);
+
+INSERT INTO artists VALUES (1, "Willie Nelson");
+INSERT INTO artists VALUES (2, "Patsy Cline");
+
+---------------------------------------
+-- Labels
+---------------------------------------
+CREATE TABLE labels (
+ id INTEGER NOT NULL PRIMARY KEY,
+ name VARCHAR(32)
+);
+
+INSERT INTO labels VALUES (1, "Columbia");
+INSERT INTO labels VALUES (2, "Sony");
+INSERT INTO labels VALUES (3, "Supraphon");
+
+---------------------------------------
+-- CDs
+---------------------------------------
+CREATE TABLE cds (
+ id INTEGER NOT NULL PRIMARY KEY,
+ label INTEGER,
+ artist INTEGER,
+ title VARCHAR(32),
+ year INTEGER
+);
+INSERT INTO cds VALUES (1, 1, 1, "Songs", 2005);
+INSERT INTO cds VALUES (2, 2, 1, "Read Headed Stanger", 2000);
+INSERT INTO cds VALUES (3, 1, 1, "Wanted! The Outlaws", 2004);
+INSERT INTO cds VALUES (4, 2, 1, "The Very Best of Willie Nelson", 1999);
+
+INSERT INTO cds VALUES (5, 1, 2, "12 Greates Hits", 1999);
+INSERT INTO cds VALUES (6, 2, 2, "Sweet Dreams", 1995);
+INSERT INTO cds VALUES (7, 3, 2, "The Best of Patsy Cline", 1991);
+
+---------------------------------------
+-- Tracks
+---------------------------------------
+CREATE TABLE tracks (
+ id INTEGER NOT NULL PRIMARY KEY,
+ cd INTEGER,
+ position INTEGER,
+ title VARCHAR(32)
+);
+INSERT INTO tracks VALUES (1, 1, 1, "Songs: Track 1");
+INSERT INTO tracks VALUES (2, 1, 2, "Songs: Track 2");
+INSERT INTO tracks VALUES (3, 1, 3, "Songs: Track 3");
+INSERT INTO tracks VALUES (4, 1, 4, "Songs: Track 4");
+
+INSERT INTO tracks VALUES (5, 2, 1, "Read Headed Stanger: Track 1");
+INSERT INTO tracks VALUES (6, 2, 2, "Read Headed Stanger: Track 2");
+INSERT INTO tracks VALUES (7, 2, 3, "Read Headed Stanger: Track 3");
+INSERT INTO tracks VALUES (8, 2, 4, "Read Headed Stanger: Track 4");
+
+INSERT INTO tracks VALUES (9, 3, 1, "Wanted! The Outlaws: Track 1");
+INSERT INTO tracks VALUES (10, 3, 2, "Wanted! The Outlaws: Track 2");
+
+INSERT INTO tracks VALUES (11, 4, 1, "The Very Best of Willie Nelson: Track 1");
+INSERT INTO tracks VALUES (12, 4, 2, "The Very Best of Willie Nelson: Track 2");
+INSERT INTO tracks VALUES (13, 4, 3, "The Very Best of Willie Nelson: Track 3");
+INSERT INTO tracks VALUES (14, 4, 4, "The Very Best of Willie Nelson: Track 4");
+INSERT INTO tracks VALUES (15, 4, 5, "The Very Best of Willie Nelson: Track 5");
+INSERT INTO tracks VALUES (16, 4, 6, "The Very Best of Willie Nelson: Track 6");
+
+INSERT INTO tracks VALUES (17, 5, 1, "12 Greates Hits: Track 1");
+INSERT INTO tracks VALUES (18, 5, 2, "12 Greates Hits: Track 2");
+INSERT INTO tracks VALUES (19, 5, 3, "12 Greates Hits: Track 3");
+INSERT INTO tracks VALUES (20, 5, 4, "12 Greates Hits: Track 4");
+
+INSERT INTO tracks VALUES (21, 6, 1, "Sweet Dreams: Track 1");
+INSERT INTO tracks VALUES (22, 6, 2, "Sweet Dreams: Track 2");
+INSERT INTO tracks VALUES (23, 6, 3, "Sweet Dreams: Track 3");
+INSERT INTO tracks VALUES (24, 6, 4, "Sweet Dreams: Track 4");
+
+INSERT INTO tracks VALUES (25, 7, 1, "The Best of Patsy Cline: Track 1");
+INSERT INTO tracks VALUES (26, 7, 2, "The Best of Patsy Cline: Track 2");
+
+SQL_END
+
+foreach my $statement (split /;/, $sql) {
+ $statement =~ s/^\s*//gs;
+ $statement =~ s/\s*$//gs;
+ next unless $statement;
+ Music::DBI->db_Main->do($statement) or die "$@ $!";
+}
+
+Music::DBI->dbi_commit;
+
+package Music::Artist;
+use base 'Music::DBI';
+Music::Artist->table('artists');
+Music::Artist->columns(All => qw/id name/);
+
+
+package Music::Label;
+use base 'Music::DBI';
+Music::Label->table('labels');
+Music::Label->columns(All => qw/id name/);
+
+package Music::CD;
+use base 'Music::DBI';
+Music::CD->table('cds');
+Music::CD->columns(All => qw/id label artist title year/);
+
+
+package Music::Track;
+use base 'Music::DBI';
+Music::Track->table('tracks');
+Music::Track->columns(All => qw/id cd position title/);
+
+Music::Artist->has_many(cds => 'Music::CD');
+Music::Label->has_many(cds => 'Music::CD');
+Music::CD->has_many(tracks => 'Music::Track');
+Music::CD->has_a(artist => 'Music::Artist');
+Music::CD->has_a(label => 'Music::Label');
+Music::Track->has_a(cd => 'Music::CD');
+
+package main;
+
+{
+ my $where = { };
+ my $attr;
+ my @artists = Music::Artist->deep_search_where($where, $attr);
+ is_deeply [ sort @artists ], [ 1, 2 ], "all without order";
+}
+
+{
+ my $where = { };
+ my $attr = { order_by => 'name' };
+ my @artists = Music::Artist->deep_search_where($where, $attr);
+ is_deeply \@artists, [ 2, 1 ], "all with ORDER BY name";
+}
+
+{
+ my $where = { };
+ my $attr = { order_by => 'name DESC' };
+ my @artists = Music::Artist->deep_search_where($where, $attr);
+ is_deeply \@artists, [ 1, 2 ], "all with ORDER BY name DESC";
+}
+
+{
+ my $where = { name => { -like => 'Patsy Cline' }, };
+ my $attr;
+ my @artists = Music::Artist->deep_search_where($where, $attr);
+ is_deeply \@artists, [ 2 ], "simple search";
+}
+
+{
+ my $where = { 'artist.name' => 'Patsy Cline' };
+ my $attr = { } ;
+ my @cds = Music::CD->deep_search_where($where, $attr);
+ is_deeply [ sort @cds ], [ 5, 6, 7 ], "Patsy's CDs";
+}
+
+{
+ my $where = { 'artist.name' => 'Patsy Cline' };
+ my $attr = { order_by => "title" } ;
+ my @cds = Music::CD->deep_search_where($where, $attr);
+ is_deeply [ @cds ], [ 5, 6, 7 ], "Patsy's CDs by title";
+
+ my $count = Music::CD->count_deep_search_where($where);
+ is_deeply $count, 3, "count Patsy's CDs by title";
+}
+
+{
+ my $where = { 'cd.title' => { -like => 'S%' }, };
+ my $attr = { order_by => "cd.title, title" } ;
+ my @cds = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @cds ], [1, 2, 3, 4, 21, 22, 23, 24 ], "Tracks from CDs whose name starts with 'S'";
+}
+
+{
+ my $where = {
+ 'cd.artist.name' => { -like => 'W%' },
+ 'cd.year' => { '>' => 2000 },
+ 'position' => { '<' => 3 }
+ };
+ my $attr = { order_by => "cd.title DESC, title" } ;
+ my @cds = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @cds ], [ 9, 10, 1, 2 ], "First 2 tracks from W's albums after 2000 ";
+
+ my $count = Music::Track->count_deep_search_where($where);
+ is_deeply $count, 4, "Count First 2 tracks from W's albums after 2000";
+}
+
+{
+ my $where = {
+ 'cd.artist.name' => { -like => 'W%' },
+ 'cd.year' => { '>' => 2000 },
+ 'position' => { '<' => 3 }
+ };
+ my $attr = { order_by => [ 'cd.title DESC' , 'title' ] } ;
+ my @cds = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @cds ], [ 9, 10, 1, 2 ], "First 2 tracks from W's albums after 2000, array ref order ";
+
+ my $count = Music::Track->count_deep_search_where($where);
+ is_deeply $count, 4, "Count First 2 tracks from W's albums after 2000, array ref order";
+}
+
+{
+ my $where = { 'cd.title' => [ -and => { -like => '%o%' }, { -like => '%W%' } ] };
+ my $attr = { order_by => [ 'cd.id' ] } ;
+
+ my @tracks = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @tracks ], [ 3, 3, 4, 4, 4, 4, 4, 4 ], "Tracks from CD titles containing 'o' AND 'W'";
+}
+
+{
+ my $where = { 'cd.year' => [ 1995, 1999 ] };
+ my $attr = { order_by => [ 'cd.id' ] } ;
+
+ my @tracks = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @tracks ], [ 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 6, 6 ],
+ "Tracks from CDs from 1995, 1999";
+}
+
+{
+ my $where = { 'cd.year' => { -in => [ 1995, 1999 ] } };
+ my $attr = { order_by => [ 'cd.id' ] } ;
+
+ my @tracks = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @tracks ], [ 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 6, 6 ],
+ "Tracks from CDs in 1995, 1999";
+}
+
+{
+ my $where = { -and => [ 'cd.year' => [ 1995, 1999 ], position => { '<=', 2 } ] };
+ my $attr = { order_by => [ 'cd.id' ] } ;
+
+ my @tracks = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @tracks ], [ 4, 4, 5, 5, 6, 6 ],
+ "First 2 tracks Tracks from CDs from 1995, 1999";
+}
+
+{
+ my $where = { -and => [ 'cd.year' => { -in => [ 1995, 1999 ] }, position => { '<=', 2 } ] };
+ my $attr = { order_by => [ 'cd.id' ] } ;
+
+ my @tracks = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @tracks ], [ 4, 4, 5, 5, 6, 6 ],
+ "First 2 tracks Tracks from CDs in 1995, 1999";
+}
+
+{
+ my $where = { 'label.name' => { -in => [ 'Sony', 'Supraphon', 'Bogus' ] } };
+ my $attr = { order_by => [ 'id' ] } ;
+
+ my @cds = Music::CD->deep_search_where($where, $attr);
+ is_deeply [ @cds ], [ 2, 4, 6, 7 ],
+ "CDs from Sony or Supraphon";
+}
+
+{
+ my $where = { 'label.name' => [ 'Sony', 'Supraphon', 'Bogus' ] };
+ my $attr = { order_by => [ 'id' ] } ;
+
+ my @cds = Music::CD->deep_search_where($where, $attr);
+ is_deeply [ @cds ], [ 2, 4, 6, 7 ],
+ "CDs from Sony or Supraphon";
+}
+
+END { unlink $DB if -e $DB }
+
Property changes on: DBIx-Class/0.09/trunk/t/cdbi-DeepAbstractSearch/01_search.t
___________________________________________________________________
Name: svn:executable
+ *
Added: DBIx-Class/0.09/trunk/t/cdbi-abstract/search_where.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-abstract/search_where.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-abstract/search_where.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,74 @@
+#!/usr/bin/perl -w
+
+use Test::More;
+
+use strict;
+use warnings;
+
+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 => 10);
+}
+
+INIT {
+ use lib 't/testlib';
+ use Film;
+}
+
+
+Film->create({ Title => $_, Rating => "PG" }) for ("Superman", "Super Fuzz");
+Film->create({ Title => "Batman", Rating => "PG13" });
+
+my $superman = Film->search_where( Title => "Superman" );
+is $superman->next->Title, "Superman", "search_where() as iterator";
+is $superman->next, undef;
+
+{
+ my @supers = Film->search_where({ title => { 'like' => 'Super%' } });
+ is_deeply [sort map $_->Title, @supers],
+ [sort ("Super Fuzz", "Superman")], 'like';
+}
+
+
+my @all = Film->search_where({}, { order_by => "Title ASC" });
+is_deeply ["Batman", "Super Fuzz", "Superman"],
+ [map $_->Title, @all],
+ "order_by ASC";
+
+ at all = Film->search_where({}, { order_by => "Title DESC" });
+is_deeply ["Superman", "Super Fuzz", "Batman"],
+ [map $_->Title, @all],
+ "order_by DESC";
+
+ at all = Film->search_where({ Rating => "PG" }, { limit => 1, order_by => "Title ASC" });
+is_deeply ["Super Fuzz"],
+ [map $_->Title, @all],
+ "where, limit";
+
+ at all = Film->search_where({}, { limit => 2, order_by => "Title ASC" });
+is_deeply ["Batman", "Super Fuzz"],
+ [map $_->Title, @all],
+ "limit";
+
+ at all = Film->search_where({}, { offset => 1, order_by => "Title ASC" });
+is_deeply ["Super Fuzz", "Superman"],
+ [map $_->Title, @all],
+ "offset";
+
+ at all = Film->search_where({}, { limit => 1, offset => 1, order_by => "Title ASC" });
+is_deeply ["Super Fuzz"],
+ [map $_->Title, @all],
+ "limit + offset";
+
+ at all = Film->search_where({}, { limit => 2, offset => 1,
+ limit_dialect => "Top", order_by => "Title ASC"
+ });
+is_deeply ["Super Fuzz", "Superman"],
+ [map $_->Title, @all],
+ "limit_dialect ignored";
+
Modified: DBIx-Class/0.09/trunk/t/cdbi-t/01-columns.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/01-columns.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/01-columns.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -4,7 +4,7 @@
BEGIN {
eval "use DBIx::Class::CDBICompat;";
- plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required') : (tests=> 24);
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@") : (tests=> 24);
}
@@ -22,13 +22,13 @@
State->columns(Other => qw/Capital Population/);
#State->has_many(cities => "City");
-sub accessor_name {
+sub accessor_name_for {
my ($class, $column) = @_;
my $return = $column eq "Rain" ? "Rainfall" : $column;
return $return;
}
-sub mutator_name {
+sub mutator_name_for {
my ($class, $column) = @_;
my $return = $column eq "Rain" ? "set_Rainfall" : "set_$column";
return $return;
Modified: DBIx-Class/0.09/trunk/t/cdbi-t/02-Film.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/02-Film.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/02-Film.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -9,7 +9,7 @@
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 96);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 98);
}
INIT {
@@ -37,7 +37,7 @@
ok $@, "Can't get title with no object";
}
-eval { my $duh = Film->create; };
+eval { my $duh = Film->insert; };
like $@, qr/create needs a hashref/, "needs a hashref";
ok +Film->create_test_film;
@@ -126,6 +126,11 @@
{
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%");
@@ -137,6 +142,11 @@
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
@@ -163,11 +173,11 @@
}
eval {
- my $ishtar = Film->create({ Title => 'Ishtar', Director => 'Elaine May' });
+ my $ishtar = Film->insert({ Title => 'Ishtar', Director => 'Elaine May' });
my $mandn =
- Film->create({ Title => 'Mikey and Nicky', Director => 'Elaine May' });
+ Film->insert({ Title => 'Mikey and Nicky', Director => 'Elaine May' });
my $new_leaf =
- Film->create({ Title => 'A New Leaf', Director => 'Elaine May' });
+ 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,
@@ -263,7 +273,7 @@
{ # update deleted object
my $rt = "Royal Tenenbaums";
- my $ten = Film->create({ title => $rt, Rating => "R" });
+ 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);
@@ -284,7 +294,7 @@
# Primary key of 0
{
- my $zero = Film->create({ Title => 0, Rating => "U" });
+ 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";
@@ -344,7 +354,7 @@
{
{
- ok my $byebye = DeletingFilm->create(
+ ok my $byebye = DeletingFilm->insert(
{
Title => 'Goodbye Norma Jean',
Rating => 'PG',
@@ -362,9 +372,8 @@
}
SKIP: {
- #skip "DBIx::Class doesn't yet have a live objects index", 3;
- #skip "Scalar::Util::weaken not available", 3
- #if !$Class::DBI::Weaken_Is_Available;
+ 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');
@@ -386,7 +395,7 @@
isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste4),
"Clearing cache and retrieving again gives new object";
- $btaste=Film->create({
+ $btaste=Film->insert({
Title => 'Bad Taste 2',
Director => 'Peter Jackson',
Rating => 'R',
Modified: DBIx-Class/0.09/trunk/t/cdbi-t/04-lazy.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/04-lazy.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/04-lazy.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -1,7 +1,9 @@
+#!/usr/bin/perl -w
+
use strict;
use Test::More;
+use Test::Warn;
-
#----------------------------------------------------------------------
# Test lazy loading
#----------------------------------------------------------------------
@@ -13,7 +15,7 @@
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 25);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 36);
}
INIT {
@@ -79,3 +81,104 @@
};
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};
+}
Modified: DBIx-Class/0.09/trunk/t/cdbi-t/06-hasa.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/06-hasa.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/06-hasa.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -4,7 +4,7 @@
BEGIN {
eval "use DBIx::Class::CDBICompat;";
if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
next;
}
eval "use DBD::SQLite";
Added: DBIx-Class/0.09/trunk/t/cdbi-t/08-inheritcols.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/08-inheritcols.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/08-inheritcols.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,27 @@
+#!/usr/bin/perl -w
+
+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";
Modified: DBIx-Class/0.09/trunk/t/cdbi-t/13-constraint.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/13-constraint.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/13-constraint.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -15,26 +15,26 @@
use Film;
sub valid_rating {
- my $value = shift;
- my $ok = grep $value eq $_, qw/U Uc PG 12 15 18/;
- return $ok;
+ 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',
+ 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");
+ 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");
@@ -45,8 +45,8 @@
is $ver->Rating, 12, "Rating now 12";
eval {
- $ver->Rating(13);
- $ver->update;
+ $ver->Rating(13);
+ $ver->update;
};
ok $@, $@;
is $ver->Rating, 12, "Rating still 12";
@@ -61,44 +61,47 @@
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";
+ 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->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";
+ 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' }) };
- is $@, '', "Can create codirector";
- is $freeaa->codirector, '2001-03-03', "Set the codirector";
+ 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__
@@ -106,13 +109,13 @@
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;
- });
+ 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;
+ });
}
Modified: DBIx-Class/0.09/trunk/t/cdbi-t/14-might_have.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/14-might_have.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/14-might_have.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -8,7 +8,7 @@
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 18);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 22);
}
use lib 't/testlib';
@@ -67,4 +67,17 @@
}
-
+{
+ 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
Modified: DBIx-Class/0.09/trunk/t/cdbi-t/15-accessor.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/15-accessor.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/15-accessor.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -4,11 +4,12 @@
BEGIN {
eval "use DBIx::Class::CDBICompat;";
if ($@) {
+ diag $@;
plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 53);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 54);
}
INIT {
@@ -17,7 +18,9 @@
use lib 't/testlib';
require Film;
require Actor;
+ require Director;
Actor->has_a(film => 'Film');
+ Film->has_a(director => 'Director');
sub Class::DBI::sheep { ok 0; }
}
@@ -33,12 +36,19 @@
return $col;
}
-sub Actor::accessor_name {
+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 mutatori_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',
@@ -131,8 +141,20 @@
}
-SKIP: { # have non persistent accessor?
- #skip "Compat layer doesn't handle TEMP columns yet", 11;
+
+# 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");
@@ -152,11 +174,10 @@
}
}
-SKIP: { # was bug with TEMP and no Essential
- #skip "Compat layer doesn't have TEMP columns yet", 5;
+{
is_deeply(
- Actor->columns('Essential'),
- Actor->columns('Primary'),
+ [Actor->columns('Essential')],
+ [Actor->columns('Primary')],
"Actor has no specific essential columns"
);
ok(Actor->find_column('nonpersistent'), "nonpersistent is a column");
@@ -166,8 +187,7 @@
isa_ok $pj => "Actor";
}
-SKIP: {
- #skip "Compat layer doesn't handle read-only objects yet", 10;
+{
Film->autoupdate(1);
my $naked = Film->create({ title => 'Naked' });
my $sandl = Film->create({ title => 'Secrets and Lies' });
Modified: DBIx-Class/0.09/trunk/t/cdbi-t/19-set_sql.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/19-set_sql.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/19-set_sql.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -8,7 +8,7 @@
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 17);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 20);
}
use lib 't/testlib';
@@ -19,6 +19,11 @@
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' });
@@ -68,6 +73,22 @@
};
{
+ 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{
@@ -109,4 +130,3 @@
is $apg[1]->title, "B", "and B";
}
-#} # end SKIP block
Modified: DBIx-Class/0.09/trunk/t/cdbi-t/21-iterator.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/21-iterator.t 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/21-iterator.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -4,11 +4,11 @@
BEGIN {
eval "use DBIx::Class::CDBICompat;";
if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 33);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 37);
}
use lib 't/testlib';
@@ -49,8 +49,6 @@
is $it->next->title, "Film 2", "And 2 is still next";
}
-SKIP: {
- #skip "Iterator doesn't yet have slice support", 19;
{
my $it = Film->retrieve_all;
@@ -85,4 +83,14 @@
is $it->next->title, "Film 2", "And 2 is still next";
}
-} # End SKIP
+{
+ 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";
+}
Added: DBIx-Class/0.09/trunk/t/cdbi-t/22-deflate_order.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/22-deflate_order.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/22-deflate_order.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,24 @@
+$| = 1;
+use strict;
+
+use Test::More;
+
+eval { require Time::Piece::MySQL };
+plan skip_all => "Need Time::Piece::MySQL for this test" if $@;
+
+eval { require 't/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 $@;
+
Added: DBIx-Class/0.09/trunk/t/cdbi-t/23-cascade.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/23-cascade.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/23-cascade.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,76 @@
+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 => 12);
+}
+
+INIT {
+ use lib 't/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;
+ ok +Film->retrieve("Alligator"), "has_many with @{[ keys %$args ]} => @{[ values %$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";
+#}
Added: DBIx-Class/0.09/trunk/t/cdbi-t/24-meta_info.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/24-meta_info.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/24-meta_info.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,80 @@
+#!/usr/bin/perl -w
+
+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;
+}
Added: DBIx-Class/0.09/trunk/t/cdbi-t/26-mutator.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/26-mutator.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/26-mutator.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -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/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";
+
Added: DBIx-Class/0.09/trunk/t/cdbi-t/columns_as_hashes.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/columns_as_hashes.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/columns_as_hashes.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,106 @@
+#!/usr/bin/perl -w
+
+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/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
Added: DBIx-Class/0.09/trunk/t/cdbi-t/columns_dont_override_custom_accessors.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/columns_dont_override_custom_accessors.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/columns_dont_override_custom_accessors.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,34 @@
+#!/usr/bin/perl -w
+
+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' );
Added: DBIx-Class/0.09/trunk/t/cdbi-t/construct.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/construct.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/construct.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,45 @@
+#!/usr/bin/perl -w
+
+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/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";
+}
Added: DBIx-Class/0.09/trunk/t/cdbi-t/copy.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/copy.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/copy.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,43 @@
+#!/usr/bin/perl -w
+
+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/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";
+
Added: DBIx-Class/0.09/trunk/t/cdbi-t/early_column_heisenbug.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/early_column_heisenbug.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/early_column_heisenbug.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -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;
Added: DBIx-Class/0.09/trunk/t/cdbi-t/has_many_loads_foreign_class.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/has_many_loads_foreign_class.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/has_many_loads_foreign_class.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -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/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
Added: DBIx-Class/0.09/trunk/t/cdbi-t/hasa_without_loading.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/hasa_without_loading.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/hasa_without_loading.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,23 @@
+#!/usr/bin/perl -w
+
+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)];
Added: DBIx-Class/0.09/trunk/t/cdbi-t/max_min_value_of.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/max_min_value_of.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/max_min_value_of.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,34 @@
+#!/usr/bin/perl -w
+
+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/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 );
Added: DBIx-Class/0.09/trunk/t/cdbi-t/multi_column_set.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/multi_column_set.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/multi_column_set.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,27 @@
+#!/usr/bin/perl -w
+
+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;
Added: DBIx-Class/0.09/trunk/t/cdbi-t/object_cache.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/object_cache.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/object_cache.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -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/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;
+}
Added: DBIx-Class/0.09/trunk/t/cdbi-t/retrieve_from_sql_with_limit.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/retrieve_from_sql_with_limit.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/retrieve_from_sql_with_limit.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,27 @@
+#!/usr/bin/perl -w
+
+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/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;
+}
Added: DBIx-Class/0.09/trunk/t/cdbi-t/set_to_undef.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/set_to_undef.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/set_to_undef.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,25 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+use Test::NoWarnings;
+
+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, this => 42 });
+$thing->set( this => undef );
+$thing->discard_changes;
Added: DBIx-Class/0.09/trunk/t/cdbi-t/set_vs_DateTime.t
===================================================================
--- DBIx-Class/0.09/trunk/t/cdbi-t/set_vs_DateTime.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/cdbi-t/set_vs_DateTime.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,32 @@
+#!/usr/bin/perl -w
+
+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;
Added: DBIx-Class/0.09/trunk/t/dbh_do.t
===================================================================
--- DBIx-Class/0.09/trunk/t/dbh_do.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/dbh_do.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,33 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 8;
+use lib qw(t/lib);
+use DBICTest;
+
+
+my $schema = DBICTest->init_schema();
+my $storage = $schema->storage;
+
+my $test_func = sub {
+ is $_[0], $storage;
+ is $_[1], $storage->dbh;
+ is $_[2], "foo";
+ is $_[3], "bar";
+};
+
+$storage->dbh_do(
+ $test_func,
+ "foo", "bar"
+);
+
+my $storage_class = ref $storage;
+{
+ no strict 'refs';
+ *{$storage_class .'::__test_method'} = $test_func;
+}
+$storage->dbh_do("__test_method", "foo", "bar");
+
+
\ No newline at end of file
Added: DBIx-Class/0.09/trunk/t/deleting_many_to_many.t
===================================================================
--- DBIx-Class/0.09/trunk/t/deleting_many_to_many.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/deleting_many_to_many.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,23 @@
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 5;
+
+my $cd = $schema->resultset("CD")->find(2);
+ok $cd->liner_notes;
+ok keys %{$cd->{_relationship_data}}, "_relationship_data populated";
+
+$cd->discard_changes;
+ok $cd->liner_notes, 'relationships still valid after discarding changes';
+
+ok $cd->liner_notes->delete;
+$cd->discard_changes;
+ok !$cd->liner_notes, 'discard_changes resets relationship';
\ No newline at end of file
Added: DBIx-Class/0.09/trunk/t/discard_changes_in_DESTROY.t
===================================================================
--- DBIx-Class/0.09/trunk/t/discard_changes_in_DESTROY.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/discard_changes_in_DESTROY.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,32 @@
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 1;
+
+{
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, @_; };
+ {
+ # Test that this doesn't cause infinite recursion.
+ local *DBICTest::Artist::DESTROY;
+ local *DBICTest::Artist::DESTROY = sub { $_[0]->discard_changes };
+
+ my $artist = $schema->resultset("Artist")->create( {
+ artistid => 10,
+ name => "artist number 10",
+ });
+
+ $artist->name("Wibble");
+
+ print "# About to call DESTROY\n";
+ }
+ is_deeply \@warnings, [];
+}
\ No newline at end of file
Added: DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result/FriendList.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result/FriendList.pm (rev 0)
+++ DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result/FriendList.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,118 @@
+package #hide from pause
+ DBICNGTest::Schema::Result::FriendList;
+
+ use Moose;
+ extends 'DBICNGTest::Schema::Result';
+
+
+=head1 NAME
+
+Zoomwit::tlib::DBIC::Schema::Result::FriendList; An example Friends Class;
+
+=head1 VERSION
+
+0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+
+=head1 DESCRIPTION
+
+A Person can have zero or more friends
+A Person can't be their own friend
+A Person over 18 can't be friends with Persons under 18 and vis versa.
+A Person can have friendships that are not mutual.
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head1 PACKAGE METHODS
+
+This module defines the following package methods
+
+=head2 table
+
+Name of the Physical table in the database
+
+=cut
+
+__PACKAGE__
+ ->table('friend_list');
+
+
+=head2 add_columns
+
+Add columns and meta information
+
+=head3 fk_person_id
+
+ID of the person with friends
+
+=head3 fk_friend_id
+
+Who is the friend?
+
+=cut
+
+__PACKAGE__
+ ->add_columns(
+ fk_person_id => {
+ data_type=>'integer',
+ },
+ fk_friend_id => {
+ data_type=>'integer',
+ },
+);
+
+
+=head2 primary_key
+
+Sets the Primary keys for this table
+
+=cut
+
+__PACKAGE__
+ ->set_primary_key(qw/fk_person_id fk_friend_id/);
+
+
+=head2 befriender
+
+The person that 'owns' the friendship (list)
+
+=cut
+
+__PACKAGE__
+ ->belongs_to( befriender => 'DBICNGTest::Schema::Result::Person', {
+ 'foreign.person_id' => 'self.fk_person_id' });
+
+
+=head2 friendee
+
+The actual friend that befriender is listing
+
+=cut
+
+__PACKAGE__
+ ->belongs_to( friendee => 'DBICNGTest::Schema::Result::Person', {
+ 'foreign.person_id' => 'self.fk_friend_id' });
+
+
+=head1 METHODS
+
+This module defines the following methods.
+
+=head1 AUTHORS
+
+See L<DBIx::Class> for more information regarding authors.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+
+1;
Added: DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result/Gender.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result/Gender.pm (rev 0)
+++ DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result/Gender.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,117 @@
+package #hide from pause
+ DBICNGTest::Schema::Result::Gender;
+
+ use Moose;
+ extends 'DBICNGTest::Schema::Result';
+
+
+=head1 NAME
+
+DBICNGTest::Schema::Result::Gender; An example Gender Class;
+
+=head1 DESCRIPTION
+
+Tests for this type of FK relationship
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head2 label
+
+example of using an attribute to add constraints on a table insert
+
+=cut
+
+has 'label' =>(is=>'rw', required=>1, isa=>'Str');
+
+
+=head1 PACKAGE METHODS
+
+This module defines the following package methods
+
+=head2 table
+
+Name of the Physical table in the database
+
+=cut
+
+__PACKAGE__
+ ->table('gender');
+
+
+=head2 add_columns
+
+Add columns and meta information
+
+=head3 gender_id
+
+Primary Key which is an auto generated UUID
+
+=head3 label
+
+Text label of the gender (ie, 'male', 'female', 'transgender', etc.).
+
+=cut
+
+__PACKAGE__
+ ->add_columns(
+ gender_id => {
+ data_type=>'integer',
+ },
+ label => {
+ data_type=>'varchar',
+ size=>12,
+ },
+ );
+
+
+=head2 primary_key
+
+Sets the Primary keys for this table
+
+=cut
+
+__PACKAGE__
+ ->set_primary_key(qw/gender_id/);
+
+
+=head2
+
+Marks the unique columns
+
+=cut
+
+__PACKAGE__
+ ->add_unique_constraint('gender_label_unique' => [ qw/label/ ]);
+
+
+=head2 people
+
+A resultset of people with this gender
+
+=cut
+
+__PACKAGE__
+ ->has_many(
+ people => 'DBICNGTest::Schema::Result::Person',
+ {'foreign.fk_gender_id' => 'self.gender_id'}
+ );
+
+
+=head1 METHODS
+
+This module defines the following methods.
+
+=head1 AUTHORS
+
+See L<DBIx::Class> for more information regarding authors.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+
+1;
Added: DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result/Person.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result/Person.pm (rev 0)
+++ DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result/Person.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,178 @@
+package #hide from pause
+ DBICNGTest::Schema::Result::Person;
+
+ use Moose;
+ use DateTime;
+ extends 'DBICNGTest::Schema::Result';
+
+
+=head1 NAME
+
+DBICNGTest::Schema::Result::Person; An example Person Class;
+
+=head1 DESCRIPTION
+
+Tests for this type of FK relationship
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head2 created
+
+attribute for the created column
+
+=cut
+
+has 'created' => (
+ is=>'ro',
+ isa=>'DateTime',
+ required=>1,
+ default=>sub {
+ DateTime->now;
+ },
+);
+
+
+=head1 PACKAGE METHODS
+
+This module defines the following package methods
+
+=head2 table
+
+Name of the Physical table in the database
+
+=cut
+
+__PACKAGE__
+ ->table('person');
+
+
+=head2 add_columns
+
+Add columns and meta information
+
+=head3 person_id
+
+Primary Key which is an auto generated autoinc
+
+=head3 fk_gender_id
+
+foreign key to the Gender table
+
+=head3 name
+
+Just an ordinary name
+
+=head3 age
+
+The person's age
+
+head3 created
+
+When the person was added to the database
+
+=cut
+
+__PACKAGE__
+ ->add_columns(
+ person_id => {
+ data_type=>'integer',
+ },
+ fk_gender_id => {
+ data_type=>'integer',
+ },
+ name => {
+ data_type=>'varchar',
+ size=>32,
+ },
+ age => {
+ data_type=>'integer',
+ default_value=>25,
+ },
+ created => {
+ data_type=>'datetime',
+ default_value=>'date("now")',
+ });
+
+
+=head2 primary_key
+
+Sets the Primary keys for this table
+
+=cut
+
+__PACKAGE__
+ ->set_primary_key(qw/person_id/);
+
+
+=head2 friendlist
+
+Each Person might have a resultset of friendlist
+
+=cut
+
+__PACKAGE__
+ ->has_many(
+ friendlist => 'DBICNGTest::Schema::Result::FriendList',
+ {'foreign.fk_person_id' => 'self.person_id'});
+
+
+=head2 gender
+
+This person's gender
+
+=cut
+
+__PACKAGE__
+ ->belongs_to( gender => 'DBICNGTest::Schema::Result::Gender', {
+ 'foreign.gender_id' => 'self.fk_gender_id' });
+
+
+=head2 fanlist
+
+A resultset of the people listing me as a friend (if any)
+
+=cut
+
+__PACKAGE__
+ ->belongs_to( fanlist => 'DBICNGTest::Schema::Result::FriendList', {
+ 'foreign.fk_friend_id' => 'self.person_id' });
+
+
+=head2 friends
+
+A resultset of Persons who are in my FriendList
+
+=cut
+
+__PACKAGE__
+ ->many_to_many( friends => 'friendlist', 'friend' );
+
+
+=head2 fans
+
+A resultset of people that have me in their friendlist
+
+=cut
+
+__PACKAGE__
+ ->many_to_many( fans => 'fanlist', 'befriender' );
+
+
+=head1 METHODS
+
+This module defines the following methods.
+
+=head1 AUTHORS
+
+See L<DBIx::Class> for more information regarding authors.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+
+1;
Added: DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result.pm (rev 0)
+++ DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/Result.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,83 @@
+package # hide from PAUSE
+ DBICNGTest::Schema::Result;
+
+ use Moose;
+ extends 'DBIx::Class', 'Moose::Object';
+
+=head1 NAME
+
+DBICNGTest::Schema::Result; Base Class for result and class objects
+
+=head1 SYNOPSIS
+
+ package DBICNGTest::Schema::Result::Member;
+
+ use Moose;
+ extends 'DBICNGTest::Schema::Result';
+
+ ## Rest of the class definition.
+
+=head1 DESCRIPTION
+
+Defines the base case for loading DBIC Schemas. We add in some additional
+helpful functions for administering you schemas. This namespace is dedicated
+to integration of Moose based development practices
+
+=head1 PACKAGE METHODS
+
+The following is a list of package methods declared with this class.
+
+=head2 load_components
+
+Components to preload.
+
+=cut
+
+__PACKAGE__->load_components(qw/
+ PK::Auto
+ InflateColumn::DateTime
+ Core
+/);
+
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head1 METHODS
+
+This module declares the following methods
+
+=head2 new
+
+overload new to make sure we get a good meta object and that the attributes all
+get properly setup. This is done so that our instances properly get a L<Moose>
+meta class.
+
+=cut
+
+sub new
+{
+ my $class = shift @_;
+ my $attrs = shift @_;
+
+ my $obj = $class->SUPER::new($attrs);
+
+ return $class->meta->new_object(
+ __INSTANCE__ => $obj, %$attrs
+ );
+}
+
+
+=head1 AUTHORS
+
+See L<DBIx::Class> for more information regarding authors.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+
+1;
\ No newline at end of file
Added: DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/ResultSet/Person.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/ResultSet/Person.pm (rev 0)
+++ DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/ResultSet/Person.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,95 @@
+package # hide from pause
+ DBICNGTest::Schema::ResultSet::Person;
+
+ use Moose;
+ extends 'DBICNGTest::Schema::ResultSet';
+
+
+=head1 NAME
+
+DBICNGTest::Schema::ResultSet:Person; Example Resultset
+
+=head1 VERSION
+
+0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+
+=head1 SYNOPSIS
+
+ ##Example Usage
+
+See Tests for more example usage.
+
+=head1 DESCRIPTION
+
+Resultset Methods for the Person Source
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head2 literal
+
+a literal attribute for testing
+
+=cut
+
+has 'literal' => (is=>'ro', isa=>'Str', required=>1, lazy=>1, default=>'hi');
+
+
+=head2 available_genders
+
+A resultset of the genders people can have. Keep in mind this get's run once
+only at the first compile, so it's only good for stuff that doesn't change
+between reboots.
+
+=cut
+
+has 'available_genders' => (
+ is=>'ro',
+ isa=>'DBICNGTest::Schema::ResultSet',
+ required=>1,
+ lazy=>1,
+ default=> sub {
+ shift
+ ->result_source
+ ->schema
+ ->resultset('Gender');
+ }
+);
+
+
+=head1 METHODS
+
+This module defines the following methods.
+
+=head2 older_than($int)
+
+Only people over a given age
+
+=cut
+
+sub older_than
+{
+ my ($self, $age) = @_;
+
+ return $self->search({age=>{'>'=>$age}});
+}
+
+
+=head1 AUTHORS
+
+See L<DBIx::Class> for more information regarding authors.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+
+1;
Added: DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/ResultSet.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/ResultSet.pm (rev 0)
+++ DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema/ResultSet.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,68 @@
+package # hide from PAUSE
+ DBICNGTest::Schema::ResultSet;
+
+ use Moose;
+ extends 'DBIx::Class::ResultSet', 'Moose::Object';
+
+=head1 NAME
+
+DBICNGTest::Schema::ResultSet; A base ResultSet Class
+
+=head1 SYNOPSIS
+
+ package DBICNGTest::Schema::ResultSet::Member;
+
+ use Moose;
+ extends 'DBICNGTest::Schema::ResultSet';
+
+ ## Rest of the class definition.
+
+=head1 DESCRIPTION
+
+All ResultSet classes will inherit from this. This provides some base function
+for all your resultsets and it is also the default resultset if you don't
+bother to declare a custom resultset in the resultset namespace
+
+=head1 PACKAGE METHODS
+
+The following is a list of package methods declared with this class.
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head1 METHODS
+
+This module declares the following methods
+
+=head2 new
+
+overload new to make sure we get a good meta object and that the attributes all
+get properly setup. This is done so that our instances properly get a L<Moose>
+meta class.
+
+=cut
+
+sub new
+{
+ my $class = shift @_;
+ my $obj = $class->SUPER::new(@_);
+
+ return $class->meta->new_object(
+ __INSTANCE__ => $obj, @_
+ );
+}
+
+
+=head1 AUTHORS
+
+See L<DBIx::Class> for more information regarding authors.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+
+1;
\ No newline at end of file
Added: DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema.pm (rev 0)
+++ DBIx-Class/0.09/trunk/t/lib/DBICNGTest/Schema.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,162 @@
+package # hide from PAUSE
+ DBICNGTest::Schema;
+
+ use Moose;
+ use Path::Class::File;
+ extends 'DBIx::Class::Schema', 'Moose::Object';
+
+
+=head1 NAME
+
+DBICNGTest::Schema; Schema Base For Testing Moose Roles, Traits, etc.
+
+=head1 SYNOPSIS
+
+ my $schema = DBICNGTest::Schema->connect($dsn);
+
+ ## Do anything you would as with a normal $schema object.
+
+=head1 DESCRIPTION
+
+Defines the base case for loading DBIC Schemas. We add in some additional
+helpful functions for administering you schemas. This namespace is dedicated
+to integration of Moose based development practices.
+
+=head1 PACKAGE METHODS
+
+The following is a list of package methods declared with this class.
+
+=head2 load_namespaces
+
+Automatically load the classes and resultsets from their default namespaces.
+
+=cut
+
+__PACKAGE__->load_namespaces(
+ default_resultset_class => 'ResultSet',
+);
+
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head1 METHODS
+
+This module declares the following methods
+
+=head2 new
+
+overload new to make sure we get a good meta object and that the attributes all
+get properly setup. This is done so that our instances properly get a L<Moose>
+meta class.
+
+=cut
+
+sub new
+{
+ my $class = shift @_;
+ my $obj = $class->SUPER::new(@_);
+
+ return $class->meta->new_object(
+ __INSTANCE__ => $obj, @_
+ );
+}
+
+
+=head2 connect_and_setup
+
+Creates a schema, deploys a database and sets the testing data.
+
+=cut
+
+sub connect_and_setup {
+ my $class = shift @_;
+ my $db_file = shift @_;
+
+ my ($dsn, $user, $pass) = (
+ $ENV{DBICNG_DSN} || "dbi:SQLite:${db_file}",
+ $ENV{DBICNG_USER} || '',
+ $ENV{DBICNG_PASS} || '',
+ );
+
+ return $class
+ ->connect($dsn, $user, $pass, { AutoCommit => 1 })
+ ->setup;
+}
+
+
+=head2 setup
+
+deploy a database and populate it with the initial data
+
+=cut
+
+sub setup {
+ my $self = shift @_;
+ $self->deploy();
+ $self->initial_populate(@_);
+
+ return $self;
+}
+
+
+=head2 initial_populate
+
+initializing the startup database information
+
+=cut
+
+sub initial_populate {
+ my $self = shift @_;
+
+ my @genders = $self->populate('Gender' => [
+ [qw(gender_id label)],
+ [qw(1 female)],
+ [qw(2 male)],
+ [qw(3 transgender)],
+ ]);
+
+ my @persons = $self->populate('Person' => [
+ [ qw(person_id fk_gender_id name age) ],
+ [ qw(1 1 john 25) ],
+ [ qw(2 1 dan 35) ],
+ [ qw(3 2 mary 15) ],
+ [ qw(4 2 jane 95) ],
+ [ qw(5 3 steve 40) ],
+ ]);
+
+ my @friends = $self->populate('FriendList' => [
+ [ qw(fk_person_id fk_friend_id) ],
+ [ qw(1 2) ],
+ [ qw(1 3) ],
+ [ qw(2 3) ],
+ [ qw(3 2) ],
+ ]);
+}
+
+
+=head2 job_handler_echo
+
+This is a method to test the job handler role.
+
+=cut
+
+sub job_handler_echo {
+ my ($schema, $job, $alert) = @_;
+ return $alert;
+}
+
+
+=head1 AUTHORS
+
+See L<DBIx::Class> for more information regarding authors.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+
+1;
Modified: DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/CD.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/CD.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/CD.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -24,7 +24,7 @@
__PACKAGE__->set_primary_key('cdid');
__PACKAGE__->add_unique_constraint([ qw/artist title/ ]);
-__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist' );
+__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist', undef, { is_deferrable => 1 } );
__PACKAGE__->has_many( tracks => 'DBICTest::Schema::Track' );
__PACKAGE__->has_many(
Modified: DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/FileColumn.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/FileColumn.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/FileColumn.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -4,6 +4,7 @@
use strict;
use warnings;
use base qw/DBIx::Class::Core/;
+use File::Temp qw/tempdir/;
__PACKAGE__->load_components(qw/InflateColumn::File/);
@@ -11,7 +12,12 @@
__PACKAGE__->add_columns(
id => { data_type => 'integer', is_auto_increment => 1 },
- file => { data_type => 'varchar', is_file_column => 1, file_column_path => '/tmp', size=>255 }
+ file => {
+ data_type => 'varchar',
+ is_file_column => 1,
+ file_column_path => tempdir(CLEANUP => 1),
+ size => 255
+ }
);
__PACKAGE__->set_primary_key('id');
Added: DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/LongColumns.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/LongColumns.pm (rev 0)
+++ DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/LongColumns.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,64 @@
+package # hide from PAUSE
+ DBICTest::Schema::LongColumns;
+
+use base qw/DBIx::Class::Core/;
+
+__PACKAGE__->table('long_columns');
+__PACKAGE__->add_columns(
+ 'lcid' => {
+ data_type => 'int',
+ is_auto_increment => 1,
+ },
+ '64_character_column_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa' => {
+ data_type => 'int',
+ },
+ '32_character_column_aaaaaaaaaaaa' => {
+ data_type => 'int',
+ },
+ '32_character_column_bbbbbbbbbbbb' => {
+ data_type => 'int',
+ },
+ '16_character_col' => {
+ data_type => 'int',
+ },
+ '8_char_c' => {
+ data_type => 'int',
+ },
+);
+
+__PACKAGE__->set_primary_key('lcid');
+
+__PACKAGE__->add_unique_constraint([qw( 16_character_col 32_character_column_aaaaaaaaaaaa )]);
+
+__PACKAGE__->add_unique_constraint([qw( 8_char_c 16_character_col 32_character_column_aaaaaaaaaaaa )]);
+
+__PACKAGE__->add_unique_constraint([qw( 8_char_c 16_character_col 32_character_column_bbbbbbbbbbbb )]);
+
+__PACKAGE__->add_unique_constraint([qw( 64_character_column_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa )]);
+
+__PACKAGE__->belongs_to(
+ 'owner',
+ 'DBICTest::Schema::LongColumns',
+ {
+ 'foreign.lcid' => 'self.64_character_column_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa',
+ },
+);
+
+__PACKAGE__->belongs_to(
+ 'owner2',
+ 'DBICTest::Schema::LongColumns',
+ {
+ 'foreign.32_character_column_aaaaaaaaaaaa' => 'self.32_character_column_bbbbbbbbbbbb',
+ 'foreign.32_character_column_bbbbbbbbbbbb' => 'self.32_character_column_aaaaaaaaaaaa',
+ },
+);
+
+__PACKAGE__->belongs_to(
+ 'owner3',
+ 'DBICTest::Schema::LongColumns',
+ {
+ 'foreign.8_char_c' => 'self.16_character_col',
+ },
+);
+
+1;
Added: DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/SequenceTest.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/SequenceTest.pm (rev 0)
+++ DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/SequenceTest.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,37 @@
+package # hide from PAUSE
+ DBICTest::Schema::SequenceTest;
+
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table('sequence_test');
+__PACKAGE__->source_info({
+ "source_info_key_A" => "source_info_value_A",
+ "source_info_key_B" => "source_info_value_B",
+ "source_info_key_C" => "source_info_value_C",
+ "source_info_key_D" => "source_info_value_D",
+});
+__PACKAGE__->add_columns(
+ 'pkid1' => {
+ data_type => 'integer',
+ auto_nextval => 1,
+ sequence => 'pkid1_seq',
+ },
+ 'pkid2' => {
+ data_type => 'integer',
+ auto_nextval => 1,
+ sequence => 'pkid2_seq',
+ },
+ 'nonpkid' => {
+ data_type => 'integer',
+ auto_nextval => 1,
+ sequence => 'nonpkid_seq',
+ },
+ 'name' => {
+ data_type => 'varchar',
+ size => 100,
+ is_nullable => 1,
+ },
+);
+__PACKAGE__->set_primary_key('pkid1', 'pkid2');
+
+1;
Modified: DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/TwoKeys.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/TwoKeys.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema/TwoKeys.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -11,7 +11,7 @@
__PACKAGE__->set_primary_key(qw/artist cd/);
__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist' );
-__PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD' );
+__PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD', undef, { is_deferrable => 0 } );
__PACKAGE__->has_many(
'fourkeys_to_twokeys', 'DBICTest::Schema::FourKeys_to_TwoKeys', {
Modified: DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/lib/DBICTest/Schema.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -7,6 +7,7 @@
__PACKAGE__->load_classes(qw/
Artist
+ SequenceTest
Employee
CD
FileColumn
@@ -37,7 +38,8 @@
qw/SelfRefAlias TreeLike TwoKeyTreeLike Event EventTZ NoPrimaryKey/,
qw/Collection CollectionObject TypedObject/,
qw/Owners BooksInLibrary/,
- qw/ForceForeign/
+ qw/ForceForeign/,
+ qw/LongColumns/,
);
sub sqlt_deploy_hook {
Added: DBIx-Class/0.09/trunk/t/lib/DBICTest/Stats.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICTest/Stats.pm (rev 0)
+++ DBIx-Class/0.09/trunk/t/lib/DBICTest/Stats.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,63 @@
+package DBICTest::Stats;
+use strict;
+use warnings;
+
+use base qw/DBIx::Class::Storage::Statistics/;
+
+sub txn_begin {
+ my $self = shift;
+
+ $self->{'TXN_BEGIN'}++;
+ return $self->{'TXN_BEGIN'};
+}
+
+sub txn_rollback {
+ my $self = shift;
+
+ $self->{'TXN_ROLLBACK'}++;
+ return $self->{'TXN_ROLLBACK'};
+}
+
+sub txn_commit {
+ my $self = shift;
+
+ $self->{'TXN_COMMIT'}++;
+ return $self->{'TXN_COMMIT'};
+}
+
+sub svp_begin {
+ my ($self, $name) = @_;
+
+ $self->{'SVP_BEGIN'}++;
+ return $self->{'SVP_BEGIN'};
+}
+
+sub svp_release {
+ my ($self, $name) = @_;
+
+ $self->{'SVP_RELEASE'}++;
+ return $self->{'SVP_RELEASE'};
+}
+
+sub svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->{'SVP_ROLLBACK'}++;
+ return $self->{'SVP_ROLLBACK'};
+}
+
+sub query_start {
+ my ($self, $string, @bind) = @_;
+
+ $self->{'QUERY_START'}++;
+ return $self->{'QUERY_START'};
+}
+
+sub query_end {
+ my ($self, $string) = @_;
+
+ $self->{'QUERY_END'}++;
+ return $self->{'QUERY_START'};
+}
+
+1;
Added: DBIx-Class/0.09/trunk/t/lib/DBICTest/SyntaxErrorComponent3.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICTest/SyntaxErrorComponent3.pm (rev 0)
+++ DBIx-Class/0.09/trunk/t/lib/DBICTest/SyntaxErrorComponent3.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,5 @@
+package DBICErrorTest::SyntaxError;
+
+use strict;
+
+I'm a syntax error!
Modified: DBIx-Class/0.09/trunk/t/lib/DBICVersionNew.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/lib/DBICVersionNew.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/lib/DBICVersionNew.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -21,9 +21,17 @@
'is_auto_increment' => 0,
'default_value' => undef,
'is_foreign_key' => 0,
+ 'is_nullable' => 0,
+ 'size' => '10'
+ },
+ 'NewVersionName' => {
+ 'data_type' => 'VARCHAR',
+ 'is_auto_increment' => 0,
+ 'default_value' => undef,
+ 'is_foreign_key' => 0,
'is_nullable' => 1,
'size' => '20'
- },
+ }
);
__PACKAGE__->set_primary_key('Version');
Added: DBIx-Class/0.09/trunk/t/relationship_after_update.t
===================================================================
--- DBIx-Class/0.09/trunk/t/relationship_after_update.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/relationship_after_update.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,30 @@
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 2;
+
+my $bookmark = $schema->resultset("Bookmark")->find(1);
+my $link = $bookmark->link;
+my $link_id = $link->id;
+
+my $new_link = $schema->resultset("Link")->new({
+ id => 42,
+ url => "http://monstersarereal.com",
+ title => "monstersarereal.com"
+});
+
+# Changing a relationship by id rather than by object would cause
+# old related_resultsets to be used.
+$bookmark->link($new_link->id);
+is $bookmark->link->id, $new_link->id;
+
+$bookmark->update;
+is $bookmark->link->id, $new_link->id;
Added: DBIx-Class/0.09/trunk/t/relationship_doesnt_exist.t
===================================================================
--- DBIx-Class/0.09/trunk/t/relationship_doesnt_exist.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/relationship_doesnt_exist.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,30 @@
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 3;
+
+my $bookmark = $schema->resultset("Bookmark")->find(1);
+my $link = $bookmark->link;
+my $link_id = $link->id;
+ok $link->id;
+
+$link->delete;
+is $schema->resultset("Link")->search(id => $link_id)->count, 0,
+ "link $link_id was deleted";
+
+# Get a fresh object with nothing cached
+$bookmark = $schema->resultset("Bookmark")->find($bookmark->id);
+
+# This would create a new link row if none existed
+$bookmark->link;
+
+is $schema->resultset("Link")->search(id => $link_id)->count, 0,
+ 'accessor did not create a link object where there was none';
Added: DBIx-Class/0.09/trunk/t/resultset_overload.t
===================================================================
--- DBIx-Class/0.09/trunk/t/resultset_overload.t (rev 0)
+++ DBIx-Class/0.09/trunk/t/resultset_overload.t 2008-04-25 15:03:12 UTC (rev 4291)
@@ -0,0 +1,26 @@
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 6;
+
+{
+ my $rs = $schema->resultset("CD")->search({});
+
+ ok $rs->count;
+ is $rs, $rs->count, "resultset as number with results";
+ ok $rs, "resultset as boolean always true";
+}
+
+{
+ my $rs = $schema->resultset("CD")->search({ title => "Does not exist" });
+
+ ok !$rs->count;
+ is $rs, $rs->count, "resultset as number without results";
+ ok $rs, "resultset as boolean always true";
+}
\ No newline at end of file
Modified: DBIx-Class/0.09/trunk/t/testlib/Actor.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/testlib/Actor.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/testlib/Actor.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -15,7 +15,7 @@
__PACKAGE__->columns(TEMP => qw/ nonpersistent /);
__PACKAGE__->add_constructor(salary_between => 'salary >= ? AND salary <= ?');
-sub mutator_name { "set_$_[1]" }
+sub mutator_name_for { "set_$_[1]" }
sub create_sql {
return qq{
Modified: DBIx-Class/0.09/trunk/t/testlib/MyBase.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/testlib/MyBase.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/testlib/MyBase.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -2,8 +2,10 @@
MyBase;
use strict;
-use base qw(DBIx::Class);
+use base qw(DBIx::Class::CDBICompat);
+use DBI;
+
use vars qw/$dbh/;
my @connect = ("dbi:mysql:test", "", "");
Modified: DBIx-Class/0.09/trunk/t/testlib/MyFoo.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/testlib/MyFoo.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/testlib/MyFoo.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -13,7 +13,7 @@
inflate => sub { Date::Simple->new(shift) },
deflate => 'format',
);
-__PACKAGE__->find_column('tdate')->placeholder("IF(1, CURDATE(), ?)");
+#__PACKAGE__->find_column('tdate')->placeholder("IF(1, CURDATE(), ?)");
sub create_sql {
return qq{
Modified: DBIx-Class/0.09/trunk/t/testlib/PgBase.pm
===================================================================
--- DBIx-Class/0.09/trunk/t/testlib/PgBase.pm 2008-04-24 09:04:15 UTC (rev 4290)
+++ DBIx-Class/0.09/trunk/t/testlib/PgBase.pm 2008-04-25 15:03:12 UTC (rev 4291)
@@ -2,7 +2,7 @@
PgBase;
use strict;
-use base 'DBIx::Class';
+use base 'DBIx::Class::CDBICompat';
my $db = $ENV{DBD_PG_DBNAME} || 'template1';
my $user = $ENV{DBD_PG_USER} || 'postgres';
More information about the Bast-commits
mailing list