[Bast-commits] r4161 - in DBIx-Class/0.08/trunk: . lib/DBIx/Class
lib/DBIx/Class/CDBICompat lib/DBIx/Class/Relationship
lib/DBIx/Class/ResultSourceProxy lib/DBIx/Class/Serialize
lib/DBIx/Class/Storage t t/cdbi-abstract t/cdbi-t t/testlib
matthewt at dev.catalyst.perl.org
matthewt at dev.catalyst.perl.org
Tue Mar 11 03:03:51 GMT 2008
Author: matthewt
Date: 2008-03-11 03:03:50 +0000 (Tue, 11 Mar 2008)
New Revision: 4161
Added:
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/AbstractSearch.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Copy.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Iterator.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Relationship.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Relationships.pm
DBIx-Class/0.08/trunk/t/cdbi-DeepAbstractSearch/
DBIx-Class/0.08/trunk/t/cdbi-abstract/
DBIx-Class/0.08/trunk/t/cdbi-abstract/search_where.t
DBIx-Class/0.08/trunk/t/cdbi-t/08-inheritcols.t
DBIx-Class/0.08/trunk/t/cdbi-t/22-deflate_order.t
DBIx-Class/0.08/trunk/t/cdbi-t/23-cascade.t
DBIx-Class/0.08/trunk/t/cdbi-t/24-meta_info.t
DBIx-Class/0.08/trunk/t/cdbi-t/26-mutator.t
DBIx-Class/0.08/trunk/t/cdbi-t/columns_as_hashes.t
DBIx-Class/0.08/trunk/t/cdbi-t/columns_dont_override_custom_accessors.t
DBIx-Class/0.08/trunk/t/cdbi-t/construct.t
DBIx-Class/0.08/trunk/t/cdbi-t/copy.t
DBIx-Class/0.08/trunk/t/cdbi-t/early_column_heisenbug.t
DBIx-Class/0.08/trunk/t/cdbi-t/has_many_loads_foreign_class.t
DBIx-Class/0.08/trunk/t/cdbi-t/hasa_without_loading.t
DBIx-Class/0.08/trunk/t/cdbi-t/max_min_value_of.t
DBIx-Class/0.08/trunk/t/cdbi-t/multi_column_set.t
DBIx-Class/0.08/trunk/t/cdbi-t/object_cache.t
DBIx-Class/0.08/trunk/t/cdbi-t/retrieve_from_sql_with_limit.t
DBIx-Class/0.08/trunk/t/cdbi-t/set_to_undef.t
DBIx-Class/0.08/trunk/t/cdbi-t/set_vs_DateTime.t
DBIx-Class/0.08/trunk/t/deleting_many_to_many.t
DBIx-Class/0.08/trunk/t/discard_changes_in_DESTROY.t
DBIx-Class/0.08/trunk/t/relationship_after_update.t
DBIx-Class/0.08/trunk/t/relationship_doesnt_exist.t
DBIx-Class/0.08/trunk/t/resultset_overload.t
Removed:
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/HasA.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/HasMany.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/MightHave.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm
Modified:
DBIx-Class/0.08/trunk/
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/AccessorMapping.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnCase.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/GetSet.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ImaDBI.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/LazyLoading.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Retrieve.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/TempColumns.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Triggers.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/DB.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/PK.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/Accessor.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/Base.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/ResultSet.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/ResultSourceHandle.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/ResultSourceProxy/Table.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/Row.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/Schema.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/Serialize/Storable.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI.pm
DBIx-Class/0.08/trunk/t/03podcoverage.t
DBIx-Class/0.08/trunk/t/18inserterror.t
DBIx-Class/0.08/trunk/t/75limit.t
DBIx-Class/0.08/trunk/t/84serialize.t
DBIx-Class/0.08/trunk/t/cdbi-t/01-columns.t
DBIx-Class/0.08/trunk/t/cdbi-t/02-Film.t
DBIx-Class/0.08/trunk/t/cdbi-t/04-lazy.t
DBIx-Class/0.08/trunk/t/cdbi-t/06-hasa.t
DBIx-Class/0.08/trunk/t/cdbi-t/14-might_have.t
DBIx-Class/0.08/trunk/t/cdbi-t/15-accessor.t
DBIx-Class/0.08/trunk/t/cdbi-t/19-set_sql.t
DBIx-Class/0.08/trunk/t/cdbi-t/21-iterator.t
DBIx-Class/0.08/trunk/t/testlib/MyBase.pm
DBIx-Class/0.08/trunk/t/testlib/MyFoo.pm
DBIx-Class/0.08/trunk/t/testlib/PgBase.pm
Log:
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.
Property changes on: DBIx-Class/0.08/trunk
___________________________________________________________________
Name: svk:merge
- 168d5346-440b-0410-b799-f706be625ff1:/DBIx-Class-current:2207
462d4d0c-b505-0410-bf8e-ce8f877b3390:/local/bast/DBIx-Class:3159
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/on_disconnect_do:3694
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/versioned_enhancements:4125
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/on_disconnect_do:3694
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/versioned_enhancements:4125
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
Added: DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/AbstractSearch.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/AbstractSearch.pm (rev 0)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/AbstractSearch.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/CDBICompat/AccessorMapping.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/AccessorMapping.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/AccessorMapping.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -6,18 +6,17 @@
sub mk_group_accessors {
my ($class, $group, @cols) = @_;
- unless ($class->can('accessor_name') || $class->can('mutator_name')) {
+ unless ($class->_can_accessor_name_for || $class->_can_mutator_name_for) {
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->_try_accessor_name_for($col);
+ my $wo_meth = $class->_try_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,16 +25,46 @@
}
}
+# CDBI 3.0.7 decided to change "accessor_name" and "mutator_name" to
+# "accessor_name_for" and "mutator_name_for". This is recent enough
+# that we should support both. CDBI does.
+sub _can_accessor_name_for {
+ my $class = shift;
+ return $class->can("accessor_name") || $class->can("accessor_name_for");
+}
+
+sub _can_mutator_name_for {
+ my $class = shift;
+ return $class->can("mutator_name") || $class->can("mutator_name_for");
+}
+
+sub _try_accessor_name_for {
+ my($class, $column) = @_;
+
+ my $method = $class->_can_accessor_name_for;
+ return $column unless $method;
+ return $class->$method($column);
+}
+
+sub _try_mutator_name_for {
+ my($class, $column) = @_;
+
+ my $method = $class->_can_mutator_name_for;
+ return $column unless $method;
+ return $class->$method($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);
+ if ($class->_can_accessor_name_for) {
+ my $acc = $class->_try_accessor_name_for($col);
$attrs->{$col} = delete $attrs->{$acc} if exists $attrs->{$acc};
}
- if ($class->can('mutator_name')) {
- my $mut = $class->mutator_name($col);
+ if ($class->_can_mutator_name_for) {
+ my $mut = $class->_try_mutator_name_for($col);
$attrs->{$col} = delete $attrs->{$mut} if exists $attrs->{$mut};
}
}
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnCase.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnCase.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnCase.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -79,18 +79,70 @@
return \%new_query;
}
+
+# 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);
+
+ for my $name ($name, lc $name) {
+ no strict 'refs';
+ no warnings 'redefine';
+ *{$class .'::'. $name} = $accessor;
+ }
+
+ $our_accessors{$accessor}++;
+
+ return 1;
+ }
+}
+
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 ]);
+
+ # 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);
+ }
}
- return $class->next::method($type, $group,
- @fields, @extra);
}
sub new {
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnGroups.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnGroups.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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";
@@ -27,24 +31,26 @@
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);
}
Added: DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm (rev 0)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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;
Added: DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Copy.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Copy.pm (rev 0)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Copy.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/CDBICompat/GetSet.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/GetSet.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/GetSet.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/CDBICompat/HasA.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/HasA.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/HasA.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/CDBICompat/HasMany.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/HasMany.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/HasMany.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/CDBICompat/ImaDBI.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ImaDBI.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ImaDBI.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -8,7 +8,7 @@
use base qw/DBIx::Class/;
__PACKAGE__->mk_classdata('_transform_sql_handler_order'
- => [ qw/TABLE ESSENTIAL JOIN/ ] );
+ => [ qw/TABLE ESSENTIAL JOIN IDENTIFIER/ ] );
__PACKAGE__->mk_classdata('_transform_sql_handlers' =>
{
@@ -24,9 +24,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) = @_;
Added: DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Iterator.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Iterator.pm (rev 0)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Iterator.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -0,0 +1,47 @@
+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 {
+ return $_[0]->count;
+}
+
+1;
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/LazyLoading.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/LazyLoading.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/LazyLoading.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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);
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/CDBICompat/MightHave.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/MightHave.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/MightHave.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm (rev 0)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -0,0 +1,32 @@
+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_dead_from_object_index {}
+
+sub remove_from_object_index {}
+
+sub clear_object_index {}
+
+1;
Deleted: DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/CDBICompat/Relationship.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Relationship.pm (rev 0)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Relationship.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/CDBICompat/Relationships.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Relationships.pm (rev 0)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Relationships.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -0,0 +1,186 @@
+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, $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 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/trunk/lib/DBIx/Class/CDBICompat/Retrieve.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Retrieve.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Retrieve.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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;
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/TempColumns.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/TempColumns.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/TempColumns.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/CDBICompat/Triggers.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Triggers.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Triggers.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/CDBICompat.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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 is better 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/trunk/lib/DBIx/Class/DB.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/DB.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/DB.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/PK.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/PK.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/PK.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/Relationship/Accessor.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/Accessor.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/Accessor.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/Relationship/Base.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/Base.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/Base.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -295,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/trunk/lib/DBIx/Class/ResultSet.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/ResultSet.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/ResultSet.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/ResultSourceHandle.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/ResultSourceHandle.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/ResultSourceHandle.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/ResultSourceProxy/Table.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/ResultSourceProxy/Table.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/ResultSourceProxy/Table.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/Row.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Row.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Row.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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}) {
@@ -470,7 +472,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;
}
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/Schema.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Schema.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Schema.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -734,6 +734,12 @@
$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;
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/Serialize/Storable.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Serialize/Storable.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Serialize/Storable.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/lib/DBIx/Class/Storage/DBI.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -1122,6 +1122,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};
}
Modified: DBIx-Class/0.08/trunk/t/03podcoverage.t
===================================================================
--- DBIx-Class/0.08/trunk/t/03podcoverage.t 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/t/03podcoverage.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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,9 +55,11 @@
'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::Stringify' => { skip => 1 },
'DBIx::Class::CDBICompat::TempColumns' => { skip => 1 },
Modified: DBIx-Class/0.08/trunk/t/18inserterror.t
===================================================================
--- DBIx-Class/0.08/trunk/t/18inserterror.t 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/t/18inserterror.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/75limit.t
===================================================================
--- DBIx-Class/0.08/trunk/t/75limit.t 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/t/75limit.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/84serialize.t
===================================================================
--- DBIx-Class/0.08/trunk/t/84serialize.t 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/t/84serialize.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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 ");
}
-
Added: DBIx-Class/0.08/trunk/t/cdbi-abstract/search_where.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-abstract/search_where.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-abstract/search_where.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/01-columns.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/01-columns.t 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/01-columns.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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);
}
Modified: DBIx-Class/0.08/trunk/t/cdbi-t/02-Film.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/02-Film.t 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/02-Film.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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;
@@ -163,11 +163,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 +263,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 +284,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 +344,7 @@
{
{
- ok my $byebye = DeletingFilm->create(
+ ok my $byebye = DeletingFilm->insert(
{
Title => 'Goodbye Norma Jean',
Rating => 'PG',
@@ -362,9 +362,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 +385,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/trunk/t/cdbi-t/04-lazy.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/04-lazy.t 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/04-lazy.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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 => 35);
}
INIT {
@@ -79,3 +81,76 @@
};
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
+{
+ 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;
+}
Modified: DBIx-Class/0.08/trunk/t/cdbi-t/06-hasa.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/06-hasa.t 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/06-hasa.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/08-inheritcols.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/08-inheritcols.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/08-inheritcols.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -0,0 +1,23 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 3;
+
+use Class::DBI;
+
+package A;
+ at A::ISA = qw(Class::DBI);
+__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/trunk/t/cdbi-t/14-might_have.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/14-might_have.t 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/14-might_have.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/15-accessor.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/15-accessor.t 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/15-accessor.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/19-set_sql.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/19-set_sql.t 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/19-set_sql.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/21-iterator.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/21-iterator.t 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/21-iterator.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/22-deflate_order.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/22-deflate_order.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/22-deflate_order.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/23-cascade.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/23-cascade.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/23-cascade.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/24-meta_info.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/24-meta_info.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/24-meta_info.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -0,0 +1,68 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More 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/trunk/t/cdbi-t/26-mutator.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/26-mutator.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/26-mutator.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/columns_as_hashes.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/columns_as_hashes.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/columns_as_hashes.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/columns_dont_override_custom_accessors.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/columns_dont_override_custom_accessors.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/columns_dont_override_custom_accessors.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/construct.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/construct.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/construct.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -0,0 +1,31 @@
+#!/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';
+ 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";
\ No newline at end of file
Added: DBIx-Class/0.08/trunk/t/cdbi-t/copy.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/copy.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/copy.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/early_column_heisenbug.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/early_column_heisenbug.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/early_column_heisenbug.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/has_many_loads_foreign_class.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/has_many_loads_foreign_class.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/has_many_loads_foreign_class.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/hasa_without_loading.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/hasa_without_loading.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/hasa_without_loading.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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=> 3);
+}
+
+package Foo;
+
+use base qw(Class::DBI);
+
+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/trunk/t/cdbi-t/max_min_value_of.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/max_min_value_of.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/max_min_value_of.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/multi_column_set.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/multi_column_set.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/multi_column_set.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/object_cache.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/object_cache.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/object_cache.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/retrieve_from_sql_with_limit.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/retrieve_from_sql_with_limit.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/retrieve_from_sql_with_limit.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/set_to_undef.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/set_to_undef.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/set_to_undef.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/cdbi-t/set_vs_DateTime.t
===================================================================
--- DBIx-Class/0.08/trunk/t/cdbi-t/set_vs_DateTime.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/cdbi-t/set_vs_DateTime.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/deleting_many_to_many.t
===================================================================
--- DBIx-Class/0.08/trunk/t/deleting_many_to_many.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/deleting_many_to_many.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/discard_changes_in_DESTROY.t
===================================================================
--- DBIx-Class/0.08/trunk/t/discard_changes_in_DESTROY.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/discard_changes_in_DESTROY.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -0,0 +1,32 @@
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 1;
+
+{
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, @_; };
+ {
+ # Test that this doesn't cause infinite recursion.
+ local *DBICTest::Artist::DESTROY;
+ local *DBICTest::Artist::DESTROY = sub { $_[0]->discard_changes };
+
+ my $artist = $schema->resultset("Artist")->create( {
+ artistid => 10,
+ name => "artist number 10",
+ });
+
+ $artist->name("Wibble");
+
+ print "# About to call DESTROY\n";
+ }
+ is_deeply \@warnings, [];
+}
\ No newline at end of file
Added: DBIx-Class/0.08/trunk/t/relationship_after_update.t
===================================================================
--- DBIx-Class/0.08/trunk/t/relationship_after_update.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/relationship_after_update.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/relationship_doesnt_exist.t
===================================================================
--- DBIx-Class/0.08/trunk/t/relationship_doesnt_exist.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/relationship_doesnt_exist.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/resultset_overload.t
===================================================================
--- DBIx-Class/0.08/trunk/t/resultset_overload.t (rev 0)
+++ DBIx-Class/0.08/trunk/t/resultset_overload.t 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/testlib/MyBase.pm
===================================================================
--- DBIx-Class/0.08/trunk/t/testlib/MyBase.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/t/testlib/MyBase.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/testlib/MyFoo.pm
===================================================================
--- DBIx-Class/0.08/trunk/t/testlib/MyFoo.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/t/testlib/MyFoo.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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/trunk/t/testlib/PgBase.pm
===================================================================
--- DBIx-Class/0.08/trunk/t/testlib/PgBase.pm 2008-03-11 03:02:31 UTC (rev 4160)
+++ DBIx-Class/0.08/trunk/t/testlib/PgBase.pm 2008-03-11 03:03:50 UTC (rev 4161)
@@ -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