[Bast-commits] r4234 - in
DBIx-Class/0.08/branches/storage-ms-access: . 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/Serialize
lib/DBIx/Class/Storage lib/DBIx/Class/Storage/DBI
lib/DBIx/Class/Storage/DBI/Oracle
lib/SQL/Translator/Parser/DBIx t t/cdbi-DeepAbstractSearch
t/cdbi-abstract t/cdbi-t t/lib t/lib/DBICTest
t/lib/DBICTest/Schema t/testlib
matthewt at dev.catalyst.perl.org
matthewt at dev.catalyst.perl.org
Mon Mar 24 19:24:19 GMT 2008
Author: matthewt
Date: 2008-03-24 19:24:19 +0000 (Mon, 24 Mar 2008)
New Revision: 4234
Added:
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/AbstractSearch.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Copy.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Iterator.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Relationship.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Relationships.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/SQLTransformer.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/TxnScopeGuard.pm
DBIx-Class/0.08/branches/storage-ms-access/t/93storage_replication.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-DeepAbstractSearch/
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-DeepAbstractSearch/01_search.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-abstract/
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-abstract/search_where.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/08-inheritcols.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/22-deflate_order.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/23-cascade.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/24-meta_info.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/26-mutator.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/columns_as_hashes.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/columns_dont_override_custom_accessors.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/construct.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/copy.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/early_column_heisenbug.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/has_many_loads_foreign_class.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/hasa_without_loading.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/max_min_value_of.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/multi_column_set.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/object_cache.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/retrieve_from_sql_with_limit.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/set_to_undef.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/set_vs_DateTime.t
DBIx-Class/0.08/branches/storage-ms-access/t/dbh_do.t
DBIx-Class/0.08/branches/storage-ms-access/t/deleting_many_to_many.t
DBIx-Class/0.08/branches/storage-ms-access/t/discard_changes_in_DESTROY.t
DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema/SequenceTest.pm
DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Stats.pm
DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/SyntaxErrorComponent3.pm
DBIx-Class/0.08/branches/storage-ms-access/t/relationship_after_update.t
DBIx-Class/0.08/branches/storage-ms-access/t/relationship_doesnt_exist.t
DBIx-Class/0.08/branches/storage-ms-access/t/resultset_overload.t
Removed:
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/HasA.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/HasMany.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/MightHave.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm
Modified:
DBIx-Class/0.08/branches/storage-ms-access/
DBIx-Class/0.08/branches/storage-ms-access/Changes
DBIx-Class/0.08/branches/storage-ms-access/Makefile.PL
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/AccessorMapping.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ColumnCase.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Constructor.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/GetSet.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ImaDBI.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/LazyLoading.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Retrieve.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/TempColumns.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Triggers.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/DB.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/InflateColumn/File.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Manual/Cookbook.pod
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Manual/FAQ.pod
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/PK.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Relationship/Accessor.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Relationship/Base.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/ResultSet.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/ResultSource.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/ResultSourceHandle.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/ResultSourceProxy/Table.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Row.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Schema.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Schema/Versioned.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Serialize/Storable.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Oracle.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Pg.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Replication.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/SQLite.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/mysql.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/Statistics.pm
DBIx-Class/0.08/branches/storage-ms-access/lib/SQL/Translator/Parser/DBIx/Class.pm
DBIx-Class/0.08/branches/storage-ms-access/t/03podcoverage.t
DBIx-Class/0.08/branches/storage-ms-access/t/18inserterror.t
DBIx-Class/0.08/branches/storage-ms-access/t/71mysql.t
DBIx-Class/0.08/branches/storage-ms-access/t/72pg.t
DBIx-Class/0.08/branches/storage-ms-access/t/73oracle.t
DBIx-Class/0.08/branches/storage-ms-access/t/745db2.t
DBIx-Class/0.08/branches/storage-ms-access/t/75limit.t
DBIx-Class/0.08/branches/storage-ms-access/t/81transactions.t
DBIx-Class/0.08/branches/storage-ms-access/t/84serialize.t
DBIx-Class/0.08/branches/storage-ms-access/t/86sqlt.t
DBIx-Class/0.08/branches/storage-ms-access/t/90ensure_class_loaded.t
DBIx-Class/0.08/branches/storage-ms-access/t/94versioning.t
DBIx-Class/0.08/branches/storage-ms-access/t/96file_column.t
DBIx-Class/0.08/branches/storage-ms-access/t/96multi_create.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/01-columns.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/02-Film.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/04-lazy.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/06-hasa.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/13-constraint.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/14-might_have.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/15-accessor.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/19-set_sql.t
DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/21-iterator.t
DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema.pm
DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema/CD.pm
DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema/FileColumn.pm
DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema/TwoKeys.pm
DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICVersionNew.pm
DBIx-Class/0.08/branches/storage-ms-access/t/testlib/Actor.pm
DBIx-Class/0.08/branches/storage-ms-access/t/testlib/MyBase.pm
DBIx-Class/0.08/branches/storage-ms-access/t/testlib/MyFoo.pm
DBIx-Class/0.08/branches/storage-ms-access/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.
Property changes on: DBIx-Class/0.08/branches/storage-ms-access
___________________________________________________________________
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:/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/versioned_enhancements:4125
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/trunk:4232
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
Modified: DBIx-Class/0.08/branches/storage-ms-access/Changes
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/Changes 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/Changes 2008-03-24 19:24:19 UTC (rev 4234)
@@ -1,5 +1,16 @@
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.
+
+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.08/branches/storage-ms-access/Makefile.PL
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/Makefile.PL 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/Makefile.PL 2008-03-24 19:24:19 UTC (rev 4234)
@@ -24,6 +24,8 @@
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 +35,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 +45,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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/AbstractSearch.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/AbstractSearch.pm (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/AbstractSearch.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/AccessorMapping.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/AccessorMapping.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/AccessorMapping.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ColumnCase.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ColumnCase.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ColumnCase.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ColumnGroups.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ColumnGroups.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Constructor.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Constructor.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Constructor.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Copy.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Copy.pm (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Copy.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/GetSet.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/GetSet.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/GetSet.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/HasA.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/HasA.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/HasA.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/HasMany.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/HasMany.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/HasMany.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ImaDBI.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ImaDBI.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ImaDBI.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Iterator.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Iterator.pm (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Iterator.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/LazyLoading.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/LazyLoading.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/LazyLoading.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/MightHave.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/MightHave.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/MightHave.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Relationship.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Relationship.pm (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Relationship.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Relationships.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Relationships.pm (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Relationships.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Retrieve.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Retrieve.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Retrieve.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/SQLTransformer.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/SQLTransformer.pm (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/SQLTransformer.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/TempColumns.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/TempColumns.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/TempColumns.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Triggers.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Triggers.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat/Triggers.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/CDBICompat.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -15,7 +15,6 @@
Constraints
Triggers
ReadOnly
- GetSet
LiveObjectIndex
AttributeAPI
Stringify
@@ -23,16 +22,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 +46,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 +101,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.08/branches/storage-ms-access/lib/DBIx/Class/DB.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/DB.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/DB.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/InflateColumn/File.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/InflateColumn/File.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/InflateColumn/File.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/Manual/Cookbook.pod
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Manual/Cookbook.pod 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Manual/Cookbook.pod 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/Manual/FAQ.pod
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Manual/FAQ.pod 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Manual/FAQ.pod 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/PK.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/PK.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/PK.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/Relationship/Accessor.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Relationship/Accessor.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Relationship/Accessor.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/Relationship/Base.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Relationship/Base.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Relationship/Base.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/ResultSet.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/ResultSet.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/ResultSet.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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
@@ -996,6 +1000,10 @@
return $count;
}
+sub _bool {
+ return 1;
+}
+
=head2 count_literal
=over 4
@@ -2124,7 +2132,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.08/branches/storage-ms-access/lib/DBIx/Class/ResultSource.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/ResultSource.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/ResultSource.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/ResultSourceHandle.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/ResultSourceHandle.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/ResultSourceHandle.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/ResultSourceProxy/Table.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/ResultSourceProxy/Table.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/ResultSourceProxy/Table.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/Row.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Row.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Row.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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
Modified: DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Schema/Versioned.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Schema/Versioned.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Schema/Versioned.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -4,28 +4,43 @@
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 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;
@@ -35,8 +50,67 @@
__PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');
+package 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 +122,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 +145,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 +177,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 +195,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 +351,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 +374,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.08/branches/storage-ms-access/lib/DBIx/Class/Schema.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Schema.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Schema.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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
Modified: DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Serialize/Storable.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Serialize/Storable.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Serialize/Storable.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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');
Modified: DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Oracle.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Oracle.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Oracle.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Pg.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Pg.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Pg.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Replication.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Replication.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/Replication.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -89,9 +89,9 @@
# 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];
+ @dsns = map { ($_->[3]->{priority} || 10) => $_ } @{$info->[0]}[1..@{$info->[0]}-1];
$global_options->{dsns} = \@dsns;
$self->read_source->connect_info( [ 'dbi:Multi:', undef, undef, { %$global_options } ] );
Modified: DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/SQLite.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/SQLite.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/SQLite.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/mysql.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/mysql.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI/mysql.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/DBI.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -14,7 +14,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/
);
__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
@@ -429,6 +430,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 +449,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 +523,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 +552,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 +583,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 +596,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 +621,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 +634,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 +775,8 @@
return $self->_sql_maker;
}
+sub _rebless {}
+
sub _populate_dbh {
my ($self) = @_;
my @info = @{$self->_dbi_connect_info || []};
@@ -776,7 +790,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 +875,60 @@
$dbh;
}
+sub svp_begin {
+ my ($self, $name) = @_;
+
+ $self->throw_exception("You failed to provide a savepoint name!") if !$name;
+ if($self->{transaction_depth} == 0) {
+ warn("Can't use savepoints without a transaction.");
+ return 0;
+ }
+
+ if(!$self->can('_svp_begin')) {
+ warn("Your Storage implementation doesn't support savepoints!");
+ return 0;
+ }
+ $self->debugobj->svp_begin($name) if $self->debug;
+ $self->_svp_begin($name);
+}
+
+sub svp_release {
+ my ($self, $name) = @_;
+
+ $self->throw_exception("You failed to provide a savepoint name!") if !$name;
+
+ if($self->{transaction_depth} == 0) {
+ warn("Can't use savepoints without a transaction.");
+ return 0;
+ }
+
+ if(!$self->can('_svp_release')) {
+ warn("Your Storage implementation doesn't support savepoint releasing!");
+ return 0;
+ }
+ $self->debugobj->svp_release($name) if $self->debug;
+ $self->_svp_release($name);
+}
+
+sub svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->throw_exception("You failed to provide a savepoint name!") if !$name;
+
+ if($self->{transaction_depth} == 0) {
+ warn("Can't use savepoints without a transaction.");
+ return 0;
+ }
+
+ if(!$self->can('_svp_rollback')) {
+ warn("Your Storage implementation doesn't support savepoints!");
+ return 0;
+ }
+ $self->debugobj->svp_rollback($name) if $self->debug;
+ $self->_svp_rollback($name);
+}
+
sub txn_begin {
my $self = shift;
$self->ensure_connected();
@@ -872,6 +939,8 @@
# we should reconnect on begin_work
# for AutoCommit users
$self->dbh->begin_work;
+ } elsif ($self->auto_savepoint) {
+ $self->svp_begin ("savepoint_$self->{transaction_depth}");
}
$self->{transaction_depth}++;
}
@@ -887,7 +956,9 @@
if $self->_dbh_autocommit;
}
elsif($self->{transaction_depth} > 1) {
- $self->{transaction_depth}--
+ $self->{transaction_depth}--;
+ $self->svp_release ("savepoint_$self->{transaction_depth}")
+ if $self->auto_savepoint;
}
}
@@ -904,6 +975,10 @@
}
elsif($self->{transaction_depth} > 1) {
$self->{transaction_depth}--;
+ if ($self->auto_savepoint) {
+ $self->svp_rollback ("savepoint_$self->{transaction_depth}");
+ $self->svp_release ("savepoint_$self->{transaction_depth}");
+ }
}
else {
die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
@@ -1010,7 +1085,7 @@
sub _execute {
my $self = shift;
- $self->dbh_do($self->can('_dbh_execute'), @_)
+ $self->dbh_do('_dbh_execute', @_)
}
sub insert {
@@ -1019,6 +1094,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 +1208,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};
}
@@ -1198,7 +1287,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 +1349,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 +1366,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 +1418,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 +1439,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 +1466,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 +1474,42 @@
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;
+ }
+
+ 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 +1573,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 +1658,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.08/branches/storage-ms-access/lib/DBIx/Class/Storage/Statistics.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/Statistics.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/Statistics.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/Storage/TxnScopeGuard.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/TxnScopeGuard.pm (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage/TxnScopeGuard.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/lib/DBIx/Class/Storage.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class/Storage.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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,50 @@
sub txn_rollback { die "Virtual method!" }
+=head2 svp_begin
+
+Arguments: $savepoint_name
+
+Establishes a new savepoint of the specified name within the current
+transaction.
+
+=cut
+
+sub svp_begin { die "Virtual method!" }
+
+=head2 svp_release
+
+Arguments: $savepoint_name
+
+Destroy a savepoint, but keep the effects of the commands executed since
+it's creation.
+
+=cut
+
+sub svp_release { die "Virtual method!" }
+
+=head2 svp_rollback
+
+Arguments: $savepoint_name
+
+Rollback to the savepoint of the specified name.
+
+=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
Modified: DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/DBIx/Class.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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>
@@ -274,6 +276,8 @@
sszabo: Stephan Szabo <sszabo at bigpanda.com>
+teejay : Aaron Trevena <teejay at cpan.org>
+
Todd Lipcon
Tom Hukins
Modified: DBIx-Class/0.08/branches/storage-ms-access/lib/SQL/Translator/Parser/DBIx/Class.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/lib/SQL/Translator/Parser/DBIx/Class.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/lib/SQL/Translator/Parser/DBIx/Class.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -9,9 +9,8 @@
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;
@@ -30,26 +29,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 +65,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 +95,29 @@
$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",
fields => $unique_constraints{$uniq}
);
+
+ my $index = $table->add_index(
+ # TODO: Pick a better than that wont conflict
+ name => $unique_constraints{$uniq}->[0],
+ 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,36 @@
# 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 => $table->name . "_fk_$keys[0]",
+ 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 => join('_', @keys),
+ fields => \@keys,
+ type => 'NORMAL',
+ );
+ }
}
}
@@ -174,8 +202,8 @@
}
}
- if ($dbixschema->can('sqlt_deploy_hook')) {
- $dbixschema->sqlt_deploy_hook($schema);
+ if ($dbicschema->can('sqlt_deploy_hook')) {
+ $dbicschema->sqlt_deploy_hook($schema);
}
return 1;
Modified: DBIx-Class/0.08/branches/storage-ms-access/t/03podcoverage.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/03podcoverage.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/03podcoverage.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/18inserterror.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/18inserterror.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/18inserterror.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/71mysql.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/71mysql.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/71mysql.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -5,6 +5,7 @@
use lib qw(t/lib);
use DBICTest;
use DBI::Const::GetInfoType;
+use DBICTest::Stats;
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
@@ -13,15 +14,18 @@
plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'
unless ($dsn && $user);
-plan tests => 5;
+plan tests => 9;
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
my $dbh = $schema->storage->dbh;
+my $stats = new DBICTest::Stats();
+$schema->storage->debugobj($stats);
+$schema->storage->debug(1);
$dbh->do("DROP TABLE IF EXISTS artist;");
-$dbh->do("CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(255), charfield CHAR(10));");
+$dbh->do("CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(255), charfield CHAR(10)) ENGINE=InnoDB;");
#'dbi:mysql:host=localhost;database=dbic_test', 'dbic_test', '');
@@ -68,6 +72,32 @@
},
};
+$schema->txn_begin();
+
+my $arty = $schema->resultset('Artist')->find(1);
+
+my $name = $arty->name();
+
+$schema->svp_begin('savepoint1');
+
+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');
+
+$schema->svp_rollback('savepoint1');
+
+cmp_ok($stats->{'SVP_ROLLBACK'}, '==', 1, 'Statistics svp_rollback tickled');
+
+$arty->discard_changes();
+
+cmp_ok($arty->name(), 'eq', $name, 'Name rolled back');
+
+$schema->txn_commit();
+
SKIP: {
my $mysql_version = $dbh->get_info( $GetInfoType{SQL_DBMS_VER} );
skip "Cannot determine MySQL server version", 1 if !$mysql_version;
Modified: DBIx-Class/0.08/branches/storage-ms-access/t/72pg.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/72pg.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/72pg.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -4,6 +4,7 @@
use Test::More;
use lib qw(t/lib);
use DBICTest;
+use DBICTest::Stats;
{
package DBICTest::Schema::Casecheck;
@@ -27,10 +28,10 @@
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 => 43;
DBICTest::Schema->load_classes( 'Casecheck' );
-my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { auto_savepoint => 1});
# Check that datetime_parser returns correctly before we explicitly connect.
SKIP: {
@@ -45,9 +46,18 @@
}
my $dbh = $schema->storage->dbh;
+my $stats = new DBICTest::Stats();
+$schema->storage->debugobj($stats);
+$schema->storage->debug(1);
+
$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 +186,96 @@
});
}
+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");
+}
+
+$schema->txn_begin();
+
+my $arty = $schema->resultset('Artist')->find(1);
+
+my $name = $arty->name();
+
+$schema->svp_begin('savepoint1');
+
+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');
+
+$schema->svp_rollback('savepoint1');
+
+cmp_ok($stats->{'SVP_ROLLBACK'}, '==', 1, 'Statistics svp_rollback tickled');
+
+$arty->discard_changes();
+
+cmp_ok($arty->name(), 'eq', $name, 'Name rolled back');
+
+$schema->txn_commit();
+
+$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'},'==',3,'Correct number of savepoints created');
+
+cmp_ok($stats->{'SVP_RELEASE'},'==',2,'Correct number of savepoints released');
+
+cmp_ok($stats->{'SVP_ROLLBACK'},'==',2,'Correct number of savepoint rollbacks');
+
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.08/branches/storage-ms-access/t/73oracle.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/73oracle.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/73oracle.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/745db2.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/745db2.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/745db2.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/75limit.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/75limit.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/75limit.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/81transactions.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/81transactions.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/81transactions.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/84serialize.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/84serialize.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/84serialize.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/86sqlt.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/86sqlt.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/86sqlt.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -10,7 +10,7 @@
my $schema = DBICTest->init_schema;
-plan tests => 60;
+plan tests => 77;
my $translator = SQL::Translator->new(
parser_args => {
@@ -42,13 +42,13 @@
'display' => 'twokeys->cd',
'selftable' => 'twokeys', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 0,
},
{
'display' => 'twokeys->artist',
'selftable' => 'twokeys', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
@@ -58,14 +58,14 @@
'display' => 'fourkeys_to_twokeys->twokeys',
'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',
'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,
},
],
@@ -75,13 +75,13 @@
'display' => 'cd_to_producer->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',
'selftable' => 'cd_to_producer', 'foreigntable' => 'producer',
'selfcols' => ['producer'], 'foreigncols' => ['producerid'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 1,
},
],
@@ -91,13 +91,13 @@
'display' => 'self_ref_alias->self_ref for 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',
'selftable' => 'self_ref_alias', 'foreigntable' => 'self_ref',
'selfcols' => ['alias'], 'foreigncols' => ['id'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 1,
},
],
@@ -107,7 +107,7 @@
'display' => 'cd->artist',
'selftable' => 'cd', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
@@ -117,13 +117,13 @@
'display' => 'artist_undirected_map->artist for 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',
'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist',
'selfcols' => ['id2'], 'foreigncols' => ['artistid'],
- on_delete => 'CASCADE', on_update => '',
+ on_delete => 'CASCADE', on_update => '', deferrable => 1,
},
],
@@ -133,7 +133,7 @@
'display' => 'track->cd',
'selftable' => 'track', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
@@ -143,7 +143,7 @@
'display' => 'treelike->treelike for parent',
'selftable' => 'treelike', 'foreigntable' => 'treelike',
'selfcols' => ['parent'], 'foreigncols' => ['id'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
@@ -153,7 +153,7 @@
'display' => 'twokeytreelike->twokeytreelike for parent1,parent2',
'selftable' => 'twokeytreelike', 'foreigntable' => 'twokeytreelike',
'selfcols' => ['parent1', 'parent2'], 'foreigncols' => ['id1','id2'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 1,
},
],
@@ -163,7 +163,7 @@
'display' => 'tags->cd',
'selftable' => 'tags', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
@@ -173,7 +173,7 @@
'display' => 'bookmark->link',
'selftable' => 'bookmark', 'foreigntable' => 'link',
'selfcols' => ['link'], 'foreigncols' => ['id'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 1,
},
],
# ForceForeign
@@ -182,7 +182,7 @@
'display' => 'forceforeign->artist',
'selftable' => 'forceforeign', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artist_id'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 1,
},
],
@@ -359,4 +359,6 @@
"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'" );
}
Modified: DBIx-Class/0.08/branches/storage-ms-access/t/90ensure_class_loaded.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/90ensure_class_loaded.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/90ensure_class_loaded.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/93storage_replication.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/93storage_replication.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/93storage_replication.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -0,0 +1,69 @@
+use strict;
+use warnings;
+use lib qw(t/lib);
+
+use File::Copy;
+
+use DBICTest;
+
+use Test::More;
+
+BEGIN {
+ eval "use DBD::Multi";
+ plan $@
+ ? ( skip_all => 'needs DBD::Multi for testing' )
+ : ( tests => 3 );
+}
+
+my $schema = DBICTest->init_schema();
+
+$schema->storage_type( '::DBI::Replication' );
+
+
+my $db_file1 = "t/var/DBIxClass.db";
+my $db_file2 = "t/var/DBIxClass_slave1.db";
+my $db_file3 = "t/var/DBIxClass_slave2.db";
+my $dsn1 = $ENV{"DBICTEST_DSN"} || "dbi:SQLite:${db_file1}";
+my $dsn2 = $ENV{"DBICTEST_DSN2"} || "dbi:SQLite:${db_file2}";
+my $dsn3 = $ENV{"DBICTEST_DSN3"} || "dbi:SQLite:${db_file3}";
+
+$schema->connect( [
+ [ $dsn1, '', '', { AutoCommit => 1 } ],
+ [ $dsn2, '', '', { priority => 10 } ],
+ [ $dsn3, '', '', { priority => 10 } ]
+ ]
+ );
+
+$schema->populate('Artist', [
+ [ qw/artistid name/ ],
+ [ 4, 'Ozric Tentacles']
+ ]);
+
+my $new_artist1 = $schema->resultset('Artist')->find(4);
+
+isa_ok ($new_artist1, 'DBICTest::Artist');
+
+# reconnect
+my $schema2 = $schema->connect( [
+ [ $dsn1, '', '', { AutoCommit => 1 } ],
+ [ $dsn2, '', '', { priority => 10 } ],
+ [ $dsn3, '', '', { priority => 10 } ]
+ ]
+ );
+
+# try and read (should fail)
+eval { my $new_artist2 = $schema2->resultset('Artist')->find(4); };
+ok($@, 'read after disconnect fails because it uses slave 1 which we have neglected to "replicate" yet');
+
+# try and read (should succede after faked synchronisation)
+copy($db_file1, $db_file2);
+$schema2 = $schema->connect( [
+ [ $dsn1, '', '', { AutoCommit => 1 } ],
+ [ $dsn2, '', '', { priority => 10 } ],
+ [ $dsn3, '', '', { priority => 10 } ]
+ ]
+ );
+my $new_artist3 = $schema2->resultset('Artist')->find(4);
+isa_ok ($new_artist3, 'DBICTest::Artist');
+
+unlink $db_file2;
Modified: DBIx-Class/0.08/branches/storage-ms-access/t/94versioning.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/94versioning.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/94versioning.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/96file_column.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/96file_column.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/96file_column.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/96multi_create.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/96multi_create.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/96multi_create.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-DeepAbstractSearch/01_search.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-DeepAbstractSearch/01_search.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-DeepAbstractSearch/01_search.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-DeepAbstractSearch/01_search.t
___________________________________________________________________
Name: svn:executable
+ *
Added: DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-abstract/search_where.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-abstract/search_where.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-abstract/search_where.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/01-columns.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/01-columns.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/01-columns.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/02-Film.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/02-Film.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/02-Film.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/04-lazy.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/04-lazy.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/04-lazy.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/06-hasa.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/06-hasa.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/06-hasa.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/08-inheritcols.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/08-inheritcols.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/08-inheritcols.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/13-constraint.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/13-constraint.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/13-constraint.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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,44 @@
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' }) };
+ is $@, '', "Can create codirector";
+ is $freeaa->codirector, '2001-03-03', "Set the codirector";
}
__DATA__
@@ -106,13 +106,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.08/branches/storage-ms-access/t/cdbi-t/14-might_have.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/14-might_have.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/14-might_have.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/15-accessor.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/15-accessor.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/15-accessor.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/19-set_sql.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/19-set_sql.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/19-set_sql.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/21-iterator.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/21-iterator.t 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/21-iterator.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/22-deflate_order.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/22-deflate_order.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/22-deflate_order.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/23-cascade.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/23-cascade.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/23-cascade.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/24-meta_info.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/24-meta_info.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/24-meta_info.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -0,0 +1,76 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+BEGIN {
+ 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.08/branches/storage-ms-access/t/cdbi-t/26-mutator.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/26-mutator.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/26-mutator.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -0,0 +1,41 @@
+use strict;
+use Test::More;
+
+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.08/branches/storage-ms-access/t/cdbi-t/columns_as_hashes.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/columns_as_hashes.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/columns_as_hashes.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/columns_dont_override_custom_accessors.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/columns_dont_override_custom_accessors.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/columns_dont_override_custom_accessors.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/construct.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/construct.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/construct.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/copy.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/copy.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/copy.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/early_column_heisenbug.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/early_column_heisenbug.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/early_column_heisenbug.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/has_many_loads_foreign_class.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/has_many_loads_foreign_class.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/has_many_loads_foreign_class.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/hasa_without_loading.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/hasa_without_loading.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/hasa_without_loading.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/max_min_value_of.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/max_min_value_of.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/max_min_value_of.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/multi_column_set.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/multi_column_set.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/multi_column_set.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/object_cache.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/object_cache.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/object_cache.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/retrieve_from_sql_with_limit.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/retrieve_from_sql_with_limit.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/retrieve_from_sql_with_limit.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/set_to_undef.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/set_to_undef.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/set_to_undef.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/cdbi-t/set_vs_DateTime.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/set_vs_DateTime.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/cdbi-t/set_vs_DateTime.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/dbh_do.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/dbh_do.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/dbh_do.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/deleting_many_to_many.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/deleting_many_to_many.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/deleting_many_to_many.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/discard_changes_in_DESTROY.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/discard_changes_in_DESTROY.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/discard_changes_in_DESTROY.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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
Modified: DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema/CD.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema/CD.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema/CD.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/lib/DBICTest/Schema/FileColumn.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema/FileColumn.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema/FileColumn.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/lib/DBICTest/Schema/SequenceTest.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema/SequenceTest.pm (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema/SequenceTest.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/lib/DBICTest/Schema/TwoKeys.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema/TwoKeys.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema/TwoKeys.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/lib/DBICTest/Schema.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Schema.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -7,6 +7,7 @@
__PACKAGE__->load_classes(qw/
Artist
+ SequenceTest
Employee
CD
FileColumn
Added: DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Stats.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Stats.pm (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/Stats.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/lib/DBICTest/SyntaxErrorComponent3.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/SyntaxErrorComponent3.pm (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICTest/SyntaxErrorComponent3.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -0,0 +1,5 @@
+package DBICErrorTest::SyntaxError;
+
+use strict;
+
+I'm a syntax error!
Modified: DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICVersionNew.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICVersionNew.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/lib/DBICVersionNew.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/relationship_after_update.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/relationship_after_update.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/relationship_after_update.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/relationship_doesnt_exist.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/relationship_doesnt_exist.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/relationship_doesnt_exist.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/resultset_overload.t
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/resultset_overload.t (rev 0)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/resultset_overload.t 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/testlib/Actor.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/testlib/Actor.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/testlib/Actor.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/testlib/MyBase.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/testlib/MyBase.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/testlib/MyBase.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/testlib/MyFoo.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/testlib/MyFoo.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/testlib/MyFoo.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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.08/branches/storage-ms-access/t/testlib/PgBase.pm
===================================================================
--- DBIx-Class/0.08/branches/storage-ms-access/t/testlib/PgBase.pm 2008-03-24 19:22:06 UTC (rev 4233)
+++ DBIx-Class/0.08/branches/storage-ms-access/t/testlib/PgBase.pm 2008-03-24 19:24:19 UTC (rev 4234)
@@ -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