[Bast-commits] r4173 - in DBIx-Class/0.08/branches/oracle_sequence:
. lib/DBIx lib/DBIx/Class lib/DBIx/Class/CDBICompat
lib/DBIx/Class/Manual lib/DBIx/Class/Relationship
lib/DBIx/Class/ResultClass lib/DBIx/Class/ResultSourceProxy
lib/DBIx/Class/Schema lib/DBIx/Class/Serialize
lib/DBIx/Class/Storage lib/DBIx/Class/Storage/DBI
lib/DBIx/Class/Storage/DBI/ODBC
lib/SQL/Translator/Parser/DBIx script t t/cdbi-abstract
t/cdbi-t t/lib t/lib/DBICTest t/lib/DBICTest/Schema t/testlib
matthewt at dev.catalyst.perl.org
matthewt at dev.catalyst.perl.org
Tue Mar 11 20:30:43 GMT 2008
Author: matthewt
Date: 2008-03-11 20:30:42 +0000 (Tue, 11 Mar 2008)
New Revision: 4173
Added:
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/AbstractSearch.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Copy.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Iterator.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Relationship.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Relationships.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/TxnScopeGuard.pm
DBIx-Class/0.08/branches/oracle_sequence/t/746mssql.t
DBIx-Class/0.08/branches/oracle_sequence/t/93storage_replication.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-DeepAbstractSearch/
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-abstract/
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-abstract/search_where.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/08-inheritcols.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/22-deflate_order.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/23-cascade.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/24-meta_info.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/26-mutator.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/columns_as_hashes.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/columns_dont_override_custom_accessors.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/construct.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/copy.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/early_column_heisenbug.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/has_many_loads_foreign_class.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/hasa_without_loading.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/max_min_value_of.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/multi_column_set.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/object_cache.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/retrieve_from_sql_with_limit.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/set_to_undef.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/set_vs_DateTime.t
DBIx-Class/0.08/branches/oracle_sequence/t/deleting_many_to_many.t
DBIx-Class/0.08/branches/oracle_sequence/t/discard_changes_in_DESTROY.t
DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/Schema/ForceForeign.pm
DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/SyntaxErrorComponent3.pm
DBIx-Class/0.08/branches/oracle_sequence/t/relationship_after_update.t
DBIx-Class/0.08/branches/oracle_sequence/t/relationship_doesnt_exist.t
DBIx-Class/0.08/branches/oracle_sequence/t/resultset_overload.t
Removed:
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/HasA.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/HasMany.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/MightHave.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm
Modified:
DBIx-Class/0.08/branches/oracle_sequence/
DBIx-Class/0.08/branches/oracle_sequence/Changes
DBIx-Class/0.08/branches/oracle_sequence/Makefile.PL
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/AccessorMapping.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ColumnCase.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/GetSet.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ImaDBI.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/LazyLoading.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Retrieve.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/TempColumns.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Triggers.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/DB.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Manual/Cookbook.pod
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Manual/Joining.pod
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/PK.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Relationship/Accessor.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Relationship/Base.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Relationship/BelongsTo.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultClass/HashRefInflator.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultSet.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultSourceHandle.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultSourceProxy/Table.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Row.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Schema.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Schema/Versioned.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Serialize/Storable.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI/Replication.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI/SQLite.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/Statistics.pm
DBIx-Class/0.08/branches/oracle_sequence/lib/SQL/Translator/Parser/DBIx/Class.pm
DBIx-Class/0.08/branches/oracle_sequence/script/dbicadmin
DBIx-Class/0.08/branches/oracle_sequence/t/03podcoverage.t
DBIx-Class/0.08/branches/oracle_sequence/t/18inserterror.t
DBIx-Class/0.08/branches/oracle_sequence/t/68inflate.t
DBIx-Class/0.08/branches/oracle_sequence/t/73oracle_inflate.t
DBIx-Class/0.08/branches/oracle_sequence/t/746db2_400.t
DBIx-Class/0.08/branches/oracle_sequence/t/75limit.t
DBIx-Class/0.08/branches/oracle_sequence/t/76joins.t
DBIx-Class/0.08/branches/oracle_sequence/t/81transactions.t
DBIx-Class/0.08/branches/oracle_sequence/t/84serialize.t
DBIx-Class/0.08/branches/oracle_sequence/t/86sqlt.t
DBIx-Class/0.08/branches/oracle_sequence/t/89dbicadmin.t
DBIx-Class/0.08/branches/oracle_sequence/t/90ensure_class_loaded.t
DBIx-Class/0.08/branches/oracle_sequence/t/94versioning.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/01-columns.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/02-Film.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/04-lazy.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/06-hasa.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/14-might_have.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/15-accessor.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/19-set_sql.t
DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/21-iterator.t
DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/Schema.pm
DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/Schema/CD.pm
DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICVersionNew.pm
DBIx-Class/0.08/branches/oracle_sequence/t/testlib/MyBase.pm
DBIx-Class/0.08/branches/oracle_sequence/t/testlib/MyFoo.pm
DBIx-Class/0.08/branches/oracle_sequence/t/testlib/PgBase.pm
Log:
r15080 at agaton (orig r3853): matthewt | 2007-11-06 14:53:48 +0000
make belongs_to accept an [] join cond
r15099 at agaton (orig r3872): castaway | 2007-11-12 21:13:33 +0000
Added cookbook recipe for using dual, thanks Richard
r15106 at agaton (orig r3879): ash | 2007-11-15 12:49:53 +0000
Fix is_foreign_key_constraint - thanks Jon Schutz
r15107 at agaton (orig r3880): ash | 2007-11-15 13:02:15 +0000
Adding missing file
r15108 at agaton (orig r3881): ash | 2007-11-15 13:52:58 +0000
Fix t/82cascade_copy.t
r15110 at agaton (orig r3883): tomboh | 2007-11-15 15:05:12 +0000
Remove an unneeded requirement.
r15112 at agaton (orig r3885): ash | 2007-11-16 14:30:51 +0000
Version bump
r15113 at agaton (orig r3886): ash | 2007-11-19 18:11:53 +0000
Fix END block
r15114 at agaton (orig r3887): wreis | 2007-11-21 13:57:35 +0000
minor fixes for ResultSet docs
r15115 at agaton (orig r3888): ash | 2007-11-22 15:27:23 +0000
Fix mistakes
r15116 at agaton (orig r3889): ash | 2007-11-24 21:24:53 +0000
Sort tables for consistent output
r15124 at agaton (orig r3897): wreis | 2007-12-11 01:29:51 +0000
minor doc fix
r15128 at agaton (orig r3901): ash | 2007-12-20 11:02:15 +0000
Add proper thaw hooks so schema gets re-attached
r15135 at agaton (orig r3908): perigrin | 2008-01-02 20:52:13 +0000
move dbicadmin to JSON::Any
r15136 at agaton (orig r3909): semifor | 2008-01-02 22:24:23 +0000
Added Storage::DBI subclass for MSSQL auto PK over ODBC.
r15137 at agaton (orig r3910): nothingmuch | 2008-01-03 13:18:36 +0000
failing test for inflate not being triggerred with copy()
r15138 at agaton (orig r3911): nothingmuch | 2008-01-03 13:31:49 +0000
test plan
r15139 at agaton (orig r3912): nothingmuch | 2008-01-03 13:35:20 +0000
introduce set_inflated_columns
r15140 at agaton (orig r3913): nothingmuch | 2008-01-03 13:36:07 +0000
pod coverage for Storage::DBI::ODBC::Microsoft_SQL_Server
r15141 at agaton (orig r3914): nothingmuch | 2008-01-03 13:53:00 +0000
dbicadmin printed even when quiet
r15142 at agaton (orig r3915): nothingmuch | 2008-01-03 13:54:38 +0000
make the dbicadmin test portable to JSON modules that do not support single quotes and bare strings, even on windaz
r15143 at agaton (orig r3916): nothingmuch | 2008-01-03 14:50:52 +0000
changelog
r15145 at agaton (orig r3918): tomboh | 2008-01-07 15:23:15 +0000
Fix class name typo
r15152 at agaton (orig r3925): nigel | 2008-01-11 12:55:17 +0000
Copied documentation for id & discard_charges methods from Pk.pm
into Row.pm as few people think to look in Pk.pm. Put reference
back to original source.
r15169 at agaton (orig r3942): schwern | 2008-01-16 10:25:36 +0000
Declare dep on JSON::Any rather than JSON.
No reason JSON::Any should prefer JSON.pm over it's default ordering.
r15170 at agaton (orig r3943): schwern | 2008-01-16 10:26:26 +0000
And fix the check in the dbicadmin test to look for JSON::Any.
r15181 at agaton (orig r3954): matthewt | 2008-01-18 13:03:08 +0000
added strict and warnings to HashRefInflator, fixed inflation for empty has_many rels
r15182 at agaton (orig r3955): matthewt | 2008-01-20 12:28:55 +0000
made search_rs smarter about when to preserve the cache to fix mm prefetch usage
r15330 at agaton (orig r3965): semifor | 2008-01-22 15:13:11 +0000
Added build_datetime_parser method for MSSQL over ODBC.
r16132 at agaton (orig r3970): castaway | 2008-01-24 13:19:52 +0000
Oops, fix joining manual to be correct
r16133 at agaton (orig r3971): castaway | 2008-01-24 23:22:49 +0000
Version 0.08009
r16134 at agaton (orig r3972): castaway | 2008-01-24 23:36:59 +0000
0.08009 released
r16258 at agaton (orig r3975): tomboh | 2008-01-25 17:20:38 +0000
Fix a typo and a couple of links.
r16861 at agaton (orig r4024): oyse | 2008-02-05 08:42:32 +0000
Added ?\195?\152ystein Torget to the list of contributers
r16979 at agaton (orig r4050): ash | 2008-02-10 17:31:27 +0000
Add txn_scope_guard method/object
r17297 at agaton (orig r4110): ash | 2008-02-28 19:33:59 +0000
Todo tests for txn_rollback and scope_guard
r17300 at agaton (orig r4113): ash | 2008-03-01 12:17:54 +0000
Fix versioning test so it works with SQLT 0.09.
r17301 at agaton (orig r4114): ash | 2008-03-04 12:06:34 +0000
is_deferrable patch from Debolaz
r17306 at agaton (orig r4119): teejay | 2008-03-04 19:29:45 +0000
Applied fixes to replication connect_info method
r17307 at agaton (orig r4120): teejay | 2008-03-04 19:31:32 +0000
Applied fixes to replication connect_info method
r17308 at agaton (orig r4121): teejay | 2008-03-04 20:18:45 +0000
works but shouldn't
r17319 at agaton (orig r4122): teejay | 2008-03-04 20:41:32 +0000
roughly DTRT - please to be making less awful
r17323 at agaton (orig r4126): captainL | 2008-03-05 00:07:45 +0000
r3439 at luke-mbp (orig r3680): captainL | 2007-08-15 13:56:57 +0100
new branch for ::Versioned enhancements
r3503 at luke-mbp (orig r3681): captainL | 2007-08-15 14:29:01 +0100
created ->get_db_version and moved all overridable stuff to do_upgrade
r3955 at luke-mbp (orig r3682): captainL | 2007-08-15 23:29:57 +0100
tests are a mess, but Versioned.pm should work now
r3956 at luke-mbp (orig r3683): captainL | 2007-08-16 00:45:32 +0100
moved upgrade file reading into upgrade from _on_connect
r3958 at luke-mbp (orig r3689): captainL | 2007-08-21 12:56:31 +0100
works well, we now just require a nice way to deploy the SchemaVersions table
r3959 at luke-mbp (orig r3692): captainL | 2007-08-21 17:58:17 +0100
determines parser from dbh driver name and gives parser the dbh from schema to connect
r4213 at luke-mbp (orig r3831): captainL | 2007-10-23 13:18:13 +0100
fixed versioning test and checked db and schema versions are not equal before upgrading
r4214 at luke-mbp (orig r3832): captainL | 2007-10-23 15:08:46 +0100
changed constraint and index generation to be consistent with DB defaults
r4215 at luke-mbp (orig r3833): captainL | 2007-10-23 15:40:47 +0100
added entry to Changes
r4283 at luke-mbp (orig r3838): captainL | 2007-10-24 21:42:22 +0100
fixed broken regex when reading sql files
r5785 at luke-mbp (orig r3891): ash | 2007-11-24 22:17:41 +0000
Change diffing code to use $sqlt_schema. Sort tables in parser
r5786 at luke-mbp (orig r3892): captainL | 2007-11-25 16:26:57 +0000
upgrade will only produce a diff between the DB and the DBIC schema if explicitly requested
r5824 at luke-mbp (orig r4012): ash | 2008-02-01 19:33:00 +0000
Fallback to SQL->SQL to diff for old producers
r5825 at luke-mbp (orig r4014): castaway | 2008-02-01 23:01:26 +0000
Sanitise filename of sqlite backup file
r5830 at luke-mbp (orig r4047): captainL | 2008-02-09 15:26:50 +0000
sanified layout of Versioned.pm and documented changes
r6828 at luke-mbp (orig r4075): ash | 2008-02-13 13:26:10 +0000
Fix typo
r6831 at luke-mbp (orig r4078): captainL | 2008-02-14 00:27:14 +0000
fixed versioned loading split bug
r6846 at luke-mbp (orig r4103): captainL | 2008-02-27 15:11:21 +0000
increased sqlt rev dep
r6847 at luke-mbp (orig r4104): captainL | 2008-02-27 15:12:12 +0000
fixed behaviour or is_foreign_key_constraint and unique index names
r6848 at luke-mbp (orig r4105): captainL | 2008-02-28 10:28:31 +0000
changed versioning table from SchemaVersions to dbix_class_schema_versions with transition ability
r6849 at luke-mbp (orig r4106): captainL | 2008-02-28 10:54:28 +0000
hack bugfix for sqlt_type weirdness
r6850 at luke-mbp (orig r4107): captainL | 2008-02-28 16:11:44 +0000
cleaned up get_db_version
r6851 at luke-mbp (orig r4108): captainL | 2008-02-28 16:41:19 +0000
lowercased column names of versions table
r6852 at luke-mbp (orig r4109): captainL | 2008-02-28 16:59:04 +0000
removed startup comment if no action required
r6862 at luke-mbp (orig r4123): captainL | 2008-03-04 23:14:23 +0000
improved docs and added env var to skip version checks on connect
r6864 at luke-mbp (orig r4125): captainL | 2008-03-04 23:28:21 +0000
manual merge for deferrable changes from trunk
r17324 at agaton (orig r4127): captainL | 2008-03-05 10:38:19 +0000
added entry in Changes for versioning branch
r17355 at agaton (orig r4143): castaway | 2008-03-06 23:26:08 +0000
Random pod/doc pokage
r17397 at agaton (orig r4157): marcus | 2008-03-10 09:50:47 +0000
proper skip
r17401 at agaton (orig r4161): matthewt | 2008-03-11 03:03:50 +0000
r10429 at agaton (orig r3609): matthewt | 2007-07-27 01:28:35 +0100
created cdbicompat integration branch
r10431 at agaton (orig r3611): matthewt | 2007-07-27 06:14:35 +0100
initial merge of Schwern's CDBICompat work, with many thanks
r10432 at agaton (orig r3612): matthewt | 2007-07-27 06:16:18 +0100
and my tradditional collection of missing add commands
r14008 at agaton (orig r3715): schwern | 2007-08-31 10:17:21 +0100
r32768 at windhund: schwern | 2007-08-10 02:54:30 -0700
Document that we're doing AbstractSearch, too
Split out the customization recepie a bit.
Document some limitations.
r14009 at agaton (orig r3716): schwern | 2007-08-31 10:17:41 +0100
r32769 at windhund: schwern | 2007-08-10 02:56:14 -0700
Pull in some tests from CDBI 3.16 that already work.
Try to fix some issues with the testlibs.
r14010 at agaton (orig r3717): schwern | 2007-08-31 10:18:11 +0100
r32849 at windhund: schwern | 2007-08-31 01:39:19 -0700
Add POD to new CDBICompat modules so they pass POD coverage.
r14011 at agaton (orig r3718): schwern | 2007-08-31 10:18:27 +0100
r32850 at windhund: schwern | 2007-08-31 01:39:40 -0700
$schema isn't defined if the test is skipped.
r15165 at agaton (orig r3938): schwern | 2008-01-16 07:57:37 +0000
r52284 at windhund: schwern | 2008-01-15 18:23:19 -0800
Allow CDBI objects to be accessed like hashes as people tend to do for
performance reasons.
r15166 at agaton (orig r3939): schwern | 2008-01-16 07:57:57 +0000
r52285 at windhund: schwern | 2008-01-15 23:56:23 -0800
mst pointed out that my $val = $obj->{col}; $obj->col(23); print $val; will reflect the change because of the deferring. Using a tied scalar as the value is much, much simpler.
r15168 at agaton (orig r3941): schwern | 2008-01-16 10:17:55 +0000
r52290 at windhund: schwern | 2008-01-16 02:17:30 -0800
freeze/thaw/dclone as functions can't be made to reliably work. I'll
have to change the calling code in my app.
r15179 at agaton (orig r3952): schwern | 2008-01-17 21:32:12 +0000
r52302 at windhund: schwern | 2008-01-17 13:31:44 -0800
Make freeze/thaw and dclone work as functions on CDBICompat objects.
r15180 at agaton (orig r3953): schwern | 2008-01-17 23:57:56 +0000
r52305 at windhund: schwern | 2008-01-17 15:57:39 -0800
Make the hash-key warning dependent on DBIC_CDBICOMPAT_HASH_WARN because
boy is it annoying!
r17034 at agaton (orig r4051): schwern | 2008-02-12 10:32:43 +0000
r54475 at windhund: schwern | 2008-02-11 19:17:45 -0800
Original tests from Class::DBI::Plugin::DeepAbstractSearch
r17035 at agaton (orig r4052): schwern | 2008-02-12 10:32:57 +0000
r54476 at windhund: schwern | 2008-02-11 19:21:42 -0800
Test "like" in search_where()
r17036 at agaton (orig r4053): schwern | 2008-02-12 10:33:11 +0000
r54480 at windhund: schwern | 2008-02-12 02:27:53 -0800
Not going to do DeepAbstractSearch after all.
r17037 at agaton (orig r4054): schwern | 2008-02-12 10:33:26 +0000
r54481 at windhund: schwern | 2008-02-12 02:29:30 -0800
Remove stray $DB::single
r17038 at agaton (orig r4055): schwern | 2008-02-12 10:33:49 +0000
r54482 at windhund: schwern | 2008-02-12 02:32:29 -0800
Merge HasA, HasMany and MightHave into one file, Relationships, for easier
development.
Implement meta_info() and emulate the basic CDBI::Relationship object.
r17043 at agaton (orig r4060): schwern | 2008-02-13 02:34:42 +0000
r54488 at windhund: schwern | 2008-02-12 18:33:57 -0800
Fix the POD coverage test.
r17044 at agaton (orig r4061): schwern | 2008-02-13 03:26:46 +0000
r54494 at windhund: schwern | 2008-02-12 19:16:29 -0800
When emulating $obj->{column} do not call any custom column method, just
access the data directly with get/set_column().
r17045 at agaton (orig r4062): schwern | 2008-02-13 03:26:57 +0000
r54495 at windhund: schwern | 2008-02-12 19:20:26 -0800
Localize the warning tests.
r17046 at agaton (orig r4063): schwern | 2008-02-13 03:27:15 +0000
r54496 at windhund: schwern | 2008-02-12 19:26:10 -0800
Hash access no works despite lack of existing accessor method.
r17047 at agaton (orig r4064): schwern | 2008-02-13 03:46:35 +0000
r54500 at windhund: schwern | 2008-02-12 19:46:17 -0800
Emulate that Class::DBI inflates immediately
r17048 at agaton (orig r4065): schwern | 2008-02-13 07:14:31 +0000
r54502 at windhund: schwern | 2008-02-12 23:14:09 -0800
Emulate that CDBI throws out all changed columns and reloads them on
request in case the database modifies the new value (say, via a trigger)
r17049 at agaton (orig r4066): schwern | 2008-02-13 07:21:44 +0000
r54504 at windhund: schwern | 2008-02-12 23:16:34 -0800
Remove the big, out of date list of CDBICompat components
Document the limits of CDBI::Relationship support
r17050 at agaton (orig r4067): schwern | 2008-02-13 07:21:57 +0000
r54505 at windhund: schwern | 2008-02-12 23:21:28 -0800
Document the relationship declaration limitation.
r17051 at agaton (orig r4068): schwern | 2008-02-13 07:23:25 +0000
r54508 at windhund: schwern | 2008-02-12 23:22:51 -0800
POD mistake.
r17052 at agaton (orig r4069): schwern | 2008-02-13 09:07:03 +0000
r54510 at windhund: schwern | 2008-02-13 00:51:47 -0800
Fix update() so it throws out inflated values, too
r17053 at agaton (orig r4070): schwern | 2008-02-13 09:07:17 +0000
r54511 at windhund: schwern | 2008-02-13 01:04:38 -0800
Quiet a warning
r17054 at agaton (orig r4071): schwern | 2008-02-13 09:07:34 +0000
r54512 at windhund: schwern | 2008-02-13 01:06:42 -0800
Test that DateTime objects can safely be updated twice (which is what triggers
the equality check).
Remove the stringification to shield broken equality since DateTime seems
to work.
This also shuts up a warning in GetSet when you set to an undef value.
Test that.
Change from bitwise xor to regular xor since bitwise is overkill and nobody
knows what ^ is.
r17055 at agaton (orig r4072): schwern | 2008-02-13 09:12:09 +0000
r54516 at windhund: schwern | 2008-02-13 01:11:54 -0800
Fix the test to skip if MyFoo won't load.
r17056 at agaton (orig r4073): schwern | 2008-02-13 09:41:44 +0000
r54518 at windhund: schwern | 2008-02-13 01:41:26 -0800
Fix create() in the same way as update() so it throws out the new values and
reloads them from the database on demand.
r17057 at agaton (orig r4074): schwern | 2008-02-13 10:14:50 +0000
r54520 at windhund: schwern | 2008-02-13 02:14:34 -0800
Forgot to set up the relationship between Actor and Film. Turns it out
was working because create() was holding onto the given values but once
we changed it to throw them out it (properly) broke.
r17059 at agaton (orig r4076): schwern | 2008-02-14 00:10:53 +0000
r54522 at windhund: schwern | 2008-02-13 16:10:06 -0800
Emulate $CDBI::Weaken_Not_Available and CDBI::Plugin::NoCache
r17060 at agaton (orig r4077): schwern | 2008-02-14 00:11:08 +0000
r54523 at windhund: schwern | 2008-02-13 16:10:33 -0800
Expand the CDBICompat docs to show of it's features, the fact that you're
getting DBIC objects and to be more oriented towards CDBI users.
r17062 at agaton (orig r4079): schwern | 2008-02-14 09:43:47 +0000
r54531 at windhund: schwern | 2008-02-14 01:43:24 -0800
Put the stringification back, older versions of DateTime string equality are
still broken. But don't bother to stringify anything that's not a reference.
r17063 at agaton (orig r4080): schwern | 2008-02-14 12:24:30 +0000
r54534 at windhund: schwern | 2008-02-14 03:57:52 -0800
cascade delete test from Class-DBI 3.0.17
r17064 at agaton (orig r4081): schwern | 2008-02-14 12:24:45 +0000
r54535 at windhund: schwern | 2008-02-14 04:23:57 -0800
Implement cascade => "None"
r17145 at agaton (orig r4092): schwern | 2008-02-21 08:37:02 +0000
r54549 at windhund: schwern | 2008-02-21 00:34:10 -0800
Add in a warning if a column is declared as TEMP but it's already declared
real.
r17147 at agaton (orig r4094): schwern | 2008-02-24 09:12:46 +0000
Ensure that has_many() loads the foreign class.
r17148 at agaton (orig r4095): schwern | 2008-02-24 09:13:30 +0000
r54553 at windhund: schwern | 2008-02-21 21:04:31 -0800
The infinite loop with sub DESTROY { $_[0]->discard_changes } is a DBIC
thing.
r17149 at agaton (orig r4096): schwern | 2008-02-24 09:27:17 +0000
r54591 at windhund: schwern | 2008-02-24 01:20:41 -0800
Greatly speed up result_source_instance() and all the many things which
use it by eliminating the calls to $self->result_class.
r17150 at agaton (orig r4097): schwern | 2008-02-24 09:27:31 +0000
r54592 at windhund: schwern | 2008-02-24 01:22:57 -0800
Fix the pod coverage failure.
r17151 at agaton (orig r4098): schwern | 2008-02-24 09:27:49 +0000
r54593 at windhund: schwern | 2008-02-24 01:24:55 -0800
Fix the DESTROY/discard_changes() infinite recursion at the DBIC level.
r17152 at agaton (orig r4099): schwern | 2008-02-24 09:44:17 +0000
r54597 at windhund: schwern | 2008-02-24 01:43:58 -0800
Add NoObjectIndex which turns the live object index off and removes all the
hooks in insert and such, but retains stub indexing methods so as not to
break code.
r17153 at agaton (orig r4100): schwern | 2008-02-24 09:46:04 +0000
r54599 at windhund: schwern | 2008-02-24 01:45:49 -0800
Remove the now redudant ObjIndexStubs.
Fix pod coverage.
r17357 at agaton (orig r4145): schwern | 2008-03-07 16:04:34 +0000
Fix the merge with txn_scope_guard() and put the necessary =cut in.
r17358 at agaton (orig r4146): schwern | 2008-03-07 16:05:35 +0000
Fix the skip for DBD::Multi
r17359 at agaton (orig r4147): schwern | 2008-03-07 16:08:41 +0000
r54601 at windhund: schwern | 2008-02-24 11:13:43 +0100
Make meta_info() 'args' work.
r17360 at agaton (orig r4148): schwern | 2008-03-07 16:09:00 +0000
r54993 at windhund: schwern | 2008-03-04 10:29:45 +0100
Wrap columns() in an array ref for better is_deeply() diagnostics.
r17398 at agaton (orig r4158): schwern | 2008-03-11 00:38:09 +0000
No reason to store an empty hash ref for each column
r17399 at agaton (orig r4159): schwern | 2008-03-11 01:18:49 +0000
Fixed a heisenbug where looking at a column group would cause it to be shared.
r17402 at agaton (orig r4162): matthewt | 2008-03-11 03:12:33 +0000
moving t/cdbi-t/hasa_without_loading.t to CDBICompat makes it fail, can't leave it using CDBI so have temporarily skipped the test that fails
r17403 at agaton (orig r4163): matthewt | 2008-03-11 03:15:09 +0000
moved t/cdbi-t/08-inheritcols.t to use CDBICompat
r17404 at agaton (orig r4164): matthewt | 2008-03-11 03:19:20 +0000
fix Date::Simple req in t/cdbi-t/04-lazy.t
r17426 at agaton (orig r4168): ash | 2008-03-11 14:29:33 +0000
Fix depend on Time::Piece for cdbi
r17427 at agaton (orig r4169): ash | 2008-03-11 14:38:10 +0000
test to make sure the errors in components of resultset classes are reported right.
r17428 at agaton (orig r4170): ash | 2008-03-11 15:03:34 +0000
Fix errors from resultset components (and move tests into t/90ensure_class_loaded since its testing same sort of things)
r17429 at agaton (orig r4171): ash | 2008-03-11 15:10:50 +0000
Make throw_exception in RS a bit more forgiving too
Property changes on: DBIx-Class/0.08/branches/oracle_sequence
___________________________________________________________________
Name: svk:merge
- 168d5346-440b-0410-b799-f706be625ff1:/DBIx-Class-current:2207
462d4d0c-b505-0410-bf8e-ce8f877b3390:/local/bast/DBIx-Class:3159
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/on_disconnect_do:3694
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-C3:318
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-current:2222
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-joins:173
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-resultset:570
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/datetime:1716
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/find_compat:1855
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/find_unique_query_fixes:2142
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/inflate:1988
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/many_to_many:2025
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/re_refactor_bugfix:1944
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/reorganize_tests:1827
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/resultset-new-refactor:1766
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/resultset_2_electric_boogaloo:2175
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/resultset_cleanup:2102
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/sqlt_tests_refactor:2043
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/trunk/DBIx-Class:3606
fe160bb6-dc1c-0410-9f2b-d64a711b54a5:/local/DBIC-trunk-0.08:10510
+ 168d5346-440b-0410-b799-f706be625ff1:/DBIx-Class-current:2207
462d4d0c-b505-0410-bf8e-ce8f877b3390:/local/bast/DBIx-Class:3159
9c88509d-e914-0410-b01c-b9530614cbfe:/local/DBIx-Class:32260
9c88509d-e914-0410-b01c-b9530614cbfe:/local/DBIx-Class-CDBICompat:54993
9c88509d-e914-0410-b01c-b9530614cbfe:/vendor/DBIx-Class:31122
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/cdbicompat_integration:4160
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/on_disconnect_do:3694
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/versioned_enhancements:4125
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/trunk:4171
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-C3:318
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-current:2222
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-joins:173
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class-resultset:570
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/datetime:1716
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/find_compat:1855
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/find_unique_query_fixes:2142
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/inflate:1988
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/many_to_many:2025
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/re_refactor_bugfix:1944
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/reorganize_tests:1827
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/resultset-new-refactor:1766
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/resultset_2_electric_boogaloo:2175
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/resultset_cleanup:2102
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/branches/DBIx-Class/sqlt_tests_refactor:2043
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/trunk/DBIx-Class:3606
fe160bb6-dc1c-0410-9f2b-d64a711b54a5:/local/DBIC-trunk-0.08:10510
Modified: DBIx-Class/0.08/branches/oracle_sequence/Changes
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/Changes 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/Changes 2008-03-11 20:30:42 UTC (rev 4173)
@@ -1,4 +1,24 @@
Revision history for DBIx::Class
+
+ - is_deferable support on relations used by the SQL::Translator
+ parser (Anders Nor Berle)
+ - Refactored DBIx::Class::Schema::Versioned
+ - Syntax errors from resultset components are now reported correctly
+
+0.08010 2008-03-01 10:30
+ - Fix t/94versioning.t so it passes with latest SQL::Translator
+
+0.08009 2008-01-20 13:30
+ - Made search_rs smarter about when to preserve the cache to fix
+ mm prefetch usage
+ - Added Storage::DBI subclass for MSSQL over ODBC.
+ - Added freeze, thaw and dclone methods to Schema so that thawed
+ objects will get re-attached to the schema.
+ - Moved dbicadmin to JSON::Any wrapped JSON.pm for a sane API
+ - introduced DBIx::Class::set_inflated_columns
+ - DBIx::Class::Row::copy uses set_inflated_columns
+
+0.08008 2007-11-16 14:30:00
- Fixed join merging bug (test from Zby)
- When adding relationships, it will throw an exception if you get the
foreign and self parts the wrong way round in the condition
@@ -17,6 +37,8 @@
- ResultSource::reverse_relationship_info can distinguish between
sources using the same table
- Row::insert will now not fall over if passed duplicate related objects
+ - Row::copy will not fall over if you have two relationships to the
+ same source with a unique constraint on it
0.08007 2007-09-04 19:36:00
- patch for Oracle datetime inflation (abram at arin.net)
Modified: DBIx-Class/0.08/branches/oracle_sequence/Makefile.PL
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/Makefile.PL 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/Makefile.PL 2008-03-11 20:30:42 UTC (rev 4173)
@@ -16,7 +16,7 @@
requires 'Module::Find' => 0;
requires 'Class::Inspector' => 0;
requires 'Class::Accessor::Grouped' => 0.05002;
-requires 'JSON' => 1.00;
+requires 'JSON::Any' => 1.00;
requires 'Scope::Guard' => 0.03;
# Perl 5.8.0 doesn't have utf8::is_utf8()
@@ -33,6 +33,8 @@
if( -e 'inc/.author' ) {
build_requires 'DBIx::ContextualFetch';
build_requires 'Class::Trigger';
+ build_requires 'Time::Piece';
+
system('pod2text lib/DBIx/Class.pm > README');
}
@@ -41,3 +43,28 @@
auto_install;
WriteAll;
+
+
+if ($Module::Install::AUTHOR) {
+ # Need to do this _after_ WriteAll else it looses track of them
+ Meta->{values}{build_requires} = [ grep {
+ $_->[0] !~ /
+ DBIx::ContextualFetch |
+ Class::Trigger |
+ Time::Piece
+ /x;
+ } @{Meta->{values}{build_requires}} ];
+
+ my @scalar_keys = Module::Install::Metadata::Meta_TupleKeys();
+ sub Module::Install::Metadata::Meta_TupleKeys {
+ return @scalar_keys, 'resources';
+ }
+ Meta->{values}{resources} = [
+ [ 'MailingList', 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class' ],
+ [ 'IRC', 'irc://irc.perl.org/#dbix-class' ],
+ ];
+ Meta->write;
+}
+
+
+
Added: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/AbstractSearch.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/AbstractSearch.pm (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/AbstractSearch.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,37 @@
+package # hide form PAUSE
+ DBIx::Class::CDBICompat::AbstractSearch;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::AbstractSearch
+
+=head1 SYNOPSIS
+
+See DBIx::Class::CDBICompat for directions for use.
+
+=head1 DESCRIPTION
+
+Emulates L<Class::DBI::AbstractSearch>.
+
+=cut
+
+# The keys are mostly the same.
+my %cdbi2dbix = (
+ limit => 'rows',
+);
+
+sub search_where {
+ my $class = shift;
+ my $where = (ref $_[0]) ? $_[0] : { @_ };
+ my $attr = (ref $_[0]) ? $_[1] : {};
+
+ # Translate the keys
+ $attr->{$cdbi2dbix{$_}} = delete $attr->{$_} for keys %cdbi2dbix;
+
+ return $class->resultset_instance->search($where, $attr);
+}
+
+1;
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/AccessorMapping.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/AccessorMapping.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/AccessorMapping.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ColumnCase.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ColumnCase.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ColumnCase.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ColumnGroups.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ColumnGroups.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Copy.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Copy.pm (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Copy.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,36 @@
+package # hide from PAUSE
+ DBIx::Class::CDBICompat::Copy;
+
+use strict;
+use warnings;
+
+use Carp;
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::Copy
+
+=head1 SYNOPSIS
+
+See DBIx::Class::CDBICompat for directions for use.
+
+=head1 DESCRIPTION
+
+Emulates C<<Class::DBI->copy($new_id)>>.
+
+=cut
+
+
+# CDBI's copy will take an id in addition to a hash ref.
+sub copy {
+ my($self, $arg) = @_;
+ return $self->next::method($arg) if ref $arg;
+
+ my @primary_columns = $self->primary_columns;
+ croak("Need hash-ref to edit copied column values")
+ if @primary_columns > 1;
+
+ return $self->next::method({ $primary_columns[0] => $arg });
+}
+
+1;
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/GetSet.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/GetSet.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/GetSet.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -16,7 +16,17 @@
}
sub set {
- return shift->set_column(@_);
+ my($self, %data) = @_;
+
+ # set_columns() is going to do a string comparison before setting.
+ # This breaks on DateTime objects (whose comparison is arguably broken)
+ # so we stringify anything first.
+ for my $key (keys %data) {
+ next unless ref $data{$key};
+ $data{$key} = "$data{$key}";
+ }
+
+ return shift->set_columns(\%data);
}
1;
Deleted: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/HasA.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/HasA.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/HasA.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -1,46 +0,0 @@
-package # hide from PAUSE
- DBIx::Class::CDBICompat::HasA;
-
-use strict;
-use warnings;
-
-sub has_a {
- my ($self, $col, $f_class, %args) = @_;
- $self->throw_exception( "No such column ${col}" ) unless $self->has_column($col);
- $self->ensure_class_loaded($f_class);
- if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a
- if (!ref $args{'inflate'}) {
- my $meth = $args{'inflate'};
- $args{'inflate'} = sub { $f_class->$meth(shift); };
- }
- if (!ref $args{'deflate'}) {
- my $meth = $args{'deflate'};
- $args{'deflate'} = sub { shift->$meth; };
- }
- $self->inflate_column($col, \%args);
- return 1;
- }
-
- $self->belongs_to($col, $f_class);
- return 1;
-}
-
-sub search {
- my $self = shift;
- my $attrs = {};
- if (@_ > 1 && ref $_[$#_] eq 'HASH') {
- $attrs = { %{ pop(@_) } };
- }
- my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift)
- : {@_})
- : undef());
- if (ref $where eq 'HASH') {
- foreach my $key (keys %$where) { # has_a deflation hack
- $where->{$key} = ''.$where->{$key}
- if eval { $where->{$key}->isa('DBIx::Class') };
- }
- }
- $self->next::method($where, $attrs);
-}
-
-1;
Deleted: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/HasMany.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/HasMany.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/HasMany.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -1,46 +0,0 @@
-package # hide from PAUSE
- DBIx::Class::CDBICompat::HasMany;
-
-use strict;
-use warnings;
-
-sub has_many {
- my ($class, $rel, $f_class, $f_key, $args) = @_;
-
- my @f_method;
-
- if (ref $f_class eq 'ARRAY') {
- ($f_class, @f_method) = @$f_class;
- }
-
- if (ref $f_key eq 'HASH' && !$args) { $args = $f_key; undef $f_key; };
-
- $args ||= {};
- if (delete $args->{no_cascade_delete}) {
- $args->{cascade_delete} = 0;
- }
-
- if( !$f_key and !@f_method ) {
- my $f_source = $f_class->result_source_instance;
- ($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class }
- $f_source->relationships;
- }
-
- $class->next::method($rel, $f_class, $f_key, $args);
-
- if (@f_method) {
- no strict 'refs';
- no warnings 'redefine';
- my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; };
- *{"${class}::${rel}"} =
- sub {
- my $rs = shift->search_related($rel => @_);
- $rs->{attrs}{record_filter} = $post_proc;
- return (wantarray ? $rs->all : $rs);
- };
- return 1;
- }
-
-}
-
-1;
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ImaDBI.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ImaDBI.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ImaDBI.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Iterator.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Iterator.pm (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Iterator.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/LazyLoading.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/LazyLoading.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/LazyLoading.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -12,6 +12,21 @@
__PACKAGE__->mk_classdata('live_object_index' => { });
__PACKAGE__->mk_classdata('live_object_init_count' => { });
+# Caching is on by default, but a classic CDBI hack to turn it off is to
+# set this variable false.
+$Class::DBI::Weaken_Is_Available = 1
+ unless defined $Class::DBI::Weaken_Is_Available;
+__PACKAGE__->mk_classdata('__nocache' => 0);
+
+sub nocache {
+ my $class = shift;
+
+ return $class->__nocache(@_) if @_;
+
+ return 1 if $Class::DBI::Weaken_Is_Available == 0;
+ return $class->__nocache;
+}
+
# Ripped from Class::DBI 0.999, all credit due to Tony Bowden for this code,
# all blame due to me for whatever bugs I introduced porting it.
@@ -30,11 +45,15 @@
delete @$live{ keys %$live };
}
+
# And now the fragments to tie it in to DBIx::Class::Table
sub insert {
my ($self, @rest) = @_;
$self->next::method(@rest);
+
+ return $self if $self->nocache;
+
# Because the insert will die() if it can't insert into the db (or should)
# we can be sure the object *was* inserted if we got this far. In which
# case, given primary keys are unique and ID only returns a
@@ -55,6 +74,9 @@
sub inflate_result {
my ($class, @rest) = @_;
my $new = $class->next::method(@rest);
+
+ return $new if $new->nocache;
+
if (my $key = $new->ID) {
#warn "Key $key";
my $live = $class->live_object_index;
@@ -67,16 +89,4 @@
return $new;
}
-sub discard_changes {
- my ($self) = @_;
- if (my $key = $self->ID) {
- $self->remove_from_object_index;
- my $ret = $self->next::method;
- $self->live_object_index->{$key} = $self if $self->in_storage;
- return $ret;
- } else {
- return $self->next::method;
- }
-}
-
1;
Deleted: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/MightHave.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/MightHave.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/MightHave.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -1,17 +0,0 @@
-package # hide from PAUSE
- DBIx::Class::CDBICompat::MightHave;
-
-use strict;
-use warnings;
-
-sub might_have {
- my ($class, $rel, $f_class, @columns) = @_;
- if (ref $columns[0] || !defined $columns[0]) {
- return $class->next::method($rel, $f_class, @columns);
- } else {
- return $class->next::method($rel, $f_class, undef,
- { proxy => \@columns });
- }
-}
-
-1;
Added: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/ObjIndexStubs.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -1,11 +0,0 @@
-package # hide from PAUSE
- DBIx::Class::CDBICompat::ObjIndexStubs;
-
-use strict;
-use warnings;
-
-sub remove_from_object_index { }
-
-sub clear_object_index { }
-
-1;
Added: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Relationship.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Relationship.pm (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Relationship.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,42 @@
+package
+ DBIx::Class::CDBICompat::Relationship;
+
+use strict;
+use warnings;
+
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::Relationship
+
+=head1 DESCRIPTION
+
+Emulate the Class::DBI::Relationship object returned from C<meta_info()>.
+
+=cut
+
+my %method2key = (
+ name => 'type',
+ class => 'self_class',
+ accessor => 'accessor',
+ foreign_class => 'class',
+ args => 'args',
+);
+
+sub new {
+ my($class, $args) = @_;
+
+ return bless $args, $class;
+}
+
+for my $method (keys %method2key) {
+ my $key = $method2key{$method};
+ my $code = sub {
+ $_[0]->{$key};
+ };
+
+ no strict 'refs';
+ *{$method} = $code;
+}
+
+1;
Added: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Relationships.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Relationships.pm (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Relationships.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Retrieve.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Retrieve.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Retrieve.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/TempColumns.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/TempColumns.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/TempColumns.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -5,41 +5,70 @@
use warnings;
use base qw/DBIx::Class/;
+use Carp;
+
__PACKAGE__->mk_classdata('_temp_columns' => { });
sub _add_column_group {
my ($class, $group, @cols) = @_;
- if ($group eq 'TEMP') {
- $class->_register_column_group($group => @cols);
- $class->mk_group_accessors('temp' => @cols);
- my %tmp = %{$class->_temp_columns};
- $tmp{$_} = 1 for @cols;
- $class->_temp_columns(\%tmp);
- } else {
- return $class->next::method($group, @cols);
+
+ return $class->next::method($group, @cols) unless $group eq 'TEMP';
+
+ my %new_cols = map { $_ => 1 } @cols;
+ my %tmp_cols = %{$class->_temp_columns};
+
+ for my $existing_col ( grep $new_cols{$_}, $class->columns ) {
+ # Already been declared TEMP
+ next if $tmp_cols{$existing_col};
+
+ carp "Declaring column $existing_col as TEMP but it already exists";
}
+
+ $class->_register_column_group($group => @cols);
+ $class->mk_group_accessors('temp' => @cols);
+
+ $class->_temp_columns({ %tmp_cols, %new_cols });
}
sub new {
my ($class, $attrs, @rest) = @_;
- my %temp;
- foreach my $key (keys %$attrs) {
- $temp{$key} = delete $attrs->{$key} if $class->_temp_columns->{$key};
- }
+
+ my $temp = $class->_extract_temp_data($attrs);
+
my $new = $class->next::method($attrs, @rest);
- foreach my $key (keys %temp) {
- $new->set_temp($key, $temp{$key});
- }
+
+ $new->set_temp($_, $temp->{$_}) for keys %$temp;
+
return $new;
}
+sub _extract_temp_data {
+ my($self, $data) = @_;
+ my %temp;
+ foreach my $key (keys %$data) {
+ $temp{$key} = delete $data->{$key} if $self->_temp_columns->{$key};
+ }
+
+ return \%temp;
+}
+
sub find_column {
my ($class, $col, @rest) = @_;
return $col if $class->_temp_columns->{$col};
return $class->next::method($col, @rest);
}
+sub set {
+ my($self, %data) = @_;
+
+ my $temp_data = $self->_extract_temp_data(\%data);
+
+ $self->set_temp($_, $temp_data->{$_}) for keys %$temp_data;
+
+ return $self->next::method(%data);
+}
+
sub get_temp {
my ($self, $column) = @_;
$self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Triggers.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Triggers.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat/Triggers.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -7,6 +7,9 @@
sub insert {
my $self = shift;
+
+ return $self->create(@_) unless ref $self;
+
$self->call_trigger('before_create');
$self->next::method(@_);
$self->call_trigger('after_create');
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/CDBICompat.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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/branches/oracle_sequence/lib/DBIx/Class/DB.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/DB.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/DB.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -150,35 +150,26 @@
=cut
+__PACKAGE__->mk_classdata('_result_source_instance' => []);
+
sub result_source_instance {
my $class = shift;
$class = ref $class || $class;
-
- __PACKAGE__->mk_classdata(qw/_result_source_instance/)
- unless __PACKAGE__->can('_result_source_instance');
-
- return $class->_result_source_instance(@_) if @_;
+ return $class->_result_source_instance([$_[0], $class]) if @_;
- my $source = $class->_result_source_instance;
- return {} unless Scalar::Util::blessed($source);
+ my($source, $result_class) = @{$class->_result_source_instance};
+ return unless Scalar::Util::blessed($source);
- if ($source->result_class ne $class) {
- # Remove old source instance so we dont get deep recursion
- #$DB::single = 1;
- # Need to set it to a non-undef value so that it doesn't just fallback to
- # a parent class's _result_source_instance
- #$class->_result_source_instance({});
- #$class->table($class);
- #$source = $class->_result_source_instance;
+ if ($result_class ne $class) { # new class
+ # Give this new class it's own source and register it.
- $DB::single = 1;
$source = $source->new({
%$source,
source_name => $class,
result_class => $class
} );
- $class->_result_source_instance($source);
+ $class->_result_source_instance([$source, $class]);
if (my $coderef = $class->can('schema_instance')) {
$coderef->($class)->register_class($class, $class);
}
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Manual/Cookbook.pod
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Manual/Cookbook.pod 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Manual/Cookbook.pod 2008-03-11 20:30:42 UTC (rev 4173)
@@ -767,38 +767,37 @@
=head2 Create a new row in a related table
- my $book->create_related('author', { name => 'Fred'});
+ my $author = $book->create_related('author', { name => 'Fred'});
=head2 Search in a related table
Only searches for books named 'Titanic' by the author in $author.
- my $author->search_related('books', { name => 'Titanic' });
+ my $books_rs = $author->search_related('books', { name => 'Titanic' });
=head2 Delete data in a related table
Deletes only the book named Titanic by the author in $author.
- my $author->delete_related('books', { name => 'Titanic' });
+ $author->delete_related('books', { name => 'Titanic' });
=head2 Ordering a relationship result set
If you always want a relation to be ordered, you can specify this when you
create the relationship.
-To order C<< $book->pages >> by descending page_number.
+To order C<< $book->pages >> by descending page_number, create the relation
+as follows:
- Book->has_many('pages' => 'Page', 'book', { order_by => \'page_number DESC'} );
+ __PACKAGE__->has_many('pages' => 'Page', 'book', { order_by => \'page_number DESC'} );
=head2 Many-to-many relationships
This is straightforward using L<ManyToMany|DBIx::Class::Relationship/many_to_many>:
- package My::DB;
- # ... set up connection ...
-
package My::User;
- use base 'My::DB';
+ use base 'DBIx::Class';
+ __PACKAGE__->load_components('Core');
__PACKAGE__->table('user');
__PACKAGE__->add_columns(qw/id name/);
__PACKAGE__->set_primary_key('id');
@@ -806,7 +805,8 @@
__PACKAGE__->many_to_many('addresses' => 'user_address', 'address');
package My::UserAddress;
- use base 'My::DB';
+ use base 'DBIx::Class';
+ __PACKAGE__->load_components('Core');
__PACKAGE__->table('user_address');
__PACKAGE__->add_columns(qw/user address/);
__PACKAGE__->set_primary_key(qw/user address/);
@@ -814,7 +814,8 @@
__PACKAGE__->belongs_to('address' => 'My::Address');
package My::Address;
- use base 'My::DB';
+ use base 'DBIx::Class';
+ __PACKAGE__->load_components('Core');
__PACKAGE__->table('address');
__PACKAGE__->add_columns(qw/id street town area_code country/);
__PACKAGE__->set_primary_key('id');
@@ -841,7 +842,7 @@
$genus->add_to_species({ name => 'troglodyte' });
$genus->wings(2);
$genus->update;
- $schema->txn_do($coderef2); # Can have a nested transaction
+ $schema->txn_do($coderef2); # Can have a nested transaction. Only the outer will actualy commit
return $genus->species;
};
@@ -874,7 +875,8 @@
The recommend way of achieving this is to use the
L<make_schema_at|DBIx::Class::Schema::Loader/make_schema_at> method:
- perl -MDBIx::Class::Schema::Loader=make_schema_at,dump_to_dir:./lib -e 'make_schema_at("My::Schema", { debug => 1 }, [ "dbi:Pg:dbname=foo","postgres" ])'
+ perl -MDBIx::Class::Schema::Loader=make_schema_at,dump_to_dir:./lib \
+ -e 'make_schema_at("My::Schema", { debug => 1 }, [ "dbi:Pg:dbname=foo","postgres" ])'
This will create a tree of files rooted at C<./lib/My/Schema/> containing
source definitions for all the tables found in the C<foo> database.
@@ -920,6 +922,98 @@
requires that the files for 0.1 as created above are available in the
given directory to diff against.
+=head2 Select from dual
+
+Dummy tables are needed by some databases to allow calling functions
+or expressions that aren't based on table content, for examples of how
+this applies to various database types, see:
+L<http://troels.arvin.dk/db/rdbms/#other-dummy_table>.
+
+Note: If you're using Oracles dual table don't B<ever> do anything
+other than a select, if you CRUD on your dual table you *will* break
+your database.
+
+Make a table class as you would for any other table
+
+ package MyAppDB::Dual;
+ use strict;
+ use warnings;
+ use base 'DBIx::Class';
+ __PACKAGE__->load_components("Core");
+ __PACKAGE__->table("Dual");
+ __PACKAGE__->add_columns(
+ "dummy",
+ { data_type => "VARCHAR2", is_nullable => 0, size => 1 },
+ );
+
+Once you've loaded your table class select from it using C<select>
+and C<as> instead of C<columns>
+
+ my $rs = $schema->resultset('Dual')->search(undef,
+ { select => [ 'sydate' ],
+ as => [ 'now' ]
+ },
+ );
+
+All you have to do now is be careful how you access your resultset, the below
+will not work because there is no column called 'now' in the Dual table class
+
+ while (my $dual = $rs->next) {
+ print $dual->now."\n";
+ }
+ # Can't locate object method "now" via package "MyAppDB::Dual" at headshot.pl line 23.
+
+You could of course use 'dummy' in C<as> instead of 'now', or C<add_columns> to
+your Dual class for whatever you wanted to select from dual, but that's just
+silly, instead use C<get_column>
+
+ while (my $dual = $rs->next) {
+ print $dual->get_column('now')."\n";
+ }
+
+Or use C<cursor>
+
+ my $cursor = $rs->cursor;
+ while (my @vals = $cursor->next) {
+ print $vals[0]."\n";
+ }
+
+Or use L<DBIx::Class::ResultClass::HashRefInflator>
+
+ $rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
+ while ( my $dual = $rs->next ) {
+ print $dual->{now}."\n";
+ }
+
+Here are some example C<select> conditions to illustrate the different syntax
+you could use for doing stuff like
+C<oracles.heavily(nested(functions_can('take', 'lots'), OF), 'args')>
+
+ # get a sequence value
+ select => [ 'A_SEQ.nextval' ],
+
+ # get create table sql
+ select => [ { 'dbms_metadata.get_ddl' => [ "'TABLE'", "'ARTIST'" ]} ],
+
+ # get a random num between 0 and 100
+ select => [ { "trunc" => [ { "dbms_random.value" => [0,100] } ]} ],
+
+ # what year is it?
+ select => [ { 'extract' => [ \'year from sysdate' ] } ],
+
+ # do some math
+ select => [ {'round' => [{'cos' => [ \'180 * 3.14159265359/180' ]}]}],
+
+ # which day of the week were you born on?
+ select => [{'to_char' => [{'to_date' => [ "'25-DEC-1980'", "'dd-mon-yyyy'" ]}, "'day'"]}],
+
+ # select 16 rows from dual
+ select => [ "'hello'" ],
+ as => [ 'world' ],
+ group_by => [ 'cube( 1, 2, 3, 4 )' ],
+
+
+
=head2 Adding Indexes And Functions To Your SQL
Often you will want indexes on columns on your table to speed up searching. To
@@ -1029,7 +1123,7 @@
Add the L<DBIx::Class::Schema::Versioned> schema component to your
Schema class. This will add a new table to your database called
-C<SchemaVersions> which will keep track of which version is installed
+C<dbix_class_schema_vesion> which will keep track of which version is installed
and warn if the user trys to run a newer schema version than the
database thinks it has.
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Manual/Joining.pod
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Manual/Joining.pod 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Manual/Joining.pod 2008-03-11 20:30:42 UTC (rev 4173)
@@ -165,7 +165,7 @@
join => [ 'room', 'room' ]
-The aliases are: C<room_1> and C<room_2>.
+The aliases are: C<room> and C<room_2>.
=cut
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/PK.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/PK.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/PK.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -39,14 +39,21 @@
my ($self) = @_;
delete $self->{_dirty_columns};
return unless $self->in_storage; # Don't reload if we aren't real!
- my ($reload) = $self->result_source->resultset->find
- (map { $self->$_ } $self->primary_columns);
+
+ my $reload = $self->result_source->resultset->find(
+ map { $self->$_ } $self->primary_columns
+ );
unless ($reload) { # If we got deleted in the mean-time
$self->in_storage(0);
return $self;
}
- delete @{$self}{keys %$self};
- @{$self}{keys %$reload} = values %$reload;
+
+ %$self = %$reload;
+
+ # Avoid a possible infinite loop with
+ # sub DESTROY { $_[0]->discard_changes }
+ bless $reload, 'Do::Not::Exist';
+
return $self;
}
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Relationship/Accessor.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Relationship/Accessor.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Relationship/Accessor.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -36,7 +36,7 @@
$class->inflate_column($rel,
{ inflate => sub {
my ($val, $self) = @_;
- return $self->find_or_create_related($rel, {}, {});
+ return $self->find_or_new_related($rel, {}, {});
},
deflate => sub {
my ($val, $self) = @_;
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Relationship/Base.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Relationship/Base.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Relationship/Base.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -109,6 +109,13 @@
should, set this attribute to a true or false value to override the detection
of when to create constraints.
+=item is_deferrable
+
+Tells L<SQL::Translator> that the foreign key constraint it creates should be
+deferrable. In other words, the user may request that the constraint be ignored
+until the end of the transaction. Currently, only the PostgreSQL producer
+actually supports this.
+
=back
=head2 register_relationship
@@ -288,7 +295,8 @@
sub find_or_new_related {
my $self = shift;
- return $self->find_related(@_) || $self->new_related(@_);
+ my $obj = $self->find_related(@_);
+ return defined $obj ? $obj : $self->new_related(@_);
}
=head2 find_or_create_related
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Relationship/BelongsTo.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Relationship/BelongsTo.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Relationship/BelongsTo.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -41,20 +41,25 @@
);
}
# explicit join condition
- elsif (ref $cond eq 'HASH') {
- my $cond_rel;
- for (keys %$cond) {
- if (m/\./) { # Explicit join condition
- $cond_rel = $cond;
- last;
+ elsif (ref $cond) {
+ if (ref $cond eq 'HASH') { # ARRAY is also valid
+ my $cond_rel;
+ for (keys %$cond) {
+ if (m/\./) { # Explicit join condition
+ $cond_rel = $cond;
+ last;
+ }
+ $cond_rel->{"foreign.$_"} = "self.".$cond->{$_};
}
- $cond_rel->{"foreign.$_"} = "self.".$cond->{$_};
+ $cond = $cond_rel;
}
- my $acc_type = (keys %$cond_rel == 1 and $class->has_column($rel))
- ? 'filter'
- : 'single';
+ my $acc_type = ((ref $cond eq 'HASH')
+ && keys %$cond == 1
+ && $class->has_column($rel))
+ ? 'filter'
+ : 'single';
$class->add_relationship($rel, $f_class,
- $cond_rel,
+ $cond,
{ accessor => $acc_type, %{$attrs || {}} }
);
}
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultClass/HashRefInflator.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultClass/HashRefInflator.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultClass/HashRefInflator.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -1,5 +1,8 @@
package DBIx::Class::ResultClass::HashRefInflator;
+use strict;
+use warnings;
+
=head1 NAME
DBIx::Class::ResultClass::HashRefInflator
@@ -61,7 +64,7 @@
# related sources.
# to avoid emtpy has_many rels contain one empty hashref
- return if (not keys %$me);
+ return undef if (not keys %$me);
my $def;
@@ -71,13 +74,14 @@
last;
}
}
- return unless $def;
+ return undef unless $def;
return { %$me,
map {
( $_ =>
- ref($rest->{$_}[0]) eq 'ARRAY' ? [ map { mk_hash(@$_) } @{$rest->{$_}} ]
- : mk_hash( @{$rest->{$_}} )
+ ref($rest->{$_}[0]) eq 'ARRAY'
+ ? [ grep defined, map mk_hash(@$_), @{$rest->{$_}} ]
+ : mk_hash( @{$rest->{$_}} )
)
} keys %$rest
};
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultSet.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultSet.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultSet.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -3,14 +3,15 @@
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;
use Storable;
use DBIx::Class::ResultSetColumn;
use DBIx::Class::ResultSourceHandle;
+use List::Util ();
use base qw/DBIx::Class/;
__PACKAGE__->mk_group_accessors('simple' => qw/result_class _source_handle/);
@@ -50,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
@@ -168,18 +173,26 @@
sub search_rs {
my $self = shift;
- my $rows;
-
- unless (@_) { # no search, effectively just a clone
- $rows = $self->get_cache;
- }
-
my $attrs = {};
$attrs = pop(@_) if @_ > 1 and ref $_[$#_] eq 'HASH';
my $our_attrs = { %{$self->{attrs}} };
my $having = delete $our_attrs->{having};
my $where = delete $our_attrs->{where};
+ my $rows;
+
+ my %safe = (alias => 1, cache => 1);
+
+ unless (
+ (@_ && defined($_[0])) # @_ == () or (undef)
+ ||
+ (keys %$attrs # empty attrs or only 'safe' attrs
+ && List::Util::first { !$safe{$_} } keys %$attrs)
+ ) {
+ # no search, effectively just a clone
+ $rows = $self->get_cache;
+ }
+
my $new_attrs = { %{$our_attrs}, %{$attrs} };
# merge new attrs into inherited
@@ -929,7 +942,7 @@
with to find the number of elements. If passed arguments, does a search
on the resultset and counts the results of that.
-Note: When using C<count> with C<group_by>, L<DBIX::Class> emulates C<GROUP BY>
+Note: When using C<count> with C<group_by>, L<DBIx::Class> emulates C<GROUP BY>
using C<COUNT( DISTINCT( columns ) )>. Some databases (notably SQLite) do
not support C<DISTINCT> with multiple columns. If you are using such a
database, you should only use columns from the main table in your C<group_by>
@@ -987,6 +1000,10 @@
return $count;
}
+sub _bool {
+ return 1;
+}
+
=head2 count_literal
=over 4
@@ -2115,7 +2132,12 @@
sub throw_exception {
my $self=shift;
- $self->_source_handle->schema->throw_exception(@_);
+ if (ref $self && $self->_source_handle->schema) {
+ $self->_source_handle->schema->throw_exception(@_)
+ } else {
+ croak(@_);
+ }
+
}
# XXX: FIXME: Attributes docs need clearing up
@@ -2204,7 +2226,7 @@
=over 4
Indicates additional columns to be selected from storage. Works the same as
-L<select> but adds columns to the selection.
+L</select> but adds columns to the selection.
=back
@@ -2212,7 +2234,7 @@
=over 4
-Indicates additional column names for those added via L<+select>.
+Indicates additional column names for those added via L</+select>.
=back
@@ -2334,6 +2356,7 @@
below.
For more help on using joins with search, see L<DBIx::Class::Manual::Joining>.
+
=head2 prefetch
=over 4
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultSourceHandle.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultSourceHandle.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultSourceHandle.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -3,6 +3,7 @@
use strict;
use warnings;
use Storable;
+use Carp;
use base qw/DBIx::Class/;
@@ -14,6 +15,9 @@
__PACKAGE__->mk_group_accessors('simple' => qw/schema source_moniker/);
+# Schema to use when thawing.
+our $thaw_schema;
+
=head1 NAME
DBIx::Class::ResultSourceHandle
@@ -71,20 +75,43 @@
sub STORABLE_freeze {
my ($self, $cloning) = @_;
+
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));
}
=head2 STORABLE_thaw
-Thaws frozen handle.
+Thaws frozen handle. Resets the internal schema reference to the package
+variable C<$thaw_schema>. The recomened way of setting this is to use
+C<$schema->thaw($ice)> which handles this for you.
=cut
+
sub STORABLE_thaw {
my ($self, $cloning,$ice) = @_;
%$self = %{ Storable::thaw($ice) };
+
+ 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
+
+Ash Berlin C<< <ash at cpan.org> >>
+
+=cut
+
1;
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultSourceProxy/Table.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultSourceProxy/Table.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/ResultSourceProxy/Table.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -12,6 +12,42 @@
__PACKAGE__->mk_classdata('table_alias'); # FIXME: Doesn't actually do
# anything yet!
+sub _init_result_source_instance {
+ my $class = shift;
+
+ $class->mk_classdata('result_source_instance')
+ unless $class->can('result_source_instance');
+
+ my $table = $class->result_source_instance;
+ my $class_has_table_instance = ($table and $table->result_class eq $class);
+ return $table if $class_has_table_instance;
+
+ if( $table ) {
+ $table = $class->table_class->new({
+ %$table,
+ result_class => $class,
+ source_name => undef,
+ schema => undef
+ });
+ }
+ else {
+ $table = $class->table_class->new({
+ name => undef,
+ result_class => $class,
+ source_name => undef,
+ });
+ }
+
+ $class->result_source_instance($table);
+
+ if ($class->can('schema_instance')) {
+ $class =~ m/([^:]+)$/;
+ $class->schema_instance->register_class($class, $class);
+ }
+
+ return $table;
+}
+
=head1 NAME
DBIx::Class::ResultSourceProxy::Table - provides a classdata table
@@ -47,7 +83,7 @@
unless (ref $table) {
$table = $class->table_class->new({
$class->can('result_source_instance') ?
- %{$class->result_source_instance} : (),
+ %{$class->result_source_instance||{}} : (),
name => $table,
result_class => $class,
source_name => undef,
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Row.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Row.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Row.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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}) {
@@ -116,7 +118,6 @@
next;
}
}
- use Data::Dumper;
$new->throw_exception("No such column $key on $class")
unless $class->has_column($key);
$new->store_column($key => $attrs->{$key});
@@ -139,6 +140,9 @@
an entirely new object into the database, use C<create> (see
L<DBIx::Class::ResultSet/create>).
+To fetch an uninserted row object, call
+L<new|DBIx::Class::ResultSet/new> on a resultset.
+
This will also insert any uninserted, related objects held inside this
one, see L<DBIx::Class::ResultSet/create> for more details.
@@ -160,12 +164,10 @@
%{$self->{_inflated_column} || {}});
if(!$self->{_rel_in_storage}) {
- $source->storage->txn_begin;
# The guard will save us if we blow out of this scope via die
+ $rollback_guard = $source->storage->txn_scope_guard;
- $rollback_guard = Scope::Guard->new(sub { $source->storage->txn_rollback });
-
## Should all be in relationship_data, but we need to get rid of the
## 'filter' reltype..
## These are the FK rels, need their IDs for the insert.
@@ -248,8 +250,7 @@
}
}
}
- $source->storage->txn_commit;
- $rollback_guard->dismiss;
+ $rollback_guard->commit;
}
$self->in_storage(1);
@@ -264,8 +265,14 @@
$obj->in_storage; # Get value
$obj->in_storage(1); # Set value
-Indicates whether the object exists as a row in the database or not
+Indicates whether the object exists as a row in the database or
+not. This is set to true when L<DBIx::Class::ResultSet/find>,
+L<DBIx::Class::ResultSet/create> or L<DBIx::Class::ResultSet/insert>
+are used.
+Creating a row object using L<DBIx::Class::ResultSet/new>, or calling
+L</delete> on one, sets it to false.
+
=cut
sub in_storage {
@@ -283,9 +290,10 @@
required.
Also takes an options hashref of C<< column_name => value> pairs >> to update
-first. But be aware that this hashref might be edited in place, so dont rely on
-it being the same after a call to C<update>. If you need to preserve the hashref,
-it is sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
+first. But be aware that the hashref will be passed to
+C<set_inflated_columns>, which might edit it in place, so dont rely on it being
+the same after a call to C<update>. If you need to preserve the hashref, it is
+sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
=cut
@@ -296,38 +304,7 @@
$self->throw_exception("Cannot safely update a row in a PK-less table")
if ! keys %$ident_cond;
- if ($upd) {
- foreach my $key (keys %$upd) {
- if (ref $upd->{$key}) {
- my $info = $self->relationship_info($key);
- if ($info && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'single')
- {
- my $rel = delete $upd->{$key};
- $self->set_from_related($key => $rel);
- $self->{_relationship_data}{$key} = $rel;
- } elsif ($info && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'multi'
- && ref $upd->{$key} eq 'ARRAY') {
- my $others = delete $upd->{$key};
- foreach my $rel_obj (@$others) {
- if(!Scalar::Util::blessed($rel_obj)) {
- $rel_obj = $self->create_related($key, $rel_obj);
- }
- }
- $self->{_relationship_data}{$key} = $others;
-# $related->{$key} = $others;
- next;
- }
- elsif ($self->has_column($key)
- && exists $self->column_info($key)->{_inflate_info})
- {
- $self->set_inflated_column($key, delete $upd->{$key});
- }
- }
- }
- $self->set_columns($upd);
- }
+ $self->set_inflated_columns($upd) if $upd;
my %to_update = $self->get_dirty_columns;
return $self unless keys %to_update;
my $rows = $self->result_source->storage->update(
@@ -354,7 +331,7 @@
reinserted using C<< ->insert() >> before C<< ->update() >> can be used
on it. If you delete an object in a class with a C<has_many>
relationship, all the related objects will be deleted as well. To turn
-this behavior off, pass C<cascade_delete => 0> in the C<$attr>
+this behavior off, pass C<< cascade_delete => 0 >> in the C<$attr>
hashref. Any database-level cascade or restrict will take precedence
over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
@@ -388,11 +365,12 @@
my $val = $obj->get_column($col);
-Gets a column value from a row object. Does not do any queries; the column
-must have already been fetched from the database and stored in the object. If
-there is an inflated value stored that has not yet been deflated, it is deflated
-when the method is invoked.
+Returns a raw column value from the row object, if it has already
+been fetched from the database or set by an accessor.
+If an L<inflated value|DBIx::Class::InflateColumn> has been set, it
+will be deflated and returned.
+
=cut
sub get_column {
@@ -429,7 +407,7 @@
my %data = $obj->get_columns;
-Does C<get_column>, for all column values at once.
+Does C<get_column>, for all loaded column values at once.
=cut
@@ -460,9 +438,10 @@
=head2 get_inflated_columns
- my $inflated_data = $obj->get_inflated_columns;
+ my %inflated_data = $obj->get_inflated_columns;
-Similar to get_columns but objects are returned for inflated columns instead of their raw non-inflated values.
+Similar to get_columns but objects are returned for inflated columns
+instead of their raw non-inflated values.
=cut
@@ -478,9 +457,13 @@
$obj->set_column($col => $val);
-Sets a column value. If the new value is different from the old one,
+Sets a raw column value. If the new value is different from the old one,
the column is marked as dirty for when you next call $obj->update.
+If passed an object or reference, this will happily attempt store the
+value, and a later insert/update will try and stringify/numify as
+appropriate.
+
=cut
sub set_column {
@@ -490,7 +473,11 @@
my $old = $self->get_column($column);
my $ret = $self->store_column(@_);
$self->{_dirty_columns}{$column} = 1
- if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
+ if (defined $old xor defined $ret) || (defined $old && $old ne $ret);
+
+ # XXX clear out the relation cache for this column
+ delete $self->{related_resultsets}{$column};
+
return $ret;
}
@@ -510,6 +497,52 @@
return $self;
}
+=head2 set_inflated_columns
+
+ my $copy = $orig->set_inflated_columns({ $col => $val, $rel => $obj, ... });
+
+Sets more than one column value at once, taking care to respect inflations and
+relationships if relevant. Be aware that this hashref might be edited in place,
+so dont rely on it being the same after a call to C<set_inflated_columns>. If
+you need to preserve the hashref, it is sufficient to pass a shallow copy to
+C<set_inflated_columns>, e.g. ( { %{ $href } } )
+
+=cut
+
+sub set_inflated_columns {
+ my ( $self, $upd ) = @_;
+ foreach my $key (keys %$upd) {
+ if (ref $upd->{$key}) {
+ my $info = $self->relationship_info($key);
+ if ($info && $info->{attrs}{accessor}
+ && $info->{attrs}{accessor} eq 'single')
+ {
+ my $rel = delete $upd->{$key};
+ $self->set_from_related($key => $rel);
+ $self->{_relationship_data}{$key} = $rel;
+ } elsif ($info && $info->{attrs}{accessor}
+ && $info->{attrs}{accessor} eq 'multi'
+ && ref $upd->{$key} eq 'ARRAY') {
+ my $others = delete $upd->{$key};
+ foreach my $rel_obj (@$others) {
+ if(!Scalar::Util::blessed($rel_obj)) {
+ $rel_obj = $self->create_related($key, $rel_obj);
+ }
+ }
+ $self->{_relationship_data}{$key} = $others;
+# $related->{$key} = $others;
+ next;
+ }
+ elsif ($self->has_column($key)
+ && exists $self->column_info($key)->{_inflate_info})
+ {
+ $self->set_inflated_column($key, delete $upd->{$key});
+ }
+ }
+ }
+ $self->set_columns($upd);
+}
+
=head2 copy
my $copy = $orig->copy({ change => $to, ... });
@@ -531,17 +564,31 @@
bless $new, ref $self;
$new->result_source($self->result_source);
- $new->set_columns($changes);
+ $new->set_inflated_columns($changes);
$new->insert;
+
+ # Its possible we'll have 2 relations to the same Source. We need to make
+ # sure we don't try to insert the same row twice esle we'll violate unique
+ # constraints
+ my $rels_copied = {};
+
foreach my $rel ($self->result_source->relationships) {
my $rel_info = $self->result_source->relationship_info($rel);
- if ($rel_info->{attrs}{cascade_copy}) {
- my $resolved = $self->result_source->resolve_condition(
- $rel_info->{cond}, $rel, $new);
- foreach my $related ($self->search_related($rel)) {
- $related->copy($resolved);
- }
+
+ next unless $rel_info->{attrs}{cascade_copy};
+
+ my $resolved = $self->result_source->resolve_condition(
+ $rel_info->{cond}, $rel, $new
+ );
+
+ my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
+ foreach my $related ($self->search_related($rel)) {
+ my $id_str = join("\0", $related->id);
+ next if $copied->{$id_str};
+ $copied->{$id_str} = 1;
+ my $rel_copy = $related->copy($resolved);
}
+
}
return $new;
}
@@ -634,7 +681,8 @@
$obj->update_or_insert
-Updates the object if it's already in the db, else inserts it.
+Updates the object if it's already in the database, according to
+L</in_storage>, else inserts it.
=head2 insert_or_update
@@ -736,6 +784,22 @@
}
}
+=head2 id
+
+Returns the primary key(s) for a row. Can't be called as a class method.
+Actually implemented in L<DBIx::Class::PK>
+
+=head2 discard_changes
+
+Re-selects the row from the database, losing any changes that had
+been made.
+
+This method can also be used to refresh from storage, retrieving any
+changes made since the row was last read from storage. Actually
+implemented in L<DBIx::Class::PK>
+
+=cut
+
1;
=head1 AUTHORS
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Schema/Versioned.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Schema/Versioned.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Schema/Versioned.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -4,28 +4,43 @@
use warnings;
__PACKAGE__->load_components(qw/ Core/);
-__PACKAGE__->table('SchemaVersions');
+__PACKAGE__->table('dbix_class_schema_versions');
__PACKAGE__->add_columns
- ( 'Version' => {
+ ( 'version' => {
'data_type' => 'VARCHAR',
'is_auto_increment' => 0,
'default_value' => undef,
'is_foreign_key' => 0,
- 'name' => 'Version',
+ 'name' => 'version',
'is_nullable' => 0,
'size' => '10'
},
- 'Installed' => {
+ 'installed' => {
'data_type' => 'VARCHAR',
'is_auto_increment' => 0,
'default_value' => undef,
'is_foreign_key' => 0,
- 'name' => 'Installed',
+ 'name' => 'installed',
'is_nullable' => 0,
'size' => '20'
},
);
+__PACKAGE__->set_primary_key('version');
+
+package DBIx::Class::Version::TableCompat;
+use base 'DBIx::Class';
+__PACKAGE__->load_components(qw/ Core/);
+__PACKAGE__->table('SchemaVersions');
+
+__PACKAGE__->add_columns
+ ( 'Version' => {
+ 'data_type' => 'VARCHAR',
+ },
+ 'Installed' => {
+ 'data_type' => 'VARCHAR',
+ },
+ );
__PACKAGE__->set_primary_key('Version');
package DBIx::Class::Version;
@@ -35,8 +50,67 @@
__PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');
+package DBIx::Class::VersionCompat;
+use base 'DBIx::Class::Schema';
+use strict;
+use warnings;
+__PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat');
+
+
# ---------------------------------------------------------------------------
+
+=head1 NAME
+
+DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
+
+=head1 SYNOPSIS
+
+ package Library::Schema;
+ use base qw/DBIx::Class::Schema/;
+ # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
+ __PACKAGE__->load_classes(qw/CD Book DVD/);
+
+ __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
+ __PACKAGE__->upgrade_directory('/path/to/upgrades/');
+ __PACKAGE__->backup_directory('/path/to/backups/');
+
+
+=head1 DESCRIPTION
+
+This module is a component designed to extend L<DBIx::Class::Schema>
+classes, to enable them to upgrade to newer schema layouts. To use this
+module, you need to have called C<create_ddl_dir> on your Schema to
+create your upgrade files to include with your delivery.
+
+A table called I<dbix_class_schema_versions> is created and maintained by the
+module. This contains two fields, 'Version' and 'Installed', which
+contain each VERSION of your Schema, and the date+time it was installed.
+
+The actual upgrade is called manually by calling C<upgrade> on your
+schema object. Code is run at connect time to determine whether an
+upgrade is needed, if so, a warning "Versions out of sync" is
+produced.
+
+So you'll probably want to write a script which generates your DDLs and diffs
+and another which executes the upgrade.
+
+NB: At the moment, only SQLite and MySQL are supported. This is due to
+spotty behaviour in the SQL::Translator producers, please help us by
+them.
+
+=head1 METHODS
+
+=head2 upgrade_directory
+
+Use this to set the directory your upgrade files are stored in.
+
+=head2 backup_directory
+
+Use this to set the directory you want your backups stored in.
+
+=cut
+
package DBIx::Class::Schema::Versioned;
use strict;
@@ -48,7 +122,18 @@
__PACKAGE__->mk_classdata('_filedata');
__PACKAGE__->mk_classdata('upgrade_directory');
__PACKAGE__->mk_classdata('backup_directory');
+__PACKAGE__->mk_classdata('do_backup');
+__PACKAGE__->mk_classdata('do_diff_on_init');
+=head2 schema_version
+
+Returns the current schema class' $VERSION; does -not- use $schema->VERSION
+since that varies in results depending on if version.pm is installed, and if
+so the perl or XS versions. If you want this to change, bug the version.pm
+author to make vpp and vxs behave the same.
+
+=cut
+
sub schema_version {
my ($self) = @_;
my $class = ref($self)||$self;
@@ -60,97 +145,24 @@
return $version;
}
-sub connection {
- my $self = shift;
- $self->next::method(@_);
- $self->_on_connect;
- return $self;
-}
+=head2 get_db_version
-sub _on_connect
-{
- my ($self) = @_;
- my $vschema = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
- my $vtable = $vschema->resultset('Table');
- my $pversion;
+Returns the version that your database is currently at. This is determined by the values in the
+dbix_class_schema_versions table that $self->upgrade writes to.
- if(!$self->_source_exists($vtable))
- {
-# $vschema->storage->debug(1);
- $vschema->storage->ensure_connected();
- $vschema->deploy();
- $pversion = 0;
- }
- else
- {
- my $psearch = $vtable->search(undef,
- { select => [
- { 'max' => 'Installed' },
- ],
- as => ['maxinstall'],
- })->first;
- $pversion = $vtable->search({ Installed => $psearch->get_column('maxinstall'),
- })->first;
- $pversion = $pversion->Version if($pversion);
- }
-# warn("Previous version: $pversion\n");
- if($pversion eq $self->schema_version)
- {
- warn "This version is already installed\n";
- return 1;
- }
+=cut
-## use IC::DT?
+sub get_db_version
+{
+ my ($self, $rs) = @_;
- if(!$pversion)
- {
- $vtable->create({ Version => $self->schema_version,
- Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
- });
- ## If we let the user do this, where does the Version table get updated?
- warn "No previous version found, calling deploy to install this version.\n";
- $self->deploy();
- return 1;
- }
-
- my $file = $self->ddl_filename(
- $self->storage->sqlt_type,
- $self->upgrade_directory,
- $self->schema_version
- );
- if(!$file)
- {
- # No upgrade path between these two versions
- return 1;
- }
-
- $file = $self->ddl_filename(
- $self->storage->sqlt_type,
- $self->upgrade_directory,
- $self->schema_version,
- $pversion,
- );
-# $file =~ s/@{[ $self->schema_version ]}/"${pversion}-" . $self->schema_version/e;
- if(!-f $file)
- {
- warn "Upgrade not possible, no upgrade file found ($file)\n";
- return;
- }
-
- my $fh;
- open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
- my @data = split(/;\n/, join('', <$fh>));
- close($fh);
- @data = grep { $_ && $_ !~ /^-- / } @data;
- @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data;
-
- $self->_filedata(\@data);
-
- ## Don't do this yet, do only on command?
- ## If we do this later, where does the Version table get updated??
- warn "Versions out of sync. This is " . $self->schema_version .
- ", your database contains version $pversion, please call upgrade on your Schema.\n";
-# $self->upgrade($pversion, $self->schema_version);
+ my $vtable = $self->{vschema}->resultset('Table');
+ my $version = 0;
+ eval {
+ my $stamp = $vtable->get_column('installed')->max;
+ $version = $vtable->search({ installed => $stamp })->first->version;
+ };
+ return $version;
}
sub _source_exists
@@ -165,6 +177,17 @@
return 1;
}
+=head2 backup
+
+This is an overwritable method which is called just before the upgrade, to
+allow you to make a backup of the database. Per default this method attempts
+to call C<< $self->storage->backup >>, to run the standard backup on each
+database type.
+
+This method should return the name of the backup file, if appropriate..
+
+=cut
+
sub backup
{
my ($self) = @_;
@@ -172,126 +195,155 @@
$self->storage->backup($self->backup_directory());
}
-sub upgrade
-{
- my ($self) = @_;
+# is this just a waste of time? if not then merge with DBI.pm
+sub _create_db_to_schema_diff {
+ my $self = shift;
- ## overridable sub, per default just run all the commands.
+ my %driver_to_db_map = (
+ 'mysql' => 'MySQL'
+ );
- $self->backup();
+ my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}};
+ unless ($db) {
+ print "Sorry, this is an unsupported DB\n";
+ return;
+ }
- $self->run_upgrade(qr/create/i);
- $self->run_upgrade(qr/alter table .*? add/i);
- $self->run_upgrade(qr/alter table .*? (?!drop)/i);
- $self->run_upgrade(qr/alter table .*? drop/i);
- $self->run_upgrade(qr/drop/i);
-# $self->run_upgrade(qr//i);
+ eval 'require SQL::Translator "0.09"';
+ if ($@) {
+ $self->throw_exception("SQL::Translator 0.09 required");
+ }
- my $vschema = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
- my $vtable = $vschema->resultset('Table');
- $vtable->create({ Version => $self->schema_version,
- Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
- });
-}
+ my $db_tr = SQL::Translator->new({
+ add_drop_table => 1,
+ parser => 'DBI',
+ parser_args => { dbh => $self->storage->dbh }
+ });
+ $db_tr->producer($db);
+ my $dbic_tr = SQL::Translator->new;
+ $dbic_tr->parser('SQL::Translator::Parser::DBIx::Class');
+ $dbic_tr = $self->storage->configure_sqlt($dbic_tr, $db);
+ $dbic_tr->data($self);
+ $dbic_tr->producer($db);
-sub run_upgrade
-{
- my ($self, $stm) = @_;
-# print "Reg: $stm\n";
- my @statements = grep { $_ =~ $stm } @{$self->_filedata};
-# print "Statements: ", join("\n", @statements), "\n";
- $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
+ $db_tr->schema->name('db_schema');
+ $dbic_tr->schema->name('dbic_schema');
- for (@statements)
+ # is this really necessary?
+ foreach my $tr ($db_tr, $dbic_tr) {
+ my $data = $tr->data;
+ $tr->parser->($tr, $$data);
+ }
+
+ my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db,
+ $dbic_tr->schema, $db,
+ { ignore_constraint_names => 1, ignore_index_names => 1, caseopt => 1 });
+
+ my $filename = $self->ddl_filename(
+ $db,
+ $self->upgrade_directory,
+ $self->schema_version,
+ 'PRE',
+ );
+ my $file;
+ if(!open($file, ">$filename"))
{
- $self->storage->debugobj->query_start($_) if $self->storage->debug;
- $self->storage->dbh->do($_) or warn "SQL was:\n $_";
- $self->storage->debugobj->query_end($_) if $self->storage->debug;
+ $self->throw_exception("Can't open $filename for writing ($!)");
+ next;
}
+ print $file $diff;
+ close($file);
- return 1;
+ print "WARNING: There may be differences between your DB and your DBIC schema. Please review and if necessary run the SQL in $filename to sync your DB.\n";
}
-1;
+=head2 upgrade
-=head1 NAME
+Call this to attempt to upgrade your database from the version it is at to the version
+this DBIC schema is at.
-DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
+It requires an SQL diff file to exist in $schema->upgrade_directory, normally you will
+have created this using $schema->create_ddl_dir.
-=head1 SYNOPSIS
+=cut
- package Library::Schema;
- use base qw/DBIx::Class::Schema/;
- # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
- __PACKAGE__->load_classes(qw/CD Book DVD/);
+sub upgrade
+{
+ my ($self) = @_;
+ my $db_version = $self->get_db_version();
- __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
- __PACKAGE__->upgrade_directory('/path/to/upgrades/');
- __PACKAGE__->backup_directory('/path/to/backups/');
+ # db unversioned
+ unless ($db_version) {
+ # set version in dbix_class_schema_versions table, can't actually upgrade as we don 't know what version the DB is at
+ $self->_create_db_to_schema_diff() if ($self->do_diff_on_init);
- sub backup
- {
- my ($self) = @_;
- # my special backup process
+ # create versions table and version row
+ $self->{vschema}->deploy;
+ $self->_set_db_version;
+ return;
}
- sub upgrade
- {
- my ($self) = @_;
+ # db and schema at same version. do nothing
+ if ($db_version eq $self->schema_version) {
+ print "Upgrade not necessary\n";
+ return;
+ }
- ## overridable sub, per default just runs all the commands.
+ # strangely the first time this is called can
+ # differ to subsequent times. so we call it
+ # here to be sure.
+ # XXX - just fix it
+ $self->storage->sqlt_type;
+
+ my $upgrade_file = $self->ddl_filename(
+ $self->storage->sqlt_type,
+ $self->upgrade_directory,
+ $self->schema_version,
+ $db_version,
+ );
- $self->run_upgrade(qr/create/i);
- $self->run_upgrade(qr/alter table .*? add/i);
- $self->run_upgrade(qr/alter table .*? (?!drop)/i);
- $self->run_upgrade(qr/alter table .*? drop/i);
- $self->run_upgrade(qr/drop/i);
- $self->run_upgrade(qr//i);
+ unless (-f $upgrade_file) {
+ warn "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
+ return;
}
-=head1 DESCRIPTION
+ # backup if necessary then apply upgrade
+ $self->_filedata($self->_read_sql_file($upgrade_file));
+ $self->backup() if($self->do_backup);
+ $self->txn_do(sub { $self->do_upgrade() });
-This module is a component designed to extend L<DBIx::Class::Schema>
-classes, to enable them to upgrade to newer schema layouts. To use this
-module, you need to have called C<create_ddl_dir> on your Schema to
-create your upgrade files to include with your delivery.
+ # set row in dbix_class_schema_versions table
+ $self->_set_db_version;
+}
-A table called I<SchemaVersions> is created and maintained by the
-module. This contains two fields, 'Version' and 'Installed', which
-contain each VERSION of your Schema, and the date+time it was installed.
+sub _set_db_version {
+ my $self = shift;
-If you would like to influence which levels of version change need
-upgrades in your Schema, you can override the method C<ddl_filename>
-in L<DBIx::Class::Schema>. Return a false value if there is no upgrade
-path between the two versions supplied. By default, every change in
-your VERSION is regarded as needing an upgrade.
+ my $vtable = $self->{vschema}->resultset('Table');
+ $vtable->create({ version => $self->schema_version,
+ installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
+ });
-The actual upgrade is called manually by calling C<upgrade> on your
-schema object. Code is run at connect time to determine whether an
-upgrade is needed, if so, a warning "Versions out of sync" is
-produced.
+}
-NB: At the moment, SQLite upgrading is rather spotty, as SQL::Translator::Diff
-returns SQL statements that SQLite does not support.
+sub _read_sql_file {
+ my $self = shift;
+ my $file = shift || return;
+ my $fh;
+ open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
+ my @data = split(/\n/, join('', <$fh>));
+ @data = grep(!/^--/, @data);
+ @data = split(/;/, join('', @data));
+ close($fh);
+ @data = grep { $_ && $_ !~ /^-- / } @data;
+ @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data;
+ return \@data;
+}
-=head1 METHODS
+=head2 do_upgrade
-=head2 backup
-
-This is an overwritable method which is called just before the upgrade, to
-allow you to make a backup of the database. Per default this method attempts
-to call C<< $self->storage->backup >>, to run the standard backup on each
-database type.
-
-This method should return the name of the backup file, if appropriate.
-
-C<backup> is called from C<upgrade>, make sure you call it, if you write your
-own <upgrade> method.
-
-=head2 upgrade
-
This is an overwritable method used to run your upgrade. The freeform method
allows you to run your upgrade any way you please, you can call C<run_upgrade>
any number of times to run the actual SQL commands, and in between you can
@@ -299,6 +351,22 @@
commands, then migrate your data from old to new tables/formats, then
issue the DROP commands when you are finished.
+Will run the whole file as it is by default.
+
+=cut
+
+sub do_upgrade
+{
+ my ($self) = @_;
+
+ ## overridable sub, per default just run all the commands.
+ $self->run_upgrade(qr/create/i);
+ $self->run_upgrade(qr/alter table .*? add/i);
+ $self->run_upgrade(qr/alter table .*? (?!drop)/i);
+ $self->run_upgrade(qr/alter table .*? drop/i);
+ $self->run_upgrade(qr/drop/i);
+}
+
=head2 run_upgrade
$self->run_upgrade(qr/create/i);
@@ -306,23 +374,94 @@
Runs a set of SQL statements matching a passed in regular expression. The
idea is that this method can be called any number of times from your
C<upgrade> method, running whichever commands you specify via the
-regex in the parameter.
+regex in the parameter. Probably won't work unless called from the overridable
+do_upgrade method.
-=head2 upgrade_directory
+=cut
-Use this to set the directory your upgrade files are stored in.
+sub run_upgrade
+{
+ my ($self, $stm) = @_;
-=head2 backup_directory
+ return unless ($self->_filedata);
+ my @statements = grep { $_ =~ $stm } @{$self->_filedata};
+ $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
-Use this to set the directory you want your backups stored in.
+ for (@statements)
+ {
+ $self->storage->debugobj->query_start($_) if $self->storage->debug;
+ $self->storage->dbh->do($_) or warn "SQL was:\n $_";
+ $self->storage->debugobj->query_end($_) if $self->storage->debug;
+ }
-=head2 schema_version
+ return 1;
+}
-Returns the current schema class' $VERSION; does -not- use $schema->VERSION
-since that varies in results depending on if version.pm is installed, and if
-so the perl or XS versions. If you want this to change, bug the version.pm
-author to make vpp and vxs behave the same.
+=head2 connection
-=head1 AUTHOR
+Overloaded method. This checks the DBIC schema version against the DB version and
+warns if they are not the same or if the DB is unversioned. It also provides
+compatibility between the old versions table (SchemaVersions) and the new one
+(dbix_class_schema_versions).
+To avoid the checks on connect, set the env var DBIC_NO_VERSION_CHECK. This can be
+useful for scripts.
+
+=cut
+
+sub connection {
+ my $self = shift;
+ $self->next::method(@_);
+ $self->_on_connect;
+ return $self;
+}
+
+sub _on_connect
+{
+ my ($self) = @_;
+ $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
+ my $vtable = $self->{vschema}->resultset('Table');
+
+ # check for legacy versions table and move to new if exists
+ my $vschema_compat = DBIx::Class::VersionCompat->connect(@{$self->storage->connect_info()});
+ unless ($self->_source_exists($vtable)) {
+ my $vtable_compat = $vschema_compat->resultset('TableCompat');
+ if ($self->_source_exists($vtable_compat)) {
+ $self->{vschema}->deploy;
+ map { $vtable->create({ installed => $_->Installed, version => $_->Version }) } $vtable_compat->all;
+ $self->storage->dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
+ }
+ }
+
+ # useful when connecting from scripts etc
+ return if ($ENV{DBIC_NO_VERSION_CHECK});
+
+ my $pversion = $self->get_db_version();
+
+ if($pversion eq $self->schema_version)
+ {
+# warn "This version is already installed\n";
+ return 1;
+ }
+
+ if(!$pversion)
+ {
+ warn "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
+ return 1;
+ }
+
+ warn "Versions out of sync. This is " . $self->schema_version .
+ ", your database contains version $pversion, please call upgrade on your Schema.\n";
+}
+
+1;
+
+
+=head1 AUTHORS
+
Jess Robinson <castaway at desert-island.demon.co.uk>
+Luke Saunders <luke at shadowcatsystems.co.uk>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Schema.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Schema.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Schema.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -734,6 +734,21 @@
$self->storage->txn_do(@_);
}
+=head2 txn_scope_guard
+
+Runs C<txn_scope_guard> on the schema's storage.
+
+=cut
+
+sub txn_scope_guard {
+ my $self = shift;
+
+ $self->storage or $self->throw_exception
+ ('txn_scope_guard called on $schema without storage');
+
+ $self->storage->txn_scope_guard(@_);
+}
+
=head2 txn_begin
Begins a transaction (does nothing if AutoCommit is off). Equivalent to
@@ -1059,8 +1074,44 @@
For an example of what you can do with this, see
L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
+=head2 thaw
+
+Provided as the recommened way of thawing schema objects. You can call
+C<Storable::thaw> directly if you wish, but the thawed objects will not have a
+reference to any schema, so are rather useless
+
=cut
+sub thaw {
+ my ($self, $obj) = @_;
+ local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
+ return Storable::thaw($obj);
+}
+
+=head2 freeze
+
+This doesn't actualy do anything more than call L<Storable/freeze>, it is just
+provided here for symetry.
+
+=cut
+
+sub freeze {
+ return Storable::freeze($_[1]);
+}
+
+=head2 dclone
+
+Recommeneded way of dcloning objects. This is needed to properly maintain
+references to the schema object (which itself is B<not> cloned.)
+
+=cut
+
+sub dclone {
+ my ($self, $obj) = @_;
+ local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
+ return Storable::dclone($obj);
+}
+
1;
=head1 AUTHORS
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Serialize/Storable.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Serialize/Storable.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Serialize/Storable.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -4,14 +4,19 @@
use Storable;
sub STORABLE_freeze {
- my ($self,$cloning) = @_;
+ my ($self, $cloning) = @_;
my $to_serialize = { %$self };
+
delete $to_serialize->{result_source};
+ delete $to_serialize->{related_resultsets};
+ delete $to_serialize->{_inflated_column};
+
return (Storable::freeze($to_serialize));
}
sub STORABLE_thaw {
- my ($self,$cloning,$serialized) = @_;
+ my ($self, $cloning, $serialized) = @_;
+
%$self = %{ Storable::thaw($serialized) };
$self->result_source($self->result_source_instance)
if $self->can('result_source_instance');
Added: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,96 @@
+package DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server;
+use strict;
+use warnings;
+
+use base qw/DBIx::Class::Storage::DBI/;
+
+sub _prep_for_execute {
+ my $self = shift;
+ my ($op, $extra_bind, $ident, $args) = @_;
+
+ my ($sql, $bind) = $self->SUPER::_prep_for_execute(@_);
+ $sql .= ';SELECT SCOPE_IDENTITY()' if $op eq 'insert';
+
+ return ($sql, $bind);
+}
+
+sub insert {
+ my ($self, $source, $to_insert) = @_;
+
+ my $bind_attributes = $self->source_bind_attributes($source);
+ my (undef, $sth) = $self->_execute( 'insert' => [], $source, $bind_attributes, $to_insert);
+ $self->{_scope_identity} = $sth->fetchrow_array;
+
+ return $to_insert;
+}
+
+sub last_insert_id { shift->{_scope_identity} }
+
+sub sqlt_type { 'SQLServer' }
+
+sub _sql_maker_opts {
+ my ( $self, $opts ) = @_;
+
+ if ( $opts ) {
+ $self->{_sql_maker_opts} = { %$opts };
+ }
+
+ return { limit_dialect => 'Top', %{$self->{_sql_maker_opts}||{}} };
+}
+
+sub build_datetime_parser {
+ my $self = shift;
+ my $type = "DateTime::Format::Strptime";
+ eval "use ${type}";
+ $self->throw_exception("Couldn't load ${type}: $@") if $@;
+ return $type->new( pattern => '%F %T' );
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBIx::Class::Storage::ODBC::Microsoft_SQL_Server - Support specific to
+Microsoft SQL Server over ODBC
+
+=head1 DESCRIPTION
+
+This class implements support specific to Microsoft SQL Server over ODBC,
+including auto-increment primary keys and SQL::Abstract::Limit dialect. It
+is loaded automatically by by DBIx::Class::Storage::DBI::ODBC when it
+detects a MSSQL back-end.
+
+=head1 IMPLEMENTATION NOTES
+
+Microsoft SQL Server supports three methods of retrieving the IDENTITY
+value for inserted row: IDENT_CURRENT, @@IDENTITY, and SCOPE_IDENTITY().
+SCOPE_IDENTITY is used here because it is the safest. However, it must
+be called is the same execute statement, not just the same connection.
+
+So, this implementation appends a SELECT SCOPE_IDENTITY() statement
+onto each INSERT to accommodate that requirement.
+
+=head1 METHODS
+
+=head2 insert
+
+=head2 last_insert_id
+
+=head2 sqlt_type
+
+=head2 build_datetime_parser
+
+The resulting parser handles the MSSQL C<DATETIME> type, but is almost
+certainly not sufficient for the other MSSQL 2008 date/time types.
+
+=head1 AUTHORS
+
+Marc Mims C<< <marc at questright.com> >>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI/Replication.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI/Replication.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI/Replication.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -89,9 +89,9 @@
# We need to copy-pass $global_options, since connect_info clears it while
# processing options
- $self->write_source->connect_info( [ @{$info->[0]}, { %$global_options } ] );
+ $self->write_source->connect_info( @{$info->[0]}, { %$global_options } );
- @dsns = map { ($_->[3]->{priority} || 10) => $_ } @{$info}[1..@$info-1];
+ @dsns = map { ($_->[3]->{priority} || 10) => $_ } @{$info->[0]}[1..@{$info->[0]}-1];
$global_options->{dsns} = \@dsns;
$self->read_source->connect_info( [ 'dbi:Multi:', undef, undef, { %$global_options } ] );
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI/SQLite.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI/SQLite.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI/SQLite.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -33,7 +33,7 @@
# my $dbfile = file($dbname);
my ($vol, $dbdir, $file) = File::Spec->splitpath($dbname);
# my $file = $dbfile->basename();
- $file = strftime("%y%m%d%h%M%s", localtime()) . $file;
+ $file = strftime("%Y-%m-%d-%H_%M_%S", localtime()) . $file;
$file = "B$file" while(-f $file);
mkdir($dir) unless -f $dir;
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/DBI.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -1133,6 +1133,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};
}
@@ -1340,21 +1343,22 @@
$version ||= $schema->VERSION || '1.x';
$sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
- $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.08: '}
+ $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.09: '}
. $self->_check_sqlt_message . q{'})
if !$self->_check_sqlt_version;
my $sqlt = SQL::Translator->new({
-# debug => 1,
add_drop_table => 1,
});
+
+ $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
+ my $sqlt_schema = $sqlt->translate({ data => $schema }) or die $sqlt->error;
+
foreach my $db (@$databases)
{
$sqlt->reset();
- $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
-# $sqlt->parser_args({'DBIx::Class' => $schema);
$sqlt = $self->configure_sqlt($sqlt, $db);
- $sqlt->data($schema);
+ $sqlt->{schema} = $sqlt_schema;
$sqlt->producer($db);
my $file;
@@ -1362,23 +1366,22 @@
if(-e $filename)
{
warn("$filename already exists, skipping $db");
- next;
- }
-
- my $output = $sqlt->translate;
- if(!$output)
- {
- warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
- next;
- }
- if(!open($file, ">$filename"))
- {
- $self->throw_exception("Can't open $filename for writing ($!)");
+ next unless ($preversion);
+ } else {
+ my $output = $sqlt->translate;
+ if(!$output)
+ {
+ warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
next;
- }
- print $file $output;
- close($file);
-
+ }
+ if(!open($file, ">$filename"))
+ {
+ $self->throw_exception("Can't open $filename for writing ($!)");
+ next;
+ }
+ print $file $output;
+ close($file);
+ }
if($preversion)
{
require SQL::Translator::Diff;
@@ -1390,43 +1393,48 @@
warn("No previous schema file found ($prefilename)");
next;
}
- #### We need to reparse the SQLite file we just wrote, so that
- ## Diff doesnt get all confoosed, and Diff is *very* confused.
- ## FIXME: rip Diff to pieces!
-# my $target_schema = $sqlt->schema;
-# unless ( $target_schema->name ) {
-# $target_schema->name( $filename );
-# }
- my @input;
- push @input, {file => $prefilename, parser => $db};
- push @input, {file => $filename, parser => $db};
- my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
- my $file = $_->{'file'};
- my $parser = $_->{'parser'};
+ my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
+ print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
+ if(-e $difffile)
+ {
+ warn("$difffile already exists, skipping");
+ next;
+ }
+
+ my $source_schema;
+ {
my $t = SQL::Translator->new;
$t->debug( 0 );
$t->trace( 0 );
- $t->parser( $parser ) or die $t->error;
- my $out = $t->translate( $file ) or die $t->error;
- my $schema = $t->schema;
- unless ( $schema->name ) {
- $schema->name( $file );
+ $t->parser( $db ) or die $t->error;
+ my $out = $t->translate( $prefilename ) or die $t->error;
+ $source_schema = $t->schema;
+ unless ( $source_schema->name ) {
+ $source_schema->name( $prefilename );
}
- ($schema, $parser);
- } @input;
+ }
+ # The "new" style of producers have sane normalization and can support
+ # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
+ # And we have to diff parsed SQL against parsed SQL.
+ my $dest_schema = $sqlt_schema;
+
+ unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
+ my $t = SQL::Translator->new;
+ $t->debug( 0 );
+ $t->trace( 0 );
+ $t->parser( $db ) or die $t->error;
+ my $out = $t->translate( $filename ) or die $t->error;
+ $dest_schema = $t->schema;
+ $dest_schema->name( $filename )
+ unless $dest_schema->name;
+ }
+
my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
- $target_schema, $db,
+ $dest_schema, $db,
{}
);
- my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
- print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
- if(-e $difffile)
- {
- warn("$difffile already exists, skipping");
- next;
- }
if(!open $file, ">$difffile")
{
$self->throw_exception("Can't write to $difffile ($!)");
@@ -1490,7 +1498,7 @@
return join('', @rows);
}
- $self->throw_exception(q{Can't deploy without SQL::Translator 0.08: '}
+ $self->throw_exception(q{Can't deploy without SQL::Translator 0.09: '}
. $self->_check_sqlt_message . q{'})
if !$self->_check_sqlt_version;
@@ -1575,9 +1583,9 @@
my $_check_sqlt_message; # private
sub _check_sqlt_version {
return $_check_sqlt_version if defined $_check_sqlt_version;
- eval 'use SQL::Translator 0.08';
- $_check_sqlt_message = $@ ? $@ : '';
- $_check_sqlt_version = $@ ? 0 : 1;
+ eval 'use SQL::Translator "0.09"';
+ $_check_sqlt_message = $@ || '';
+ $_check_sqlt_version = !$@;
}
sub _check_sqlt_message {
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/Statistics.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/Statistics.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/Statistics.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -3,6 +3,7 @@
use warnings;
use base qw/Class::Accessor::Grouped/;
+use IO::File;
__PACKAGE__->mk_group_accessors(simple => qw/callback debugfh/);
Added: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/TxnScopeGuard.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/TxnScopeGuard.pm (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage/TxnScopeGuard.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,96 @@
+package # Hide from pause for now - till we get it working
+ DBIx::Class::Storage::TxnScopeGuard;
+
+use strict;
+use warnings;
+
+sub new {
+ my ($class, $storage) = @_;
+
+ $storage->txn_begin;
+ bless [ 0, $storage ], ref $class || $class;
+}
+
+sub commit {
+ my $self = shift;
+
+ $self->[1]->txn_commit;
+ $self->[0] = 1;
+}
+
+sub DESTROY {
+ my ($dismiss, $storage) = @{$_[0]};
+
+ return if $dismiss;
+
+ my $exception = $@;
+
+ $DB::single = 1;
+
+ local $@;
+ eval { $storage->txn_rollback };
+ my $rollback_exception = $@;
+ if($rollback_exception) {
+ my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
+
+ $storage->throw_exception(
+ "Transaction aborted: ${exception}. "
+ . "Rollback failed: ${rollback_exception}"
+ ) unless $rollback_exception =~ /$exception_class/;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBIx::Class::Storage::TxnScopeGuard
+
+=head1 SYNOPSIS
+
+ sub foo {
+ my ($self, $schema) = @_;
+
+ my $guard = $schema->txn_scope_guard;
+
+ # Multiple database operations here
+
+ $guard->commit;
+ }
+
+=head1 DESCRIPTION
+
+An object that behaves much like L<Scope::Guard>, but hardcoded to do the
+right thing with transactions in DBIx::Class.
+
+=head1 METHODS
+
+=head2 new
+
+Creating an instance of this class will start a new transaction. Expects a
+L<DBIx::Class::Storage> object as its only argument.
+
+=head2 commit
+
+Commit the transaction, and stop guarding the scope. If this method is not
+called (i.e. an exception is thrown) and this object goes out of scope then
+the transaction is rolled back.
+
+=cut
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema/txn_scope_guard>.
+
+=head1 AUTHOR
+
+Ash Berlin, 2008.
+
+Insipred by L<Scope::Guard> by chocolateboy.
+
+This module is free software. It may be used, redistributed and/or modified
+under the same terms as Perl itself.
+
+=cut
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class/Storage.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -8,6 +8,7 @@
use Scalar::Util qw/weaken/;
use Carp::Clan qw/^DBIx::Class/;
use IO::File;
+use DBIx::Class::Storage::TxnScopeGuard;
__PACKAGE__->mk_group_accessors('simple' => qw/debug debugobj schema/);
__PACKAGE__->mk_group_accessors('inherited' => 'cursor_class');
@@ -261,6 +262,18 @@
sub txn_rollback { die "Virtual method!" }
+=for comment
+
+=head2 txn_scope_guard
+
+Return an object that does stuff.
+
+=cut
+
+sub txn_scope_guard {
+ return DBIx::Class::Storage::TxnScopeGuard->new($_[0]);
+}
+
=head2 sql_maker
Returns a C<sql_maker> object - normally an object of class
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/DBIx/Class.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -24,7 +24,7 @@
# i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
# brain damage and presumably various other packaging systems too
-$VERSION = '0.08007';
+$VERSION = '0.08010';
sub MODIFY_CODE_ATTRIBUTES {
my ($class,$code, at attrs) = @_;
@@ -218,6 +218,8 @@
da5id: David Jack Olrik <djo at cpan.org>
+debolaz: Anders Nor Berle <berle at cpan.org>
+
dkubb: Dan Kubb <dan.kubb-cpan at onautopilot.com>
dnm: Justin Wheeler <jwheeler at datademons.com>
@@ -254,10 +256,14 @@
Numa: Dan Sully <daniel at cpan.org>
+oyse: Øystein Torget <oystein.torget at dnv.com>
+
paulm: Paul Makepeace
penguin: K J Cheetham
+perigrin: Chris Prather <chris at prather.org>
+
phaylon: Robert Sedlacek <phaylon at dunkelheit.at>
quicksilver: Jules Bean
@@ -270,6 +276,8 @@
sszabo: Stephan Szabo <sszabo at bigpanda.com>
+teejay : Aaron Trevena <teejay at cpan.org>
+
Todd Lipcon
Tom Hukins
Modified: DBIx-Class/0.08/branches/oracle_sequence/lib/SQL/Translator/Parser/DBIx/Class.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/lib/SQL/Translator/Parser/DBIx/Class.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/lib/SQL/Translator/Parser/DBIx/Class.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -9,9 +9,8 @@
use strict;
use warnings;
-use vars qw($DEBUG $VERSION @EXPORT_OK);
+use vars qw($DEBUG @EXPORT_OK);
$DEBUG = 0 unless defined $DEBUG;
-$VERSION = sprintf "%d.%02d", q$Revision 1.0$ =~ /(\d+)\.(\d+)/;
use Exporter;
use Data::Dumper;
@@ -30,26 +29,25 @@
sub parse {
my ($tr, $data) = @_;
my $args = $tr->parser_args;
- my $dbixschema = $args->{'DBIx::Schema'} || $data;
- $dbixschema ||= $args->{'package'};
+ my $dbicschema = $args->{'DBIx::Class::Schema'} || $args->{"DBIx::Schema"} ||$data;
+ $dbicschema ||= $args->{'package'};
my $limit_sources = $args->{'sources'};
- die 'No DBIx::Schema' unless ($dbixschema);
- if (!ref $dbixschema) {
- eval "use $dbixschema;";
- die "Can't load $dbixschema ($@)" if($@);
+ die 'No DBIx::Class::Schema' unless ($dbicschema);
+ if (!ref $dbicschema) {
+ eval "use $dbicschema;";
+ die "Can't load $dbicschema ($@)" if($@);
}
my $schema = $tr->schema;
my $table_no = 0;
-# print Dumper($dbixschema->registered_classes);
+ $schema->name( ref($dbicschema) . " v" . ($dbicschema->VERSION || '1.x'))
+ unless ($schema->name);
- #foreach my $tableclass ($dbixschema->registered_classes)
-
my %seen_tables;
- my @monikers = $dbixschema->sources;
+ my @monikers = sort $dbicschema->sources;
if ($limit_sources) {
my $ref = ref $limit_sources || '';
die "'sources' parameter must be an array or hash ref" unless $ref eq 'ARRAY' || ref eq 'HASH';
@@ -65,10 +63,11 @@
}
- foreach my $moniker (@monikers)
+ foreach my $moniker (sort @monikers)
{
- my $source = $dbixschema->source($moniker);
+ my $source = $dbicschema->source($moniker);
+ # Its possible to have multiple DBIC source using same table
next if $seen_tables{$source->name}++;
my $table = $schema->add_table(
@@ -96,14 +95,29 @@
$table->primary_key($source->primary_columns);
my @primary = $source->primary_columns;
+ foreach my $field (@primary) {
+ my $index = $table->add_index(
+ name => $field,
+ fields => [$field],
+ type => 'NORMAL',
+ );
+ }
my %unique_constraints = $source->unique_constraints;
- foreach my $uniq (keys %unique_constraints) {
+ foreach my $uniq (sort keys %unique_constraints) {
if (!$source->compare_relationship_keys($unique_constraints{$uniq}, \@primary)) {
$table->add_constraint(
type => 'unique',
name => "$uniq",
fields => $unique_constraints{$uniq}
);
+
+ my $index = $table->add_index(
+ # TODO: Pick a better than that wont conflict
+ name => $unique_constraints{$uniq}->[0],
+ fields => $unique_constraints{$uniq},
+ type => 'NORMAL',
+ );
+
}
}
@@ -111,7 +125,7 @@
my %created_FK_rels;
- foreach my $rel (@rels)
+ foreach my $rel (sort @rels)
{
my $rel_info = $source->relationship_info($rel);
@@ -139,6 +153,8 @@
$on_update = $otherrelationship->{'attrs'}->{cascade_copy} ? 'CASCADE' : '';
}
+ my $is_deferrable = $rel_info->{attrs}{is_deferrable} || 0;
+
# Make sure we dont create the same foreign key constraint twice
my $key_test = join("\x00", @keys);
@@ -148,24 +164,36 @@
# If the sets are different, then we assume it's a foreign key from
# us to another table.
# OR: If is_foreign_key_constraint attr is explicity set (or set to false) on the relation
- if ( ! exists $created_FK_rels{$rel_table}->{$key_test} &&
- ( exists $rel_info->{attrs}{is_foreign_key_constraint} &&
- $rel_info->{attrs}{is_foreign_key_constraint} ||
- !$source->compare_relationship_keys(\@keys, \@primary)
- )
- )
- {
- $created_FK_rels{$rel_table}->{$key_test} = 1;
- $table->add_constraint(
- type => 'foreign_key',
- name => "fk_$keys[0]",
- fields => \@keys,
- reference_fields => \@refkeys,
- reference_table => $rel_table,
- on_delete => $on_delete,
- on_update => $on_update
- );
+ next if ( exists $created_FK_rels{$rel_table}->{$key_test} );
+ if ( exists $rel_info->{attrs}{is_foreign_key_constraint}) {
+ # not is this attr set to 0 but definitely if set to 1
+ next unless ($rel_info->{attrs}{is_foreign_key_constraint});
+ } else {
+ # not if might have
+ # next if ($rel_info->{attrs}{accessor} eq 'single' && exists $rel_info->{attrs}{join_type} && uc($rel_info->{attrs}{join_type}) eq 'LEFT');
+ # not sure about this one
+ next if $source->compare_relationship_keys(\@keys, \@primary);
}
+
+ $created_FK_rels{$rel_table}->{$key_test} = 1;
+ if (scalar(@keys)) {
+ $table->add_constraint(
+ type => 'foreign_key',
+ name => $table->name . "_fk_$keys[0]",
+ fields => \@keys,
+ reference_fields => \@refkeys,
+ reference_table => $rel_table,
+ on_delete => $on_delete,
+ on_update => $on_update,
+ deferrable => $is_deferrable,
+ );
+
+ my $index = $table->add_index(
+ name => join('_', @keys),
+ fields => \@keys,
+ type => 'NORMAL',
+ );
+ }
}
}
@@ -174,8 +202,8 @@
}
}
- if ($dbixschema->can('sqlt_deploy_hook')) {
- $dbixschema->sqlt_deploy_hook($schema);
+ if ($dbicschema->can('sqlt_deploy_hook')) {
+ $dbicschema->sqlt_deploy_hook($schema);
}
return 1;
Modified: DBIx-Class/0.08/branches/oracle_sequence/script/dbicadmin
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/script/dbicadmin 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/script/dbicadmin 2008-03-11 20:30:42 UTC (rev 4173)
@@ -4,11 +4,11 @@
use Getopt::Long;
use Pod::Usage;
-use JSON qw( jsonToObj );
+use JSON::Any;
-$JSON::BareKey = 1;
-$JSON::QuotApos = 1;
+my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1);
+
GetOptions(
'schema=s' => \my $schema_class,
'class=s' => \my $resultset_class,
@@ -50,7 +50,7 @@
die('No schema specified') if(!$schema_class);
eval("require $schema_class");
die('Unable to load schema') if ($@);
-$connect = jsonToObj( $connect ) if ($connect);
+$connect = $json->jsonToObj( $connect ) if ($connect);
my $schema = $schema_class->connect(
( $connect ? @$connect : () )
);
@@ -59,15 +59,15 @@
my $resultset = eval{ $schema->resultset($resultset_class) };
die('Unable to load the class with the schema') if ($@);
-$set = jsonToObj( $set ) if ($set);
-$where = jsonToObj( $where ) if ($where);
-$attrs = jsonToObj( $attrs ) if ($attrs);
+$set = $json->jsonToObj( $set ) if ($set);
+$where = $json->jsonToObj( $where ) if ($where);
+$attrs = $json->jsonToObj( $attrs ) if ($attrs);
if ($op eq 'insert') {
die('Do not use the where option with the insert op') if ($where);
die('Do not use the attrs option with the insert op') if ($attrs);
my $obj = $resultset->create( $set );
- print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n";
+ print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$quiet);
}
elsif ($op eq 'update') {
$resultset = $resultset->search( ($where||{}) );
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/03podcoverage.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/03podcoverage.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/03podcoverage.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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/branches/oracle_sequence/t/18inserterror.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/18inserterror.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/18inserterror.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -7,19 +7,23 @@
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 3 );
+ : ( tests => 4 );
}
use lib qw(t/lib);
use_ok( 'DBICTest' );
-
use_ok( 'DBICTest::Schema' );
+my $schema = DBICTest->init_schema;
{
my $warnings;
local $SIG{__WARN__} = sub { $warnings .= $_[0] };
- eval { DBICTest::CD->create({ title => 'vacation in antarctica' }) };
+ eval {
+ $schema->resultset('CD')
+ ->create({ title => 'vacation in antarctica' })
+ };
+ like $@, qr/NULL/; # as opposed to some other error
ok( $warnings !~ /uninitialized value/, "No warning from Storage" );
}
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/68inflate.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/68inflate.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/68inflate.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -10,7 +10,7 @@
eval { require DateTime };
plan skip_all => "Need DateTime for inflation tests" if $@;
-plan tests => 20;
+plan tests => 21;
$schema->class('CD')
#DBICTest::Schema::CD
@@ -99,6 +99,10 @@
$cd->discard_changes;
is($cd->year->year, $before_year + 1, 'discard_changes clears the inflated value');
+
+my $copy = $cd->copy({ year => $now, title => "zemoose" });
+
+isnt( $copy->year->year, $before_year, "copy" );
# eval { $cd->store_inflated_column('year', \'year + 1') };
# print STDERR "ERROR: $@" if($@);
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/73oracle_inflate.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/73oracle_inflate.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/73oracle_inflate.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -54,9 +54,6 @@
# clean up our mess
END {
- # Set the metadata back for the last_updated_on column
- $schema->class('Track')->add_column( 'last_updated_on' => $col_metadata );
-
if($dbh) {
$dbh->do("DROP TABLE track");
}
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/746db2_400.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/746db2_400.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/746db2_400.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -21,7 +21,7 @@
my $dbh = $schema->storage->dbh;
-$dbh->do("DROP TABLE artist", { RaiseError => 0, PrintError => 0 });
+eval { $dbh->do("DROP TABLE artist") };
$dbh->do("CREATE TABLE artist (artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1), name VARCHAR(255), charfield CHAR(10))");
Added: DBIx-Class/0.08/branches/oracle_sequence/t/746mssql.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/746mssql.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/746mssql.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,63 @@
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ODBC_DSN}, _USER and _PASS to run this test'
+ unless ($dsn && $user);
+
+plan tests => 12;
+
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {AutoCommit => 1});
+
+$schema->storage->ensure_connected;
+isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server' );
+
+my $dbh = $schema->storage->dbh;
+
+eval { $dbh->do("DROP TABLE artist") };
+
+ $dbh->do(<<'');
+CREATE TABLE artist (
+ artistid INT IDENTITY NOT NULL,
+ name VARCHAR(255),
+ charfield CHAR(10),
+ primary key(artistid)
+)
+
+my %seen_id;
+
+# test primary key handling
+my $new = $schema->resultset('Artist')->create({ name => 'foo' });
+ok($new->artistid > 0, "Auto-PK worked");
+
+$seen_id{$new->artistid}++;
+
+# test LIMIT support
+for (1..6) {
+ $new = $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
+ is ( $seen_id{$new->artistid}, undef, "id for Artist $_ is unique" );
+ $seen_id{$new->artistid}++;
+}
+
+my $it = $schema->resultset('Artist')->search( {}, {
+ rows => 3,
+ order_by => 'artistid',
+});
+
+is( $it->count, 3, "LIMIT count ok" );
+is( $it->next->name, "foo", "iterator->next ok" );
+$it->next;
+is( $it->next->name, "Artist 2", "iterator->next ok" );
+is( $it->next, undef, "next past end of resultset ok" );
+
+
+# clean up our mess
+END {
+ $dbh->do('DROP TABLE artist') if $dbh;
+}
+
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/75limit.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/75limit.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/75limit.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -9,8 +9,8 @@
BEGIN {
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 9);
-}
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 10);
+}
# test LIMIT
my $it = $schema->resultset("CD")->search( {},
@@ -51,6 +51,15 @@
);
is( $cds[0]->title, "Spoonful of bees", "software offset ok" );
+
+ at cds = $schema->resultset("CD")->search( {},
+ {
+ offset => 2,
+ order_by => 'year' }
+);
+is( $cds[0]->title, "Spoonful of bees", "offset with no limit" );
+
+
# based on a failing criteria submitted by waswas
# requires SQL::Abstract >= 1.20
$it = $schema->resultset("CD")->search(
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/76joins.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/76joins.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/76joins.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -247,12 +247,8 @@
is($cd->producers->first->name, 'Matt S Trout', 'many_to_many accessor ok');
-TODO: {
- local $TODO = 'use prefetched values for many_to_many accessor';
+is($queries, 1, 'many_to_many accessor with nested prefetch ran exactly 1 query');
- is($queries, 1, 'many_to_many accessor with nested prefetch ran exactly 1 query');
-}
-
$queries = 0;
my $producers = $cd->search_related('cd_to_producer')->search_related('producer');
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/81transactions.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/81transactions.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/81transactions.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -2,12 +2,13 @@
use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
my $schema = DBICTest->init_schema();
-plan tests => 54;
+plan tests => 67;
my $code = sub {
my ($artist, @cd_titles) = @_;
@@ -236,3 +237,99 @@
my $err = $@;
ok(($err eq ''), 'Pre-connection nested transactions.');
}
+
+# Test txn_rollback with nested
+{
+ local $TODO = "Work out how this should work";
+ my $local_schema = DBICTest->init_schema();
+
+ my $artist_rs = $local_schema->resultset('Artist');
+ throws_ok {
+
+ $local_schema->txn_begin;
+ $artist_rs->create({ name => 'Test artist rollback 1'});
+ $local_schema->txn_begin;
+ is($local_schema->storage->transaction_depth, 2, "Correct transaction depth");
+ $artist_rs->create({ name => 'Test artist rollback 2'});
+ $local_schema->txn_rollback;
+ } qr/Not sure what this should be.... something tho/, "Rolled back okay";
+ is($local_schema->storage->transaction_depth, 0, "Correct transaction depth");
+
+ ok(!$artist_rs->find({ name => 'Test artist rollback 1'}), "Test Artist not created")
+ || $artist_rs->find({ name => 'Test artist rollback 1'})->delete;
+}
+
+# Test txn_scope_guard
+{
+ local $TODO = "Work out how this should work";
+ my $schema = DBICTest->init_schema();
+
+ is($schema->storage->transaction_depth, 0, "Correct transaction depth");
+ my $artist_rs = $schema->resultset('Artist');
+ throws_ok {
+ my $guard = $schema->txn_scope_guard;
+
+
+ $artist_rs->create({
+ name => 'Death Cab for Cutie',
+ made_up_column => 1,
+ });
+
+ $guard->commit;
+ } qr/No such column made_up_column.*?line 16/, "Error propogated okay";
+
+ ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+
+ my $inner_exception;
+ eval {
+ outer($schema, 1);
+ };
+ is($@, $inner_exception, "Nested exceptions propogated");
+
+ ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+
+
+ eval {
+ # The 0 arg says done die, just let the scope guard go out of scope
+ # forcing a txn_rollback to happen
+ outer($schema, 0);
+ };
+ is($@, "Not sure what we want here, but something", "Rollback okay");
+
+ ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+
+ sub outer {
+ my ($schema) = @_;
+
+ my $guard = $schema->txn_scope_guard;
+ $schema->resultset('Artist')->create({
+ name => 'Death Cab for Cutie',
+ });
+ inner(@_);
+ $guard->commit;
+ }
+
+ sub inner {
+ my ($schema, $fatal) = @_;
+ my $guard = $schema->txn_scope_guard;
+
+ my $artist = $artist_rs->find({ name => 'Death Cab for Cutie' });
+
+ is($schema->storage->transaction_depth, 2, "Correct transaction depth");
+ undef $@;
+ eval {
+ $artist->cds->create({
+ title => 'Plans',
+ year => 2005,
+ $fatal ? ( foo => 'bar' ) : ()
+ });
+ };
+ if ($@) {
+ # Record what got thrown so we can test it propgates out properly.
+ $inner_exception = $@;
+ die $@;
+ }
+
+ # See what happens if we dont $guard->commit;
+ }
+}
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/84serialize.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/84serialize.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/84serialize.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -4,13 +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 => 1;
+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);
-my $copy = eval { Storable::dclone($artist) };
-is_deeply($copy, $artist, 'serialize row object works');
+plan tests => (7 * keys %stores);
+for my $name (keys %stores) {
+ my $store = $stores{$name};
+
+ 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);
+ }
+
+ my $copy = eval { $store->($artist) };
+ is_deeply($copy, $artist, "serialize row object works: $name");
+
+ # Test that an object with a related_resultset can be serialized.
+ my @cds = $artist->related_resultset("cds");
+
+ ok $artist->{related_resultsets}, 'has key: related_resultsets';
+
+ $copy = eval { $store->($artist) };
+ for my $key (keys %$artist) {
+ next if $key eq 'related_resultsets';
+ next if $key eq '_inflated_column';
+ is_deeply($copy->{$key}, $artist->{$key},
+ qq[serialize with related_resultset "$key"]);
+ }
+
+ ok eval { $copy->discard_changes; 1 } or diag $@;
+ is($copy->id, $artist->id, "IDs still match ");
+}
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/86sqlt.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/86sqlt.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/86sqlt.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -10,7 +10,7 @@
my $schema = DBICTest->init_schema;
-plan tests => 56;
+plan tests => 77;
my $translator = SQL::Translator->new(
parser_args => {
@@ -42,13 +42,13 @@
'display' => 'twokeys->cd',
'selftable' => 'twokeys', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 0,
},
{
'display' => 'twokeys->artist',
'selftable' => 'twokeys', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 0,
},
],
@@ -58,14 +58,14 @@
'display' => 'fourkeys_to_twokeys->twokeys',
'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'twokeys',
'selfcols' => ['t_artist', 't_cd'], 'foreigncols' => ['artist', 'cd'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 0,
},
{
'display' => 'fourkeys_to_twokeys->fourkeys',
'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'fourkeys',
'selfcols' => [qw(f_foo f_bar f_hello f_goodbye)],
'foreigncols' => [qw(foo bar hello goodbye)],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 0,
},
],
@@ -75,13 +75,13 @@
'display' => 'cd_to_producer->cd',
'selftable' => 'cd_to_producer', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 0,
},
{
'display' => 'cd_to_producer->producer',
'selftable' => 'cd_to_producer', 'foreigntable' => 'producer',
'selfcols' => ['producer'], 'foreigncols' => ['producerid'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 0,
},
],
@@ -91,13 +91,13 @@
'display' => 'self_ref_alias->self_ref for self_ref',
'selftable' => 'self_ref_alias', 'foreigntable' => 'self_ref',
'selfcols' => ['self_ref'], 'foreigncols' => ['id'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 0,
},
{
'display' => 'self_ref_alias->self_ref for alias',
'selftable' => 'self_ref_alias', 'foreigntable' => 'self_ref',
'selfcols' => ['alias'], 'foreigncols' => ['id'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 0,
},
],
@@ -107,7 +107,7 @@
'display' => 'cd->artist',
'selftable' => 'cd', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
@@ -117,13 +117,13 @@
'display' => 'artist_undirected_map->artist for id1',
'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist',
'selfcols' => ['id1'], 'foreigncols' => ['artistid'],
- on_delete => 'CASCADE', on_update => '',
+ on_delete => 'CASCADE', on_update => '', deferrable => 0,
},
{
'display' => 'artist_undirected_map->artist for id2',
'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist',
'selfcols' => ['id2'], 'foreigncols' => ['artistid'],
- on_delete => 'CASCADE', on_update => '',
+ on_delete => 'CASCADE', on_update => '', deferrable => 0,
},
],
@@ -133,7 +133,7 @@
'display' => 'track->cd',
'selftable' => 'track', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 0,
},
],
@@ -143,7 +143,7 @@
'display' => 'treelike->treelike for parent',
'selftable' => 'treelike', 'foreigntable' => 'treelike',
'selfcols' => ['parent'], 'foreigncols' => ['id'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 0,
},
],
@@ -153,7 +153,7 @@
'display' => 'twokeytreelike->twokeytreelike for parent1,parent2',
'selftable' => 'twokeytreelike', 'foreigntable' => 'twokeytreelike',
'selfcols' => ['parent1', 'parent2'], 'foreigncols' => ['id1','id2'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 0,
},
],
@@ -163,7 +163,7 @@
'display' => 'tags->cd',
'selftable' => 'tags', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 0,
},
],
@@ -173,9 +173,19 @@
'display' => 'bookmark->link',
'selftable' => 'bookmark', 'foreigntable' => 'link',
'selfcols' => ['link'], 'foreigncols' => ['id'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 0,
},
],
+ # ForceForeign
+ forceforeign => [
+ {
+ 'display' => 'forceforeign->artist',
+ 'selftable' => 'forceforeign', 'foreigntable' => 'artist',
+ 'selfcols' => ['artist'], 'foreigncols' => ['artist_id'],
+ on_delete => '', on_update => '', deferrable => 0,
+ },
+ ],
+
);
my %unique_constraints = (
@@ -222,7 +232,6 @@
);
my $tschema = $translator->schema();
-
# Test that the $schema->sqlt_deploy_hook was called okay and that it removed
# the 'link' table
ok( !defined($tschema->get_table('link')), "Link table was removed by hook");
@@ -232,6 +241,8 @@
ok( !defined($constraint), 'nonexistent FOREIGN KEY constraint not found' );
$constraint = get_constraint('UNIQUE', 'cd', ['artist']);
ok( !defined($constraint), 'nonexistent UNIQUE constraint not found' );
+$constraint = get_constraint('FOREIGN KEY', 'forceforeign', ['cd'], 'cd', ['cdid']);
+ok( !defined($constraint), 'forced nonexistent FOREIGN KEY constraint not found' );
for my $expected_constraints (keys %fk_constraints) {
for my $expected_constraint (@{ $fk_constraints{$expected_constraints} }) {
@@ -348,4 +359,6 @@
"on_delete parameter correct for `$desc'" );
is( $got->on_update, $expected->{on_update},
"on_update parameter correct for `$desc'" );
+ is( $got->deferrable, $expected->{deferrable},
+ "is_deferrable parameter correct for `$desc'" );
}
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/89dbicadmin.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/89dbicadmin.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/89dbicadmin.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -8,8 +8,8 @@
my $schema = DBICTest->init_schema();
-eval 'require JSON';
-plan skip_all => 'Install JSON to run this test' if ($@);
+eval 'require JSON::Any';
+plan skip_all => 'Install JSON::Any to run this test' if ($@);
eval 'require Text::CSV_XS';
if ($@) {
@@ -19,26 +19,31 @@
plan tests => 5;
-# double quotes round the arguments and single-quote within to make sure the
-# tests run on windows as well
+# the script supports double quotes round the arguments and single-quote within
+# to make sure it runs on windows as well, but only if JSON::Any picks the right module
+
+
my $employees = $schema->resultset('Employee');
-my $cmd = qq|$^X script/dbicadmin --schema=DBICTest::Schema --class=Employee --tlibs --connect="['dbi:SQLite:dbname=t/var/DBIxClass.db','','',{AutoCommit:1}]" --force --tlibs|;
+my @cmd = ($^X, qw|script/dbicadmin --quiet --schema=DBICTest::Schema --class=Employee --tlibs|, q|--connect=["dbi:SQLite:dbname=t/var/DBIxClass.db","","",{"AutoCommit":1}]|, qw|--force --tlibs|);
-`$cmd --op=insert --set="{name:'Matt'}"`;
+system(@cmd, qw|--op=insert --set={"name":"Matt"}|);
ok( ($employees->count()==1), 'insert count' );
my $employee = $employees->find(1);
ok( ($employee->name() eq 'Matt'), 'insert valid' );
-`$cmd --op=update --set="{name:'Trout'}"`;
+system(@cmd, qw|--op=update --set={"name":"Trout"}|);
$employee = $employees->find(1);
ok( ($employee->name() eq 'Trout'), 'update' );
-`$cmd --op=insert --set="{name:'Aran'}"`;
-my $data = `$cmd --op=select --attrs="{order_by:'name'}"`;
+system(@cmd, qw|--op=insert --set={"name":"Aran"}|);
+
+open(my $fh, "-|", @cmd, qw|--op=select --attrs={"order_by":"name"}|) or die $!;
+my $data = do { local $/; <$fh> };
+close($fh);
ok( ($data=~/Aran.*Trout/s), 'select with attrs' );
-`$cmd --op=delete --where="{name:'Trout'}"`;
+system(@cmd, qw|--op=delete --where={"name":"Trout"}|);
ok( ($employees->count()==1), 'delete' );
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/90ensure_class_loaded.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/90ensure_class_loaded.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/90ensure_class_loaded.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -13,7 +13,7 @@
my $schema = DBICTest->init_schema();
-plan tests => 19;
+plan tests => 20;
# Test ensure_class_found
ok( $schema->ensure_class_found('DBIx::Class::Schema'),
@@ -72,4 +72,16 @@
'load_optional_class(DBICTest::SyntaxErrorComponent2) threw ok' );
}
+
+eval {
+ package Fake::ResultSet;
+
+ use base 'DBIx::Class::ResultSet';
+
+ __PACKAGE__->load_components('+DBICTest::SyntaxErrorComponent3');
+};
+
+# Make sure the errors in components of resultset classes are reported right.
+like($@, qr!\Qsyntax error at t/lib/DBICTest/SyntaxErrorComponent3.pm!, "Errors from RS components reported right");
+
1;
Added: DBIx-Class/0.08/branches/oracle_sequence/t/93storage_replication.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/93storage_replication.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/93storage_replication.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,69 @@
+use strict;
+use warnings;
+use lib qw(t/lib);
+
+use File::Copy;
+
+use DBICTest;
+
+use Test::More;
+
+BEGIN {
+ eval "use DBD::Multi";
+ plan $@
+ ? ( skip_all => 'needs DBD::Multi for testing' )
+ : ( tests => 3 );
+}
+
+my $schema = DBICTest->init_schema();
+
+$schema->storage_type( '::DBI::Replication' );
+
+
+my $db_file1 = "t/var/DBIxClass.db";
+my $db_file2 = "t/var/DBIxClass_slave1.db";
+my $db_file3 = "t/var/DBIxClass_slave2.db";
+my $dsn1 = $ENV{"DBICTEST_DSN"} || "dbi:SQLite:${db_file1}";
+my $dsn2 = $ENV{"DBICTEST_DSN2"} || "dbi:SQLite:${db_file2}";
+my $dsn3 = $ENV{"DBICTEST_DSN3"} || "dbi:SQLite:${db_file3}";
+
+$schema->connect( [
+ [ $dsn1, '', '', { AutoCommit => 1 } ],
+ [ $dsn2, '', '', { priority => 10 } ],
+ [ $dsn3, '', '', { priority => 10 } ]
+ ]
+ );
+
+$schema->populate('Artist', [
+ [ qw/artistid name/ ],
+ [ 4, 'Ozric Tentacles']
+ ]);
+
+my $new_artist1 = $schema->resultset('Artist')->find(4);
+
+isa_ok ($new_artist1, 'DBICTest::Artist');
+
+# reconnect
+my $schema2 = $schema->connect( [
+ [ $dsn1, '', '', { AutoCommit => 1 } ],
+ [ $dsn2, '', '', { priority => 10 } ],
+ [ $dsn3, '', '', { priority => 10 } ]
+ ]
+ );
+
+# try and read (should fail)
+eval { my $new_artist2 = $schema2->resultset('Artist')->find(4); };
+ok($@, 'read after disconnect fails because it uses slave 1 which we have neglected to "replicate" yet');
+
+# try and read (should succede after faked synchronisation)
+copy($db_file1, $db_file2);
+$schema2 = $schema->connect( [
+ [ $dsn1, '', '', { AutoCommit => 1 } ],
+ [ $dsn2, '', '', { priority => 10 } ],
+ [ $dsn3, '', '', { priority => 10 } ]
+ ]
+ );
+my $new_artist3 = $schema2->resultset('Artist')->find(4);
+isa_ok ($new_artist3, 'DBICTest::Artist');
+
+unlink $db_file2;
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/94versioning.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/94versioning.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/94versioning.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -3,71 +3,83 @@
use warnings;
use Test::More;
use File::Spec;
+use File::Copy;
+#warn "$dsn $user $pass";
+my ($dsn, $user, $pass);
+
BEGIN {
- eval "use DBD::SQLite; use SQL::Translator 0.08;";
+ ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
+
+ plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'
+ unless ($dsn);
+
+
+ eval "use DBD::mysql; use SQL::Translator 0.08;";
plan $@
- ? ( skip_all => 'needs DBD::SQLite and SQL::Translator 0.08 for testing' )
- : ( tests => 6 );
+ ? ( skip_all => 'needs DBD::mysql and SQL::Translator 0.08 for testing' )
+ : ( tests => 13 );
}
+my $version_table_name = 'dbix_class_schema_versions';
+my $old_table_name = 'SchemaVersions';
+
use lib qw(t/lib);
-
use_ok('DBICVersionOrig');
-my $db_file = "t/var/versioning.db";
-unlink($db_file) if -e $db_file;
-unlink($db_file . "-journal") if -e $db_file . "-journal";
-mkdir("t/var") unless -d "t/var";
-unlink('t/var/DBICVersion-Schema-1.0-SQLite.sql');
+my $schema_orig = DBICVersion::Schema->connect($dsn, $user, $pass);
+eval { $schema_orig->storage->dbh->do('drop table ' . $version_table_name) };
+eval { $schema_orig->storage->dbh->do('drop table ' . $old_table_name) };
-my $schema_orig = DBICVersion::Schema->connect(
- "dbi:SQLite:$db_file",
- undef,
- undef,
- { AutoCommit => 1 },
-);
-# $schema->storage->ensure_connected();
+is($schema_orig->ddl_filename('MySQL', 't/var', '1.0'), File::Spec->catfile('t', 'var', 'DBICVersion-Schema-1.0-MySQL.sql'), 'Filename creation working');
+unlink('t/var/DBICVersion-Schema-1.0-MySQL.sql') if (-e 't/var/DBICVersion-Schema-1.0-MySQL.sql');
+$schema_orig->create_ddl_dir('MySQL', undef, 't/var');
-is($schema_orig->ddl_filename('SQLite', 't/var', '1.0'), File::Spec->catfile('t', 'var', 'DBICVersion-Schema-1.0-SQLite.sql'), 'Filename creation working');
-$schema_orig->create_ddl_dir('SQLite', undef, 't/var');
+ok(-f 't/var/DBICVersion-Schema-1.0-MySQL.sql', 'Created DDL file');
+$schema_orig->deploy({ add_drop_table => 1 });
+$schema_orig->upgrade();
-ok(-f 't/var/DBICVersion-Schema-1.0-SQLite.sql', 'Created DDL file');
-## do this here or let Versioned.pm do it?
-# $schema->deploy();
-
-my $tvrs = $schema_orig->resultset('Table');
+my $tvrs = $schema_orig->{vschema}->resultset('Table');
is($schema_orig->_source_exists($tvrs), 1, 'Created schema from DDL file');
eval "use DBICVersionNew";
-my $schema_new = DBICVersion::Schema->connect(
- "dbi:SQLite:$db_file",
- undef,
- undef,
- { AutoCommit => 1 },
-);
+{
+ unlink('t/var/DBICVersion-Schema-2.0-MySQL.sql');
+ unlink('t/var/DBICVersion-Schema-1.0-2.0-MySQL.sql');
-unlink('t/var/DBICVersion-Schema-2.0-SQLite.sql');
-unlink('t/var/DBICVersion-Schema-1.0-2.0-SQLite.sql');
-$schema_new->create_ddl_dir('SQLite', undef, 't/var', '1.0');
-ok(-f 't/var/DBICVersion-Schema-1.0-2.0-SQLite.sql', 'Created DDL upgrade file');
+ my $schema_upgrade = DBICVersion::Schema->connect($dsn, $user, $pass);
+ is($schema_upgrade->get_db_version(), '1.0', 'get_db_version ok');
+ is($schema_upgrade->schema_version, '2.0', 'schema version ok');
+ $schema_upgrade->create_ddl_dir('MySQL', '2.0', 't/var', '1.0');
+ ok(-f 't/var/DBICVersion-Schema-1.0-2.0-MySQL.sql', 'Created DDL file');
+ $schema_upgrade->upgrade();
+ is($schema_upgrade->get_db_version(), '2.0', 'db version number upgraded');
-## create new to pick up filedata for upgrade files we just made (on_connect)
-my $schema_upgrade = DBICVersion::Schema->connect(
- "dbi:SQLite:$db_file",
- undef,
- undef,
- { AutoCommit => 1 },
-);
+ eval {
+ $schema_upgrade->storage->dbh->do('select NewVersionName from TestVersion');
+ };
+ is($@, '', 'new column created');
+}
-## do this here or let Versioned.pm do it?
-$schema_upgrade->upgrade();
-$tvrs = $schema_upgrade->resultset('Table');
-is($schema_upgrade->_source_exists($tvrs), 1, 'Upgraded schema from DDL file');
+{
+ my $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
+ eval {
+ $schema_version->storage->dbh->do('select * from ' . $version_table_name);
+ };
+ is($@, '', 'version table exists');
-unlink($db_file) if -e $db_file;
-unlink($db_file . "-journal") if -e $db_file . "-journal";
-unlink('t/var/DBICVersion-Schema-1.0-SQLite.sql');
-unlink('t/var/DBICVersion-Schema-2.0-SQLite.sql');
-unlink('t/var/DBICVersion-Schema-1.0-2.0-SQLite.sql');
-unlink(<t/var/backup/*>);
+ eval {
+ $schema_version->storage->dbh->do("DROP TABLE IF EXISTS $old_table_name");
+ $schema_version->storage->dbh->do("RENAME TABLE $version_table_name TO $old_table_name");
+ };
+ is($@, '', 'versions table renamed to old style table');
+
+ $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
+ is($schema_version->get_db_version, '2.0', 'transition from old table name to new okay');
+
+ eval {
+ $schema_version->storage->dbh->do('select * from ' . $old_table_name);
+ };
+ ok($@, 'old version table gone');
+
+}
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-abstract/search_where.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-abstract/search_where.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-abstract/search_where.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,74 @@
+#!/usr/bin/perl -w
+
+use Test::More;
+
+use strict;
+use warnings;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 10);
+}
+
+INIT {
+ use lib 't/testlib';
+ use Film;
+}
+
+
+Film->create({ Title => $_, Rating => "PG" }) for ("Superman", "Super Fuzz");
+Film->create({ Title => "Batman", Rating => "PG13" });
+
+my $superman = Film->search_where( Title => "Superman" );
+is $superman->next->Title, "Superman", "search_where() as iterator";
+is $superman->next, undef;
+
+{
+ my @supers = Film->search_where({ title => { 'like' => 'Super%' } });
+ is_deeply [sort map $_->Title, @supers],
+ [sort ("Super Fuzz", "Superman")], 'like';
+}
+
+
+my @all = Film->search_where({}, { order_by => "Title ASC" });
+is_deeply ["Batman", "Super Fuzz", "Superman"],
+ [map $_->Title, @all],
+ "order_by ASC";
+
+ at all = Film->search_where({}, { order_by => "Title DESC" });
+is_deeply ["Superman", "Super Fuzz", "Batman"],
+ [map $_->Title, @all],
+ "order_by DESC";
+
+ at all = Film->search_where({ Rating => "PG" }, { limit => 1, order_by => "Title ASC" });
+is_deeply ["Super Fuzz"],
+ [map $_->Title, @all],
+ "where, limit";
+
+ at all = Film->search_where({}, { limit => 2, order_by => "Title ASC" });
+is_deeply ["Batman", "Super Fuzz"],
+ [map $_->Title, @all],
+ "limit";
+
+ at all = Film->search_where({}, { offset => 1, order_by => "Title ASC" });
+is_deeply ["Super Fuzz", "Superman"],
+ [map $_->Title, @all],
+ "offset";
+
+ at all = Film->search_where({}, { limit => 1, offset => 1, order_by => "Title ASC" });
+is_deeply ["Super Fuzz"],
+ [map $_->Title, @all],
+ "limit + offset";
+
+ at all = Film->search_where({}, { limit => 2, offset => 1,
+ limit_dialect => "Top", order_by => "Title ASC"
+ });
+is_deeply ["Super Fuzz", "Superman"],
+ [map $_->Title, @all],
+ "limit_dialect ignored";
+
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/01-columns.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/01-columns.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/01-columns.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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/branches/oracle_sequence/t/cdbi-t/02-Film.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/02-Film.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/02-Film.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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/branches/oracle_sequence/t/cdbi-t/04-lazy.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/04-lazy.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/04-lazy.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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,77 @@
};
ok($@, $@);
+
+warning_is {
+ Lazy->columns( TEMP => qw(that) );
+} "Declaring column that as TEMP but it already exists";
+
+# Test that create() and update() throws out columns that changed
+{
+ my $l = Lazy->create({
+ this => 99,
+ that => 2,
+ oop => 3,
+ opop => 4,
+ });
+
+ ok $l->db_Main->do(qq{
+ UPDATE @{[ $l->table ]}
+ SET oop = ?
+ WHERE this = ?
+ }, undef, 87, $l->this);
+
+ is $l->oop, 87;
+
+ $l->oop(32);
+ $l->update;
+
+ ok $l->db_Main->do(qq{
+ UPDATE @{[ $l->table ]}
+ SET oop = ?
+ WHERE this = ?
+ }, undef, 23, $l->this);
+
+ is $l->oop, 23;
+
+ $l->delete;
+}
+
+
+# Now again for inflated values
+SKIP: {
+ skip "Requires Date::Simple", 5 unless eval "use Date::Simple; 1; ";
+ Lazy->has_a(
+ orp => 'Date::Simple',
+ inflate => sub { Date::Simple->new($_[0] . '-01-01') },
+ deflate => 'format'
+ );
+
+ my $l = Lazy->create({
+ this => 89,
+ that => 2,
+ orp => 1998,
+ });
+
+ ok $l->db_Main->do(qq{
+ UPDATE @{[ $l->table ]}
+ SET orp = ?
+ WHERE this = ?
+ }, undef, 1987, $l->this);
+
+ is $l->orp, '1987-01-01';
+
+ $l->orp(2007);
+ is $l->orp, '2007-01-01'; # make sure it's inflated
+ $l->update;
+
+ ok $l->db_Main->do(qq{
+ UPDATE @{[ $l->table ]}
+ SET orp = ?
+ WHERE this = ?
+ }, undef, 1942, $l->this);
+
+ is $l->orp, '1942-01-01';
+
+ $l->delete;
+}
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/06-hasa.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/06-hasa.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/06-hasa.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -4,7 +4,7 @@
BEGIN {
eval "use DBIx::Class::CDBICompat;";
if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
next;
}
eval "use DBD::SQLite";
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/08-inheritcols.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/08-inheritcols.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/08-inheritcols.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,27 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required')
+ : (tests=> 3);
+}
+
+package A;
+ at A::ISA = qw(DBIx::Class::CDBICompat);
+__PACKAGE__->columns(Primary => 'id');
+
+package A::B;
+ at A::B::ISA = 'A';
+__PACKAGE__->columns(All => qw(id b1));
+
+package A::C;
+ at A::C::ISA = 'A';
+__PACKAGE__->columns(All => qw(id c1 c2 c3));
+
+package main;
+is join (' ', sort A->columns), 'id', "A columns";
+is join (' ', sort A::B->columns), 'b1 id', "A::B columns";
+is join (' ', sort A::C->columns), 'c1 c2 c3 id', "A::C columns";
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/14-might_have.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/14-might_have.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/14-might_have.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -8,7 +8,7 @@
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 18);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 22);
}
use lib 't/testlib';
@@ -67,4 +67,17 @@
}
-
+{
+ my $host = Film->create({ title => "Gwoemul" });
+ $host->blurb("Monsters are real.");
+ my $info = $host->info;
+ is $info->blurb, "Monsters are real.";
+
+ $host->discard_changes;
+ is $host->info->id, $info->id,
+ 'relationships still valid after discard_changes';
+
+ ok $host->info->delete;
+ $host->discard_changes;
+ ok !$host->info, 'relationships rechecked after discard_changes';
+}
\ No newline at end of file
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/15-accessor.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/15-accessor.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/15-accessor.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -4,11 +4,12 @@
BEGIN {
eval "use DBIx::Class::CDBICompat;";
if ($@) {
+ diag $@;
plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 53);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 54);
}
INIT {
@@ -17,7 +18,9 @@
use lib 't/testlib';
require Film;
require Actor;
+ require Director;
Actor->has_a(film => 'Film');
+ Film->has_a(director => 'Director');
sub Class::DBI::sheep { ok 0; }
}
@@ -33,12 +36,19 @@
return $col;
}
-sub Actor::accessor_name {
+sub Actor::accessor_name_for {
my ($class, $col) = @_;
return "movie" if lc $col eq "film";
return $col;
}
+# This is a class with accessor_name_for() but no corresponding mutatori_name_for()
+sub Director::accessor_name_for {
+ my($class, $col) = @_;
+ return "nutty_as_a_fruitcake" if lc $col eq "isinsane";
+ return $col;
+}
+
my $data = {
Title => 'Bad Taste',
Director => 'Peter Jackson',
@@ -131,8 +141,20 @@
}
-SKIP: { # have non persistent accessor?
- #skip "Compat layer doesn't handle TEMP columns yet", 11;
+
+# Make sure a class with an accessor_name() method has a similar mutator.
+{
+ my $aki = Director->create({
+ name => "Aki Kaurismaki",
+ });
+
+ $aki->nutty_as_a_fruitcake(1);
+ is $aki->nutty_as_a_fruitcake, 1,
+ "a custom accessor without a custom mutator is setable";
+ $aki->update;
+}
+
+{
Film->columns(TEMP => qw/nonpersistent/);
ok(Film->find_column('nonpersistent'), "nonpersistent is a column");
ok(!Film->has_real_column('nonpersistent'), " - but it's not real");
@@ -152,11 +174,10 @@
}
}
-SKIP: { # was bug with TEMP and no Essential
- #skip "Compat layer doesn't have TEMP columns yet", 5;
+{
is_deeply(
- Actor->columns('Essential'),
- Actor->columns('Primary'),
+ [Actor->columns('Essential')],
+ [Actor->columns('Primary')],
"Actor has no specific essential columns"
);
ok(Actor->find_column('nonpersistent'), "nonpersistent is a column");
@@ -166,8 +187,7 @@
isa_ok $pj => "Actor";
}
-SKIP: {
- #skip "Compat layer doesn't handle read-only objects yet", 10;
+{
Film->autoupdate(1);
my $naked = Film->create({ title => 'Naked' });
my $sandl = Film->create({ title => 'Secrets and Lies' });
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/19-set_sql.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/19-set_sql.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/19-set_sql.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -8,7 +8,7 @@
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 17);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 20);
}
use lib 't/testlib';
@@ -19,6 +19,11 @@
my @cols = Film->columns('Essential');
is_deeply \@cols, ['title'], "1 Column in essential";
is +Film->transform_sql('__ESSENTIAL__'), 'title', '__ESSENTIAL__ expansion';
+
+ # This provides a more interesting test
+ Film->columns(Essential => qw(title rating));
+ is +Film->transform_sql('__ESSENTIAL__'), 'title, rating',
+ 'multi-col __ESSENTIAL__ expansion';
}
my $f1 = Film->create({ title => 'A', director => 'AA', rating => 'PG' });
@@ -68,6 +73,22 @@
};
{
+ Film->set_sql(
+ by_id => qq{
+ SELECT __ESSENTIAL__
+ FROM __TABLE__
+ WHERE __IDENTIFIER__
+ }
+ );
+
+ my $film = Film->retrieve_all->first;
+ my @found = Film->search_by_id($film->id);
+ is @found, 1;
+ is $found[0]->id, $film->id;
+}
+
+
+{
Actor->has_a(film => "Film");
Film->set_sql(
namerate => qq{
@@ -109,4 +130,3 @@
is $apg[1]->title, "B", "and B";
}
-#} # end SKIP block
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/21-iterator.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/21-iterator.t 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/21-iterator.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -4,11 +4,11 @@
BEGIN {
eval "use DBIx::Class::CDBICompat;";
if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 33);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 37);
}
use lib 't/testlib';
@@ -49,8 +49,6 @@
is $it->next->title, "Film 2", "And 2 is still next";
}
-SKIP: {
- #skip "Iterator doesn't yet have slice support", 19;
{
my $it = Film->retrieve_all;
@@ -85,4 +83,14 @@
is $it->next->title, "Film 2", "And 2 is still next";
}
-} # End SKIP
+{
+ my $it = Film->retrieve_all;
+ is $it, $it->count, "iterator returns count as a scalar";
+ ok $it, "iterator returns true when there are results";
+}
+
+{
+ my $it = Film->search( Title => "something which does not exist" );
+ is $it, 0;
+ ok !$it, "iterator returns false when no results";
+}
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/22-deflate_order.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/22-deflate_order.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/22-deflate_order.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,24 @@
+$| = 1;
+use strict;
+
+use Test::More;
+
+eval { require Time::Piece::MySQL };
+plan skip_all => "Need Time::Piece::MySQL for this test" if $@;
+
+eval { require 't/testlib/Log.pm' };
+plan skip_all => "Need MySQL for this test" if $@;
+
+plan tests => 2;
+
+package main;
+
+my $log = Log->insert( { message => 'initial message' } );
+ok eval { $log->datetime_stamp }, "Have datetime";
+diag $@ if $@;
+
+$log->message( 'a revised message' );
+$log->update;
+ok eval { $log->datetime_stamp }, "Have datetime after update";
+diag $@ if $@;
+
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/23-cascade.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/23-cascade.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/23-cascade.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,76 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 12);
+}
+
+INIT {
+ use lib 't/testlib';
+ use Film;
+ use Director;
+}
+
+{ # Cascade on delete
+ Director->has_many(nasties => 'Film');
+
+ my $dir = Director->insert({
+ name => "Lewis Teague",
+ });
+ my $kk = $dir->add_to_nasties({
+ Title => 'Alligator'
+ });
+ is $kk->director, $dir, "Director set OK";
+ is $dir->nasties, 1, "We have one nasty";
+
+ ok $dir->delete;
+ ok !Film->retrieve("Alligator"), "has_many cascade deletes by default";
+}
+
+
+# Two ways of saying not to cascade
+for my $args ({ no_cascade_delete => 1 }, { cascade => "None" }) {
+ Director->has_many(nasties => 'Film', $args);
+
+ my $dir = Director->insert({
+ name => "Lewis Teague",
+ });
+ my $kk = $dir->add_to_nasties({
+ Title => 'Alligator'
+ });
+ is $kk->director, $dir, "Director set OK";
+ is $dir->nasties, 1, "We have one nasty";
+
+ ok $dir->delete;
+ ok +Film->retrieve("Alligator"), "has_many with @{[ keys %$args ]} => @{[ values %$args ]}";
+ $kk->delete;
+}
+
+
+#{ # Fail on cascade
+# local $TODO = 'cascade => "Fail" unimplemented';
+#
+# Director->has_many(nasties => Film => { cascade => 'Fail' });
+#
+# my $dir = Director->insert({ name => "Nasty Noddy" });
+# my $kk = $dir->add_to_nasties({ Title => 'Killer Killers' });
+# is $kk->director, $dir, "Director set OK";
+# is $dir->nasties, 1, "We have one nasty";
+#
+# ok !eval { $dir->delete };
+# like $@, qr/1/, "Can't delete while films exist";
+#
+# my $rr = $dir->add_to_nasties({ Title => 'Revenge of the Revengers' });
+# ok !eval { $dir->delete };
+# like $@, qr/2/, "Still can't delete";
+#
+# $dir->nasties->delete_all;
+# ok eval { $dir->delete };
+# is $@, '', "Can delete once films are gone";
+#}
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/24-meta_info.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/24-meta_info.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/24-meta_info.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,73 @@
+#!/usr/bin/perl -w
+
+use strict;
+BEGIN {
+ eval "require Time::Piece";
+ use Test::More skip_all => "Time::Piece required for this test";
+}
+
+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/branches/oracle_sequence/t/cdbi-t/26-mutator.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/26-mutator.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/26-mutator.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,41 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBD::SQLite";
+ plan $@
+ ? (skip_all => 'needs DBD::SQLite for testing')
+ : (tests => 6);
+}
+
+use lib 't/testlib';
+require Film;
+
+sub Film::accessor_name_for {
+ my ($class, $col) = @_;
+ return "sheep" if lc $col eq "numexplodingsheep";
+ return $col;
+}
+
+my $data = {
+ Title => 'Bad Taste',
+ Director => 'Peter Jackson',
+ Rating => 'R',
+};
+
+my $bt;
+eval {
+ my $data = $data;
+ $data->{sheep} = 1;
+ ok $bt = Film->insert($data), "Modified accessor - with
+accessor";
+ isa_ok $bt, "Film";
+};
+is $@, '', "No errors";
+
+eval {
+ ok $bt->sheep(2), 'Modified accessor, set';
+ ok $bt->update, 'Update';
+};
+is $@, '', "No errors";
+
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/columns_as_hashes.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/columns_as_hashes.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/columns_as_hashes.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,106 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+use Test::Warn;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : ('no_plan');
+}
+
+use lib 't/testlib';
+use Film;
+
+my $waves = Film->insert({
+ Title => "Breaking the Waves",
+ Director => 'Lars von Trier',
+ Rating => 'R'
+});
+
+local $ENV{DBIC_CDBICOMPAT_HASH_WARN} = 0;
+
+{
+ local $ENV{DBIC_CDBICOMPAT_HASH_WARN} = 1;
+
+ warnings_like {
+ my $rating = $waves->{rating};
+ $waves->Rating("PG");
+ is $rating, "R", 'evaluation of column value is not deferred';
+ } qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at \Q$0};
+
+ warnings_like {
+ is $waves->{title}, $waves->Title, "columns can be accessed as hashes";
+ } qr{^Column 'title' of 'Film/$waves' was fetched as a hash at\b};
+
+ $waves->Rating("G");
+
+ warnings_like {
+ is $waves->{rating}, "G", "updating via the accessor updates the hash";
+ } qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at\b};
+
+
+ warnings_like {
+ $waves->{rating} = "PG";
+ } qr{^Column 'rating' of 'Film/$waves' was stored as a hash at\b};
+
+ $waves->update;
+ my @films = Film->search( Rating => "PG", Title => "Breaking the Waves" );
+ is @films, 1, "column updated as hash was saved";
+}
+
+warning_is {
+ $waves->{rating}
+} '', 'DBIC_CDBICOMPAT_HASH_WARN controls warnings';
+
+
+{
+ $waves->rating("R");
+ $waves->update;
+
+ no warnings 'redefine';
+ local *Film::rating = sub {
+ return "wibble";
+ };
+
+ is $waves->{rating}, "R";
+}
+
+
+{
+ no warnings 'redefine';
+ no warnings 'once';
+ local *Actor::accessor_name_for = sub {
+ my($class, $col) = @_;
+ return "movie" if lc $col eq "film";
+ return $col;
+ };
+
+ require Actor;
+ Actor->has_a( film => "Film" );
+
+ my $actor = Actor->insert({
+ name => 'Emily Watson',
+ film => $waves,
+ });
+
+ ok !eval { $actor->film };
+ is $actor->{film}->id, $waves->id,
+ 'hash access still works despite lack of accessor';
+}
+
+
+# Emulate that Class::DBI inflates immediately
+SKIP: {
+ skip "Need MySQL to run this test", 3 unless eval { require MyFoo };
+
+ my $foo = MyFoo->insert({
+ name => 'Whatever',
+ tdate => '1949-02-01',
+ });
+ isa_ok $foo, 'MyFoo';
+
+ isa_ok $foo->{tdate}, 'Date::Simple';
+ is $foo->{tdate}->year, 1949;
+}
\ No newline at end of file
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/columns_dont_override_custom_accessors.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/columns_dont_override_custom_accessors.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/columns_dont_override_custom_accessors.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,34 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 5);
+}
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(TEMP => qw[foo bar]);
+ Thing->columns(All => qw[thing_id yarrow flower]);
+ sub foo { 42 }
+ sub yarrow { "hock" }
+}
+
+is_deeply( [sort Thing->columns("TEMP")],
+ [sort qw(foo bar)],
+ "TEMP columns set"
+);
+my $thing = Thing->construct(
+ { thing_id => 23, foo => "this", bar => "that" }
+);
+
+is( $thing->id, 23 );
+is( $thing->yarrow, "hock", 'custom accessor not overwritten by column' );
+is( $thing->foo, 42, 'custom routine not overwritten by temp column' );
+is( $thing->bar, "that", 'temp column accessor generated' );
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/construct.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/construct.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/construct.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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/branches/oracle_sequence/t/cdbi-t/copy.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/copy.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/copy.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,43 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 4);
+}
+
+INIT {
+ use lib 't/testlib';
+}
+
+{
+ package # hide from PAUSE
+ MyFilm;
+
+ use base 'DBIx::Class::Test::SQLite';
+ use strict;
+
+ __PACKAGE__->set_table('Movies');
+ __PACKAGE__->columns(All => qw(id title));
+
+ sub create_sql {
+ return qq{
+ id INTEGER PRIMARY KEY AUTOINCREMENT,
+ title VARCHAR(255)
+ }
+ }
+}
+
+my $film = MyFilm->create({ title => "For Your Eyes Only" });
+ok $film->id;
+
+my $new_film = $film->copy;
+ok $new_film->id;
+isnt $new_film->id, $film->id, "copy() gets new primary key";
+
+$new_film = $film->copy(42);
+is $new_film->id, 42, "copy() with new id";
+
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/early_column_heisenbug.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/early_column_heisenbug.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/early_column_heisenbug.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,28 @@
+use strict;
+
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : ('no_plan');
+}
+
+
+{
+ package Thing;
+ use base qw(DBIx::Class::CDBICompat);
+}
+
+{
+ package Stuff;
+ use base qw(DBIx::Class::CDBICompat);
+}
+
+# There was a bug where looking at a column group before any were
+# set would cause them to be shared across classes.
+is_deeply [Stuff->columns("Essential")], [];
+Thing->columns(Essential => qw(foo bar baz));
+is_deeply [Stuff->columns("Essential")], [];
+
+1;
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/has_many_loads_foreign_class.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/has_many_loads_foreign_class.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/has_many_loads_foreign_class.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,37 @@
+use strict;
+use Test::More;
+
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => 'Class::Trigger and DBIx::ContextualFetch required' if $@;
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 3);
+}
+
+
+use lib 't/testlib';
+use Director;
+
+# Test that has_many() will load the foreign class.
+ok !Class::Inspector->loaded( 'Film' );
+ok eval { Director->has_many( films => 'Film' ); 1; } || diag $@;
+
+my $shan_hua = Director->create({
+ Name => "Shan Hua",
+});
+
+my $inframan = Film->create({
+ Title => "Inframan",
+ Director => "Shan Hua",
+});
+my $guillotine2 = Film->create({
+ Title => "Flying Guillotine 2",
+ Director => "Shan Hua",
+});
+my $guillotine = Film->create({
+ Title => "Master of the Flying Guillotine",
+ Director => "Yu Wang",
+});
+
+is_deeply [sort $shan_hua->films], [sort $inframan, $guillotine2];
\ No newline at end of file
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/hasa_without_loading.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/hasa_without_loading.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/hasa_without_loading.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,23 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required')
+ : (tests=> 2);
+}
+
+package Foo;
+
+use base qw(DBIx::Class::CDBICompat);
+
+eval {
+ Foo->table("foo");
+ Foo->columns(Essential => qw(foo bar));
+ #Foo->has_a( bar => "This::Does::Not::Exist::Yet" );
+};
+#::is $@, '';
+::is(Foo->table, "foo");
+::is_deeply [sort map lc, Foo->columns], [sort map lc, qw(foo bar)];
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/max_min_value_of.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/max_min_value_of.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/max_min_value_of.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,34 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+#----------------------------------------------------------------------
+# Test database failures
+#----------------------------------------------------------------------
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 2);
+}
+
+use lib 't/testlib';
+use Film;
+
+Film->create({
+ title => "Bad Taste",
+ numexplodingsheep => 10,
+});
+
+Film->create({
+ title => "Evil Alien Conquerers",
+ numexplodingsheep => 2,
+});
+
+is( Film->maximum_value_of("numexplodingsheep"), 10 );
+is( Film->minimum_value_of("numexplodingsheep"), 2 );
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/multi_column_set.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/multi_column_set.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/multi_column_set.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,27 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 3);
+}
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(TEMP => qw[foo bar baz]);
+ Thing->columns(All => qw[some real stuff]);
+}
+
+my $thing = Thing->construct({ foo => 23, some => 42, baz => 99 });
+$thing->set( foo => "wibble", some => "woosh" );
+is $thing->foo, "wibble";
+is $thing->some, "woosh";
+is $thing->baz, 99;
+
+$thing->discard_changes;
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/object_cache.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/object_cache.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/object_cache.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,82 @@
+use strict;
+use Test::More;
+$| = 1;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ }
+
+ eval "use DBD::SQLite";
+ plan skip_all => 'needs DBD::SQLite for testing' if $@;
+}
+
+INIT {
+ use lib 't/testlib';
+ use Film;
+}
+
+plan skip_all => "Object cache is turned off"
+ if Film->isa("DBIx::Class::CDBICompat::NoObjectIndex");
+
+plan tests => 5;
+
+
+ok +Film->create({
+ Title => 'This Is Spinal Tap',
+ Director => 'Rob Reiner',
+ Rating => 'R',
+});
+
+{
+ my $film1 = Film->retrieve( "This Is Spinal Tap" );
+ my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+ $film1->Director("Marty DiBergi");
+ is $film2->Director, "Marty DiBergi", 'retrieve returns the same object';
+
+ $film1->discard_changes;
+}
+
+{
+ Film->nocache(1);
+
+ my $film1 = Film->retrieve( "This Is Spinal Tap" );
+ my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+ $film1->Director("Marty DiBergi");
+ is $film2->Director, "Rob Reiner",
+ 'caching turned off';
+
+ $film1->discard_changes;
+}
+
+{
+ Film->nocache(0);
+
+ my $film1 = Film->retrieve( "This Is Spinal Tap" );
+ my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+ $film1->Director("Marty DiBergi");
+ is $film2->Director, "Marty DiBergi",
+ 'caching back on';
+
+ $film1->discard_changes;
+}
+
+
+{
+ Film->nocache(1);
+
+ local $Class::DBI::Weaken_Is_Available = 0;
+
+ my $film1 = Film->retrieve( "This Is Spinal Tap" );
+ my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+ $film1->Director("Marty DiBergi");
+ is $film2->Director, "Rob Reiner",
+ 'CDBI::Weaken_Is_Available turns off all caching';
+
+ $film1->discard_changes;
+}
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/retrieve_from_sql_with_limit.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/retrieve_from_sql_with_limit.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/retrieve_from_sql_with_limit.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,27 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 3);
+}
+
+INIT {
+ use lib 't/testlib';
+ use Film;
+}
+
+for my $title ("Bad Taste", "Braindead", "Forgotten Silver") {
+ Film->insert({ Title => $title, Director => 'Peter Jackson' });
+}
+
+Film->insert({ Title => "Transformers", Director => "Michael Bay"});
+
+{
+ my @films = Film->retrieve_from_sql(qq[director = "Peter Jackson" LIMIT 2]);
+ is @films, 2, "retrieve_from_sql with LIMIT";
+ is( $_->director, "Peter Jackson" ) for @films;
+}
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/set_to_undef.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/set_to_undef.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/set_to_undef.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,25 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+use Test::NoWarnings;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
+ if $@;
+ plan skip_all => "DateTime required" unless eval { require DateTime };
+ plan tests => 1;
+}
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(All => qw[thing_id this that date]);
+}
+
+my $thing = Thing->construct({ thing_id => 23, this => 42 });
+$thing->set( this => undef );
+$thing->discard_changes;
Added: DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/set_vs_DateTime.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/set_vs_DateTime.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/cdbi-t/set_vs_DateTime.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,32 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+use Test::Exception;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
+ if $@;
+ plan skip_all => "DateTime required" unless eval { require DateTime };
+ plan tests => 1;
+}
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(All => qw[thing_id this that date]);
+}
+
+my $thing = Thing->construct({ thing_id => 23, date => "01-02-1994" });
+my $date = DateTime->now;
+lives_ok {
+ $thing->set( date => $date );
+ $thing->set( date => $date );
+};
+
+
+
+$thing->discard_changes;
Added: DBIx-Class/0.08/branches/oracle_sequence/t/deleting_many_to_many.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/deleting_many_to_many.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/deleting_many_to_many.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,23 @@
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 5;
+
+my $cd = $schema->resultset("CD")->find(2);
+ok $cd->liner_notes;
+ok keys %{$cd->{_relationship_data}}, "_relationship_data populated";
+
+$cd->discard_changes;
+ok $cd->liner_notes, 'relationships still valid after discarding changes';
+
+ok $cd->liner_notes->delete;
+$cd->discard_changes;
+ok !$cd->liner_notes, 'discard_changes resets relationship';
\ No newline at end of file
Added: DBIx-Class/0.08/branches/oracle_sequence/t/discard_changes_in_DESTROY.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/discard_changes_in_DESTROY.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/discard_changes_in_DESTROY.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,32 @@
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 1;
+
+{
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, @_; };
+ {
+ # Test that this doesn't cause infinite recursion.
+ local *DBICTest::Artist::DESTROY;
+ local *DBICTest::Artist::DESTROY = sub { $_[0]->discard_changes };
+
+ my $artist = $schema->resultset("Artist")->create( {
+ artistid => 10,
+ name => "artist number 10",
+ });
+
+ $artist->name("Wibble");
+
+ print "# About to call DESTROY\n";
+ }
+ is_deeply \@warnings, [];
+}
\ No newline at end of file
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/Schema/CD.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/Schema/CD.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/Schema/CD.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -24,7 +24,7 @@
__PACKAGE__->set_primary_key('cdid');
__PACKAGE__->add_unique_constraint([ qw/artist title/ ]);
-__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist' );
+__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist', undef, { is_deferrable => 1 } );
__PACKAGE__->has_many( tracks => 'DBICTest::Schema::Track' );
__PACKAGE__->has_many(
Added: DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/Schema/ForceForeign.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/Schema/ForceForeign.pm (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/Schema/ForceForeign.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,32 @@
+package # hide from PAUSE
+ DBICTest::Schema::ForceForeign;
+
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table('forceforeign');
+__PACKAGE__->add_columns(
+ 'artist' => { data_type => 'integer' },
+ 'cd' => { data_type => 'integer' },
+);
+__PACKAGE__->set_primary_key(qw/artist/);
+
+# Normally this would not appear as a FK constraint
+# since it uses the PK
+__PACKAGE__->might_have(
+ 'artist_1', 'DBICTest::Schema::Artist', {
+ 'foreign.artist_id' => 'self.artist',
+ }, {
+ is_foreign_key_constraint => 1,
+ },
+);
+
+# Normally this would appear as a FK constraint
+__PACKAGE__->might_have(
+ 'cd_1', 'DBICTest::Schema::CD', {
+ 'foreign.cdid' => 'self.cd',
+ }, {
+ is_foreign_key_constraint => 0,
+ },
+);
+
+1;
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/Schema.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/Schema.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/Schema.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -37,7 +37,8 @@
),
qw/SelfRefAlias TreeLike TwoKeyTreeLike Event EventTZ NoPrimaryKey/,
qw/Collection CollectionObject TypedObject/,
- qw/Owners BooksInLibrary/
+ qw/Owners BooksInLibrary/,
+ qw/ForceForeign/
);
sub sqlt_deploy_hook {
Added: DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/SyntaxErrorComponent3.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/SyntaxErrorComponent3.pm (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICTest/SyntaxErrorComponent3.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,5 @@
+package DBICErrorTest::SyntaxError;
+
+use strict;
+
+I'm a syntax error!
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICVersionNew.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICVersionNew.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/lib/DBICVersionNew.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -21,9 +21,17 @@
'is_auto_increment' => 0,
'default_value' => undef,
'is_foreign_key' => 0,
+ 'is_nullable' => 0,
+ 'size' => '10'
+ },
+ 'NewVersionName' => {
+ 'data_type' => 'VARCHAR',
+ 'is_auto_increment' => 0,
+ 'default_value' => undef,
+ 'is_foreign_key' => 0,
'is_nullable' => 1,
'size' => '20'
- },
+ }
);
__PACKAGE__->set_primary_key('Version');
Added: DBIx-Class/0.08/branches/oracle_sequence/t/relationship_after_update.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/relationship_after_update.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/relationship_after_update.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,30 @@
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 2;
+
+my $bookmark = $schema->resultset("Bookmark")->find(1);
+my $link = $bookmark->link;
+my $link_id = $link->id;
+
+my $new_link = $schema->resultset("Link")->new({
+ id => 42,
+ url => "http://monstersarereal.com",
+ title => "monstersarereal.com"
+});
+
+# Changing a relationship by id rather than by object would cause
+# old related_resultsets to be used.
+$bookmark->link($new_link->id);
+is $bookmark->link->id, $new_link->id;
+
+$bookmark->update;
+is $bookmark->link->id, $new_link->id;
Added: DBIx-Class/0.08/branches/oracle_sequence/t/relationship_doesnt_exist.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/relationship_doesnt_exist.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/relationship_doesnt_exist.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,30 @@
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 3;
+
+my $bookmark = $schema->resultset("Bookmark")->find(1);
+my $link = $bookmark->link;
+my $link_id = $link->id;
+ok $link->id;
+
+$link->delete;
+is $schema->resultset("Link")->search(id => $link_id)->count, 0,
+ "link $link_id was deleted";
+
+# Get a fresh object with nothing cached
+$bookmark = $schema->resultset("Bookmark")->find($bookmark->id);
+
+# This would create a new link row if none existed
+$bookmark->link;
+
+is $schema->resultset("Link")->search(id => $link_id)->count, 0,
+ 'accessor did not create a link object where there was none';
Added: DBIx-Class/0.08/branches/oracle_sequence/t/resultset_overload.t
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/resultset_overload.t (rev 0)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/resultset_overload.t 2008-03-11 20:30:42 UTC (rev 4173)
@@ -0,0 +1,26 @@
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 6;
+
+{
+ my $rs = $schema->resultset("CD")->search({});
+
+ ok $rs->count;
+ is $rs, $rs->count, "resultset as number with results";
+ ok $rs, "resultset as boolean always true";
+}
+
+{
+ my $rs = $schema->resultset("CD")->search({ title => "Does not exist" });
+
+ ok !$rs->count;
+ is $rs, $rs->count, "resultset as number without results";
+ ok $rs, "resultset as boolean always true";
+}
\ No newline at end of file
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/testlib/MyBase.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/testlib/MyBase.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/testlib/MyBase.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -2,8 +2,10 @@
MyBase;
use strict;
-use base qw(DBIx::Class);
+use base qw(DBIx::Class::CDBICompat);
+use DBI;
+
use vars qw/$dbh/;
my @connect = ("dbi:mysql:test", "", "");
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/testlib/MyFoo.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/testlib/MyFoo.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/testlib/MyFoo.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -13,7 +13,7 @@
inflate => sub { Date::Simple->new(shift) },
deflate => 'format',
);
-__PACKAGE__->find_column('tdate')->placeholder("IF(1, CURDATE(), ?)");
+#__PACKAGE__->find_column('tdate')->placeholder("IF(1, CURDATE(), ?)");
sub create_sql {
return qq{
Modified: DBIx-Class/0.08/branches/oracle_sequence/t/testlib/PgBase.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle_sequence/t/testlib/PgBase.pm 2008-03-11 16:19:16 UTC (rev 4172)
+++ DBIx-Class/0.08/branches/oracle_sequence/t/testlib/PgBase.pm 2008-03-11 20:30:42 UTC (rev 4173)
@@ -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