[Bast-commits] r5651 - in DBIx-Class/0.08/branches/sybase: .
examples lib/DBIx lib/DBIx/Class lib/DBIx/Class/CDBICompat
lib/DBIx/Class/InflateColumn lib/DBIx/Class/Manual
lib/DBIx/Class/Relationship lib/DBIx/Class/ResultClass
lib/DBIx/Class/ResultSource lib/DBIx/Class/ResultSourceProxy
lib/DBIx/Class/Schema lib/DBIx/Class/Storage
lib/DBIx/Class/Storage/DBI lib/DBIx/Class/Storage/DBI/ODBC
lib/DBIx/Class/Storage/DBI/Oracle
lib/DBIx/Class/Storage/DBI/Replicated
lib/DBIx/Class/Storage/DBI/Role
lib/SQL/Translator/Parser/DBIx maint t t/96multi_create
t/cdbi t/cdbi/DeepAbstractSearch t/cdbi/abstract t/cdbi/sweet
t/cdbi/testlib t/lib t/lib/DBIC t/lib/DBICNSTest
t/lib/DBICNSTest/RtBug41083 t/lib/DBICNSTest/RtBug41083/ResultSet
t/lib/DBICNSTest/RtBug41083/ResultSet_A
t/lib/DBICNSTest/RtBug41083/Schema
t/lib/DBICNSTest/RtBug41083/Schema/Foo
t/lib/DBICNSTest/RtBug41083/Schema_A
t/lib/DBICNSTest/RtBug41083/Schema_A/A t/lib/DBICTest
t/lib/DBICTest/Schema t/ordered t/resultset t/search
ribasushi at dev.catalyst.perl.org
ribasushi at dev.catalyst.perl.org
Thu Feb 26 23:40:05 GMT 2009
Author: ribasushi
Date: 2009-02-26 23:40:04 +0000 (Thu, 26 Feb 2009)
New Revision: 5651
Added:
DBIx-Class/0.08/branches/sybase/Features_09
DBIx-Class/0.08/branches/sybase/examples/
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSource/View.pm
DBIx-Class/0.08/branches/sybase/t/103many_to_many_warning.t
DBIx-Class/0.08/branches/sybase/t/104view.t
DBIx-Class/0.08/branches/sybase/t/39load_namespaces_rt41083.t
DBIx-Class/0.08/branches/sybase/t/53delete_chained.t
DBIx-Class/0.08/branches/sybase/t/76select.t
DBIx-Class/0.08/branches/sybase/t/95sql_maker.t
DBIx-Class/0.08/branches/sybase/t/96multi_create/
DBIx-Class/0.08/branches/sybase/t/96multi_create/cd_single.t
DBIx-Class/0.08/branches/sybase/t/96multi_create/multilev_might_have_PKeqFK.t
DBIx-Class/0.08/branches/sybase/t/96multi_create_new.t
DBIx-Class/0.08/branches/sybase/t/96multi_create_torture.t
DBIx-Class/0.08/branches/sybase/t/99rh_perl_perf_bug.t
DBIx-Class/0.08/branches/sybase/t/cdbi/
DBIx-Class/0.08/branches/sybase/t/cdbi/01-columns.t
DBIx-Class/0.08/branches/sybase/t/cdbi/02-Film.t
DBIx-Class/0.08/branches/sybase/t/cdbi/03-subclassing.t
DBIx-Class/0.08/branches/sybase/t/cdbi/04-lazy.t
DBIx-Class/0.08/branches/sybase/t/cdbi/06-hasa.t
DBIx-Class/0.08/branches/sybase/t/cdbi/08-inheritcols.t
DBIx-Class/0.08/branches/sybase/t/cdbi/09-has_many.t
DBIx-Class/0.08/branches/sybase/t/cdbi/11-triggers.t
DBIx-Class/0.08/branches/sybase/t/cdbi/12-filter.t
DBIx-Class/0.08/branches/sybase/t/cdbi/13-constraint.t
DBIx-Class/0.08/branches/sybase/t/cdbi/14-might_have.t
DBIx-Class/0.08/branches/sybase/t/cdbi/15-accessor.t
DBIx-Class/0.08/branches/sybase/t/cdbi/16-reserved.t
DBIx-Class/0.08/branches/sybase/t/cdbi/18-has_a.t
DBIx-Class/0.08/branches/sybase/t/cdbi/19-set_sql.t
DBIx-Class/0.08/branches/sybase/t/cdbi/21-iterator.t
DBIx-Class/0.08/branches/sybase/t/cdbi/22-deflate_order.t
DBIx-Class/0.08/branches/sybase/t/cdbi/22-self_referential.t
DBIx-Class/0.08/branches/sybase/t/cdbi/23-cascade.t
DBIx-Class/0.08/branches/sybase/t/cdbi/24-meta_info.t
DBIx-Class/0.08/branches/sybase/t/cdbi/26-mutator.t
DBIx-Class/0.08/branches/sybase/t/cdbi/30-pager.t
DBIx-Class/0.08/branches/sybase/t/cdbi/68-inflate_has_a.t
DBIx-Class/0.08/branches/sybase/t/cdbi/98-failure.t
DBIx-Class/0.08/branches/sybase/t/cdbi/DeepAbstractSearch/
DBIx-Class/0.08/branches/sybase/t/cdbi/abstract/
DBIx-Class/0.08/branches/sybase/t/cdbi/columns_as_hashes.t
DBIx-Class/0.08/branches/sybase/t/cdbi/columns_dont_override_custom_accessors.t
DBIx-Class/0.08/branches/sybase/t/cdbi/construct.t
DBIx-Class/0.08/branches/sybase/t/cdbi/copy.t
DBIx-Class/0.08/branches/sybase/t/cdbi/early_column_heisenbug.t
DBIx-Class/0.08/branches/sybase/t/cdbi/has_many_loads_foreign_class.t
DBIx-Class/0.08/branches/sybase/t/cdbi/hasa_without_loading.t
DBIx-Class/0.08/branches/sybase/t/cdbi/max_min_value_of.t
DBIx-Class/0.08/branches/sybase/t/cdbi/mk_group_accessors.t
DBIx-Class/0.08/branches/sybase/t/cdbi/multi_column_set.t
DBIx-Class/0.08/branches/sybase/t/cdbi/object_cache.t
DBIx-Class/0.08/branches/sybase/t/cdbi/retrieve_from_sql_with_limit.t
DBIx-Class/0.08/branches/sybase/t/cdbi/set_to_undef.t
DBIx-Class/0.08/branches/sybase/t/cdbi/set_vs_DateTime.t
DBIx-Class/0.08/branches/sybase/t/cdbi/sweet/
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/
DBIx-Class/0.08/branches/sybase/t/lib/DBIC/
DBIx-Class/0.08/branches/sybase/t/lib/DBIC/DebugObj.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBIC/SqlMakerTest.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/
DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/ResultSet.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/ResultSet/
DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/ResultSet/Foo.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/ResultSet_A/
DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/ResultSet_A/A.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema/
DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema/Foo.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema/Foo/
DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema/Foo/Sub.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema_A/
DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema_A/A.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema_A/A/
DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema_A/A/Sub.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Artwork.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Artwork_to_Artist.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/BindType.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Encoded.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Genre.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Image.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/LyricVersion.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Lyrics.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Year1999CDs.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Year2000CDs.pm
DBIx-Class/0.08/branches/sybase/t/ordered/
DBIx-Class/0.08/branches/sybase/t/ordered/cascade_delete.t
DBIx-Class/0.08/branches/sybase/t/resultset/
DBIx-Class/0.08/branches/sybase/t/resultset/as_query.t
DBIx-Class/0.08/branches/sybase/t/search/
DBIx-Class/0.08/branches/sybase/t/search/subquery.t
Removed:
DBIx-Class/0.08/branches/sybase/VERSIONING.SKETCH
DBIx-Class/0.08/branches/sybase/t/68inflate_has_a.t
DBIx-Class/0.08/branches/sybase/t/cdbi-DeepAbstractSearch/
DBIx-Class/0.08/branches/sybase/t/cdbi-abstract/
DBIx-Class/0.08/branches/sybase/t/cdbi-sweet-t/
DBIx-Class/0.08/branches/sybase/t/cdbi-t/
DBIx-Class/0.08/branches/sybase/t/examples/
DBIx-Class/0.08/branches/sybase/t/testlib/
Modified:
DBIx-Class/0.08/branches/sybase/
DBIx-Class/0.08/branches/sybase/Changes
DBIx-Class/0.08/branches/sybase/MANIFEST.SKIP
DBIx-Class/0.08/branches/sybase/Makefile.PL
DBIx-Class/0.08/branches/sybase/TODO
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/AccessorMapping.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/ColumnCase.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/ImaDBI.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/TempColumns.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Componentised.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/DB.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Exception.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/InflateColumn/DateTime.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/InflateColumn/File.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Cookbook.pod
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Example.pod
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/FAQ.pod
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Glossary.pod
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Intro.pod
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Troubleshooting.pod
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Ordered.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/Accessor.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/Base.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/BelongsTo.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/ManyToMany.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultClass/HashRefInflator.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSet.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSetColumn.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSource.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSourceProxy/Table.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Row.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Schema.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Schema/Versioned.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/StartupCheck.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Cursor.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/MSSQL.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/ODBC.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Oracle.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Pg.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated/Replicant.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm
DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/SQLite.pm
DBIx-Class/0.08/branches/sybase/lib/SQL/Translator/Parser/DBIx/Class.pm
DBIx-Class/0.08/branches/sybase/maint/benchmark_hashrefinflator.pl
DBIx-Class/0.08/branches/sybase/maint/gen-schema.pl
DBIx-Class/0.08/branches/sybase/t/03podcoverage.t
DBIx-Class/0.08/branches/sybase/t/100populate.t
DBIx-Class/0.08/branches/sybase/t/101populate_rs.t
DBIx-Class/0.08/branches/sybase/t/18inserterror.t
DBIx-Class/0.08/branches/sybase/t/19quotes.t
DBIx-Class/0.08/branches/sybase/t/19quotes_newstyle.t
DBIx-Class/0.08/branches/sybase/t/32connect_code_ref.t
DBIx-Class/0.08/branches/sybase/t/33storage_reconnect.t
DBIx-Class/0.08/branches/sybase/t/34exception_action.t
DBIx-Class/0.08/branches/sybase/t/39load_namespaces_1.t
DBIx-Class/0.08/branches/sybase/t/41orrible.t
DBIx-Class/0.08/branches/sybase/t/47bind_attribute.t
DBIx-Class/0.08/branches/sybase/t/50fork.t
DBIx-Class/0.08/branches/sybase/t/51threads.t
DBIx-Class/0.08/branches/sybase/t/51threadtxn.t
DBIx-Class/0.08/branches/sybase/t/53delete_related.t
DBIx-Class/0.08/branches/sybase/t/54taint.t
DBIx-Class/0.08/branches/sybase/t/60core.t
DBIx-Class/0.08/branches/sybase/t/63register_class.t
DBIx-Class/0.08/branches/sybase/t/64db.t
DBIx-Class/0.08/branches/sybase/t/66relationship.t
DBIx-Class/0.08/branches/sybase/t/68inflate_resultclass_hashrefinflator.t
DBIx-Class/0.08/branches/sybase/t/71mysql.t
DBIx-Class/0.08/branches/sybase/t/72pg.t
DBIx-Class/0.08/branches/sybase/t/73oracle.t
DBIx-Class/0.08/branches/sybase/t/73oracle_inflate.t
DBIx-Class/0.08/branches/sybase/t/745db2.t
DBIx-Class/0.08/branches/sybase/t/746db2_400.t
DBIx-Class/0.08/branches/sybase/t/746mssql.t
DBIx-Class/0.08/branches/sybase/t/74mssql.t
DBIx-Class/0.08/branches/sybase/t/76joins.t
DBIx-Class/0.08/branches/sybase/t/77prefetch.t
DBIx-Class/0.08/branches/sybase/t/81transactions.t
DBIx-Class/0.08/branches/sybase/t/85utf8.t
DBIx-Class/0.08/branches/sybase/t/86sqlt.t
DBIx-Class/0.08/branches/sybase/t/87ordered.t
DBIx-Class/0.08/branches/sybase/t/88result_set_column.t
DBIx-Class/0.08/branches/sybase/t/89dbicadmin.t
DBIx-Class/0.08/branches/sybase/t/89inflate_datetime.t
DBIx-Class/0.08/branches/sybase/t/90ensure_class_loaded.t
DBIx-Class/0.08/branches/sybase/t/91debug.t
DBIx-Class/0.08/branches/sybase/t/92storage.t
DBIx-Class/0.08/branches/sybase/t/92storage_on_connect_do.t
DBIx-Class/0.08/branches/sybase/t/93nobindvars.t
DBIx-Class/0.08/branches/sybase/t/93single_accessor_object.t
DBIx-Class/0.08/branches/sybase/t/93storage_replication.t
DBIx-Class/0.08/branches/sybase/t/94versioning.t
DBIx-Class/0.08/branches/sybase/t/95sql_maker_quote.t
DBIx-Class/0.08/branches/sybase/t/96_is_deteministic_value.t
DBIx-Class/0.08/branches/sybase/t/96file_column.t
DBIx-Class/0.08/branches/sybase/t/96multi_create.t
DBIx-Class/0.08/branches/sybase/t/97result_class.t
DBIx-Class/0.08/branches/sybase/t/98savepoints.t
DBIx-Class/0.08/branches/sybase/t/99dbic_sqlt_parser.t
DBIx-Class/0.08/branches/sybase/t/bindtype_columns.t
DBIx-Class/0.08/branches/sybase/t/cdbi/DeepAbstractSearch/01_search.t
DBIx-Class/0.08/branches/sybase/t/cdbi/abstract/search_where.t
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Actor.pm
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/ActorAlias.pm
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Binary.pm
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Blurb.pm
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Director.pm
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Film.pm
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Lazy.pm
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Log.pm
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyBase.pm
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyFilm.pm
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyFoo.pm
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyStar.pm
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyStarLink.pm
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyStarLinkMCPK.pm
DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Order.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Artist.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Bookmark.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/BooksInLibrary.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/CD.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/CD_to_Producer.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Employee.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Event.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/EventTZ.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/ForceForeign.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Producer.pm
DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Track.pm
DBIx-Class/0.08/branches/sybase/t/lib/sqlite.sql
Log:
sync to trunk
Property changes on: DBIx-Class/0.08/branches/sybase
___________________________________________________________________
Name: svn:ignore
- _build
blib
Build
Build.bat
Makefile
+ _build
blib
pm_to_blib
Build
Build.bat
Makefile
Makefile.old
inc
README
META.yml
MANIFEST
Name: svk:merge
- 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/complex_join_rels:4589
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/file_column:3920
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/on_disconnect_do:3694
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/oracle_sequence:4173
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/parser_fk_index:4485
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/replication_dedux:4600
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/savepoints:4223
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/storage-ms-access:4142
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/versioned_enhancements:4125
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/versioning:4578
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
4d5fae46-8e6a-4e08-abee-817e9fb894a2:/local/bast/DBIx-Class/0.08/branches/resultsetcolumn_custom_columns:5160
4d5fae46-8e6a-4e08-abee-817e9fb894a2:/local/bast/DBIx-Class/0.08/branches/sqla_1.50_compat:5414
4d5fae46-8e6a-4e08-abee-817e9fb894a2:/local/bast/DBIx-Class/0.08/trunk:5635
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
ab17426e-7cd3-4704-a2a2-80b7c0a611bb:/local/dbic_column_attr:10946
ab17426e-7cd3-4704-a2a2-80b7c0a611bb:/local/dbic_trunk:10954
bd5ac9a7-f185-4d95-9186-dbb8b392a572:/local/os/bast/DBIx-Class/0.08/trunk:2798
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/belongs_to_null_col_fix:5244
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/cdbicompat_integration:4160
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/column_attr:5074
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/complex_join_rels:4589
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/file_column:3920
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/multi_stuff:5565
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/on_disconnect_do:3694
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/oracle_sequence:4173
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/parser_fk_index:4485
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/replication_dedux:4600
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/rt_bug_41083:5437
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/savepoints:4223
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/sqla_1.50_compat:5321
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/storage-ms-access:4142
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/subquery:5617
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/versioned_enhancements:4125
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/versioning:4578
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/branches/views:5585
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/DBIx-Class/0.08/trunk:5648
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/sybase/Changes
===================================================================
--- DBIx-Class/0.08/branches/sybase/Changes 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/Changes 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,6 +1,60 @@
Revision history for DBIx::Class
+ - multi-create using find_or_create rather than _related for post-insert
+ - fix get_inflated_columns to check has_column_loaded
+ - Add DBIC_MULTICREATE_DEBUG env var (undocumented, quasi-internal)
+ - Fix up multi-create to:
+ - correctly propagate columns loaded during multi-insert of rels
+ - not try and insert things tagged on via new_related unless required
+ - Possible to set locale in IC::DateTime extra => {} config
+ - Calling the accessor of a belongs_to when the foreign_key
+ was NULL and the row was not stored would unexpectedly fail (groditi)
+ - Split sql statements for deploy only if SQLT::Producer returned a scalar
+ containing all statements to be executed
+ - Add as_query() for ResultSet and ResultSetColumn. This makes subqueries
+ possible. See the Cookbook for details. (robkinyon, michaelr)
+ - Massive rewrite of Ordered to properly handle position constraints and
+ to make it more matpath-friendly
+ - deploy_statements called ddl_filename with the $version and $dir arguments
+ in the wrong order. (groditi)
+
+0.08099_06 2009-01-23 07:30:00 (UTC)
+ - Allow a scalarref to be supplied to the 'from' resultset attribute
+ - Classes submitted as result_class for a resultsource are now
+ automatically loaded via ensure_loaded()
+ - 'result_class' resultset attribute, identical to result_class()
+ - add 'undef_on_null_fk' option for relationship accessors of type 'single'.
+ This will prevent DBIC from querying the database if one or more of
+ the key columns IS NULL
+ - for 'belongs_to' rels, 'undef_on_null_fk' defaults to true.
+ - fixed scope unaware last_insert_id fetching for MSSQL
+ (http://msdn.microsoft.com/en-us/library/ms190315.aspx)
+ - an sqlt_deploy_hook can now be shared between result sources using
+ a configurable callback trigger
+ - new order_by => { -desc => 'colname' } syntax supported with
+ SQLA >= 1.50
+ - PG array datatype supported with SQLA >= 1.50
+ - insert should use store_column, not set_column to avoid marking
+ clean just-stored values as dirty. New test for this (groditi)
+ - regression test for source_name (groditi)
+
+0.08099_05 2008-10-30 21:30:00 (UTC)
+ - Rewritte of Storage::DBI::connect_info(), extended with an
+ additional argument format type
+ - InflateColumn::DateTime: add warning about floating timezone
+ - InflateColumn::DateTime: possible to enforce/skip inflation
+ - delete throws exception if passed arguments to prevent drunken mishaps. (purge)
+ - Fix storage to copy scalar conds before regexping to avoid
+ trying to modify a constant in odd edge cases
+ - Related resultsets on uninserted objects are now empty
+ - Fixed up related resultsets and multi-create
- Fixed superfluous connection in ODBC::_rebless
- Fixed undef PK for first insert in ODBC::Microsoft_SQL_Server
+ - Added virtual method to Versioned so a user can create upgrade
+ path across multiple versions (jgoulah)
+ - Better (and marginally faster) implementation of the HashRefInflator
+ hash construction algorithm
+ - Allow explicit specification of ON DELETE/ON UPDATE constraints
+ when using the SQLT parser
0.08099_04 2008-07-24 01:00:00
- Functionality to storage to enable a sub to be run without FK checks
Added: DBIx-Class/0.08/branches/sybase/Features_09
===================================================================
--- DBIx-Class/0.08/branches/sybase/Features_09 (rev 0)
+++ DBIx-Class/0.08/branches/sybase/Features_09 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,55 @@
+(Potential) Features for 0.09
+=============================
+
+Row/find caching - would be pretty useful
+ - Need to have good definitions of when the cache should be queried and when invalidated
+ - Be able to supply own expiry?
+ - Be able to invalidate manually? Single item / entire cache / single table
+
+Remove compose_connection / DB.pm
+ - Everyone has probably forgotten what this is anyway..
+
+Syntax improvements?
+ - "as" to "alias" ?
+ - "belongs_to" to "contains/refers/something"
+
+Using inflated objects/references as values in searches
+ - Goes together with subselects above
+ - should deflate then run search
+
+FilterColumn - like Inflate, only for changing scalar values
+ - This seems to be vaporware atm..
+
+SQL/API feature complete?
+ - UNION
+ - proper join conditions!
+ - function calls on the LHS of conditions..
+
+Moosification - ouch
+
+Prefetch improvements
+ - slow on mysql, speedup?
+ - multi has_many prefetch
+ - paging working with prefetch
+
+Magically "discover" needed joins/prefetches and add them
+ - eg $books->search({ 'author.name' => 'Fred'}), autoadds: join => 'author'
+ - also guess aliases when supplying column names that are on joined/related tables
+
+Metamodel stuff - introspection
+
+Storage API/restructure
+ - call update/insert etc on the ResultSource, which then calls to storage
+ - handle different storages/db-specific code better
+ - better cross-db code .. eg LIKE/ILIKE
+
+Relationships
+ - single vs filter, discrepancies.. remove one of them and make behave the same?
+
+Joining/searching weird attribute tables?
+ - Support legacy/badly designed junk better..
+
+Documentation - improvements
+ - better indexing for finding of stuff in general
+ - more cross-referencing of docs
+
Property changes on: DBIx-Class/0.08/branches/sybase/Features_09
___________________________________________________________________
Name: svn:mergeinfo
+
Modified: DBIx-Class/0.08/branches/sybase/MANIFEST.SKIP
===================================================================
--- DBIx-Class/0.08/branches/sybase/MANIFEST.SKIP 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/MANIFEST.SKIP 2009-02-26 23:40:04 UTC (rev 5651)
@@ -14,7 +14,7 @@
# for developers only :)
^TODO$
-^VERSIONING\.SKETCH$
+^Features_09$
# Avoid Module::Build generated and utility files.
\bBuild$
@@ -41,8 +41,9 @@
# Skip maint stuff
^maint/
-# Avoid copies to .orig
+# Avoid patch remnants
\.orig$
+\.rej$
# Dont use Module::Build anymore
^Build.PL$
Modified: DBIx-Class/0.08/branches/sybase/Makefile.PL
===================================================================
--- DBIx-Class/0.08/branches/sybase/Makefile.PL 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/Makefile.PL 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,6 +1,7 @@
use inc::Module::Install 0.67;
use strict;
use warnings;
+use POSIX ();
use 5.006001; # delete this line if you want to send patches for earlier.
@@ -8,52 +9,66 @@
perl_version '5.006001';
all_from 'lib/DBIx/Class.pm';
-requires 'Data::Page' => 2.00;
-requires 'Scalar::Util' => 0;
-requires 'SQL::Abstract' => 1.20;
-requires 'SQL::Abstract::Limit' => 0.101;
-requires 'Class::C3' => 0.13;
-requires 'Class::C3::Componentised' => 0;
-requires 'Storable' => 0;
-requires 'Carp::Clan' => 0;
-requires 'DBI' => 1.40;
-requires 'Module::Find' => 0;
-requires 'Class::Inspector' => 0;
-requires 'Class::Accessor::Grouped' => 0.05002;
-requires 'JSON::Any' => 1.00;
-requires 'Scope::Guard' => 0.03;
-requires 'Path::Class' => 0;
-requires 'List::Util' => 1.19;
-requires 'Sub::Name' => 0.04;
+requires 'Data::Page' => 2.00;
+requires 'Scalar::Util' => 0;
+requires 'SQL::Abstract' => 1.49;
+requires 'SQL::Abstract::Limit' => 0.13;
+requires 'Class::C3' => 0.20;
+requires 'Class::C3::Componentised' => 0;
+requires 'Storable' => 0;
+requires 'Carp::Clan' => 0;
+requires 'DBI' => 1.40;
+requires 'Module::Find' => 0;
+requires 'Class::Inspector' => 0;
+requires 'Class::Accessor::Grouped' => 0.08002;
+requires 'JSON::Any' => 1.17;
+requires 'Scope::Guard' => 0.03;
+requires 'Path::Class' => 0;
+requires 'List::Util' => 1.19;
+requires 'Sub::Name' => 0.04;
+requires 'namespace::clean' => 0.09;
# Perl 5.8.0 doesn't have utf8::is_utf8()
-requires 'Encode' => 0 if ($] <= 5.008000);
+requires 'Encode' => 0 if ($] <= 5.008000);
-test_requires 'DBD::SQLite' => 1.13;
+# configure_requires so the sanity check below can run
+configure_requires 'DBD::SQLite' => 1.14;
+
test_requires 'Test::Builder' => 0.33;
-test_requires 'Test::Warn' => 0.08;
-test_requires 'Test::NoWarnings' => 0.08;
+test_requires 'Test::Warn' => 0.11;
test_requires 'Test::Exception' => 0;
+test_requires 'Test::Deep' => 0;
+recommends 'SQL::Translator' => 0.09004;
+
install_script 'script/dbicadmin';
-tests "t/*.t t/*/*.t";
+tests_recursive 't';
# re-build README and require CDBI modules for testing if we're in a checkout
-my @force_build_requires_if_author = qw(
- DBIx::ContextualFetch
- Class::Trigger
- Time::Piece
- Clone
- Test::Pod::Coverage
- Test::Memory::Cycle
+my %force_requires_if_author = (
+ 'Test::Pod::Coverage' => 0,
+ 'SQL::Translator' => 0.09004,
+
+ # CDBI-compat related
+ 'DBIx::ContextualFetch' => 0,
+ 'Class::Trigger' => 0,
+ 'Time::Piece' => 0,
+ 'Clone' => 0,
+
+ # t/52cycle.t
+ 'Test::Memory::Cycle' => 0,
+
+ # t/93storage_replication.t
+ 'Moose', => 0,
+ 'MooseX::AttributeHelpers' => 0.12,
);
if ($Module::Install::AUTHOR) {
- foreach my $module (@force_build_requires_if_author) {
- build_requires $module;
+ foreach my $module (keys %force_requires_if_author) {
+ requires ($module => $force_requires_if_author{$module});
}
system('pod2text lib/DBIx/Class.pm > README');
@@ -63,14 +78,108 @@
auto_install;
-WriteAll;
+# Have all prerequisites, check DBD::SQLite sanity
+if (! $ENV{DBICTEST_NO_SQLITE_CHECK} ) {
+ my $pid = fork();
+ if (not defined $pid) {
+ die "Unable to fork(): $!";
+ }
+ elsif (! $pid) {
+ # Win32 does not have real fork()s so a segfault will bring
+ # everything down. Warn about it.
+ if ($^O eq 'MSWin32') {
+ print <<'EOW';
+
+######################################################################
+# #
+# A short stress-testing of DBD::SQLite will follow. If you have a #
+# buggy library this might very well be the last text you will see #
+# before the installation silently terminates. If this happens it #
+# would mean that you are running a buggy version of DBD::SQLite #
+# known to randomly segfault on errors. Even if you have the latest #
+# CPAN module version, the system sqlite3 dynamic library might have #
+# been compiled against an older buggy sqlite3 dev library (oddly #
+# DBD::SQLite will prefer the system library against the one bundled #
+# with it). You are strongly advised to resolve this issue before #
+# proceeding. #
+# #
+# If this happens to you (this text is the last thing you see), and #
+# you just want to install this module without worrying about the #
+# tests (which will almost certainly fail) - set the environment #
+# variable DBICTEST_NO_SQLITE_CHECK to a true value and try again. #
+# #
+######################################################################
+
+EOW
+ }
+
+ require DBI;
+ for (1 .. 100) {
+ my $dbh;
+ $dbh = DBI->connect ('dbi:SQLite::memory:', undef, undef, {
+ AutoCommit => 1,
+ RaiseError => 0,
+ PrintError => 0,
+ })
+ or die "Unable to connect to database: $@";
+ $dbh->do ('CREATE TABLE name_with_no_columns'); # a subtle syntax error
+ $dbh->do ('COMMIT'); # followed by commit
+ $dbh->disconnect;
+ }
+
+ exit 0;
+ }
+ else {
+ eval {
+ local $SIG{ALRM} = sub { die "timeout\n" };
+ alarm 5;
+ wait();
+ alarm 0;
+ };
+ my $exception = $@;
+
+ my $sig = $? & 127;
+
+# make sure process actually dies
+ $exception && kill POSIX::SIGKILL(), $pid;
+
+ if ($exception || $sig == POSIX::SIGSEGV() || $sig == POSIX::SIGABRT()
+ || $sig == 7) { # 7 == SIGBUS, haven't seen it but just in case
+ warn (<<EOE);
+
+############################### WARNING #################################
+# #
+# You are running a buggy version of DBD::SQLite known to randomly #
+# segfault on errors. Even if you have the latest CPAN module version, #
+# the sqlite3 dynamic library on this system might have been compiled #
+# against an older buggy sqlite3 dev library (oddly DBD::SQLite will #
+# prefer the system library against the one bundled with it). You are #
+# strongly advised to resolve this issue before proceeding. #
+# #
+#########################################################################
+
+EOE
+ my $ans = prompt (
+ "The test suite of this module is almost certain to fail.\n"
+ . 'Do you really want to continue?',
+ 'no',
+ );
+ exit 0 unless ($ans =~ /^y(es)?$/i);
+ }
+ }
+}
+
+
+WriteAll();
+
+
if ($Module::Install::AUTHOR) {
# Need to do this _after_ WriteAll else it looses track of them
Meta->{values}{build_requires} = [ grep {
my $ok = 1;
- foreach my $module (@force_build_requires_if_author) {
+ foreach my $module (keys %force_requires_if_author) {
if ($_->[0] =~ /$module/) {
$ok = 0;
last;
@@ -95,6 +204,3 @@
];
Meta->write;
}
-
-
-
Modified: DBIx-Class/0.08/branches/sybase/TODO
===================================================================
--- DBIx-Class/0.08/branches/sybase/TODO 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/TODO 2009-02-26 23:40:04 UTC (rev 5651)
@@ -4,19 +4,13 @@
- find why XSUB dumper kills schema in Catalyst (may be Pg only?)
2006-04-11 by castaway
- - using PK::Auto should set is_auto_increment for the PK columns, so that copy() "just works"
- docs of copy() should say that is_auto_increment is essential for auto_incrementing keys
2006-03-25 by mst
- - Refactor ResultSet::new to be less hairy
- - we should move the setup of select, as, and from out of here
- - these should be local rs attrs, not main attrs, and extra joins
- provided on search should be merged
- find a way to un-wantarray search without breaking compat
- audit logging component
- delay relationship setup if done via ->load_classes
- double-sided relationships
- - incremental deploy
- make short form of class specifier in relationships work
2006-01-31 by bluefeet
@@ -29,12 +23,6 @@
2006-02-07 by castaway
- Extract DBIC::SQL::Abstract into a separate module for CPAN
- - Chop PK::Auto::Foo up to have PK::Auto refer to an appropriate
- DBIx::Storage::DBI::Foo, which will be loaded on connect from Driver info?
-(done -> 0.06001!)
- - Add deploy method to Schema, which will create DB tables from Schema, via
- SQLT
-(sorta done)
2006-03-18 by bluefeet
- Support table locking.
@@ -58,3 +46,19 @@
rows: modify to be an alias that gets used to populate either as appropriate,
if you haven't specified one of the others
+2008-10-30 by ribasushi
+ Leftovers for next dev-release
+ - Rewrite the test suite to rely on $schema->deploy, allowing for seamless
+ testing of various RDBMS using the same tests
+ - Proper support of default create (i.e. create({}) ), with proper workarounds
+ for different Storage's
+ - Automatically infer quote_char/name_sep from $schema->storage
+ - Finally incorporate View support (needs real tests)
+ - Fix and properly test chained search attribute merging
+
+2008-11-07 by ribasushi
+ - Be loud when a relationship resolution fails because we did not select/as
+ a neccessary pk
+ - Recursive update() (all code seems to be already available)
+ - $rs->populate changes its syntax depending on wantarray context (BAD)
+ Also the interface differs from $schema->populate (not so good)
Deleted: DBIx-Class/0.08/branches/sybase/VERSIONING.SKETCH
===================================================================
--- DBIx-Class/0.08/branches/sybase/VERSIONING.SKETCH 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/VERSIONING.SKETCH 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,30 +0,0 @@
-Schema versioning/deployment ideas from Jess (with input from theorbtwo and mst):
-1) Add a method to storage to:
- - take args of DB type, version, and optional file/pathname
- - create an SQL file, via SQLT, for the current schema
- - passing prev. version + version will create an sqlt-diff'ed upgrade file, such as
- - $preversion->$currentversion-$dbtype.sql, which contains ALTER foo statements.
-2) Make deploy/deploy_statements able to to load from the appropriate file, for the current DB, or on the fly? - Compare against current schema version..
-3) Add an on_connect_cb (callback) thingy to storage.
-4) create a component to deploy version/updates:
- - it hooks itself into on_connect_cb ?
- - when run it:
- - Attempts or prompts a backup of the database. (commands for these per-rdbms can be stored in storage::dbi::<dbtype> ?)
- - Checks the version of the current schema being used
- - Compares it to some schema table containing the installed version
- - If none such exists, we can attempt to sqlt-diff the DB structure with the schema
- - If version does exist, we use an array of user-defined upgrade paths,
- eg: version = '3x.'; schema = '1.x', upgrade paths = ('1.x->2.x', '2.x->3.x')
- - Find the appropriate upgrade-path file, parse into two chunks:
- a) the commands which do not contain "DROP"
- b) the ones that do
- - Calls user callbacks for "pre-upgrade"
- - Runs the first set of commands on the DB
- - Calls user callbacks for "post-alter"
- - Runs drop commands
- - Calls user callbacks for "post-drop"
- - The user will need to define (or ignore) the following callbacks:
- - "pre-upgrade", any code to be run before the upgrade, called with schema object, version-from, version-to, db-type .. bear in mind that here any new fields in the schema will not work, but can be used via scalarrefs.
- - "post-alter", this is the main callback, at this stage, all old and new fields will be available, to allow data migration.
- - "post-drop", this is the clean-up stage, now only new fields are available.
-
Copied: DBIx-Class/0.08/branches/sybase/examples (from rev 4765, DBIx-Class/0.08/branches/sybase/t/examples)
Property changes on: DBIx-Class/0.08/branches/sybase/examples
___________________________________________________________________
Name: svn:mergeinfo
+
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/AccessorMapping.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/AccessorMapping.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/AccessorMapping.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,26 +1,35 @@
package # hide from PAUSE Indexer
- DBIx::Class::CDBICompat::AccessorMapping;
+ DBIx::Class::CDBICompat::AccessorMapping;
use strict;
use warnings;
sub mk_group_accessors {
- my ($class, $group, @cols) = @_;
+ my ($class, $group, @cols) = @_;
- foreach my $col (@cols) {
- my $ro_meth = $class->accessor_name_for($col);
- my $wo_meth = $class->mutator_name_for($col);
+ foreach my $col (@cols) {
+ my($accessor, $col) = ref $col ? @$col : (undef, $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 ]);
- $class->mk_group_wo_accessors($group => [ $wo_meth => $col ]);
+ my($ro_meth, $wo_meth);
+ if( defined $accessor and ($accessor ne $col)) {
+ $ro_meth = $wo_meth = $accessor;
+ }
+ else {
+ $ro_meth = $class->accessor_name_for($col);
+ $wo_meth = $class->mutator_name_for($col);
+ }
+
+ # warn "class: $class / col: $col / ro: $ro_meth / wo: $wo_meth\n";
+ if ($ro_meth eq $wo_meth or # they're the same
+ $wo_meth eq $col) # or only the accessor is custom
+ {
+ $class->next::method($group => [ $ro_meth => $col ]);
+ }
+ else {
+ $class->mk_group_ro_accessors($group => [ $ro_meth => $col ]);
+ $class->mk_group_wo_accessors($group => [ $wo_meth => $col ]);
+ }
}
- }
}
@@ -44,16 +53,16 @@
sub new {
- my ($class, $attrs, @rest) = @_;
- $class->throw_exception( "create needs a hashref" ) unless ref $attrs eq 'HASH';
- foreach my $col ($class->columns) {
- my $acc = $class->accessor_name_for($col);
- $attrs->{$col} = delete $attrs->{$acc} if exists $attrs->{$acc};
+ my ($class, $attrs, @rest) = @_;
+ $class->throw_exception( "create needs a hashref" ) unless ref $attrs eq 'HASH';
+ foreach my $col ($class->columns) {
+ my $acc = $class->accessor_name_for($col);
+ $attrs->{$col} = delete $attrs->{$acc} if exists $attrs->{$acc};
- my $mut = $class->mutator_name_for($col);
- $attrs->{$col} = delete $attrs->{$mut} if exists $attrs->{$mut};
- }
- return $class->next::method($attrs, @rest);
+ my $mut = $class->mutator_name_for($col);
+ $attrs->{$col} = delete $attrs->{$mut} if exists $attrs->{$mut};
+ }
+ return $class->next::method($attrs, @rest);
}
1;
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/ColumnCase.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/ColumnCase.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/ColumnCase.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -4,8 +4,6 @@
use strict;
use warnings;
-use base qw/DBIx::Class/;
-
sub _register_column_group {
my ($class, $group, @cols) = @_;
return $class->next::method($group => map lc, @cols);
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/ImaDBI.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/ImaDBI.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/ImaDBI.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -6,7 +6,7 @@
use DBIx::ContextualFetch;
use Sub::Name ();
-use base qw/DBIx::Class/;
+use base qw(Class::Data::Inheritable);
__PACKAGE__->mk_classdata('sql_transformer_class' =>
'DBIx::Class::CDBICompat::SQLTransformer');
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/TempColumns.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/TempColumns.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/CDBICompat/TempColumns.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use base qw/DBIx::Class/;
+use base qw/Class::Data::Inheritable/;
use Carp;
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Componentised.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Componentised.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Componentised.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -36,12 +36,20 @@
# successfully, and false if the class is not installed
sub load_optional_class {
my ($class, $f_class) = @_;
- if ($class->ensure_class_found($f_class)) {
- $class->ensure_class_loaded($f_class);
+ eval { $class->ensure_class_loaded($f_class) };
+ my $err = $@; # so we don't lose it
+ if (! $err) {
return 1;
- } else {
- return 0;
}
+ else {
+ my $fn = (join ('/', split ('::', $f_class) ) ) . '.pm';
+ if ($err =~ /Can't locate ${fn} in \@INC/ ) {
+ return 0;
+ }
+ else {
+ die $err;
+ }
+ }
}
1;
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/DB.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/DB.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/DB.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -152,27 +152,47 @@
__PACKAGE__->mk_classdata('_result_source_instance' => []);
+# Yep. this is horrific. Basically what's happening here is that
+# (with good reason) DBIx::Class::Schema copies the result source for
+# registration. Because we have a retarded setup order forced on us we need
+# to actually make our ->result_source_instance -be- the source used, and we
+# need to get the source name and schema into ourselves. So this makes it
+# happen.
+
+sub _maybe_attach_source_to_schema {
+ my ($class, $source) = @_;
+ if (my $meth = $class->can('schema_instance')) {
+ my $schema = $class->$meth;
+ $schema->register_class($class, $class);
+ my $new_source = $schema->source($class);
+ %$source = %$new_source;
+ $schema->source_registrations->{$class} = $source;
+ }
+}
+
sub result_source_instance {
my $class = shift;
$class = ref $class || $class;
- return $class->_result_source_instance([$_[0], $class]) if @_;
+ if (@_) {
+ my $source = $_[0];
+ $class->_result_source_instance([$source, $class]);
+ $class->_maybe_attach_source_to_schema($source);
+ return $source;
+ }
my($source, $result_class) = @{$class->_result_source_instance};
return unless Scalar::Util::blessed($source);
if ($result_class ne $class) { # new class
# Give this new class it's own source and register it.
-
$source = $source->new({
%$source,
source_name => $class,
result_class => $class
} );
$class->_result_source_instance([$source, $class]);
- if (my $coderef = $class->can('schema_instance')) {
- $coderef->($class)->register_class($class, $class);
- }
+ $class->_maybe_attach_source_to_schema($source);
}
return $source;
}
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Exception.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Exception.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Exception.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -16,8 +16,8 @@
=head1 DESCRIPTION
-Exception objects of this class are used in internally by
-he default error handling of L<DBIx::Class::Schema/throw_exception>
+Exception objects of this class are used internally by
+the default error handling of L<DBIx::Class::Schema/throw_exception>
to prevent confusing and/or redundant re-application of L<Carp>'s
stack trace information.
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/InflateColumn/DateTime.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/InflateColumn/DateTime.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/InflateColumn/DateTime.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -19,17 +19,37 @@
starts_when => { data_type => 'datetime' }
);
+NOTE: You B<must> load C<InflateColumn::DateTime> B<before> C<Core>. See
+L<DBIx::Class::Manual::Component> for details.
+
Then you can treat the specified column as a L<DateTime> object.
print "This event starts the month of ".
$event->starts_when->month_name();
-If you want to set a specific timezone for that field, use:
+If you want to set a specific timezone and locale for that field, use:
__PACKAGE__->add_columns(
- starts_when => { data_type => 'datetime', extra => { timezone => "America/Chicago" } }
+ starts_when => { data_type => 'datetime', extra => { timezone => "America/Chicago", locale => "de_DE" } }
);
+If you want to inflate no matter what data_type your column is,
+use inflate_datetime or inflate_date:
+
+ __PACKAGE__->add_columns(
+ starts_when => { data_type => 'varchar', inflate_datetime => 1 }
+ );
+
+ __PACKAGE__->add_columns(
+ starts_when => { data_type => 'varchar', inflate_date => 1 }
+ );
+
+It's also possible to explicitly skip inflation:
+
+ __PACKAGE__->add_columns(
+ starts_when => { data_type => 'datetime', inflate_datetime => 0 }
+ );
+
=head1 DESCRIPTION
This module figures out the type of DateTime::Format::* class to
@@ -71,17 +91,54 @@
my ($self, $column, $info, @rest) = @_;
$self->next::method($column, $info, @rest);
return unless defined($info->{data_type});
- my $type = lc($info->{data_type});
- $type = 'datetime' if ($type =~ /^timestamp/);
+
+ my $type;
+
+ for (qw/date datetime/) {
+ my $key = "inflate_${_}";
+
+ next unless exists $info->{$key};
+ return unless $info->{$key};
+
+ $type = $_;
+ last;
+ }
+
+ unless ($type) {
+ $type = lc($info->{data_type});
+ $type = 'datetime' if ($type =~ /^timestamp/);
+ }
+
my $timezone;
- if ( exists $info->{extra} and exists $info->{extra}{timezone} and defined $info->{extra}{timezone} ) {
+ if ( defined $info->{extra}{timezone} ) {
$timezone = $info->{extra}{timezone};
}
+ my $locale;
+ if ( defined $info->{extra}{locale} ) {
+ $locale = $info->{extra}{locale};
+ }
+
my $undef_if_invalid = $info->{datetime_undef_if_invalid};
if ($type eq 'datetime' || $type eq 'date') {
my ($parse, $format) = ("parse_${type}", "format_${type}");
+
+ # This assignment must happen here, otherwise Devel::Cycle treats
+ # the resulting deflator as a circular reference (go figure):
+ #
+ # Cycle #1
+ # DBICTest::Schema A->{source_registrations} => %B
+ # %B->{Event} => DBIx::Class::ResultSource::Table C
+ # DBIx::Class::ResultSource::Table C->{_columns} => %D
+ # %D->{created_on} => %E
+ # %E->{_inflate_info} => %F
+ # %F->{deflate} => &G
+ # closure &G, $info => $H
+ # $H => %E
+ #
+ my $floating_tz_ok = $info->{extra}{floating_tz_ok};
+
$self->inflate_column(
$column =>
{
@@ -91,11 +148,20 @@
die "Error while inflating ${value} for ${column} on ${self}: $@"
if $@ and not $undef_if_invalid;
$dt->set_time_zone($timezone) if $timezone;
+ $dt->set_locale($locale) if $locale;
return $dt;
},
deflate => sub {
my ($value, $obj) = @_;
- $value->set_time_zone($timezone) if $timezone;
+ if ($timezone) {
+ warn "You're using a floating timezone, please see the documentation of"
+ . " DBIx::Class::InflateColumn::DateTime for an explanation"
+ if ref( $value->time_zone ) eq 'DateTime::TimeZone::Floating'
+ and not $floating_tz_ok
+ and not $ENV{DBIC_FLOATING_TZ_OK};
+ $value->set_time_zone($timezone);
+ $value->set_locale($locale) if $locale;
+ }
$obj->_datetime_parser->$format($value);
},
}
@@ -115,6 +181,49 @@
1;
__END__
+=head1 USAGE NOTES
+
+If you have a datetime column with the C<timezone> extra setting, and subsenquently
+create/update this column with a DateTime object in the L<DateTime::TimeZone::Floating>
+timezone, you will get a warning (as there is a very good chance this will not have the
+result you expect). For example:
+
+ __PACKAGE__->add_columns(
+ starts_when => { data_type => 'datetime', extra => { timezone => "America/Chicago" } }
+ );
+
+ my $event = $schema->resultset('EventTZ')->create({
+ starts_at => DateTime->new(year=>2007, month=>12, day=>31, ),
+ });
+
+The warning can be avoided in several ways:
+
+=over
+
+=item Fix your broken code
+
+When calling C<set_time_zone> on a Floating DateTime object, the timezone is simply
+set to the requested value, and B<no time conversion takes place>. It is always a good idea
+to be supply explicit times to the database:
+
+ my $event = $schema->resultset('EventTZ')->create({
+ starts_at => DateTime->new(year=>2007, month=>12, day=>31, time_zone => "America/Chicago" ),
+ });
+
+=item Suppress the check on per-column basis
+
+ __PACKAGE__->add_columns(
+ starts_when => { data_type => 'datetime', extra => { timezone => "America/Chicago", floating_tz_ok => 1 } }
+ );
+
+=item Suppress the check globally
+
+Set the environment variable DBIC_FLOATING_TZ_OK to some true value.
+
+=back
+
+
+
=head1 SEE ALSO
=over 4
@@ -122,6 +231,10 @@
=item More information about the add_columns method, and column metadata,
can be found in the documentation for L<DBIx::Class::ResultSource>.
+=item Further discussion of problems inherent to the Floating timezone:
+ L<Floating DateTimes|DateTime/Floating_DateTimes>
+ and L<< $dt->set_time_zone|DateTime/"Set" Methods >>
+
=back
=head1 AUTHOR
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/InflateColumn/File.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/InflateColumn/File.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/InflateColumn/File.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -95,9 +95,11 @@
my $fs_file = $self->_file_column_file($column, $value->{filename});
mkpath [$fs_file->dir];
-
- File::Copy::copy($value->{handle}, $fs_file);
+ # File::Copy doesn't like Path::Class (or any for that matter) objects,
+ # thus ->stringify (http://rt.perl.org/rt3/Public/Bug/Display.html?id=59650)
+ File::Copy::copy($value->{handle}, $fs_file->stringify);
+
$self->_file_column_callback($value, $self, $column);
return $value->{filename};
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Cookbook.pod
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Cookbook.pod 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Cookbook.pod 2009-02-26 23:40:04 UTC (rev 5651)
@@ -68,6 +68,41 @@
For more information on generating complex queries, see
L<SQL::Abstract/WHERE CLAUSES>.
+=head2 Retrieve one and only one row from a resultset
+
+Sometimes you need only the first "top" row of a resultset. While this can be
+easily done with L<< $rs->first|DBIx::Class::ResultSet/first >>, it is suboptimal,
+as a full blown cursor for the resultset will be created and then immediately
+destroyed after fetching the first row object.
+L<< $rs->single|DBIx::Class::ResultSet/single >> is
+designed specifically for this case - it will grab the first returned result
+without even instantiating a cursor.
+
+Before replacing all your calls to C<first()> with C<single()> please observe the
+following CAVEATS:
+
+=over
+
+=item *
+While single() takes a search condition just like search() does, it does
+_not_ accept search attributes. However one can always chain a single() to
+a search():
+
+ my $top_cd = $cd_rs -> search({}, { order_by => 'rating' }) -> single;
+
+
+=item *
+Since single() is the engine behind find(), it is designed to fetch a
+single row per database query. Thus a warning will be issued when the
+underlying SELECT returns more than one row. Sometimes however this usage
+is valid: i.e. we have an arbitrary number of cd's but only one of them is
+at the top of the charts at any given time. If you know what you are doing,
+you can silence the warning by explicitly limiting the resultset size:
+
+ my $top_cd = $cd_rs -> search ({}, { order_by => 'rating', rows => 1 }) -> single;
+
+=back
+
=head2 Arbitrary SQL through a custom ResultSource
Sometimes you have to run arbitrary SQL because your query is too complex
@@ -106,7 +141,7 @@
SQL
# Finally, register your new ResultSource with your Schema
- My::Schema->register_source( 'UserFriendsComplex' => $new_source );
+ My::Schema->register_extra_source( 'UserFriendsComplex' => $new_source );
Next, you can execute your complex query using bind parameters like this:
@@ -116,8 +151,37 @@
}
) ];
-... and you'll get back a perfect L<DBIx::Class::ResultSet>.
+... and you'll get back a perfect L<DBIx::Class::ResultSet> (except, of course,
+that you cannot modify the rows it contains, ie. cannot call L</update>,
+L</delete>, ... on it).
+If you prefer to have the definitions of these custom ResultSources in separate
+files (instead of stuffing all of them into the same resultset class), you can
+achieve the same with subclassing the resultset class and defining the
+ResultSource there:
+
+ package My::Schema::UserFriendsComplex;
+
+ use My::Schema::User;
+ use base qw/My::Schema::User/;
+
+ __PACKAGE__->table('dummy'); # currently must be called before anything else
+
+ # Hand in your query as a scalar reference
+ # It will be added as a sub-select after FROM,
+ # so pay attention to the surrounding brackets!
+ __PACKAGE__->name( \<<SQL );
+ ( SELECT u.* FROM user u
+ INNER JOIN user_friends f ON u.id = f.user_id
+ WHERE f.friend_user_id = ?
+ UNION
+ SELECT u.* FROM user u
+ INNER JOIN user_friends f ON u.id = f.friend_user_id
+ WHERE f.user_id = ? )
+ SQL
+
+TIMTOWDI.
+
=head2 Using specific columns
When you only want specific columns from a table, you can use
@@ -216,21 +280,69 @@
{},
{
join => [qw/ cds /],
- select => [ 'name', { count => 'cds.cdid' } ],
+ select => [ 'name', { count => 'cds.id' } ],
as => [qw/ name cd_count /],
group_by => [qw/ name /]
}
);
# Equivalent SQL:
- # SELECT name, COUNT( cds.cdid ) FROM artist me
- # LEFT JOIN cd cds ON ( cds.artist = me.artistid )
+ # SELECT name, COUNT( cd.id ) FROM artist
+ # LEFT JOIN cd ON artist.id = cd.artist
# GROUP BY name
Please see L<DBIx::Class::ResultSet/ATTRIBUTES> documentation if you
are in any way unsure about the use of the attributes above (C< join
>, C< select >, C< as > and C< group_by >).
+=head2 Subqueries
+
+You can write subqueries relatively easily in DBIC.
+
+ my $inside_rs = $schema->resultset('Artist')->search({
+ name => [ 'Billy Joel', 'Brittany Spears' ],
+ });
+
+ my $rs = $schema->resultset('CD')->search({
+ artist_id => { 'IN' => $inside_rs->get_column('id')->as_query },
+ });
+
+The usual operators ( =, !=, IN, NOT IN, etc) are supported.
+
+B<NOTE>: You have to explicitly use '=' when doing an equality comparison.
+The following will B<not> work:
+
+ my $rs = $schema->resultset('CD')->search({
+ artist_id => $inside_rs->get_column('id')->as_query,
+ });
+
+=head3 Support
+
+Subqueries are supported in the where clause (first hashref), and in the
+from, select, and +select attributes.
+
+=head3 Correlated subqueries
+
+ my $cdrs = $schema->resultset('CD');
+ my $rs = $cdrs->search({
+ year => {
+ '=' => $cdrs->search(
+ { artistid => { '=' => \'me.artistid' } },
+ { alias => 'inner' }
+ )->get_column('year')->max_rs->as_query,
+ },
+ });
+
+That creates the following SQL:
+
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
+ FROM cd me
+ WHERE year = (
+ SELECT MAX(inner.year)
+ FROM cd inner
+ WHERE artistid = me.artistid
+ )
+
=head2 Predefined searches
You can write your own L<DBIx::Class::ResultSet> class by inheriting from it
@@ -312,7 +424,7 @@
'artist.name' => 'Bob Marley'
},
{
- join => [qw/artist/], # join the artist table
+ join => 'artist', # join the artist table
}
);
@@ -329,7 +441,7 @@
'artist.name' => 'Bob Marley'
},
{
- join => [qw/ artist /],
+ join => 'artist',
order_by => [qw/ artist.name /]
}
);
@@ -370,9 +482,9 @@
'artist.name' => 'Bob Marley'
},
{
- join => [qw/ artist /],
+ join => 'artist',
order_by => [qw/ artist.name /],
- prefetch => [qw/ artist /] # return artist data too!
+ prefetch => 'artist' # return artist data too!
}
);
@@ -399,6 +511,34 @@
definitely use data from a related table. Pre-fetching related tables when you
only need columns from the main table will make performance worse!
+=head2 Multiple joins
+
+In the examples above, the C<join> attribute was a scalar. If you
+pass an array reference instead, you can join to multiple tables. In
+this example, we want to limit the search further, using
+C<LinerNotes>:
+
+ # Relationships defined elsewhere:
+ # CD->belongs_to('artist' => 'Artist');
+ # CD->has_one('liner_notes' => 'LinerNotes', 'cd');
+ my $rs = $schema->resultset('CD')->search(
+ {
+ 'artist.name' => 'Bob Marley'
+ 'liner_notes.notes' => { 'like', '%some text%' },
+ },
+ {
+ join => [qw/ artist liner_notes /],
+ order_by => [qw/ artist.name /],
+ }
+ );
+
+ # Equivalent SQL:
+ # SELECT cd.*, artist.*, liner_notes.* FROM cd
+ # JOIN artist ON cd.artist = artist.id
+ # JOIN liner_notes ON cd.id = liner_notes.cd
+ # WHERE artist.name = 'Bob Marley'
+ # ORDER BY artist.name
+
=head2 Multi-step joins
Sometimes you want to join more than one relationship deep. In this example,
@@ -422,8 +562,8 @@
# Equivalent SQL:
# SELECT artist.* FROM artist
- # JOIN ( cd ON artist.id = cd.artist )
- # JOIN ( liner_notes ON cd.id = liner_notes.cd )
+ # LEFT JOIN cd ON artist.id = cd.artist
+ # LEFT JOIN liner_notes ON cd.id = liner_notes.cd
# WHERE liner_notes.notes LIKE '%some text%'
Joins can be nested to an arbitrary level. So if we decide later that we
@@ -449,12 +589,39 @@
# Equivalent SQL:
# SELECT artist.* FROM artist
- # JOIN ( cd ON artist.id = cd.artist )
- # JOIN ( liner_notes ON cd.id = liner_notes.cd )
- # JOIN ( author ON author.id = liner_notes.author )
+ # LEFT JOIN cd ON artist.id = cd.artist
+ # LEFT JOIN liner_notes ON cd.id = liner_notes.cd
+ # LEFT JOIN author ON author.id = liner_notes.author
# WHERE liner_notes.notes LIKE '%some text%'
# AND author.name = 'A. Writer'
+=head2 Multi-step and multiple joins
+
+With various combinations of array and hash references, you can join
+tables in any combination you desire. For example, to join Artist to
+CD and Concert, and join CD to LinerNotes:
+
+ # Relationships defined elsewhere:
+ # Artist->has_many('concerts' => 'Concert', 'artist');
+
+ my $rs = $schema->resultset('Artist')->search(
+ { },
+ {
+ join => [
+ {
+ cds => 'liner_notes'
+ },
+ 'concerts'
+ ],
+ }
+ );
+
+ # Equivalent SQL:
+ # SELECT artist.* FROM artist
+ # LEFT JOIN cd ON artist.id = cd.artist
+ # LEFT JOIN liner_notes ON cd.id = liner_notes.cd
+ # LEFT JOIN concert ON artist.id = concert.artist
+
=head2 Multi-step prefetch
From 0.04999_05 onwards, C<prefetch> can be nested more than one relationship
@@ -471,8 +638,8 @@
# Equivalent SQL:
# SELECT tag.*, cd.*, artist.* FROM tag
- # JOIN cd ON tag.cd = cd.cdid
- # JOIN artist ON cd.artist = artist.artistid
+ # JOIN cd ON tag.cd = cd.id
+ # JOIN artist ON cd.artist = artist.id
Now accessing our C<cd> and C<artist> relationships does not need additional
SQL statements:
@@ -678,7 +845,7 @@
### The statement below will print
print "I can do admin stuff\n" if $admin->can('do_admin_stuff');
-=head2 Skip object creation for faster results
+=head2 Skip row object creation for faster results
DBIx::Class is not built for speed, it's built for convenience and
ease of use, but sometimes you just need to get the data, and skip the
@@ -691,9 +858,9 @@
$rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
my $hash_ref = $rs->find(1);
-
+
Wasn't that easy?
-
+
=head2 Get raw data for blindingly fast results
If the L<HashRefInflator|DBIx::Class::ResultClass::HashRefInflator> solution
@@ -701,7 +868,7 @@
exactly as they come out of the data base with none of the convenience methods
wrapped round them.
-This is used like so:-
+This is used like so:
my $cursor = $rs->cursor
while (my @vals = $cursor->next) {
@@ -815,6 +982,12 @@
__PACKAGE__->has_many('pages' => 'Page', 'book', { order_by => \'page_number DESC'} );
+=head2 Filtering a relationship result set
+
+If you want to get a filtered result set, you can just add add to $attr as follows:
+
+ __PACKAGE__->has_many('pages' => 'Page', 'book', { where => { scrap => 0 } } );
+
=head2 Many-to-many relationships
This is straightforward using L<ManyToMany|DBIx::Class::Relationship/many_to_many>:
@@ -1042,7 +1215,9 @@
Often you will want indexes on columns on your table to speed up searching. To
do this, create a method called C<sqlt_deploy_hook> in the relevant source
-class:
+class (refer to the advanced
+L<callback system|DBIx::Class::ResultSource/sqlt_deploy_callback> if you wish
+to share a hook between multiple sources):
package My::Schema::Artist;
@@ -1076,10 +1251,12 @@
$sqlt_schema->drop_table('table_name');
}
-You could also add views or procedures to the output using
-L<SQL::Translator::Schema/add_view> or
-L<SQL::Translator::Schema/add_procedure>.
+You could also add views, procedures or triggers to the output using
+L<SQL::Translator::Schema/add_view>,
+L<SQL::Translator::Schema/add_procedure> or
+L<SQL::Translator::Schema/add_trigger>.
+
=head2 Schema versioning
The following example shows simplistically how you might use DBIx::Class to
@@ -1172,7 +1349,7 @@
generator to put the quotes the correct place.
In most cases you should set these as part of the arguments passed to
-L<DBIx::Class::Schema/conect>:
+L<DBIx::Class::Schema/connect>:
my $schema = My::Schema->connect(
'dbi:mysql:my_db',
@@ -1202,6 +1379,44 @@
The limit dialect can also be set at connect time by specifying a
C<limit_dialect> key in the final hash as shown above.
+=head2 Working with PostgreSQL array types
+
+If your SQL::Abstract version (>= 1.50) supports it, you can assign to
+PostgreSQL array values by passing array references in the C<\%columns>
+(C<\%vals>) hashref of the L<DBIx::Class::ResultSet/create> and
+L<DBIx::Class::Row/update> family of methods:
+
+ $resultset->create({
+ numbers => [1, 2, 3]
+ });
+
+ $row->update(
+ {
+ numbers => [1, 2, 3]
+ },
+ {
+ day => '2008-11-24'
+ }
+ );
+
+In conditions (eg. C<\%cond> in the L<DBIx::Class::ResultSet/search> family of
+methods) you cannot directly use array references (since this is interpreted as
+a list of values to be C<OR>ed), but you can use the following syntax to force
+passing them as bind values:
+
+ $resultset->search(
+ {
+ numbers => \[ '= ?', [numbers => [1, 2, 3]] ]
+ }
+ );
+
+See L<SQL::Abstract/array_datatypes> and L<SQL::Abstract/Literal SQL with
+placeholders and bind values (subqueries)> for more explanation. Note that
+L<DBIx::Class> sets L<SQL::Abstract/bindtype> to C<columns>, so you must pass
+the bind values (the C<[1, 2, 3]> arrayref in the above example) wrapped in
+arrayrefs together with the column name, like this: C<< [column_name => value]
+>>.
+
=head1 BOOTSTRAPPING/MIGRATING
=head2 Easy migration from class-based to schema-based setup
@@ -1455,5 +1670,67 @@
statement and dig down to see if certain parameters cause aberrant behavior.
You might want to check out L<DBIx::Class::QueryLog> as well.
+=head1 STARTUP SPEED
+L<DBIx::Class|DBIx::Class> programs can have a significant startup delay
+as the ORM loads all the relevant classes. This section examines
+techniques for reducing the startup delay.
+
+These tips are are listed in order of decreasing effectiveness - so the
+first tip, if applicable, should have the greatest effect on your
+application.
+
+=head2 Statically Define Your Schema
+
+If you are using
+L<DBIx::Class::Schema::Loader|DBIx::Class::Schema::Loader> to build the
+classes dynamically based on the database schema then there will be a
+significant startup delay.
+
+For production use a statically defined schema (which can be generated
+using L<DBIx::Class::Schema::Loader|DBIx::Class::Schema::Loader> to dump
+the database schema once - see
+L<make_schema_at|DBIx::Class::Schema::Loader/make_schema_at> and
+L<dump_directory|DBIx::Class::Schema::Loader/dump_directory> for more
+details on creating static schemas from a database).
+
+=head2 Move Common Startup into a Base Class
+
+Typically L<DBIx::Class> result classes start off with
+
+ use base qw/DBIx::Class/;
+ __PACKAGE__->load_components(qw/InflateColumn::DateTime Core/);
+
+If this preamble is moved into a common base class:-
+
+ package MyDBICbase;
+
+ use base qw/DBIx::Class/;
+ __PACKAGE__->load_components(qw/InflateColumn::DateTime Core/);
+ 1;
+
+and each result class then uses this as a base:-
+
+ use base qw/MyDBICbase/;
+
+then the load_components is only performed once, which can result in a
+considerable startup speedup for schemas with many classes.
+
+=head2 Explicitly List Schema Result Classes
+
+The schema class will normally contain
+
+ __PACKAGE__->load_classes();
+
+to load the result classes. This will use L<Module::Find|Module::Find>
+to find and load the appropriate modules. Explicitly defining the
+classes you wish to load will remove the overhead of
+L<Module::Find|Module::Find> and the related directory operations:-
+
+ __PACKAGE__->load_classes(qw/ CD Artist Track /);
+
+If you are instead using the L<load_namespaces|DBIx::Class::Schema/load_namespaces>
+syntax to load the appropriate classes there is not a direct alternative
+avoiding L<Module::Find|Module::Find>.
+
=cut
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Example.pod
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Example.pod 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Example.pod 2009-02-26 23:40:04 UTC (rev 5651)
@@ -72,6 +72,8 @@
mkdir MyDatabase
mkdir MyDatabase/Main
+ mkdir MyDatabase/Main/Result
+ mkdir MyDatabase/Main/ResultSet
Then, create the following DBIx::Class::Schema classes:
@@ -79,47 +81,47 @@
package MyDatabase::Main;
use base qw/DBIx::Class::Schema/;
- __PACKAGE__->load_classes(qw/Artist Cd Track/);
+ __PACKAGE__->load_namespaces;
1;
-MyDatabase/Main/Artist.pm:
+MyDatabase/Main/Result/Artist.pm:
- package MyDatabase::Main::Artist;
+ package MyDatabase::Main::Result::Artist;
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/PK::Auto Core/);
__PACKAGE__->table('artist');
__PACKAGE__->add_columns(qw/ artistid name /);
__PACKAGE__->set_primary_key('artistid');
- __PACKAGE__->has_many('cds' => 'MyDatabase::Main::Cd');
+ __PACKAGE__->has_many('cds' => 'MyDatabase::Main::Result::Cd');
1;
-MyDatabase/Main/Cd.pm:
+MyDatabase/Main/Result/Cd.pm:
- package MyDatabase::Main::Cd;
+ package MyDatabase::Main::Result::Cd;
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/PK::Auto Core/);
__PACKAGE__->table('cd');
__PACKAGE__->add_columns(qw/ cdid artist title/);
__PACKAGE__->set_primary_key('cdid');
- __PACKAGE__->belongs_to('artist' => 'MyDatabase::Main::Artist');
- __PACKAGE__->has_many('tracks' => 'MyDatabase::Main::Track');
+ __PACKAGE__->belongs_to('artist' => 'MyDatabase::Main::Result::Artist');
+ __PACKAGE__->has_many('tracks' => 'MyDatabase::Main::Result::Track');
1;
-MyDatabase/Main/Track.pm:
+MyDatabase/Main/Result/Track.pm:
- package MyDatabase::Main::Track;
+ package MyDatabase::Main::Result::Track;
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/PK::Auto Core/);
__PACKAGE__->table('track');
__PACKAGE__->add_columns(qw/ trackid cd title/);
__PACKAGE__->set_primary_key('trackid');
- __PACKAGE__->belongs_to('cd' => 'MyDatabase::Main::Cd');
+ __PACKAGE__->belongs_to('cd' => 'MyDatabase::Main::Result::Cd');
1;
@@ -220,7 +222,6 @@
},
{
join => [qw/ cd /],
- prefetch => [qw/ cd /]
}
);
while (my $track = $rs->next) {
@@ -273,7 +274,6 @@
},
{
join => [qw/ artist /],
- prefetch => [qw/ artist /]
}
);
while (my $cd = $rs->next) {
@@ -358,11 +358,18 @@
The testdb.pl script is an excellent start for testing your database
model.
+This example uses load_namespaces to load in the appropriate Row classes
+from the MyDatabase::Main::Result namespace, and any required resultset
+classes from the MyDatabase::Main::ResultSet namespace (although we
+created the directory in the directions above we did not add, or need to
+add, any resultset classes).
+
=head1 TODO
=head1 AUTHOR
sc_ from irc.perl.org#dbix-class
Kieren Diment <kd at totaldatasolution.com>
+ Nigel Metheringham <nigelm at cpan.org>
=cut
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/FAQ.pod
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/FAQ.pod 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/FAQ.pod 2009-02-26 23:40:04 UTC (rev 5651)
@@ -68,7 +68,25 @@
be alarmed if the error from incorrect connection details happens a
lot later.
+=item .. use DBIx::Class across multiple databases?
+If your database server allows you to run querys across multiple
+databases at once, then so can DBIx::Class. All you need to do is make
+sure you write the database name as part of the
+L<DBIx::Class::ResultSource/table> call. Eg:
+
+ __PACKAGE__->table('mydb.mytablename');
+
+And load all the Result classes for both / all databases using one
+L<DBIx::Class::Schema/load_namespaces> call.
+
+=item .. use DBIx::Class across PostgreSQL/DB2/Oracle schemas?
+
+Add the name of the schema to the L<DBIx::Class::ResultSource/table>
+as part of the name, and make sure you give the one user you are going
+to connect with rights to read/write all the schemas/tables as
+necessary.
+
=back
=head2 Relationships
@@ -77,7 +95,7 @@
=item .. tell DBIx::Class about relationships between my tables?
-There are a vareity of relationship types that come pre-defined for
+There are a variety of relationship types that come pre-defined for
you to use. These are all listed in L<DBIx::Class::Relationship>. If
you need a non-standard type, or more information, look in
L<DBIx::Class::Relationship::Base>.
@@ -113,13 +131,20 @@
Read the documentation on L<DBIx::Class::Relationship/many_to_many>.
-=item .. stop DBIx::Class from attempting to cascade deletes on my has_many relationships?
+=item .. stop DBIx::Class from attempting to cascade deletes on my has_many and might_have relationships?
By default, DBIx::Class cascades deletes and updates across
-C<has_many> relationships. If your database already does this (and
-that is probably better), turn it off by supplying C<< cascade_delete => 0 >>
-in the relationship attributes. See L<DBIx::Class::Relationship::Base>.
+C<has_many> and C<might_have> relationships. You can disable this
+behaviour on a per-relationship basis by supplying
+C<< cascade_delete => 0 >> in the relationship attributes.
+The cascaded operations are performed after the requested delete or
+update, so if your database has a constraint on the relationship, it
+will have deleted/updated the related records or raised an exception
+before DBIx::Class gets to perform the cascaded operation.
+
+See L<DBIx::Class::Relationship>.
+
=item .. use a relationship?
Use its name. An accessor is created using the name. See examples in
@@ -258,6 +283,18 @@
L<DBIx::Class::Manual::Cookbook>, try looking in the SQL::Abstract
documentation.
+=item .. make searches in Oracle (10gR2 and newer) case-insensitive?
+
+To make Oracle behave like most RDBMS use on_connect_do to issue
+alter session statements on database connection establishment:
+
+ ->on_connect_do("ALTER SESSION SET NLS_COMP = 'LINGUISTIC'");
+ ->on_connect_do("ALTER SESSION SET NLS_SORT = '<NLS>_CI'");
+ e.g.
+ ->on_connect_do("ALTER SESSION SET NLS_SORT = 'BINARY_CI'");
+ ->on_connect_do("ALTER SESSION SET NLS_SORT = 'GERMAN_CI'");
+
+
=back
=head2 Fetching data
@@ -294,11 +331,11 @@
Then call L<DBIx::Class::ResultSet/slice> and ask it only to return 1 row:
- ->slice(0,1)
+ ->slice(0)
These two calls can be combined into a single statement:
- ->search->(undef, { order_by => "id DESC" })->slice(0,1)
+ ->search->(undef, { order_by => "id DESC" })->slice(0)
Why slice instead of L<DBIx::Class::ResultSet/first> or L<DBIx::Class::ResultSet/single>?
If supported by the database, slice will use LIMIT/OFFSET to hint to the database that we
@@ -409,6 +446,41 @@
You can add your own data accessors to your classes.
+One method is to use the built in mk_group_accessors (via L<Class::Accessor::Grouped>)
+
+ package MyTable;
+
+ use parent 'DBIx::Class';
+
+ __PACKAGE__->table('foo'); #etc
+ __PACKAGE__->mk_group_accessors('simple' => qw/non_column_data/); # must use simple group
+
+An another method is to use L<Moose> with your L<DBIx::Class> package.
+
+ package MyTable;
+
+ use Moose; # import Moose
+ use Moose::Util::TypeConstraint; # import Moose accessor type constraints
+
+ extends 'DBIx::Class'; # Moose changes the way we define our parent (base) package
+
+ has 'non_column_data' => ( is => 'rw', isa => 'Str' ); # define a simple attribute
+
+ __PACKAGE__->table('foo'); # etc
+
+With either of these methods the resulting use of the accesssor would be
+
+ my $row;
+
+ # assume that some where in here $row will get assigned to a MyTable row
+
+ $row->non_column_data('some string'); # would set the non_column_data accessor
+
+ # some other stuff happens here
+
+ $row->update(); # would not inline the non_column_data accessor into the update
+
+
=item How do I use DBIx::Class objects in my TT templates?
Like normal objects, mostly. However you need to watch out for TT
@@ -443,6 +515,16 @@
$resultset->set_primary_key(@column);
+=item How do I make my program start faster?
+
+Look at the tips in L<DBIx::Class::Manual::Cookbook/"STARTUP SPEED">
+
+=item How do I reduce the overhead of database queries?
+
+You can reduce the overhead of object creation within L<DBIx::Class>
+using the tips in L<DBIx::Class::Manual::Cookbook/"Skip row object creation for faster results">
+and L<DBIx::Class::Manual::Cookbook/"Get raw data for blindingly fast results">
+
=back
=head2 Notes for CDBI users
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Glossary.pod
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Glossary.pod 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Glossary.pod 2009-02-26 23:40:04 UTC (rev 5651)
@@ -36,6 +36,18 @@
way it's a method of mapping the contents of database tables (rows),
to objects in programming-language-space. DBIx::Class is an ORM.
+=head2 Relationship
+
+In DBIx::Class a relationship defines the connection between exactly
+two tables. The relationship condition lists the columns in each table
+that contain the same values. It is used to output an SQL JOIN
+condition between the tables.
+
+=head2 Relationship bridge
+
+A relationship bridge, such as C<many_to_many> defines an accessor to
+retrieve row contents across multiple relationships.
+
=head2 ResultSet
This is an object representing a set of data. It can either be an
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Intro.pod
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Intro.pod 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Intro.pod 2009-02-26 23:40:04 UTC (rev 5651)
@@ -86,30 +86,25 @@
use base qw/DBIx::Class::Schema/;
In this class you load your result_source ("table", "model") classes, which we
-will define later, using the load_classes() method. You can specify which
-classes to load manually:
+will define later, using the load_namespaces() method:
- # load My::Schema::Album and My::Schema::Artist
- __PACKAGE__->load_classes(qw/ Album Artist /);
+ # load My::Schema::Result::* and their resultset classes
+ __PACKAGE__->load_namespaces();
-Or load classes by namespace:
+By default this loads all the Result (Row) classes in the
+My::Schema::Result:: namespace, and also any resultset classes in the
+My::Schema::ResultSet:: namespace (if missing, the resultsets are
+defaulted to be DBIx::Class::ResultSet objects). You can change the
+result and resultset namespaces by using options to the
+L<DBIx::Class::Schema/load_namespaces> call.
- # load My::Schema::Album, My::Schema::Artist and My::OtherSchema::LinerNotes
- __PACKAGE__->load_classes(
- {
- 'My::Schema' => [qw/ Album Artist /],
- 'My::OtherSchema' => [qw/ LinerNotes /]
- }
- );
+It is also possible to do the same things manually by calling
+C<load_classes> for the Row classes and defining in those classes any
+required resultset classes.
-Or let your schema class load all classes in its namespace automatically:
-
- # load My::Schema::*
- __PACKAGE__->load_classes();
-
Next, create each of the classes you want to load as specified above:
- package My::Schema::Album;
+ package My::Schema::Result::Album;
use base qw/DBIx::Class/;
Load any components required by each class with the load_components() method.
@@ -164,7 +159,7 @@
See L<DBIx::Class::ResultSource> for more details of the possible column
attributes.
-Accessors are created for each column automatically, so My::Schema::Album will
+Accessors are created for each column automatically, so My::Schema::Result::Album will
have albumid() (or album(), when using the accessor), artist() and title()
methods.
@@ -181,7 +176,7 @@
make a predefined accessor for fetching objects that contain this Table's
foreign key:
- __PACKAGE__->has_many('albums', 'My::Schema::Artist', 'album_id');
+ __PACKAGE__->has_many('albums', 'My::Schema::Result::Artist', 'album_id');
See L<DBIx::Class::Relationship> for more information about the various types of
available relationships and how you can design your own.
@@ -248,7 +243,7 @@
my $album = $schema->resultset('Album')->find(14);
This will run a C<SELECT> with C<albumid = 14> in the C<WHERE> clause, and
-return an instance of C<My::Schema::Album> that represents this row. Once you
+return an instance of C<My::Schema::Result::Album> that represents this row. Once you
have that row, you can access and update columns:
$album->title('Physical Graffiti');
@@ -275,7 +270,7 @@
=head2 Adding and removing rows
To create a new record in the database, you can use the C<create> method. It
-returns an instance of C<My::Schema::Album> that can be used to access the data
+returns an instance of C<My::Schema::Result::Album> that can be used to access the data
in the new record:
my $new_album = $schema->resultset('Album')->create({
@@ -384,11 +379,9 @@
=head2 Problems on RHEL5/CentOS5
-There is a problem with slow performance of certain DBIx::Class operations in
-perl-5.8.8-10 and later on RedHat and related systems, due to a bad backport of
-a "use overload" related bug. The problem is in the Perl binary itself, not in
-DBIx::Class. If your system has this problem, you will see a warning on
-startup, with some options as to what to do about it.
+There used to be an issue with the system perl on Red Hat Enterprise
+Linux 5, some versions of Fedora and derived systems. Further
+information on this can be found in L<DBIx::Class::Manual::Troubleshooting>
=head1 SEE ALSO
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Troubleshooting.pod
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Troubleshooting.pod 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Manual/Troubleshooting.pod 2009-02-26 23:40:04 UTC (rev 5651)
@@ -123,5 +123,38 @@
... ORDER BY name DESC
+=head2 Perl Performance Issues on Red Hat Systems
+
+There is a problem with slow performance of certain DBIx::Class
+operations using the system perl on some Fedora and Red Hat Enterprise
+Linux system (as well as their derivative distributions such as Centos,
+White Box and Scientific Linux).
+
+Distributions affected include Fedora 5 through to Fedora 8 and RHEL5
+upto and including RHEL5 Update 2. Fedora 9 (which uses perl 5.10) has
+never been affected - this is purely a perl 5.8.8 issue.
+
+As of September 2008 the following packages are known to be fixed and so
+free of this performance issue (this means all Fedora and RHEL5 systems
+with full current updates will not be subject to this problem):-
+
+ Fedora 8 - perl-5.8.8-41.fc8
+ RHEL5 - perl-5.8.8-15.el5_2.1
+
+The issue is due to perl doing an exhaustive search of blessed objects
+under certain circumstances. The problem shows up as performance
+degredation exponential to the number of L<DBIx::Class> row objects in
+memory, so can be unoticeable with certain data sets, but with huge
+performance impacts on other datasets.
+
+A pair of tests for susceptability to the issue, and performance effects
+of the bless/overload problem can be found in the L<DBIx::Class> test
+suite in the file C<t/99rh_perl_perf_bug.t>
+
+Further information on this issue can be found in
+L<https://bugzilla.redhat.com/show_bug.cgi?id=379791>,
+L<https://bugzilla.redhat.com/show_bug.cgi?id=460308> and
+L<http://rhn.redhat.com/errata/RHBA-2008-0876.html>
+
=cut
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Ordered.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Ordered.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Ordered.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,4 +1,3 @@
-# vim: ts=8:sw=4:sts=4:et
package DBIx::Class::Ordered;
use strict;
use warnings;
@@ -121,117 +120,158 @@
__PACKAGE__->mk_classdata( 'grouping_column' );
+=head2 null_position_value
+
+ __PACKAGE__->null_position_value(undef);
+
+This method specifies a value of L</position_column> which B<would
+never be assigned to a row> during normal operation. When
+a row is moved, its position is set to this value temporarily, so
+that any unique constrainst can not be violated. This value defaults
+to 0, which should work for all cases except when your positions do
+indeed start from 0.
+
+=cut
+
+__PACKAGE__->mk_classdata( 'null_position_value' => 0 );
+
=head2 siblings
my $rs = $item->siblings();
my @siblings = $item->siblings();
-Returns either a resultset or an array of all other objects
-excluding the one you called it on.
+Returns an B<ordered> resultset of all other objects in the same
+group excluding the one you called it on.
+The ordering is a backwards-compatibility artifact - if you need
+a resultset with no ordering applied use L</_siblings>
+
=cut
-
sub siblings {
- my( $self ) = @_;
- my $position_column = $self->position_column;
- my $rs = $self->result_source->resultset->search(
- {
- $position_column => { '!=' => $self->get_column($position_column) },
- $self->_grouping_clause(),
- },
- { order_by => $self->position_column },
- );
- return $rs->all() if (wantarray());
- return $rs;
+ my $self = shift;
+ return $self->_siblings->search ({}, { order_by => $self->position_column } );
}
-=head2 first_sibling
+=head2 previous_siblings
- my $sibling = $item->first_sibling();
+ my $prev_rs = $item->previous_siblings();
+ my @prev_siblings = $item->previous_siblings();
-Returns the first sibling object, or 0 if the first sibling
-is this sibling.
+Returns a resultset of all objects in the same group
+positioned before the object on which this method was called.
=cut
-
-sub first_sibling {
- my( $self ) = @_;
- return 0 if ($self->get_column($self->position_column())==1);
-
- return ($self->result_source->resultset->search(
- {
- $self->position_column => 1,
- $self->_grouping_clause(),
- },
- )->all())[0];
+sub previous_siblings {
+ my $self = shift;
+ my $position_column = $self->position_column;
+ my $position = $self->get_column ($position_column);
+ return ( defined $position
+ ? $self->_siblings->search ({ $position_column => { '<', $position } })
+ : $self->_siblings
+ );
}
-=head2 last_sibling
+=head2 next_siblings
- my $sibling = $item->last_sibling();
+ my $next_rs = $item->next_siblings();
+ my @next_siblings = $item->next_siblings();
-Returns the last sibling, or 0 if the last sibling is this
-sibling.
+Returns a resultset of all objects in the same group
+positioned after the object on which this method was called.
=cut
-
-sub last_sibling {
- my( $self ) = @_;
- my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
- return 0 if ($self->get_column($self->position_column())==$count);
- return ($self->result_source->resultset->search(
- {
- $self->position_column => $count,
- $self->_grouping_clause(),
- },
- )->all())[0];
+sub next_siblings {
+ my $self = shift;
+ my $position_column = $self->position_column;
+ my $position = $self->get_column ($position_column);
+ return ( defined $position
+ ? $self->_siblings->search ({ $position_column => { '>', $position } })
+ : $self->_siblings
+ );
}
=head2 previous_sibling
my $sibling = $item->previous_sibling();
-Returns the sibling that resides one position back. Returns undef
+Returns the sibling that resides one position back. Returns 0
if the current object is the first one.
=cut
sub previous_sibling {
- my( $self ) = @_;
+ my $self = shift;
my $position_column = $self->position_column;
- my $position = $self->get_column( $position_column );
- return 0 if ($position==1);
- return ($self->result_source->resultset->search(
- {
- $position_column => $position - 1,
- $self->_grouping_clause(),
- }
- )->all())[0];
+
+ my $psib = $self->previous_siblings->search(
+ {},
+ { rows => 1, order_by => { '-desc' => $position_column } },
+ )->single;
+
+ return defined $psib ? $psib : 0;
}
+=head2 first_sibling
+
+ my $sibling = $item->first_sibling();
+
+Returns the first sibling object, or 0 if the first sibling
+is this sibling.
+
+=cut
+
+sub first_sibling {
+ my $self = shift;
+ my $position_column = $self->position_column;
+
+ my $fsib = $self->previous_siblings->search(
+ {},
+ { rows => 1, order_by => { '-asc' => $position_column } },
+ )->single;
+
+ return defined $fsib ? $fsib : 0;
+}
+
=head2 next_sibling
my $sibling = $item->next_sibling();
-Returns the sibling that resides one position forward. Returns undef
+Returns the sibling that resides one position forward. Returns 0
if the current object is the last one.
=cut
sub next_sibling {
- my( $self ) = @_;
+ my $self = shift;
my $position_column = $self->position_column;
- my $position = $self->get_column( $position_column );
- my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
- return 0 if ($position==$count);
- return ($self->result_source->resultset->search(
- {
- $position_column => $position + 1,
- $self->_grouping_clause(),
- },
- )->all())[0];
+ my $nsib = $self->next_siblings->search(
+ {},
+ { rows => 1, order_by => { '-asc' => $position_column } },
+ )->single;
+
+ return defined $nsib ? $nsib : 0;
}
+=head2 last_sibling
+
+ my $sibling = $item->last_sibling();
+
+Returns the last sibling, or 0 if the last sibling is this
+sibling.
+
+=cut
+
+sub last_sibling {
+ my $self = shift;
+ my $position_column = $self->position_column;
+ my $lsib = $self->next_siblings->search(
+ {},
+ { rows => 1, order_by => { '-desc' => $position_column } },
+ )->single;
+
+ return defined $lsib ? $lsib : 0;
+}
+
=head2 move_previous
$item->move_previous();
@@ -243,9 +283,8 @@
=cut
sub move_previous {
- my( $self ) = @_;
- my $position = $self->get_column( $self->position_column() );
- return $self->move_to( $position - 1 );
+ my $self = shift;
+ return $self->move_to ($self->_position - 1);
}
=head2 move_next
@@ -259,11 +298,9 @@
=cut
sub move_next {
- my( $self ) = @_;
- my $position = $self->get_column( $self->position_column() );
- my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
- return 0 if ($position==$count);
- return $self->move_to( $position + 1 );
+ my $self = shift;
+ return 0 unless $self->next_siblings->count;
+ return $self->move_to ($self->_position + 1);
}
=head2 move_first
@@ -276,8 +313,7 @@
=cut
sub move_first {
- my( $self ) = @_;
- return $self->move_to( 1 );
+ return shift->move_to( 1 );
}
=head2 move_last
@@ -290,9 +326,8 @@
=cut
sub move_last {
- my( $self ) = @_;
- my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
- return $self->move_to( $count );
+ my $self = shift;
+ return $self->move_to( $self->_group_rs->count );
}
=head2 move_to
@@ -307,28 +342,42 @@
sub move_to {
my( $self, $to_position ) = @_;
- my $position_column = $self->position_column;
- my $from_position = $self->get_column( $position_column );
return 0 if ( $to_position < 1 );
- return 0 if ( $from_position==$to_position );
- my @between = (
- ( $from_position < $to_position )
- ? ( $from_position+1, $to_position )
- : ( $to_position, $from_position-1 )
- );
- my $rs = $self->result_source->resultset->search({
- $position_column => { -between => [ @between ] },
- $self->_grouping_clause(),
- });
- my $op = ($from_position>$to_position) ? '+' : '-';
- $rs->update({ $position_column => \"$position_column $op 1" }); #" Sorry, GEdit bug
- $self->{_ORDERED_INTERNAL_UPDATE} = 1;
- $self->update({ $position_column => $to_position });
- return 1;
-}
+ my $from_position = $self->_position;
+ return 0 if ( $from_position == $to_position );
+ my $position_column = $self->position_column;
+ {
+ my $guard = $self->result_source->schema->txn_scope_guard;
+
+ my ($direction, @between);
+ if ( $from_position < $to_position ) {
+ $direction = -1;
+ @between = map { $self->_position_value ($_) } ( $from_position + 1, $to_position );
+ }
+ else {
+ $direction = 1;
+ @between = map { $self->_position_value ($_) } ( $to_position, $from_position - 1 );
+ }
+
+ my $new_pos_val = $self->_position_value ($to_position); # record this before the shift
+
+ # we need to null-position the moved row if the position column is part of a constraint
+ if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $self->result_source->unique_constraints }} ) ) ) {
+ $self->_ordered_internal_update({ $position_column => $self->null_position_value });
+ }
+
+ $self->_shift_siblings ($direction, @between);
+ $self->_ordered_internal_update({ $position_column => $new_pos_val });
+
+ $guard->commit;
+
+ return 1;
+ }
+}
+
=head2 move_to_group
$item->move_to_group( $group, $position );
@@ -347,44 +396,54 @@
sub move_to_group {
my( $self, $to_group, $to_position ) = @_;
+ $self->throw_exception ('move_to_group() expects a group specification')
+ unless defined $to_group;
+
# if we're given a string, turn it into a hashref
unless (ref $to_group eq 'HASH') {
- $to_group = {($self->_grouping_columns)[0] => $to_group};
+ my @gcols = $self->_grouping_columns;
+
+ $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1;
+ $to_group = {$gcols[0] => $to_group};
}
my $position_column = $self->position_column;
- #my @grouping_columns = $self->_grouping_columns;
- return 0 if ( ! defined($to_group) );
return 0 if ( defined($to_position) and $to_position < 1 );
- return 0 if ( $self->_is_in_group($to_group)
- and ((not defined($to_position))
- or (defined($to_position) and $self->$position_column==$to_position)
- )
- );
+ if ($self->_is_in_group ($to_group) ) {
+ return 0 if not defined $to_position;
+ return $self->move_to ($to_position);
+ }
- # Move to end of current group and adjust siblings
- $self->move_last;
+ {
+ my $guard = $self->result_source->schema->txn_scope_guard;
- $self->set_columns($to_group);
- my $new_group_count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
- if (!defined($to_position) or $to_position > $new_group_count) {
- $self->{_ORDERED_INTERNAL_UPDATE} = 1;
- $self->update({ $position_column => $new_group_count + 1 });
- }
- else {
- my @between = ($to_position, $new_group_count);
+ # Move to end of current group to adjust siblings
+ $self->move_last;
- my $rs = $self->result_source->resultset->search({
- $position_column => { -between => [ @between ] },
- $self->_grouping_clause(),
- });
- $rs->update({ $position_column => \"$position_column + 1" }); #"
- $self->{_ORDERED_INTERNAL_UPDATE} = 1;
- $self->update({ $position_column => $to_position });
+ $self->set_inflated_columns({ %$to_group, $position_column => undef });
+ my $new_group_count = $self->_group_rs->count;
+
+ if ( not defined($to_position) or $to_position > $new_group_count) {
+ $self->set_column(
+ $position_column => $new_group_count
+ ? $self->_next_position_value ( $self->last_sibling->get_column ($position_column) ) # FIXME - no need to inflate last_sibling
+ : $self->_initial_position_value
+ );
+ }
+ else {
+ my $bumped_pos_val = $self->_position_value ($to_position);
+ my @between = ($to_position, $new_group_count);
+ $self->_shift_siblings (1, @between); #shift right
+ $self->set_column( $position_column => $bumped_pos_val );
+ }
+
+ $self->_ordered_internal_update;
+
+ $guard->commit;
+
+ return 1;
}
-
- return 1;
}
=head2 insert
@@ -398,8 +457,17 @@
sub insert {
my $self = shift;
my $position_column = $self->position_column;
- $self->set_column( $position_column => $self->result_source->resultset->search( {$self->_grouping_clause()} )->count()+1 )
- if (!$self->get_column($position_column));
+
+ unless ($self->get_column($position_column)) {
+ my $lsib = $self->last_sibling; # FIXME - no need to inflate last_sibling
+ $self->set_column(
+ $position_column => ($lsib
+ ? $self->_next_position_value ( $lsib->get_column ($position_column) )
+ : $self->_initial_position_value
+ )
+ );
+ }
+
return $self->next::method( @_ );
}
@@ -416,63 +484,261 @@
sub update {
my $self = shift;
- if ($self->{_ORDERED_INTERNAL_UPDATE}) {
- delete $self->{_ORDERED_INTERNAL_UPDATE};
- return $self->next::method( @_ );
- }
+ # this is set by _ordered_internal_update()
+ return $self->next::method(@_) if $self->{_ORDERED_INTERNAL_UPDATE};
- $self->set_columns($_[0]) if @_ > 0;
+ my $upd = shift;
+ $self->set_inflated_columns($upd) if $upd;
my %changes = $self->get_dirty_columns;
$self->discard_changes;
- my $pos_col = $self->position_column;
+ my $position_column = $self->position_column;
- # if any of our grouping columns have been changed
- if (grep {$_} map {exists $changes{$_}} $self->_grouping_columns ) {
+ # if nothing group/position related changed - short circuit
+ if (not grep { exists $changes{$_} } ($self->_grouping_columns, $position_column) ) {
+ return $self->next::method( \%changes, @_ );
+ }
- # create new_group by taking the current group and inserting changes
- my $new_group = {$self->_grouping_clause};
- foreach my $col (keys %$new_group) {
- if (exists $changes{$col}) {
- $new_group->{$col} = $changes{$col};
- delete $changes{$col}; # don't want to pass this on to next::method
+ {
+ my $guard = $self->result_source->schema->txn_scope_guard;
+
+ # if any of our grouping columns have been changed
+ if (grep { exists $changes{$_} } ($self->_grouping_columns) ) {
+
+ # create new_group by taking the current group and inserting changes
+ my $new_group = {$self->_grouping_clause};
+ foreach my $col (keys %$new_group) {
+ if (exists $changes{$col}) {
+ $new_group->{$col} = delete $changes{$col}; # don't want to pass this on to next::method
+ }
}
+
+ $self->move_to_group(
+ $new_group,
+ (exists $changes{$position_column}
+ # The FIXME bit contradicts the documentation: when changing groups without supplying explicit
+ # positions in move_to_group(), we push the item to the end of the group.
+ # However when I was rewriting this, the position from the old group was clearly passed to the new one
+ # Probably needs to go away (by ribasushi)
+ ? delete $changes{$position_column} # means there was a position change supplied with the update too
+ : $self->_position # FIXME!
+ ),
+ );
}
+ elsif (exists $changes{$position_column}) {
+ $self->move_to(delete $changes{$position_column});
+ }
- $self->move_to_group(
- $new_group,
- exists($changes{$pos_col}) ? delete($changes{$pos_col}) : $self->$pos_col
- );
+ my @res;
+ my $want = wantarray();
+ if (not defined $want) {
+ $self->next::method( \%changes, @_ );
+ }
+ elsif ($want) {
+ @res = $self->next::method( \%changes, @_ );
+ }
+ else {
+ $res[0] = $self->next::method( \%changes, @_ );
+ }
+
+ $guard->commit;
+ return $want ? @res : $res[0];
}
- elsif (exists $changes{$pos_col}) {
- $self->move_to(delete $changes{$pos_col});
- }
- return $self->next::method( \%changes );
}
=head2 delete
Overrides the DBIC delete() method by first moving the object
-to the last position, then deleting it, thus ensuring the
+to the last position, then deleting it, thus ensuring the
integrity of the positions.
=cut
sub delete {
my $self = shift;
+
+ my $guard = $self->result_source->schema->txn_scope_guard;
+
$self->move_last;
- return $self->next::method( @_ );
+
+ my @res;
+ my $want = wantarray();
+ if (not defined $want) {
+ $self->next::method( @_ );
+ }
+ elsif ($want) {
+ @res = $self->next::method( @_ );
+ }
+ else {
+ $res[0] = $self->next::method( @_ );
+ }
+
+ $guard->commit;
+ return $want ? @res : $res[0];
}
+=head1 METHODS FOR EXTENDING ORDERED
+
+You would want to override the methods below if you use sparse
+(non-linear) or non-numeric position values. This can be useful
+if you are working with preexisting non-normalised position data,
+or if you need to work with materialized path columns.
+
+=head2 _position
+
+ my $num_pos = $item->_position;
+
+Returns the B<absolute numeric position> of the current object, with the
+first object being at position 1, its sibling at position 2 and so on.
+By default simply returns the value of L</position_column>.
+
+=cut
+sub _position {
+ my $self = shift;
+
+# #the right way to do this
+# return $self->previous_siblings->count + 1;
+
+ return $self->get_column ($self->position_column);
+}
+
+=head2 _position_value
+
+ my $pos_value = $item->_position_value ( $pos )
+
+Returns the B<value> of L</position_column> of the object at numeric
+position C<$pos>. By default simply returns C<$pos>.
+
+=cut
+sub _position_value {
+ my ($self, $pos) = @_;
+
+# #the right way to do this (not optimized)
+# my $position_column = $self->position_column;
+# return $self -> _group_rs
+# -> search({}, { order_by => $position_column })
+# -> slice ( $pos - 1)
+# -> single
+# -> get_column ($position_column);
+
+ return $pos;
+}
+
+=head2 _initial_position_value
+
+ __PACKAGE__->_initial_position_value(0);
+
+This method specifies a B<value> of L</position_column> which is assigned
+to the first inserted element of a group, if no value was supplied at
+insertion time. All subsequent values are derived from this one by
+L</_next_position_value> below. Defaults to 1.
+
+=cut
+
+__PACKAGE__->mk_classdata( '_initial_position_value' => 1 );
+
+=head2 _next_position_value
+
+ my $new_value = $item->_next_position_value ( $position_value )
+
+Returns a position B<value> that would be considered C<next> with
+regards to C<$position_value>. Can be pretty much anything, given
+that C<< $position_value < $new_value >> where C<< < >> is the
+SQL comparison operator (usually works fine on strings). The
+default method expects C<$position_value> to be numeric, and
+returns C<$position_value + 1>
+
+=cut
+sub _next_position_value {
+ return $_[1] + 1;
+}
+
+=head2 _shift_siblings
+
+ $item->_shift_siblings ($direction, @between)
+
+Shifts all siblings with B<positions values> in the range @between
+(inclusive) by one position as specified by $direction (left if < 0,
+ right if > 0). By default simply increments/decrements each
+L<position_column> value by 1, doing so in a way as to not violate
+any existing constraints.
+
+Note that if you override this method and have unique constraints
+including the L<position_column> the shift is not a trivial task.
+Refer to the implementation source of the default method for more
+information.
+
+=cut
+sub _shift_siblings {
+ my ($self, $direction, @between) = @_;
+ return 0 unless $direction;
+
+ my $position_column = $self->position_column;
+
+ my ($op, $ord);
+ if ($direction < 0) {
+ $op = '-';
+ $ord = 'asc';
+ }
+ else {
+ $op = '+';
+ $ord = 'desc';
+ }
+
+ my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } });
+
+ # some databases (sqlite) are dumb and can not do a blanket
+ # increment/decrement. So what we do here is check if the
+ # position column is part of a unique constraint, and do a
+ # one-by-one update if this is the case
+
+ if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $self->result_source->unique_constraints }} ) ) ) {
+
+ my $rs = $shift_rs->search ({}, { order_by => { "-$ord", $position_column } } );
+ # FIXME - no need to inflate each row
+ while (my $r = $rs->next) {
+ $r->_ordered_internal_update ({ $position_column => \ "$position_column $op 1" } );
+ }
+ }
+ else {
+ $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
+ }
+}
+
=head1 PRIVATE METHODS
These methods are used internally. You should never have the
need to use them.
+=head2 _group_rs
+
+This method returns a resultset containing all members of the row
+group (including the row itself).
+
+=cut
+sub _group_rs {
+ my $self = shift;
+ return $self->result_source->resultset->search({$self->_grouping_clause()});
+}
+
+=head2 _siblings
+
+Returns an unordered resultset of all objects in the same group
+excluding the object you called this method on.
+
+=cut
+sub _siblings {
+ my $self = shift;
+ my $position_column = $self->position_column;
+ return $self->_group_rs->search(
+ { $position_column => { '!=' => $self->get_column($position_column) } },
+ );
+}
+
=head2 _grouping_clause
-This method returns one or more name=>value pairs for limiting a search
-by the grouping column(s). If the grouping column is not
+This method returns one or more name=>value pairs for limiting a search
+by the grouping column(s). If the grouping column is not
defined then this will return an empty list.
=cut
@@ -481,8 +747,6 @@
return map { $_ => $self->get_column($_) } $self->_grouping_columns();
}
-
-
=head2 _get_grouping_columns
Returns a list of the column names used for grouping, regardless of whether
@@ -502,55 +766,77 @@
}
}
+=head2 _is_in_group
-
-=head2 _is_in_group($other)
-
$item->_is_in_group( {user => 'fred', list => 'work'} )
Returns true if the object is in the group represented by hashref $other
+
=cut
sub _is_in_group {
my ($self, $other) = @_;
my $current = {$self->_grouping_clause};
- return 0 unless (ref $other eq 'HASH') and (keys %$current == keys %$other);
+
+ no warnings qw/uninitialized/;
+
+ return 0 if (
+ join ("\x00", sort keys %$current)
+ ne
+ join ("\x00", sort keys %$other)
+ );
for my $key (keys %$current) {
- return 0 unless exists $other->{$key};
return 0 if $current->{$key} ne $other->{$key};
}
return 1;
}
+=head2 _ordered_internal_update
+This is a short-circuited method, that is used internally by this
+module to update positioning values in isolation (i.e. without
+triggering any of the positioning integrity code).
+
+Some day you might get confronted by datasets that have ambiguous
+positioning data (i.e. duplicate position values within the same group,
+in a table without unique constraints). When manually fixing such data
+keep in mind that you can not invoke L<DBIx::Class::Row/update> like
+you normally would, as it will get confused by the wrong data before
+having a chance to update the ill-defined row. If you really know what
+you are doing use this method which bypasses any hooks introduced by
+this module.
+
+=cut
+
+sub _ordered_internal_update {
+ my $self = shift;
+ local $self->{_ORDERED_INTERNAL_UPDATE} = 1;
+ return $self->update (@_);
+}
+
1;
+
__END__
-=head1 BUGS
+=head1 CAVEATS
-=head2 Unique Constraints
-
-Unique indexes and constraints on the position column are not
-supported at this time. It would be make sense to support them,
-but there are some unexpected database issues that make this
-hard to do. The main problem from the author's view is that
-SQLite (the DB engine that we use for testing) does not support
-ORDER BY on updates.
-
=head2 Race Condition on Insert
If a position is not specified for an insert than a position
-will be chosen based on COUNT(*)+1. But, it first selects the
-count, and then inserts the record. The space of time between select
-and insert introduces a race condition. To fix this we need the
-ability to lock tables in DBIC. I've added an entry in the TODO
-about this.
+will be chosen based either on L</_initial_position_value> or
+L</_next_position_value>, depending if there are already some
+items in the current group. The space of time between the
+necessary selects and insert introduces a race condition.
+Having unique constraints on your position/group columns,
+and using transactions (see L<DBIx::Class::Storage/txn_do>)
+will prevent such race conditions going undetected.
=head2 Multiple Moves
Be careful when issueing move_* methods to multiple objects. If
you've pre-loaded the objects then when you move one of the objects
the position of the other object will not reflect their new value
-until you reload them from the database.
+until you reload them from the database - see
+L<DBIx::Class::Row/discard_changes>.
There are times when you will want to move objects as groups, such
as changeing the parent of several objects at once - this directly
@@ -559,10 +845,19 @@
solution is to somehow automagically modify the objects that exist
in the current object's result set to have the new position value.
+=head2 Default Values
+
+Using a database defined default_value on one of your group columns
+could result in the position not being assigned correctly.
+
=head1 AUTHOR
-Aran Deltac <bluefeet at cpan.org>
+ Original code framework
+ Aran Deltac <bluefeet at cpan.org>
+ Constraints support and code generalisation
+ Peter Rabbitson <ribasushi at cpan.org>
+
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/Accessor.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/Accessor.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/Accessor.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -18,6 +18,7 @@
my ($class, $rel, $acc_type) = @_;
my %meth;
if ($acc_type eq 'single') {
+ my $rel_info = $class->relationship_info($rel);
$meth{$rel} = sub {
my $self = shift;
if (@_) {
@@ -26,6 +27,13 @@
} elsif (exists $self->{_relationship_data}{$rel}) {
return $self->{_relationship_data}{$rel};
} else {
+ my $cond = $self->result_source->resolve_condition(
+ $rel_info->{cond}, $rel, $self
+ );
+ if ($rel_info->{attrs}->{undef_on_null_fk}){
+ return unless ref($cond) eq 'HASH';
+ return if grep { not defined } values %$cond;
+ }
my $val = $self->find_related($rel, {}, {});
return unless $val;
return $self->{_relationship_data}{$rel} = $val;
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/Base.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/Base.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/Base.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -67,7 +67,9 @@
To add an C<OR>ed condition, use an arrayref of hashrefs. See the
L<SQL::Abstract> documentation for more details.
-In addition to standard result set attributes, the following attributes are also valid:
+In addition to the
+L<standard ResultSet attributes|DBIx::Class::ResultSet/ATTRIBUTES>,
+the following attributes are also valid:
=over 4
@@ -186,16 +188,36 @@
if (@_ > 1 && (@_ % 2 == 1));
my $query = ((@_ > 1) ? {@_} : shift);
- my $cond = $self->result_source->resolve_condition(
+ my $source = $self->result_source;
+ my $cond = $source->resolve_condition(
$rel_obj->{cond}, $rel, $self
);
+ if ($cond eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) {
+ my $reverse = $source->reverse_relationship_info($rel);
+ foreach my $rev_rel (keys %$reverse) {
+ if ($reverse->{$rev_rel}{attrs}{accessor} eq 'multi') {
+ $attrs->{related_objects}{$rev_rel} = [ $self ];
+ Scalar::Util::weaken($attrs->{related_object}{$rev_rel}[0]);
+ } else {
+ $attrs->{related_objects}{$rev_rel} = $self;
+ Scalar::Util::weaken($attrs->{related_object}{$rev_rel});
+ }
+ }
+ }
if (ref $cond eq 'ARRAY') {
- $cond = [ map { my $hash;
- foreach my $key (keys %$_) {
- my $newkey = $key =~ /\./ ? "me.$key" : $key;
- $hash->{$newkey} = $_->{$key};
- }; $hash } @$cond ];
- } else {
+ $cond = [ map {
+ if (ref $_ eq 'HASH') {
+ my $hash;
+ foreach my $key (keys %$_) {
+ my $newkey = $key !~ /\./ ? "me.$key" : $key;
+ $hash->{$newkey} = $_->{$key};
+ }
+ $hash;
+ } else {
+ $_;
+ }
+ } @$cond ];
+ } elsif (ref $cond eq 'HASH') {
foreach my $key (grep { ! /\./ } keys %$cond) {
$cond->{"me.$key"} = delete $cond->{$key};
}
@@ -377,7 +399,7 @@
(ref $cond ? ref $cond : 'plain scalar')
) unless ref $cond eq 'HASH';
if (defined $f_obj) {
- my $f_class = $self->result_source->schema->class($rel_obj->{class});
+ my $f_class = $rel_obj->{class};
$self->throw_exception( "Object $f_obj isn't a ".$f_class )
unless Scalar::Util::blessed($f_obj) and $f_obj->isa($f_class);
}
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/BelongsTo.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/BelongsTo.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/BelongsTo.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -9,6 +9,13 @@
sub belongs_to {
my ($class, $rel, $f_class, $cond, $attrs) = @_;
+
+ # assume a foreign key contraint unless defined otherwise
+ $attrs->{is_foreign_key_constraint} = 1
+ if not exists $attrs->{is_foreign_key_constraint};
+ $attrs->{undef_on_null_fk} = 1
+ if not exists $attrs->{undef_on_null_fk};
+
# no join condition or just a column name
if (!ref $cond) {
$class->ensure_class_loaded($f_class);
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/ManyToMany.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/ManyToMany.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship/ManyToMany.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -3,6 +3,7 @@
use strict;
use warnings;
+use warnings::register;
use Sub::Name ();
sub many_to_many {
@@ -26,10 +27,21 @@
my $rs_meth = "${meth}_rs";
for ($add_meth, $remove_meth, $set_meth, $rs_meth) {
- warn "***************************************************************************\n".
- "The many-to-many relationship $meth is trying to create a utility method called $_. This will overwrite the existing method on $class. You almost certainly want to rename your method or the many-to-many relationship, as your method will not be callable (it will use the one from the relationship instead.) YOU HAVE BEEN WARNED\n".
- "***************************************************************************\n"
- if $class->can($_);
+ if ( $class->can ($_) ) {
+ warnings::warnif(<<"EOW")
+***************************************************************************
+The many-to-many relationship $meth is trying to create a utility method called
+$_. This will overwrite the existing method on $class. You almost certainly
+want to rename your method or the many-to-many relationship, as your method
+will not be callable (it will use the one from the relationship instead.)
+
+To disable this warning add the following to $class
+
+ no warnings 'DBIx::Class::Relationship::ManyToMany';
+
+***************************************************************************
+EOW
+ }
}
$rel_attrs->{alias} ||= $f_rel;
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Relationship.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -31,14 +31,17 @@
MyDB::Schema::Actor->many_to_many('roles' => 'actorroles', 'role');
## Using relationships
- $schema->resultset('Actor')->roles();
- $schema->resultset('Role')->search_related('actors', { Name => 'Fred' });
- $schema->resultset('ActorRole')->add_to_roles({ Name => 'Sherlock Holmes'});
+ $schema->resultset('Actor')->find({ id => 1})->roles();
+ $schema->resultset('Role')->find({ id => 1 })->actorroles->search_related('actor', { Name => 'Fred' });
+ $schema->resultset('Actor')->add_to_roles({ Name => 'Sherlock Holmes'});
See L<DBIx::Class::Manual::Cookbook> for more.
=head1 DESCRIPTION
+The word I<Relationship> has a specific meaning in DBIx::Class, see
+the definition in the L<Glossary|DBIx::Class::Manual::Glossary/Relationship>.
+
This class provides methods to set up relationships between the tables
in your database model. Relationships are the most useful and powerful
technique that L<DBIx::Class> provides. To create efficient database queries,
@@ -102,29 +105,29 @@
All helper methods are called similar to the following template:
- __PACKAGE__->$method_name('relname', 'Foreign::Class', $cond, $attrs);
+ __PACKAGE__->$method_name('relname', 'Foreign::Class', \%cond | \@cond, \%attrs);
Both C<$cond> and C<$attrs> are optional. Pass C<undef> for C<$cond> if
-you want to use the default value for it, but still want to set C<$attrs>.
+you want to use the default value for it, but still want to set C<\%attrs>.
See L<DBIx::Class::Relationship::Base> for documentation on the
-attrubutes that are allowed in the C<$attrs> argument.
+attrubutes that are allowed in the C<\%attrs> argument.
=head2 belongs_to
=over 4
-=item Arguments: $accessor_name, $related_class, $fk_column|\%cond|\@cond?, \%attr?
+=item Arguments: $accessor_name, $related_class, $our_fk_column|\%cond|\@cond?, \%attrs?
=back
Creates a relationship where the calling class stores the foreign
-class's primary key in one (or more) of its columns. This relationship
-defaults to using C<$accessor_name> as the column in this class
-to resolve the join against the primary key from C<$related_class>,
-unless C<$fk_column> specifies the foreign key column in this class or
-C<cond> specifies a reference to a join condition hash.
+class's primary key in one (or more) of the calling class columns.
+This relationship defaults to using C<$accessor_name> as the column
+name in this class to resolve the join against the primary key from
+C<$related_class>, unless C<$our_fk_column> specifies the foreign key column
+in this class or C<cond> specifies a reference to a join condition hash.
=over
@@ -144,7 +147,7 @@
This is the class name of the table referenced by the foreign key in
this class.
-=item fk_column
+=item our_fk_column
The column name on this class that contains the foreign key.
@@ -153,7 +156,7 @@
=item cond
A hashref where the keys are C<foreign.$column_on_related_table> and
-the values are C<self.$foreign_key_column>. This is useful for
+the values are C<self.$our_fk_column>. This is useful for
relations that are across multiple columns.
=back
@@ -208,25 +211,32 @@
relationship. To turn them on, pass C<< cascade_delete => 1 >>
in the $attr hashref.
+By default, DBIC will return undef and avoid querying the database if a
+C<belongs_to> accessor is called when any part of the foreign key IS NULL. To
+disable this behavior, pass C<< undef_on_null_fk => 0 >> in the C<$attr>
+hashref.
+
NOTE: If you are used to L<Class::DBI> relationships, this is the equivalent
of C<has_a>.
See L<DBIx::Class::Relationship::Base> for documentation on relationship
-methods and valid relationship attributes.
+methods and valid relationship attributes. Also see L<DBIx::Class::ResultSet>
+for a L<list of standard resultset attributes|DBIx::Class::ResultSet/ATTRIBUTES>
+which can be assigned to relationships as well.
=head2 has_many
=over 4
-=item Arguments: $accessor_name, $related_class, $foreign_key_column|\%cond|\@cond?, \%attr?
+=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond?, \%attrs?
=back
Creates a one-to-many relationship, where the corresponding elements
of the foreign class store the calling class's primary key in one (or
-more) of its columns. This relationship defaults to using the end of
-this classes namespace as the foreign key in C<$related_class> to
-resolve the join, unless C<$foreign_key_column> specifies the foreign
+more) of the foreign class columns. This relationship defaults to using
+the end of this classes namespace as the foreign key in C<$related_class>
+to resolve the join, unless C<$their_fk_column> specifies the foreign
key column in C<$related_class> or C<cond> specifies a reference to a
join condition hash.
@@ -249,7 +259,7 @@
This is the class name of the table which contains a foreign key
column containing PK values of this class.
-=item foreign_key_column
+=item their_fk_column
The column name on the related class that contains the foreign key.
@@ -257,7 +267,7 @@
=item cond
-A hashref where the keys are C<foreign.$foreign_key_column> and
+A hashref where the keys are C<foreign.$their_fk_column> and
the values are C<self.$matching_column>. This is useful for
relations that are across multiple columns.
@@ -330,29 +340,34 @@
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 behaviour off,
-pass C<< cascade_delete => 0 >> in the C<attr> hashref. However, any
-database-level cascade or restrict will take precedence over a
-DBIx-Class-based cascading delete.
+pass C<< cascade_delete => 0 >> in the C<$attr> hashref.
+The cascaded operations are performed after the requested delete or
+update, so if your database has a constraint on the relationship, it
+will have deleted/updated the related records or raised an exception
+before DBIx::Class gets to perform the cascaded operation.
+
If you copy an object in a class with a C<has_many> relationship, all
the related objects will be copied as well. To turn this behaviour off,
pass C<< cascade_copy => 0 >> in the C<$attr> hashref. The behaviour
defaults to C<< cascade_copy => 1 >>.
See L<DBIx::Class::Relationship::Base> for documentation on relationship
-methods and valid relationship attributes.
+methods and valid relationship attributes. Also see L<DBIx::Class::ResultSet>
+for a L<list of standard resultset attributes|DBIx::Class::ResultSet/ATTRIBUTES>
+which can be assigned to relationships as well.
=head2 might_have
=over 4
-=item Arguments: $accessor_name, $related_class, $foreign_key_column|\%cond|\@cond?, \%attr?
+=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond?, \%attrs?
=back
Creates an optional one-to-one relationship with a class. This relationship
defaults to using C<$accessor_name> as the foreign key in C<$related_class> to
-resolve the join, unless C<$foreign_key_column> specifies the foreign key
+resolve the join, unless C<$their_fk_column> specifies the foreign key
column in C<$related_class> or C<cond> specifies a reference to a join
condition hash.
@@ -374,7 +389,7 @@
This is the class name of the table which contains a foreign key
column containing PK values of this class.
-=item foreign_key_column
+=item their_fk_column
The column name on the related class that contains the foreign key.
@@ -382,7 +397,7 @@
=item cond
-A hashref where the keys are C<foreign.$column_on_related_table> and
+A hashref where the keys are C<foreign.$their_fk_column> and
the values are C<self.$matching_column>. This is useful for
relations that are across multiple columns.
@@ -414,23 +429,29 @@
If you update or delete an object in a class with a C<might_have>
relationship, the related object will be updated or deleted as well. To
turn off this behavior, add C<< cascade_delete => 0 >> to the C<$attr>
-hashref. Any database-level update or delete constraints will override
-this behavior.
+hashref.
+The cascaded operations are performed after the requested delete or
+update, so if your database has a constraint on the relationship, it
+will have deleted/updated the related records or raised an exception
+before DBIx::Class gets to perform the cascaded operation.
+
See L<DBIx::Class::Relationship::Base> for documentation on relationship
-methods and valid relationship attributes.
+methods and valid relationship attributes. Also see L<DBIx::Class::ResultSet>
+for a L<list of standard resultset attributes|DBIx::Class::ResultSet/ATTRIBUTES>
+which can be assigned to relationships as well.
=head2 has_one
=over 4
-=item Arguments: $accessor_name, $related_class, $foreign_key_column|\%cond|\@cond?, \%attr?
+=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond?, \%attrs?
=back
Creates a one-to-one relationship with a class. This relationship
defaults to using C<$accessor_name> as the foreign key in C<$related_class> to
-resolve the join, unless C<$foreign_key_column> specifies the foreign key
+resolve the join, unless C<$their_fk_column> specifies the foreign key
column in C<$related_class> or C<cond> specifies a reference to a join
condition hash.
@@ -452,7 +473,7 @@
This is the class name of the table which contains a foreign key
column containing PK values of this class.
-=item foreign_key_column
+=item their_fk_column
The column name on the related class that contains the foreign key.
@@ -460,7 +481,7 @@
=item cond
-A hashref where the keys are C<foreign.$column_on_related_table> and
+A hashref where the keys are C<foreign.$their_fk_column> and
the values are C<self.$matching_column>. This is useful for
relations that are across multiple columns.
@@ -503,16 +524,22 @@
ISBN object.
See L<DBIx::Class::Relationship::Base> for documentation on relationship
-methods and valid relationship attributes.
+methods and valid relationship attributes. Also see L<DBIx::Class::ResultSet>
+for a L<list of standard resultset attributes|DBIx::Class::ResultSet/ATTRIBUTES>
+which can be assigned to relationships as well.
=head2 many_to_many
=over 4
-=item Arguments: $accessor_name, $link_rel_name, $foreign_rel_name, \%attr?
+=item Arguments: $accessor_name, $link_rel_name, $foreign_rel_name, \%attrs?
=back
+C<many_to_many> is a I<Relationship bridge> which has a specific
+meaning in DBIx::Class, see the definition in the
+L<Glossary|DBIx::Class::Manual::Glossary/Relationship bridge>.
+
C<many_to_many> is not strictly a relationship in its own right. Instead, it is
a bridge between two resultsets which provide the same kind of convenience
accessors as true relationships provide. Although the accessor will return a
@@ -586,7 +613,9 @@
relationship.
See L<DBIx::Class::Relationship::Base> for documentation on relationship
-methods and valid relationship attributes.
+methods and valid relationship attributes. Also see L<DBIx::Class::ResultSet>
+for a L<list of standard resultset attributes|DBIx::Class::ResultSet/ATTRIBUTES>
+which can be assigned to relationships as well.
=cut
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultClass/HashRefInflator.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultClass/HashRefInflator.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultClass/HashRefInflator.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -3,26 +3,29 @@
use strict;
use warnings;
-our %inflator_cache;
-our $inflate_data;
-
=head1 NAME
DBIx::Class::ResultClass::HashRefInflator
=head1 SYNOPSIS
- my $rs = $schema->resultset('CD');
+ use DBIx::Class::ResultClass::HashRefInflator;
+ my $rs = $schema->resultset('CD');
$rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
+ while (my $hashref = $rs->next) {
+ ...
+ }
=head1 DESCRIPTION
-DBIx::Class is not built for speed: it's built for convenience and
-ease of use. But sometimes you just need to get the data, and skip the
-fancy objects. That is what this class provides.
+DBIx::Class is faster than older ORMs like Class::DBI but it still isn't
+designed primarily for speed. Sometimes you need to quickly retrieve the data
+from a massive resultset, while skipping the creation of fancy row objects.
+Specifying this class as a C<result_class> for a resultset will change C<< $rs->next >>
+to return a plain data hash-ref (or a list of such hash-refs if C<< $rs->all >> is used).
-There are two ways of using this class.
+There are two ways of applying this class to a resultset:
=over
@@ -39,53 +42,23 @@
=back
-=head1 AUTOMATICALLY INFLATING COLUMN VALUES
-
-So you want to skip the DBIx::Class object creation part, but you still want
-all your data to be inflated according to the rules you defined in your table
-classes. Setting the global variable
-C<$DBIx::Class::ResultClass::HashRefInflator::inflate_data> to a true value
-will instruct L<mk_hash> to interrogate the processed columns and apply any
-inflation methods declared via L<DBIx::Class::InflateColumn/inflate_column>.
-
-For increased speed the inflation method lookups are cached in
-C<%DBIx::Class::ResultClass::HashRefInflator::inflator_cache>. Make sure to
-reset this hash if you modify column inflators at run time.
-
-=head1 METHODS
-
-=head2 inflate_result
-
-Inflates the result and prefetched data into a hash-ref using L<mk_hash>.
-
=cut
-sub inflate_result {
- my ($self, $source, $me, $prefetch) = @_;
-
- my $hashref = mk_hash($me, $prefetch);
- inflate_hash ($source->schema, $source->result_class, $hashref) if $inflate_data;
- return $hashref;
-}
-
-=head2 mk_hash
-
-This does all the work of inflating the (pre)fetched data.
-
-=cut
-
##############
# NOTE
#
-# Generally people use this to gain as much speed as possible. If a new mk_hash is
+# Generally people use this to gain as much speed as possible. If a new &mk_hash is
# implemented, it should be benchmarked using the maint/benchmark_hashrefinflator.pl
-# script (in addition to passing all tests of course :). Additional instructions are
+# script (in addition to passing all tests of course :). Additional instructions are
# provided in the script itself.
#
-sub mk_hash {
+# This coderef is a simple recursive function
+# Arguments: ($me, $prefetch) from inflate_result() below
+my $mk_hash;
+$mk_hash = sub {
if (ref $_[0] eq 'ARRAY') { # multi relationship
- return [ map { mk_hash (@$_) || () } (@_) ];
+ return [ map { $mk_hash->(@$_) || () } (@_) ];
}
else {
my $hash = {
@@ -94,7 +67,7 @@
# the second arg is a hash of arrays for each prefetched relation
map
- { $_ => mk_hash( @{$_[1]->{$_}} ) }
+ { $_ => $mk_hash->( @{$_[1]->{$_}} ) }
( $_[1] ? (keys %{$_[1]}) : () )
};
@@ -106,49 +79,30 @@
return undef;
}
-}
+};
-=head2 inflate_hash
+=head1 METHODS
-This walks through a hashref produced by L<mk_hash> and inflates any data
-for which there is a registered inflator in the C<column_info>
+=head2 inflate_result
+Inflates the result and prefetched data into a hash-ref (invoked by L<DBIx::Class::ResultSet>)
+
=cut
-sub inflate_hash {
- my ($schema, $rc, $data) = @_;
+##################################################################################
+# inflate_result is invoked as:
+# HRI->inflate_result ($resultsource_instance, $main_data_hashref, $prefetch_data_hashref)
+sub inflate_result {
+ return $mk_hash->($_[2], $_[3]);
+}
- foreach my $column (keys %{$data}) {
- if (ref $data->{$column} eq 'HASH') {
- inflate_hash ($schema, $schema->source ($rc)->related_class ($column), $data->{$column});
- }
- elsif (ref $data->{$column} eq 'ARRAY') {
- foreach my $rel (@{$data->{$column}}) {
- inflate_hash ($schema, $schema->source ($rc)->related_class ($column), $rel);
- }
- }
- else {
- # "null is null is null"
- next if not defined $data->{$column};
+=head1 CAVEATS
- # cache the inflator coderef
- unless (exists $inflator_cache{$rc}{$column}) {
- $inflator_cache{$rc}{$column} = exists $schema->source ($rc)->_relationships->{$column}
- ? undef # currently no way to inflate a column sharing a name with a rel
- : $rc->column_info($column)->{_inflate_info}{inflate}
- ;
- }
+=over
- if ($inflator_cache{$rc}{$column}) {
- $data->{$column} = $inflator_cache{$rc}{$column}->($data->{$column});
- }
- }
- }
-}
+=item *
-=head1 CAVEAT
-
This will not work for relationships that have been prefetched. Consider the
following:
@@ -162,6 +116,8 @@
HashRefInflator only affects resultsets at inflation time, and prefetch causes
relations to be inflated when the master C<$artist> row is inflated.
+=back
+
=cut
1;
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSet.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSet.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSet.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -15,43 +15,127 @@
use Scalar::Util ();
use base qw/DBIx::Class/;
-__PACKAGE__->mk_group_accessors('simple' => qw/result_class _source_handle/);
+__PACKAGE__->mk_group_accessors('simple' => qw/_result_class _source_handle/);
=head1 NAME
-DBIx::Class::ResultSet - Responsible for fetching and creating resultset.
+DBIx::Class::ResultSet - Represents a query used for fetching a set of results.
=head1 SYNOPSIS
- my $rs = $schema->resultset('User')->search({ registered => 1 });
- my @rows = $schema->resultset('CD')->search({ year => 2005 })->all();
+ my $users_rs = $schema->resultset('User');
+ my $registered_users_rs = $schema->resultset('User')->search({ registered => 1 });
+ my @cds_in_2005 = $schema->resultset('CD')->search({ year => 2005 })->all();
=head1 DESCRIPTION
-The resultset is also known as an iterator. It is responsible for handling
-queries that may return an arbitrary number of rows, e.g. via L</search>
-or a C<has_many> relationship.
+A ResultSet is an object which stores a set of conditions representing
+a query. It is the backbone of DBIx::Class (i.e. the really
+important/useful bit).
-In the examples below, the following table classes are used:
+No SQL is executed on the database when a ResultSet is created, it
+just stores all the conditions needed to create the query.
- package MyApp::Schema::Artist;
- use base qw/DBIx::Class/;
- __PACKAGE__->load_components(qw/Core/);
- __PACKAGE__->table('artist');
- __PACKAGE__->add_columns(qw/artistid name/);
- __PACKAGE__->set_primary_key('artistid');
- __PACKAGE__->has_many(cds => 'MyApp::Schema::CD');
- 1;
+A basic ResultSet representing the data of an entire table is returned
+by calling C<resultset> on a L<DBIx::Class::Schema> and passing in a
+L<Source|DBIx::Class::Manual::Glossary/Source> name.
- package MyApp::Schema::CD;
- use base qw/DBIx::Class/;
- __PACKAGE__->load_components(qw/Core/);
- __PACKAGE__->table('cd');
- __PACKAGE__->add_columns(qw/cdid artist title year/);
- __PACKAGE__->set_primary_key('cdid');
- __PACKAGE__->belongs_to(artist => 'MyApp::Schema::Artist');
- 1;
+ my $users_rs = $schema->resultset('User');
+A new ResultSet is returned from calling L</search> on an existing
+ResultSet. The new one will contain all the conditions of the
+original, plus any new conditions added in the C<search> call.
+
+A ResultSet is also an iterator. L</next> is used to return all the
+L<DBIx::Class::Row>s the ResultSet represents.
+
+The query that the ResultSet represents is B<only> executed against
+the database when these methods are called:
+
+=over
+
+=item L</find>
+
+=item L</next>
+
+=item L</all>
+
+=item L</count>
+
+=item L</single>
+
+=item L</first>
+
+=back
+
+=head1 EXAMPLES
+
+=head2 Chaining resultsets
+
+Let's say you've got a query that needs to be run to return some data
+to the user. But, you have an authorization system in place that
+prevents certain users from seeing certain information. So, you want
+to construct the basic query in one method, but add constraints to it in
+another.
+
+ sub get_data {
+ my $self = shift;
+ my $request = $self->get_request; # Get a request object somehow.
+ my $schema = $self->get_schema; # Get the DBIC schema object somehow.
+
+ my $cd_rs = $schema->resultset('CD')->search({
+ title => $request->param('title'),
+ year => $request->param('year'),
+ });
+
+ $self->apply_security_policy( $cd_rs );
+
+ return $cd_rs->all();
+ }
+
+ sub apply_security_policy {
+ my $self = shift;
+ my ($rs) = @_;
+
+ return $rs->search({
+ subversive => 0,
+ });
+ }
+
+=head2 Multiple queries
+
+Since a resultset just defines a query, you can do all sorts of
+things with it with the same object.
+
+ # Don't hit the DB yet.
+ my $cd_rs = $schema->resultset('CD')->search({
+ title => 'something',
+ year => 2009,
+ });
+
+ # Each of these hits the DB individually.
+ my $count = $cd_rs->count;
+ my $most_recent = $cd_rs->get_column('date_released')->max();
+ my @records = $cd_rs->all;
+
+And it's not just limited to SELECT statements.
+
+ $cd_rs->delete();
+
+This is even cooler:
+
+ $cd_rs->create({ artist => 'Fred' });
+
+Which is the same as:
+
+ $schema->resultset('CD')->create({
+ title => 'something',
+ year => 2009,
+ artist => 'Fred'
+ });
+
+See: L</search>, L</count>, L</get_column>, L</all>, L</create>.
+
=head1 OVERLOADING
If a resultset is used in a numeric context it returns the L</count>.
@@ -108,7 +192,6 @@
# see https://bugzilla.redhat.com/show_bug.cgi?id=196836
my $self = {
_source_handle => $source,
- result_class => $attrs->{result_class} || $source->resolve->result_class,
cond => $attrs->{where},
count => undef,
pager => undef,
@@ -117,6 +200,10 @@
bless $self, $class;
+ $self->result_class(
+ $attrs->{result_class} || $source->resolve->result_class
+ );
+
return $self;
}
@@ -200,7 +287,7 @@
my $new_attrs = { %{$our_attrs}, %{$attrs} };
# merge new attrs into inherited
- foreach my $key (qw/join prefetch/) {
+ foreach my $key (qw/join prefetch +select +as/) {
next unless exists $attrs->{$key};
$new_attrs->{$key} = $self->_merge_attr($our_attrs->{$key}, $attrs->{$key});
}
@@ -307,7 +394,7 @@
=item Arguments: @values | \%cols, \%attrs?
-=item Return Value: $row_object
+=item Return Value: $row_object | undef
=back
@@ -341,6 +428,9 @@
If your table does not have a primary key, you B<must> provide a value for the
C<key> attribute matching one of the unique constraints on the source.
+In addition to C<key>, L</find> recognizes and applies standard
+L<resultset attributes|/ATTRIBUTES> in the same way as L</search> does.
+
Note: If your query does not return only one row, a warning is generated:
Query returned more than one row
@@ -573,24 +663,38 @@
my $cd = $schema->resultset('CD')->single({ year => 2001 });
Inflates the first result without creating a cursor if the resultset has
-any records in it; if not returns nothing. Used by L</find> as an optimisation.
+any records in it; if not returns nothing. Used by L</find> as a lean version of
+L</search>.
-Can optionally take an additional condition B<only> - this is a fast-code-path
-method; if you need to add extra joins or similar call L</search> and then
-L</single> without a condition on the L<DBIx::Class::ResultSet> returned from
-that.
+While this method can take an optional search condition (just like L</search>)
+being a fast-code-path it does not recognize search attributes. If you need to
+add extra joins or similar, call L</search> and then chain-call L</single> on the
+L<DBIx::Class::ResultSet> returned.
-B<Note>: As of 0.08100, this method assumes that the query returns only one
-row. If more than one row is returned, you will receive a warning:
+=over
+=item B<Note>
+
+As of 0.08100, this method enforces the assumption that the preceeding
+query returns only one row. If more than one row is returned, you will receive
+a warning:
+
Query returned more than one row
-In this case, you should be using L</first> or L</find> instead.
+In this case, you should be using L</first> or L</find> instead, or if you really
+know what you are doing, use the L</rows> attribute to explicitly limit the size
+of the resultset.
+=back
+
=cut
sub single {
my ($self, $where) = @_;
+ if(@_ > 2) {
+ $self->throw_exception('single() only takes search conditions, no attributes. You want ->search( $cond, $attrs )->single()');
+ }
+
my $attrs = { %{$self->_resolved_attrs} };
if ($where) {
if (defined $attrs->{where}) {
@@ -721,8 +825,8 @@
$cd_rs = $rs->search_like({ title => '%blue%'});
Performs a search, but uses C<LIKE> instead of C<=> as the condition. Note
-that this is simply a convenience method. You most likely want to use
-L</search> with specific operators.
+that this is simply a convenience method retained for ex Class::DBI users.
+You most likely want to use L</search> with specific operators.
For more information, see L<DBIx::Class::Manual::Cookbook>.
@@ -975,6 +1079,14 @@
=cut
+sub result_class {
+ my ($self, $result_class) = @_;
+ if ($result_class) {
+ $self->ensure_class_loaded($result_class);
+ $self->_result_class($result_class);
+ }
+ $self->_result_class;
+}
=head2 count
@@ -1085,7 +1197,11 @@
=cut
sub all {
- my ($self) = @_;
+ my $self = shift;
+ if(@_) {
+ $self->throw_exception("all() doesn't take any arguments, you probably wanted ->search(...)->all()");
+ }
+
return @{ $self->get_cache } if $self->get_cache;
my @obj;
@@ -1237,6 +1353,11 @@
$self->throw_exception("Values for update must be a hash")
unless ref $values eq 'HASH';
+ carp( 'WARNING! Currently $rs->update() does not generate proper SQL'
+ . ' on joined resultsets, and may affect rows well outside of the'
+ . ' contents of $rs. Use at your own risk' )
+ if ( $self->{attrs}{seen_join} );
+
my $cond = $self->_cond_for_update_delete;
return $self->result_source->storage->update(
@@ -1283,11 +1404,26 @@
will not run DBIC cascade triggers. See L</delete_all> if you need triggers
to run. See also L<DBIx::Class::Row/delete>.
+delete may not generate correct SQL for a query with joins or a resultset
+chained from a related resultset. In this case it will generate a warning:-
+
+ WARNING! Currently $rs->delete() does not generate proper SQL on
+ joined resultsets, and may delete rows well outside of the contents
+ of $rs. Use at your own risk
+
+In these cases you may find that delete_all is more appropriate, or you
+need to respecify your query in a way that can be expressed without a join.
+
=cut
sub delete {
my ($self) = @_;
-
+ $self->throw_exception("Delete should not be passed any arguments")
+ if $_[1];
+ carp( 'WARNING! Currently $rs->delete() does not generate proper SQL'
+ . ' on joined resultsets, and may delete rows well outside of the'
+ . ' contents of $rs. Use at your own risk' )
+ if ( $self->{attrs}{seen_join} );
my $cond = $self->_cond_for_update_delete;
$self->result_source->storage->delete($self->result_source, $cond);
@@ -1323,8 +1459,9 @@
=back
-Pass an arrayref of hashrefs. Each hashref should be a structure suitable for
-submitting to a $resultset->create(...) method.
+Accepts either an arrayref of hashrefs or alternatively an arrayref of arrayrefs.
+For the arrayref of hashrefs style each hashref should be a structure suitable
+forsubmitting to a $resultset->create(...) method.
In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
to insert the data, as this is a faster method.
@@ -1364,7 +1501,18 @@
print $ArtistOne->name; ## response is 'Artist One'
print $ArtistThree->cds->count ## reponse is '2'
-
+
+For the arrayref of arrayrefs style, the first element should be a list of the
+fieldsnames to which the remaining elements are rows being inserted. For
+example:
+
+ $Arstist_rs->populate([
+ [qw/artistid name/],
+ [100, 'A Formally Unknown Singer'],
+ [101, 'A singer that jumped the shark two albums ago'],
+ [102, 'An actually cool singer.'],
+ ]);
+
Please note an important effect on your data when choosing between void and
wantarray context. Since void context goes straight to C<insert_bulk> in
L<DBIx::Class::Storage::DBI> this will skip any component that is overriding
@@ -1376,7 +1524,10 @@
=cut
sub populate {
- my ($self, $data) = @_;
+ my $self = shift @_;
+ my $data = ref $_[0][0] eq 'HASH'
+ ? $_[0] : ref $_[0][0] eq 'ARRAY' ? $self->_normalize_populate_args($_[0]) :
+ $self->throw_exception('Populate expects an arrayref of hashes or arrayref of arrayrefs');
if(defined wantarray) {
my @created;
@@ -1450,6 +1601,28 @@
}
}
+=head2 _normalize_populate_args ($args)
+
+Private method used by L</populate> to normalize its incoming arguments. Factored
+out in case you want to subclass and accept new argument structures to the
+L</populate> method.
+
+=cut
+
+sub _normalize_populate_args {
+ my ($self, $data) = @_;
+ my @names = @{shift(@$data)};
+ my @results_to_create;
+ foreach my $datum (@$data) {
+ my %result_to_create;
+ foreach my $index (0..$#names) {
+ $result_to_create{$names[$index]} = $$datum[$index];
+ }
+ push @results_to_create, \%result_to_create;
+ }
+ return \@results_to_create;
+}
+
=head2 pager
=over 4
@@ -1502,7 +1675,7 @@
=item Arguments: \%vals
-=item Return Value: $object
+=item Return Value: $rowobject
=back
@@ -1519,23 +1692,37 @@
my ($self, $values) = @_;
$self->throw_exception( "new_result needs a hash" )
unless (ref $values eq 'HASH');
- $self->throw_exception(
- "Can't abstract implicit construct, condition not a hash"
- ) if ($self->{cond} && !(ref $self->{cond} eq 'HASH'));
+ my %new;
my $alias = $self->{attrs}{alias};
- my $collapsed_cond = $self->{cond} ? $self->_collapse_cond($self->{cond}) : {};
- # precendence must be given to passed values over values inherited from the cond,
- # so the order here is important.
- my %new;
- my %implied = %{$self->_remove_alias($collapsed_cond, $alias)};
- while( my($col,$value) = each %implied ){
- if(ref($value) eq 'HASH' && keys(%$value) && (keys %$value)[0] eq '='){
- $new{$col} = $value->{'='};
- next;
+ if (
+ defined $self->{cond}
+ && $self->{cond} eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION
+ ) {
+ %new = %{ $self->{attrs}{related_objects} || {} }; # nothing might have been inserted yet
+ $new{-from_resultset} = [ keys %new ] if keys %new;
+ } else {
+ $self->throw_exception(
+ "Can't abstract implicit construct, condition not a hash"
+ ) if ($self->{cond} && !(ref $self->{cond} eq 'HASH'));
+
+ my $collapsed_cond = (
+ $self->{cond}
+ ? $self->_collapse_cond($self->{cond})
+ : {}
+ );
+
+ # precendence must be given to passed values over values inherited from
+ # the cond, so the order here is important.
+ my %implied = %{$self->_remove_alias($collapsed_cond, $alias)};
+ while( my($col,$value) = each %implied ){
+ if(ref($value) eq 'HASH' && keys(%$value) && (keys %$value)[0] eq '='){
+ $new{$col} = $value->{'='};
+ next;
+ }
+ $new{$col} = $value if $self->_is_deterministic_value($value);
}
- $new{$col} = $value if $self->_is_deterministic_value($value);
}
%new = (
@@ -1620,22 +1807,57 @@
return \%unaliased;
}
+=head2 as_query
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: \[ $sql, @bind ]
+
+=back
+
+Returns the SQL query and bind vars associated with the invocant.
+
+This is generally used as the RHS for a subquery.
+
+=cut
+
+sub as_query { return shift->cursor->as_query(@_) }
+
=head2 find_or_new
=over 4
=item Arguments: \%vals, \%attrs?
-=item Return Value: $object
+=item Return Value: $rowobject
=back
-Find an existing record from this resultset. If none exists, instantiate a new
-result object and return it. The object will not be saved into your storage
+ my $artist = $schema->resultset('Artist')->find_or_new(
+ { artist => 'fred' }, { key => 'artists' });
+
+ $cd->cd_to_producer->find_or_new({ producer => $producer },
+ { key => 'primary });
+
+Find an existing record from this resultset, based on its primary
+key, or a unique constraint. If none exists, instantiate a new result
+object and return it. The object will not be saved into your storage
until you call L<DBIx::Class::Row/insert> on it.
+You most likely want this method when looking for existing rows using
+a unique constraint that is not the primary key, or looking for
+related rows.
+
If you want objects to be saved immediately, use L</find_or_create> instead.
+B<Note>: C<find_or_new> is probably not what you want when creating a
+new row in a table that uses primary keys supplied by the
+database. Passing in a primary key column with a value of I<undef>
+will cause L</find> to attempt to search for a row with a value of
+I<NULL>.
+
=cut
sub find_or_new {
@@ -1665,7 +1887,7 @@
pairs representing the columns of the table and the values you wish to
store. If the appropriate relationships are set up, foreign key fields
can also be passed an object representing the foreign row, and the
-value will be set to it's primary key.
+value will be set to its primary key.
To create related objects, pass a hashref for the value if the related
item is a foreign key relationship (L<DBIx::Class::Relationship/belongs_to>),
@@ -1684,7 +1906,7 @@
$person_rs->create({
name=>"Some Person",
- email=>"somebody at someplace.com"
+ email=>"somebody at someplace.com"
});
Example of creating a new row and also creating rows in a related C<has_many>
@@ -1703,10 +1925,10 @@
$cd_rs->create({
title=>"Music for Silly Walks",
- year=>2000,
- artist => {
- name=>"Silly Musician",
- }
+ year=>2000,
+ artist => {
+ name=>"Silly Musician",
+ }
});
=cut
@@ -1724,13 +1946,14 @@
=item Arguments: \%vals, \%attrs?
-=item Return Value: $object
+=item Return Value: $rowobject
=back
- $class->find_or_create({ key => $val, ... });
+ $cd->cd_to_producer->find_or_create({ producer => $producer },
+ { key => 'primary });
-Tries to find a record based on its primary key or unique constraint; if none
+Tries to find a record based on its primary key or unique constraints; if none
is found, creates one and returns that instead.
my $cd = $schema->resultset('CD')->find_or_create({
@@ -1751,12 +1974,18 @@
{ key => 'cd_artist_title' }
);
-Note: Because find_or_create() reads from the database and then
+B<Note>: Because find_or_create() reads from the database and then
possibly inserts based on the result, this method is subject to a race
condition. Another process could create a record in the table after
the find has completed and before the create has started. To avoid
this problem, use find_or_create() inside a transaction.
+B<Note>: C<find_or_create> is probably not what you want when creating
+a new row in a table that uses primary keys supplied by the
+database. Passing in a primary key column with a value of I<undef>
+will cause L</find> to attempt to search for a row with a value of
+I<NULL>.
+
See also L</find> and L</update_or_create>. For information on how to declare
unique constraints, see L<DBIx::Class::ResultSource/add_unique_constraint>.
@@ -1776,11 +2005,11 @@
=item Arguments: \%col_values, { key => $unique_constraint }?
-=item Return Value: $object
+=item Return Value: $rowobject
=back
- $class->update_or_create({ col => $val, ... });
+ $resultset->update_or_create({ col => $val, ... });
First, searches for an existing row matching one of the unique constraints
(including the primary key) on the source of this resultset. If a row is
@@ -1800,6 +2029,14 @@
{ key => 'cd_artist_title' }
);
+ $cd->cd_to_producer->update_or_create({
+ producer => $producer,
+ name => 'harry',
+ }, {
+ key => 'primary,
+ });
+
+
If no C<key> is specified, it searches on all unique constraints defined on the
source, including the primary key.
@@ -1808,6 +2045,12 @@
See also L</find> and L</find_or_create>. For information on how to declare
unique constraints, see L<DBIx::Class::ResultSource/add_unique_constraint>.
+B<Note>: C<update_or_create> is probably not what you want when
+looking for a row in a table that uses primary keys supplied by the
+database, unless you actually have a key value. Passing in a primary
+key column with a value of I<undef> will cause L</find> to attempt to
+search for a row with a value of I<NULL>.
+
=cut
sub update_or_create {
@@ -1967,6 +2210,49 @@
};
}
+=head2 current_source_alias
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: $source_alias
+
+=back
+
+Returns the current table alias for the result source this resultset is built
+on, that will be used in the SQL query. Usually it is C<me>.
+
+Currently the source alias that refers to the result set returned by a
+L</search>/L</find> family method depends on how you got to the resultset: it's
+C<me> by default, but eg. L</search_related> aliases it to the related result
+source name (and keeps C<me> referring to the original result set). The long
+term goal is to make L<DBIx::Class> always alias the current resultset as C<me>
+(and make this method unnecessary).
+
+Thus it's currently necessary to use this method in predefined queries (see
+L<DBIx::Class::Manual::Cookbook/Predefined searches>) when referring to the
+source alias of the current result set:
+
+ # in a result set class
+ sub modified_by {
+ my ($self, $user) = @_;
+
+ my $me = $self->current_source_alias;
+
+ return $self->search(
+ "$me.modified" => $user->id,
+ );
+ }
+
+=cut
+
+sub current_source_alias {
+ my ($self) = @_;
+
+ return ($self->{attrs} || {})->{alias} || 'me';
+}
+
sub _resolve_from {
my ($self, $extra_join) = @_;
my $source = $self->result_source;
@@ -1997,97 +2283,127 @@
my $self = shift;
return $self->{_attrs} if $self->{_attrs};
- my $attrs = { %{$self->{attrs}||{}} };
+ my $attrs = { %{ $self->{attrs} || {} } };
my $source = $self->result_source;
- my $alias = $attrs->{alias};
+ my $alias = $attrs->{alias};
$attrs->{columns} ||= delete $attrs->{cols} if exists $attrs->{cols};
- if ($attrs->{columns}) {
- delete $attrs->{as};
- } elsif (!$attrs->{select}) {
- $attrs->{columns} = [ $source->columns ];
+ my @colbits;
+
+ # build columns (as long as select isn't set) into a set of as/select hashes
+ unless ( $attrs->{select} ) {
+ @colbits = map {
+ ( ref($_) eq 'HASH' ) ? $_
+ : {
+ (
+ /^\Q${alias}.\E(.+)$/ ? $1
+ : $_
+ ) => ( /\./ ? $_ : "${alias}.$_" )
+ }
+ } ( ref($attrs->{columns}) eq 'ARRAY' ) ? @{ delete $attrs->{columns}} : (delete $attrs->{columns} || $source->columns );
}
-
- $attrs->{select} =
- ($attrs->{select}
- ? (ref $attrs->{select} eq 'ARRAY'
- ? [ @{$attrs->{select}} ]
- : [ $attrs->{select} ])
- : [ map { m/\./ ? $_ : "${alias}.$_" } @{delete $attrs->{columns}} ]
+ # add the additional columns on
+ foreach ( 'include_columns', '+columns' ) {
+ push @colbits, map {
+ ( ref($_) eq 'HASH' )
+ ? $_
+ : { ( split( /\./, $_ ) )[-1] => ( /\./ ? $_ : "${alias}.$_" ) }
+ } ( ref($attrs->{$_}) eq 'ARRAY' ) ? @{ delete $attrs->{$_} } : delete $attrs->{$_} if ( $attrs->{$_} );
+ }
+
+ # start with initial select items
+ if ( $attrs->{select} ) {
+ $attrs->{select} =
+ ( ref $attrs->{select} eq 'ARRAY' )
+ ? [ @{ $attrs->{select} } ]
+ : [ $attrs->{select} ];
+ $attrs->{as} = (
+ $attrs->{as}
+ ? (
+ ref $attrs->{as} eq 'ARRAY'
+ ? [ @{ $attrs->{as} } ]
+ : [ $attrs->{as} ]
+ )
+ : [ map { m/^\Q${alias}.\E(.+)$/ ? $1 : $_ } @{ $attrs->{select} } ]
);
- $attrs->{as} =
- ($attrs->{as}
- ? (ref $attrs->{as} eq 'ARRAY'
- ? [ @{$attrs->{as}} ]
- : [ $attrs->{as} ])
- : [ map { m/^\Q${alias}.\E(.+)$/ ? $1 : $_ } @{$attrs->{select}} ]
- );
-
+ }
+ else {
+
+ # otherwise we intialise select & as to empty
+ $attrs->{select} = [];
+ $attrs->{as} = [];
+ }
+
+ # now add colbits to select/as
+ push( @{ $attrs->{select} }, map { values( %{$_} ) } @colbits );
+ push( @{ $attrs->{as} }, map { keys( %{$_} ) } @colbits );
+
my $adds;
- if ($adds = delete $attrs->{include_columns}) {
+ if ( $adds = delete $attrs->{'+select'} ) {
$adds = [$adds] unless ref $adds eq 'ARRAY';
- push(@{$attrs->{select}}, @$adds);
- push(@{$attrs->{as}}, map { m/([^.]+)$/; $1 } @$adds);
+ push(
+ @{ $attrs->{select} },
+ map { /\./ || ref $_ ? $_ : "${alias}.$_" } @$adds
+ );
}
- if ($adds = delete $attrs->{'+select'}) {
+ if ( $adds = delete $attrs->{'+as'} ) {
$adds = [$adds] unless ref $adds eq 'ARRAY';
- push(@{$attrs->{select}},
- map { /\./ || ref $_ ? $_ : "${alias}.$_" } @$adds);
+ push( @{ $attrs->{as} }, @$adds );
}
- if (my $adds = delete $attrs->{'+as'}) {
- $adds = [$adds] unless ref $adds eq 'ARRAY';
- push(@{$attrs->{as}}, @$adds);
- }
- $attrs->{from} ||= [ { 'me' => $source->from } ];
+ $attrs->{from} ||= [ { $self->{attrs}{alias} => $source->from } ];
- if (exists $attrs->{join} || exists $attrs->{prefetch}) {
+ if ( exists $attrs->{join} || exists $attrs->{prefetch} ) {
my $join = delete $attrs->{join} || {};
- if (defined $attrs->{prefetch}) {
- $join = $self->_merge_attr(
- $join, $attrs->{prefetch}
- );
-
+ if ( defined $attrs->{prefetch} ) {
+ $join = $self->_merge_attr( $join, $attrs->{prefetch} );
+
}
- $attrs->{from} = # have to copy here to avoid corrupting the original
+ $attrs->{from} = # have to copy here to avoid corrupting the original
[
- @{$attrs->{from}},
- $source->resolve_join($join, $alias, { %{$attrs->{seen_join}||{}} })
+ @{ $attrs->{from} },
+ $source->resolve_join(
+ $join, $alias, { %{ $attrs->{seen_join} || {} } }
+ )
];
}
- $attrs->{group_by} ||= $attrs->{select} if delete $attrs->{distinct};
- if ($attrs->{order_by}) {
- $attrs->{order_by} = (ref($attrs->{order_by}) eq 'ARRAY'
- ? [ @{$attrs->{order_by}} ]
- : [ $attrs->{order_by} ]);
- } else {
- $attrs->{order_by} = [];
+ $attrs->{group_by} ||= $attrs->{select}
+ if delete $attrs->{distinct};
+ if ( $attrs->{order_by} ) {
+ $attrs->{order_by} = (
+ ref( $attrs->{order_by} ) eq 'ARRAY'
+ ? [ @{ $attrs->{order_by} } ]
+ : [ $attrs->{order_by} ]
+ );
}
+ else {
+ $attrs->{order_by} = [];
+ }
my $collapse = $attrs->{collapse} || {};
- if (my $prefetch = delete $attrs->{prefetch}) {
- $prefetch = $self->_merge_attr({}, $prefetch);
+ if ( my $prefetch = delete $attrs->{prefetch} ) {
+ $prefetch = $self->_merge_attr( {}, $prefetch );
my @pre_order;
- my $seen = $attrs->{seen_join} || {};
- foreach my $p (ref $prefetch eq 'ARRAY' ? @$prefetch : ($prefetch)) {
+ my $seen = { %{ $attrs->{seen_join} || {} } };
+ foreach my $p ( ref $prefetch eq 'ARRAY' ? @$prefetch : ($prefetch) ) {
+
# bring joins back to level of current class
- my @prefetch = $source->resolve_prefetch(
- $p, $alias, $seen, \@pre_order, $collapse
- );
- push(@{$attrs->{select}}, map { $_->[0] } @prefetch);
- push(@{$attrs->{as}}, map { $_->[1] } @prefetch);
+ my @prefetch =
+ $source->resolve_prefetch( $p, $alias, $seen, \@pre_order, $collapse );
+ push( @{ $attrs->{select} }, map { $_->[0] } @prefetch );
+ push( @{ $attrs->{as} }, map { $_->[1] } @prefetch );
}
- push(@{$attrs->{order_by}}, @pre_order);
+ push( @{ $attrs->{order_by} }, @pre_order );
}
$attrs->{collapse} = $collapse;
- if ($attrs->{page}) {
+ if ( $attrs->{page} ) {
$attrs->{offset} ||= 0;
- $attrs->{offset} += ($attrs->{rows} * ($attrs->{page} - 1));
+ $attrs->{offset} += ( $attrs->{rows} * ( $attrs->{page} - 1 ) );
}
return $self->{_attrs} = $attrs;
@@ -2158,44 +2474,44 @@
}
sub _merge_attr {
- my ($self, $a, $b) = @_;
+ my ($self, $orig, $import) = @_;
- return $b unless defined($a);
- return $a unless defined($b);
+ return $import unless defined($orig);
+ return $orig unless defined($import);
- $a = $self->_rollout_attr($a);
- $b = $self->_rollout_attr($b);
+ $orig = $self->_rollout_attr($orig);
+ $import = $self->_rollout_attr($import);
my $seen_keys;
- foreach my $b_element ( @{$b} ) {
- # find best candidate from $a to merge $b_element into
+ foreach my $import_element ( @{$import} ) {
+ # find best candidate from $orig to merge $b_element into
my $best_candidate = { position => undef, score => 0 }; my $position = 0;
- foreach my $a_element ( @{$a} ) {
- my $score = $self->_calculate_score( $a_element, $b_element );
+ foreach my $orig_element ( @{$orig} ) {
+ my $score = $self->_calculate_score( $orig_element, $import_element );
if ($score > $best_candidate->{score}) {
$best_candidate->{position} = $position;
$best_candidate->{score} = $score;
}
$position++;
}
- my ($b_key) = ( ref $b_element eq 'HASH' ) ? keys %{$b_element} : ($b_element);
+ my ($import_key) = ( ref $import_element eq 'HASH' ) ? keys %{$import_element} : ($import_element);
- if ($best_candidate->{score} == 0 || exists $seen_keys->{$b_key}) {
- push( @{$a}, $b_element );
+ if ($best_candidate->{score} == 0 || exists $seen_keys->{$import_key}) {
+ push( @{$orig}, $import_element );
} else {
- my $a_best = $a->[$best_candidate->{position}];
- # merge a_best and b_element together and replace original with merged
- if (ref $a_best ne 'HASH') {
- $a->[$best_candidate->{position}] = $b_element;
- } elsif (ref $b_element eq 'HASH') {
- my ($key) = keys %{$a_best};
- $a->[$best_candidate->{position}] = { $key => $self->_merge_attr($a_best->{$key}, $b_element->{$key}) };
+ my $orig_best = $orig->[$best_candidate->{position}];
+ # merge orig_best and b_element together and replace original with merged
+ if (ref $orig_best ne 'HASH') {
+ $orig->[$best_candidate->{position}] = $import_element;
+ } elsif (ref $import_element eq 'HASH') {
+ my ($key) = keys %{$orig_best};
+ $orig->[$best_candidate->{position}] = { $key => $self->_merge_attr($orig_best->{$key}, $import_element->{$key}) };
}
}
- $seen_keys->{$b_key} = 1; # don't merge the same key twice
+ $seen_keys->{$import_key} = 1; # don't merge the same key twice
}
- return $a;
+ return $orig;
}
sub result_source {
@@ -2228,9 +2544,13 @@
=head1 ATTRIBUTES
-The resultset takes various attributes that modify its behavior. Here's an
-overview of them:
+Attributes are used to refine a ResultSet in various ways when
+searching for data. They can be passed to any method which takes an
+C<\%attrs> argument. See L</search>, L</search_rs>, L</find>,
+L</count>.
+These are in no particular order:
+
=head2 order_by
=over 4
@@ -2248,6 +2568,10 @@
specify an order. (The scalar ref causes it to be passed as raw sql to the DB,
so you will need to manually quote things as appropriate.)
+If your L<SQL::Abstract> version supports it (>=1.50), you can also use
+C<{-desc => 'year'}>, which takes care of the quoting for you. This is the
+recommended syntax.
+
=head2 columns
=over 4
@@ -2256,12 +2580,15 @@
=back
-Shortcut to request a particular set of columns to be retrieved. Adds
-C<me.> onto the start of any column without a C<.> in it and sets C<select>
-from that, then auto-populates C<as> from C<select> as normal. (You may also
-use the C<cols> attribute, as in earlier versions of DBIC.)
+Shortcut to request a particular set of columns to be retrieved. Each
+column spec may be a string (a table column name), or a hash (in which
+case the key is the C<as> value, and the value is used as the C<select>
+expression). Adds C<me.> onto the start of any column without a C<.> in
+it and sets C<select> from that, then auto-populates C<as> from
+C<select> as normal. (You may also use the C<cols> attribute, as in
+earlier versions of DBIC.)
-=head2 include_columns
+=head2 +columns
=over 4
@@ -2269,10 +2596,13 @@
=back
-Shortcut to include additional columns in the returned results - for example
+Indicates additional columns to be selected from storage. Works the same
+as L</columns> but adds columns to the selection. (You may also use the
+C<include_columns> attribute, as in earlier versions of DBIC). For
+example:-
$schema->resultset('CD')->search(undef, {
- include_columns => ['artist.name'],
+ '+columns' => ['artist.name'],
join => ['artist']
});
@@ -2281,6 +2611,16 @@
column (or relationship) accessor, and 'name' is the name of the column
accessor in the related table.
+=head2 include_columns
+
+=over 4
+
+=item Value: \@columns
+
+=back
+
+Deprecated. Acts as a synonym for L</+columns> for backward compatibility.
+
=head2 select
=over 4
@@ -2318,7 +2658,7 @@
=over 4
-Indicates additional column names for those added via L</+select>.
+Indicates additional column names for those added via L</+select>. See L</as>.
=back
@@ -2708,6 +3048,58 @@
# SELECT child.* FROM person child
# INNER JOIN person father ON child.father_id = father.id
+If you need to express really complex joins or you need a subselect, you
+can supply literal SQL to C<from> via a scalar reference. In this case
+the contents of the scalar will replace the table name asscoiated with the
+resultsource.
+
+WARNING: This technique might very well not work as expected on chained
+searches - you have been warned.
+
+ # Assuming the Event resultsource is defined as:
+
+ MySchema::Event->add_columns (
+ sequence => {
+ data_type => 'INT',
+ is_auto_increment => 1,
+ },
+ location => {
+ data_type => 'INT',
+ },
+ type => {
+ data_type => 'INT',
+ },
+ );
+ MySchema::Event->set_primary_key ('sequence');
+
+ # This will get back the latest event for every location. The column
+ # selector is still provided by DBIC, all we do is add a JOIN/WHERE
+ # combo to limit the resultset
+
+ $rs = $schema->resultset('Event');
+ $table = $rs->result_source->name;
+ $latest = $rs->search (
+ undef,
+ { from => \ "
+ (SELECT e1.* FROM $table e1
+ JOIN $table e2
+ ON e1.location = e2.location
+ AND e1.sequence < e2.sequence
+ WHERE e2.sequence is NULL
+ ) me",
+ },
+ );
+
+ # Equivalent SQL (with the DBIC chunks added):
+
+ SELECT me.sequence, me.location, me.type FROM
+ (SELECT e1.* FROM events e1
+ JOIN events e2
+ ON e1.location = e2.location
+ AND e1.sequence < e2.sequence
+ WHERE e2.sequence is NULL
+ ) me;
+
=head2 for
=over 4
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSetColumn.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSetColumn.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSetColumn.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -2,6 +2,7 @@
use strict;
use warnings;
use base 'DBIx::Class';
+use List::Util;
=head1 NAME
@@ -36,12 +37,41 @@
my ($class, $rs, $column) = @_;
$class = ref $class if ref $class;
my $new_parent_rs = $rs->search_rs; # we don't want to mess up the original, so clone it
- $new_parent_rs->{attrs}->{prefetch} = undef; # prefetch causes additional columns to be fetched
- my $new = bless { _column => $column, _parent_resultset => $new_parent_rs }, $class;
+ my $attrs = $new_parent_rs->_resolved_attrs;
+ $new_parent_rs->{attrs}->{$_} = undef for qw(prefetch include_columns +select +as); # prefetch, include_columns, +select, +as cause additional columns to be fetched
+
+ # If $column can be found in the 'as' list of the parent resultset, use the
+ # corresponding element of its 'select' list (to keep any custom column
+ # definition set up with 'select' or '+select' attrs), otherwise use $column
+ # (to create a new column definition on-the-fly).
+ my $as_list = $attrs->{as} || [];
+ my $select_list = $attrs->{select} || [];
+ my $as_index = List::Util::first { ($as_list->[$_] || "") eq $column } 0..$#$as_list;
+ my $select = defined $as_index ? $select_list->[$as_index] : $column;
+
+ my $new = bless { _select => $select, _as => $column, _parent_resultset => $new_parent_rs }, $class;
$new->throw_exception("column must be supplied") unless $column;
return $new;
}
+=head2 as_query
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: \[ $sql, @bind ]
+
+=back
+
+Returns the SQL query and bind vars associated with the invocant.
+
+This is generally used as the RHS for a subquery.
+
+=cut
+
+sub as_query { return shift->_resultset->as_query }
+
=head2 next
=over 4
@@ -62,8 +92,7 @@
sub next {
my $self = shift;
- $self->{_resultset} = $self->{_parent_resultset}->search(undef, {select => [$self->{_column}], as => [$self->{_column}]}) unless ($self->{_resultset});
- my ($row) = $self->{_resultset}->cursor->next;
+ my ($row) = $self->_resultset->cursor->next;
return $row;
}
@@ -87,9 +116,55 @@
sub all {
my $self = shift;
- return map {$_->[0]} $self->{_parent_resultset}->search(undef, {select => [$self->{_column}], as => [$self->{_column}]})->cursor->all;
+ return map { $_->[0] } $self->_resultset->cursor->all;
}
+=head2 reset
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: $self
+
+=back
+
+Resets the underlying resultset's cursor, so you can iterate through the
+elements of the column again.
+
+Much like L<DBIx::Class::ResultSet/reset>.
+
+=cut
+
+sub reset {
+ my $self = shift;
+ $self->_resultset->cursor->reset;
+ return $self;
+}
+
+=head2 first
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: $value
+
+=back
+
+Resets the underlying resultset and returns the next value of the column in the
+resultset (or C<undef> if there is none).
+
+Much like L<DBIx::Class::ResultSet/first> but just returning the one value.
+
+=cut
+
+sub first {
+ my $self = shift;
+ my ($row) = $self->_resultset->cursor->reset->next;
+ return $row;
+}
+
=head2 min
=over 4
@@ -111,6 +186,24 @@
return shift->func('MIN');
}
+=head2 min_rs
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: $resultset
+
+=back
+
+ my $rs = $year_col->min_rs();
+
+Wrapper for ->func_rs for function MIN().
+
+=cut
+
+sub min_rs { return shift->func_rs('MIN') }
+
=head2 max
=over 4
@@ -132,6 +225,24 @@
return shift->func('MAX');
}
+=head2 max_rs
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: $resultset
+
+=back
+
+ my $rs = $year_col->max_rs();
+
+Wrapper for ->func_rs for function MAX().
+
+=cut
+
+sub max_rs { return shift->func_rs('MAX') }
+
=head2 sum
=over 4
@@ -153,6 +264,24 @@
return shift->func('SUM');
}
+=head2 sum_rs
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: $resultset
+
+=back
+
+ my $rs = $year_col->sum_rs();
+
+Wrapper for ->func_rs for function SUM().
+
+=cut
+
+sub sum_rs { return shift->func_rs('SUM') }
+
=head2 func
=over 4
@@ -175,7 +304,7 @@
sub func {
my ($self,$function) = @_;
- my $cursor = $self->{_parent_resultset}->search(undef, {select => {$function => $self->{_column}}, as => [$self->{_column}]})->cursor;
+ my $cursor = $self->func_rs($function)->cursor;
if( wantarray ) {
return map { $_->[ 0 ] } $cursor->all;
@@ -184,6 +313,67 @@
return ( $cursor->next )[ 0 ];
}
+=head2 func_rs
+
+=over 4
+
+=item Arguments: $function
+
+=item Return Value: $resultset
+
+=back
+
+Creates the resultset that C<func()> uses to run its query.
+
+=cut
+
+sub func_rs {
+ my ($self,$function) = @_;
+ return $self->{_parent_resultset}->search(
+ undef, {
+ select => {$function => $self->{_select}},
+ as => [$self->{_as}],
+ },
+ );
+}
+
+=head2 throw_exception
+
+See L<DBIx::Class::Schema/throw_exception> for details.
+
+=cut
+
+sub throw_exception {
+ my $self=shift;
+ if (ref $self && $self->{_parent_resultset}) {
+ $self->{_parent_resultset}->throw_exception(@_)
+ } else {
+ croak(@_);
+ }
+}
+
+# _resultset
+#
+# Arguments: none
+#
+# Return Value: $resultset
+#
+# $year_col->_resultset->next
+#
+# Returns the underlying resultset. Creates it from the parent resultset if
+# necessary.
+#
+sub _resultset {
+ my $self = shift;
+
+ return $self->{_resultset} ||= $self->{_parent_resultset}->search(undef,
+ {
+ select => [$self->{_select}],
+ as => [$self->{_as}]
+ }
+ );
+}
+
1;
=head1 AUTHORS
Added: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSource/View.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSource/View.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSource/View.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,123 @@
+package DBIx::Class::ResultSource::View;
+
+use strict;
+use warnings;
+
+use DBIx::Class::ResultSet;
+
+use base qw/DBIx::Class/;
+__PACKAGE__->load_components(qw/ResultSource/);
+__PACKAGE__->mk_group_accessors(
+ 'simple' => qw(is_virtual view_definition)
+);
+
+=head1 NAME
+
+DBIx::Class::ResultSource::View - ResultSource object representing a view
+
+=head1 SYNOPSIS
+
+ package MyDB::Schema::Year2000CDs;
+
+ use DBIx::Class::ResultSource::View;
+
+ __PACKAGE__->load_components('Core');
+ __PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+
+ __PACKAGE__->table('year2000cds');
+ __PACKAGE__->result_source_instance->is_virtual(1);
+ __PACKAGE__->result_source_instance->view_definition(
+ "SELECT cdid, artist, title FROM cd WHERE year ='2000'"
+ );
+
+=head1 DESCRIPTION
+
+View object that inherits from L<DBIx::Class::ResultSource>
+
+This class extends ResultSource to add basic view support.
+
+A view has a L</view_definition>, which contains an SQL query. The
+query cannot have parameters. It may contain JOINs, sub selects and
+any other SQL your database supports.
+
+View definition SQL is deployed to your database on
+L<DBIx::Class::Schema/deploy> unless you set L</is_virtual> to true.
+
+Deploying the view does B<not> translate it between different database
+syntaxes, so be careful what you write in your view SQL.
+
+Virtual views (L</is_virtual> unset or false), are assumed to not
+exist in your database as a real view. The L</view_definition> in this
+case replaces the view name in a FROM clause in a subselect.
+
+=head1 SQL EXAMPLES
+
+=over
+
+=item is_virtual set to true
+
+ $schema->resultset('Year2000CDs')->all();
+
+ SELECT cdid, artist, title FROM year2000cds me
+
+=item is_virtual set to false
+
+ $schema->resultset('Year2000CDs')->all();
+
+ SELECT cdid, artist, title FROM
+ (SELECT cdid, artist, title FROM cd WHERE year ='2000') me
+
+=back
+
+=head1 METHODS
+
+=head2 is_virtual
+
+ __PACKAGE__->result_source_instance->is_virtual(1);
+
+Set to true for a virtual view, false or unset for a real
+database-based view.
+
+=head2 view_definition
+
+ __PACKAGE__->result_source_instance->view_definition(
+ "SELECT cdid, artist, title FROM cd WHERE year ='2000'"
+ );
+
+An SQL query for your view. Will not be translated across database
+syntaxes.
+
+
+=head1 OVERRIDDEN METHODS
+
+=head2 from
+
+Returns the FROM entry for the table (i.e. the view name)
+or the SQL as a subselect if this is a virtual view.
+
+=cut
+
+sub from {
+ my $self = shift;
+ return \"(${\$self->view_definition})" if $self->is_virtual;
+ return $self->name;
+}
+
+1;
+
+=head1 AUTHORS
+
+Matt S. Trout <mst at shadowcatsystems.co.uk>
+
+With Contributions from:
+
+Guillermo Roditi E<lt>groditi at cpan.orgE<gt>
+
+Jess Robinson <castaway at desert-island.me.uk>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSource.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSource.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSource.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -13,7 +13,7 @@
__PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
_columns _primaries _unique_constraints name resultset_attributes
schema from _relationships column_info_from_storage source_info
- source_name/);
+ source_name sqlt_deploy_callback/);
__PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
result_class/);
@@ -29,18 +29,12 @@
A ResultSource is a component of a schema from which results can be directly
retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
+Basic view support also exists, see L<<DBIx::Class::ResultSource::View>.
+
=head1 METHODS
=pod
-=head2 new
-
- $class->new();
-
- $class->new({attribute_name => value});
-
-Creates a new ResultSource object. Not normally called directly by end users.
-
=cut
sub new {
@@ -55,34 +49,32 @@
$new->{_relationships} = { %{$new->{_relationships}||{}} };
$new->{name} ||= "!!NAME NOT SET!!";
$new->{_columns_info_loaded} ||= 0;
+ $new->{sqlt_deploy_callback} ||= "default_sqlt_deploy_hook";
return $new;
}
=pod
-=head2 source_info
+=head2 add_columns
-Stores a hashref of per-source metadata. No specific key names
-have yet been standardized, the examples below are purely hypothetical
-and don't actually accomplish anything on their own:
+=over
- __PACKAGE__->source_info({
- "_tablespace" => 'fast_disk_array_3',
- "_engine" => 'InnoDB',
- });
+=item Arguments: @columns
-=head2 add_columns
+=item Return value: The ResultSource object
- $table->add_columns(qw/col1 col2 col3/);
+=back
- $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
+ $source->add_columns(qw/col1 col2 col3/);
+ $source->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
+
Adds columns to the result source. If supplied key => hashref pairs, uses
the hashref as the column_info for that column. Repeated calls of this
method will add more columns, not replace them.
The column names given will be created as accessor methods on your
-L<DBIx::Class::Row> objects, you can change the name of the accessor
+L<DBIx::Class::Row> objects. You can change the name of the accessor
by supplying an L</accessor> in the column_info hash.
The contents of the column_info are not set in stone. The following
@@ -146,7 +138,7 @@
=item auto_nextval
Set this to a true value for a column whose value is retrieved
-automatically from an oracle sequence. If you do not use an oracle
+automatically from an oracle sequence. If you do not use an Oracle
trigger to get the nextval, you have to set sequence as well.
=item extra
@@ -161,10 +153,19 @@
=head2 add_column
- $table->add_column('col' => \%info?);
+=over
-Convenience alias to add_columns.
+=item Arguments: $colname, [ \%columninfo ]
+=item Return value: 1/0 (true/false)
+
+=back
+
+ $source->add_column('col' => \%info?);
+
+Add a single column and optional column info. Uses the same column
+info keys as L</add_columns>.
+
=cut
sub add_columns {
@@ -188,8 +189,16 @@
=head2 has_column
- if ($obj->has_column($col)) { ... }
+=over
+=item Arguments: $colname
+
+=item Return value: 1/0 (true/false)
+
+=back
+
+ if ($source->has_column($colname)) { ... }
+
Returns true if the source has a column of this name, false otherwise.
=cut
@@ -201,11 +210,20 @@
=head2 column_info
- my $info = $obj->column_info($col);
+=over
-Returns the column metadata hashref for a column. See the description
-of add_column for information on the contents of the hashref.
+=item Arguments: $colname
+=item Return value: Hashref of info
+
+=back
+
+ my $info = $source->column_info($col);
+
+Returns the column metadata hashref for a column, as originally passed
+to L</add_columns>. See the description of L</add_columns> for information
+on the contents of the hashref.
+
=cut
sub column_info {
@@ -238,20 +256,20 @@
return $self->_columns->{$column};
}
-=head2 column_info_from_storage
+=head2 columns
-Enables the on-demand automatic loading of the above column
-metadata from storage as neccesary. This is *deprecated*, and
-should not be used. It will be removed before 1.0.
+=over
- __PACKAGE__->column_info_from_storage(1);
+=item Arguments: None
-=head2 columns
+=item Return value: Ordered list of column names
- my @column_names = $obj->columns;
+=back
-Returns all column names in the order they were declared to add_columns.
+ my @column_names = $source->columns;
+Returns all column names in the order they were declared to L</add_columns>.
+
=cut
sub columns {
@@ -264,35 +282,56 @@
=head2 remove_columns
- $table->remove_columns(qw/col1 col2 col3/);
+=over
-Removes columns from the result source.
+=item Arguments: @colnames
+=item Return value: undefined
+
+=back
+
+ $source->remove_columns(qw/col1 col2 col3/);
+
+Removes the given list of columns by name, from the result source.
+
+B<Warning>: Removing a column that is also used in the sources primary
+key, or in one of the sources unique constraints, B<will> result in a
+broken result source.
+
=head2 remove_column
- $table->remove_column('col');
+=over
-Convenience alias to remove_columns.
+=item Arguments: $colname
+=item Return value: undefined
+
+=back
+
+ $source->remove_column('col');
+
+Remove a single column by name from the result source, similar to
+L</remove_columns>.
+
+B<Warning>: Removing a column that is also used in the sources primary
+key, or in one of the sources unique constraints, B<will> result in a
+broken result source.
+
=cut
sub remove_columns {
- my ($self, @cols) = @_;
+ my ($self, @to_remove) = @_;
- return unless $self->_ordered_columns;
+ my $columns = $self->_columns
+ or return;
- my $columns = $self->_columns;
- my @remaining;
-
- foreach my $col (@{$self->_ordered_columns}) {
- push @remaining, $col unless grep(/$col/, @cols);
+ my %to_remove;
+ for (@to_remove) {
+ delete $columns->{$_};
+ ++$to_remove{$_};
}
- foreach (@cols) {
- delete $columns->{$_};
- };
-
- $self->_ordered_columns(\@remaining);
+ $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]);
}
sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
@@ -303,12 +342,15 @@
=item Arguments: @cols
+=item Return value: undefined
+
=back
Defines one or more columns as primary key for this source. Should be
-called after C<add_columns>.
+called after L</add_columns>.
-Additionally, defines a unique constraint named C<primary>.
+Additionally, defines a L<unique constraint|add_unique_constraint>
+named C<primary>.
The primary key columns are used by L<DBIx::Class::PK::Auto> to
retrieve automatically created values from the database.
@@ -329,8 +371,17 @@
=head2 primary_columns
-Read-only accessor which returns the list of primary keys.
+=over 4
+=item Arguments: None
+
+=item Return value: Ordered list of primary column names
+
+=back
+
+Read-only accessor which returns the list of primary keys, supplied by
+L</set_primary_key>.
+
=cut
sub primary_columns {
@@ -339,6 +390,14 @@
=head2 add_unique_constraint
+=over 4
+
+=item Arguments: [ $name ], \@colnames
+
+=item Return value: undefined
+
+=back
+
Declare a unique constraint on this source. Call once for each unique
constraint.
@@ -357,6 +416,9 @@
Unique constraints are used, for example, when you call
L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
+Throws an error if any of the given column names do not yet exist on
+the result source.
+
=cut
sub add_unique_constraint {
@@ -378,12 +440,29 @@
=head2 name_unique_constraint
-Return a name for a unique constraint containing the specified columns. These
-names consist of the table name and each column name, separated by underscores.
+=over 4
+=item Arguments: @colnames
+
+=item Return value: Constraint name
+
+=back
+
+ $source->table('mytable');
+ $source->name_unique_constraint('col1', 'col2');
+ # returns
+ 'mytable_col1_col2'
+
+Return a name for a unique constraint containing the specified
+columns. The name is created by joining the table name and each column
+name, using an underscore character.
+
For example, a constraint on a table named C<cd> containing the columns
C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
+This is used by L</add_unique_constraint> if you do not specify the
+optional constraint name.
+
=cut
sub name_unique_constraint {
@@ -394,8 +473,21 @@
=head2 unique_constraints
-Read-only accessor which returns the list of unique constraints on this source.
+=over 4
+=item Arguments: None
+
+=item Return value: Hash of unique constraint data
+
+=back
+
+ $source->unique_constraints();
+
+Read-only accessor which returns a hash of unique constraints on this source.
+
+The hash is keyed by constraint name, and contains an arrayref of
+column names as values.
+
=cut
sub unique_constraints {
@@ -404,6 +496,16 @@
=head2 unique_constraint_names
+=over 4
+
+=item Arguments: None
+
+=item Return value: Unique constraint names
+
+=back
+
+ $source->unique_constraint_names();
+
Returns the list of unique constraint names defined on this source.
=cut
@@ -418,6 +520,16 @@
=head2 unique_constraint_columns
+=over 4
+
+=item Arguments: $constraintname
+
+=item Return value: List of constraint columns
+
+=back
+
+ $source->unique_constraint_columns('myconstraint');
+
Returns the list of columns that make up the specified unique constraint.
=cut
@@ -434,19 +546,214 @@
return @{ $unique_constraints{$constraint_name} };
}
+=head2 sqlt_deploy_callback
+
+=over
+
+=item Arguments: $callback
+
+=back
+
+ __PACKAGE__->sqlt_deploy_callback('mycallbackmethod');
+
+An accessor to set a callback to be called during deployment of
+the schema via L<DBIx::Class::Schema/create_ddl_dir> or
+L<DBIx::Class::Schema/deploy>.
+
+The callback can be set as either a code reference or the name of a
+method in the current result class.
+
+If not set, the L</default_sqlt_deploy_hook> is called.
+
+Your callback will be passed the $source object representing the
+ResultSource instance being deployed, and the
+L<SQL::Translator::Schema::Table> object being created from it. The
+callback can be used to manipulate the table object or add your own
+customised indexes. If you need to manipulate a non-table object, use
+the L<DBIx::Class::Schema/sqlt_deploy_hook>.
+
+See L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To
+Your SQL> for examples.
+
+This sqlt deployment callback can only be used to manipulate
+SQL::Translator objects as they get turned into SQL. To execute
+post-deploy statements which SQL::Translator does not currently
+handle, override L<DBIx::Class::Schema/deploy> in your Schema class
+and call L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
+
+=head2 default_sqlt_deploy_hook
+
+=over
+
+=item Arguments: $source, $sqlt_table
+
+=item Return value: undefined
+
+=back
+
+This is the sensible default for L</sqlt_deploy_callback>.
+
+If a method named C<sqlt_deploy_hook> exists in your Result class, it
+will be called and passed the current C<$source> and the
+C<$sqlt_table> being deployed.
+
+=cut
+
+sub default_sqlt_deploy_hook {
+ my $self = shift;
+
+ my $class = $self->result_class;
+
+ if ($class and $class->can('sqlt_deploy_hook')) {
+ $class->sqlt_deploy_hook(@_);
+ }
+}
+
+sub _invoke_sqlt_deploy_hook {
+ my $self = shift;
+ if ( my $hook = $self->sqlt_deploy_callback) {
+ $self->$hook(@_);
+ }
+}
+
+=head2 resultset
+
+=over 4
+
+=item Arguments: None
+
+=item Return value: $resultset
+
+=back
+
+Returns a resultset for the given source. This will initially be created
+on demand by calling
+
+ $self->resultset_class->new($self, $self->resultset_attributes)
+
+but is cached from then on unless resultset_class changes.
+
+=head2 resultset_class
+
+=over 4
+
+=item Arguments: $classname
+
+=item Return value: $classname
+
+=back
+
+ package My::ResultSetClass;
+ use base 'DBIx::Class::ResultSet';
+ ...
+
+ $source->resultset_class('My::ResultSet::Class');
+
+Set the class of the resultset. This is useful if you want to create your
+own resultset methods. Create your own class derived from
+L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
+this method returns the name of the existing resultset class, if one
+exists.
+
+=head2 resultset_attributes
+
+=over 4
+
+=item Arguments: \%attrs
+
+=item Return value: \%attrs
+
+=back
+
+ $source->resultset_attributes({ order_by => [ 'id' ] });
+
+Store a collection of resultset attributes, that will be set on every
+L<DBIx::Class::ResultSet> produced from this result source. For a full
+list see L<DBIx::Class::ResultSet/ATTRIBUTES>.
+
+=cut
+
+sub resultset {
+ my $self = shift;
+ $self->throw_exception(
+ 'resultset does not take any arguments. If you want another resultset, '.
+ 'call it on the schema instead.'
+ ) if scalar @_;
+
+ return $self->resultset_class->new(
+ $self,
+ {
+ %{$self->{resultset_attributes}},
+ %{$self->schema->default_resultset_attributes}
+ },
+ );
+}
+
+=head2 source_name
+
+=over 4
+
+=item Arguments: $source_name
+
+=item Result value: $source_name
+
+=back
+
+Set an alternate name for the result source when it is loaded into a schema.
+This is useful if you want to refer to a result source by a name other than
+its class name.
+
+ package ArchivedBooks;
+ use base qw/DBIx::Class/;
+ __PACKAGE__->table('books_archive');
+ __PACKAGE__->source_name('Books');
+
+ # from your schema...
+ $schema->resultset('Books')->find(1);
+
=head2 from
+=over 4
+
+=item Arguments: None
+
+=item Return value: FROM clause
+
+=back
+
+ my $from_clause = $source->from();
+
Returns an expression of the source to be supplied to storage to specify
retrieval from this source. In the case of a database, the required FROM
clause contents.
=head2 schema
+=over 4
+
+=item Arguments: None
+
+=item Return value: A schema object
+
+=back
+
+ my $schema = $source->schema();
+
Returns the L<DBIx::Class::Schema> object that this result source
-belongs too.
+belongs to.
=head2 storage
+=over 4
+
+=item Arguments: None
+
+=item Return value: A Storage object
+
+=back
+
+ $source->storage->debug(1);
+
Returns the storage handle for the current schema.
See also: L<DBIx::Class::Storage>
@@ -457,8 +764,20 @@
=head2 add_relationship
+=over 4
+
+=item Arguments: $relname, $related_source_name, \%cond, [ \%attrs ]
+
+=item Return value: 1/true if it succeeded
+
+=back
+
$source->add_relationship('relname', 'related_source', $cond, $attrs);
+L<DBIx::Class::Relationship> describes a series of methods which
+create pre-defined useful types of relationships. Look there first
+before using this method directly.
+
The relationship name can be arbitrary, but must be unique for each
relationship attached to this result source. 'related_source' should
be the name with which the related result source was registered with
@@ -470,7 +789,7 @@
The condition C<$cond> needs to be an L<SQL::Abstract>-style
representation of the join between the tables. For example, if you're
-creating a rel from Author to Book,
+creating a relation from Author to Book,
{ 'foreign.author_id' => 'self.id' }
@@ -517,6 +836,9 @@
=back
+Throws an exception if the condition is improperly supplied, or cannot
+be resolved using L</resolve_join>.
+
=cut
sub add_relationship {
@@ -567,6 +889,16 @@
=head2 relationships
+=over 4
+
+=item Arguments: None
+
+=item Return value: List of relationship names
+
+=back
+
+ my @relnames = $source->relationships();
+
Returns all relationship names for this source.
=cut
@@ -581,10 +913,12 @@
=item Arguments: $relname
+=item Return value: Hashref of relation data,
+
=back
Returns a hash of relationship information for the specified relationship
-name.
+name. The keys/values are as specified for L</add_relationship>.
=cut
@@ -599,6 +933,8 @@
=item Arguments: $rel
+=item Return value: 1/0 (true/false)
+
=back
Returns true if the source has a relationship of this name, false otherwise.
@@ -616,11 +952,22 @@
=item Arguments: $relname
+=item Return value: Hashref of relationship data
+
=back
-Returns an array of hash references of relationship information for
-the other side of the specified relationship name.
+Looks through all the relationships on the source this relationship
+points to, looking for one whose condition is the reverse of the
+condition on this relationship.
+A common use of this is to find the name of the C<belongs_to> relation
+opposing a C<has_many> relation. For definition of these look in
+L<DBIx::Class::Relationship>.
+
+The returned hashref is keyed by the name of the opposing
+relationship, and contains it's data in the same manner as
+L</relationship_info>.
+
=cut
sub reverse_relationship_info {
@@ -676,8 +1023,10 @@
=over 4
-=item Arguments: $keys1, $keys2
+=item Arguments: \@keys1, \@keys2
+=item Return value: 1/0 (true/false)
+
=back
Returns true if both sets of keynames are the same, false otherwise.
@@ -723,6 +1072,8 @@
=item Arguments: $relation
+=item Return value: Join condition arrayref
+
=back
Returns the join structure required for the related result source.
@@ -768,6 +1119,51 @@
}
}
+=head2 pk_depends_on
+
+=over 4
+
+=item Arguments: $relname, $rel_data
+
+=item Return value: 1/0 (true/false)
+
+=back
+
+Determines whether a relation is dependent on an object from this source
+having already been inserted. Takes the name of the relationship and a
+hashref of columns of the related object.
+
+=cut
+
+sub pk_depends_on {
+ my ($self, $relname, $rel_data) = @_;
+ my $cond = $self->relationship_info($relname)->{cond};
+
+ return 0 unless ref($cond) eq 'HASH';
+
+ # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
+
+ my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
+
+ # assume anything that references our PK probably is dependent on us
+ # rather than vice versa, unless the far side is (a) defined or (b)
+ # auto-increment
+
+ my $rel_source = $self->related_source($relname);
+
+ foreach my $p ($self->primary_columns) {
+ if (exists $keyhash->{$p}) {
+ unless (defined($rel_data->{$keyhash->{$p}})
+ || $rel_source->column_info($keyhash->{$p})
+ ->{is_auto_increment}) {
+ return 0;
+ }
+ }
+ }
+
+ return 1;
+}
+
=head2 resolve_condition
=over 4
@@ -782,6 +1178,8 @@
=cut
+our $UNRESOLVABLE_CONDITION = \'1 = 0';
+
sub resolve_condition {
my ($self, $cond, $as, $for) = @_;
#warn %$cond;
@@ -796,7 +1194,14 @@
$self->throw_exception("Invalid rel cond val ${v}");
if (ref $for) { # Object
#warn "$self $k $for $v";
- $ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
+ unless ($for->has_column_loaded($v)) {
+ if ($for->in_storage) {
+ $self->throw_exception("Column ${v} not loaded on ${for} trying to resolve relationship");
+ }
+ return $UNRESOLVABLE_CONDITION;
+ }
+ $ret{$k} = $for->get_column($v);
+ #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
#warn %ret;
} elsif (!defined $for) { # undef, i.e. "no object"
$ret{$k} = undef;
@@ -909,11 +1314,16 @@
if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
keys %{$collapse}) {
my ($last) = ($fail =~ /([^\.]+)$/);
- $self->throw_exception(
- "Can't prefetch multiple has_many rels ${last} and ${pre}"
- .(length($as_prefix) ? "at the same level (${as_prefix})"
- : "at top level"
- ));
+ carp (
+ "Prefetching multiple has_many rels ${last} and ${pre} "
+ .(length($as_prefix)
+ ? "at the same level (${as_prefix}) "
+ : "at top level "
+ )
+ . 'will currently disrupt both the functionality of $rs->count(), '
+ . 'and the amount of objects retrievable via $rs->next(). '
+ . 'Use at your own risk.'
+ );
}
#my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
# values %{$rel_info->{cond}};
@@ -943,6 +1353,8 @@
=item Arguments: $relname
+=item Return value: $source
+
=back
Returns the result source object for the given relationship.
@@ -963,6 +1375,8 @@
=item Arguments: $relname
+=item Return value: $classname
+
=back
Returns the class name for objects in the given relationship.
@@ -977,75 +1391,6 @@
return $self->schema->class($self->relationship_info($rel)->{source});
}
-=head2 resultset
-
-Returns a resultset for the given source. This will initially be created
-on demand by calling
-
- $self->resultset_class->new($self, $self->resultset_attributes)
-
-but is cached from then on unless resultset_class changes.
-
-=head2 resultset_class
-
-` package My::ResultSetClass;
- use base 'DBIx::Class::ResultSet';
- ...
-
- $source->resultset_class('My::ResultSet::Class');
-
-Set the class of the resultset, this is useful if you want to create your
-own resultset methods. Create your own class derived from
-L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
-this method returns the name of the existing resultset class, if one
-exists.
-
-=head2 resultset_attributes
-
- $source->resultset_attributes({ order_by => [ 'id' ] });
-
-Specify here any attributes you wish to pass to your specialised
-resultset. For a full list of these, please see
-L<DBIx::Class::ResultSet/ATTRIBUTES>.
-
-=cut
-
-sub resultset {
- my $self = shift;
- $self->throw_exception(
- 'resultset does not take any arguments. If you want another resultset, '.
- 'call it on the schema instead.'
- ) if scalar @_;
-
- return $self->resultset_class->new(
- $self,
- {
- %{$self->{resultset_attributes}},
- %{$self->schema->default_resultset_attributes}
- },
- );
-}
-
-=head2 source_name
-
-=over 4
-
-=item Arguments: $source_name
-
-=back
-
-Set the name of the result source when it is loaded into a schema.
-This is usefull if you want to refer to a result source by a name other than
-its class name.
-
- package ArchivedBooks;
- use base qw/DBIx::Class/;
- __PACKAGE__->table('books_archive');
- __PACKAGE__->source_name('Books');
-
- # from your schema...
- $schema->resultset('Books')->find(1);
-
=head2 handle
Obtain a new handle to this source. Returns an instance of a
@@ -1075,15 +1420,42 @@
}
}
-=head2 sqlt_deploy_hook($sqlt_table)
+=head2 source_info
-An optional sub which you can declare in your own Schema class that will get
-passed the L<SQL::Translator::Schema::Table> object when you deploy the schema
-via L</create_ddl_dir> or L</deploy>.
+Stores a hashref of per-source metadata. No specific key names
+have yet been standardized, the examples below are purely hypothetical
+and don't actually accomplish anything on their own:
-For an example of what you can do with this, see
-L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
+ __PACKAGE__->source_info({
+ "_tablespace" => 'fast_disk_array_3',
+ "_engine" => 'InnoDB',
+ });
+=head2 new
+
+ $class->new();
+
+ $class->new({attribute_name => value});
+
+Creates a new ResultSource object. Not normally called directly by end users.
+
+=head2 column_info_from_storage
+
+=over
+
+=item Arguments: 1/0 (default: 0)
+
+=item Return value: 1/0
+
+=back
+
+ __PACKAGE__->column_info_from_storage(1);
+
+Enables the on-demand automatic loading of the above column
+metadata from storage as neccesary. This is *deprecated*, and
+should not be used. It will be removed before 1.0.
+
+
=head1 AUTHORS
Matt S. Trout <mst at shadowcatsystems.co.uk>
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSourceProxy/Table.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSourceProxy/Table.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/ResultSourceProxy/Table.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -40,11 +40,6 @@
$class->result_source_instance($table);
- if ($class->can('schema_instance')) {
- $class =~ m/([^:]+)$/;
- $class->schema_instance->register_class($class, $class);
- }
-
return $table;
}
@@ -95,10 +90,6 @@
$class->result_source_instance($table);
- if ($class->can('schema_instance')) {
- $class =~ m/([^:]+)$/;
- $class->schema_instance->register_class($class, $class);
- }
return $class->result_source_instance->name;
}
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Row.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Row.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Row.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -8,6 +8,13 @@
use Scalar::Util ();
use Scope::Guard;
+BEGIN {
+ *MULTICREATE_DEBUG =
+ $ENV{DBIC_MULTICREATE_DEBUG}
+ ? sub () { 1 }
+ : sub () { 0 };
+}
+
__PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
=head1 NAME
@@ -21,14 +28,43 @@
This class is responsible for defining and doing basic operations on rows
derived from L<DBIx::Class::ResultSource> objects.
+Row objects are returned from L<DBIx::Class::ResultSet>s using the
+L<create|DBIx::Class::ResultSet/create>, L<find|DBIx::Class::ResultSet/find>,
+L<next|DBIx::Class::ResultSet/next> and L<all|DBIx::Class::ResultSet/all> methods,
+as well as invocations of 'single' (
+L<belongs_to|DBIx::Class::Relationship/belongs_to>,
+L<has_one|DBIx::Class::Relationship/has_one> or
+L<might_have|DBIx::Class::Relationship/might_have>)
+relationship accessors of L<DBIx::Class::Row> objects.
+
=head1 METHODS
=head2 new
- my $obj = My::Class->new($attrs);
+ my $row = My::Class->new(\%attrs);
-Creates a new row object from column => value mappings passed as a hash ref
+ my $row = $schema->resultset('MySource')->new(\%colsandvalues);
+=over
+
+=item Arguments: \%attrs or \%colsandvalues
+
+=item Returns: A Row object
+
+=back
+
+While you can create a new row object by calling C<new> directly on
+this class, you are better off calling it on a
+L<DBIx::Class::ResultSet> object.
+
+When calling it directly, you will not get a complete, usable row
+object until you pass or set the C<source_handle> attribute, to a
+L<DBIx::Class::ResultSource> instance that is attached to a
+L<DBIx::Class::Schema> with a valid connection.
+
+C<$attrs> is a hashref of column name, value data. It can also contain
+some other attributes such as the C<source_handle>.
+
Passing an object, or an arrayref of objects as a value will call
L<DBIx::Class::Relationship::Base/set_from_related> for you. When
passed a hashref or an arrayref of hashrefs as the value, these will
@@ -46,6 +82,40 @@
## check Relationship::CascadeActions and Relationship::Accessor for compat
## tests!
+sub __new_related_find_or_new_helper {
+ my ($self, $relname, $data) = @_;
+ if ($self->__their_pk_needs_us($relname, $data)) {
+ MULTICREATE_DEBUG and warn "MC $self constructing $relname via new_result";
+ return $self->result_source
+ ->related_source($relname)
+ ->resultset
+ ->new_result($data);
+ }
+ if ($self->result_source->pk_depends_on($relname, $data)) {
+ MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new";
+ return $self->result_source
+ ->related_source($relname)
+ ->resultset
+ ->find_or_new($data);
+ }
+ MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new_related";
+ return $self->find_or_new_related($relname, $data);
+}
+
+sub __their_pk_needs_us { # this should maybe be in resultsource.
+ my ($self, $relname, $data) = @_;
+ my $source = $self->result_source;
+ my $reverse = $source->reverse_relationship_info($relname);
+ my $rel_source = $source->related_source($relname);
+ my $us = { $self->get_columns };
+ foreach my $key (keys %$reverse) {
+ # if their primary key depends on us, then we have to
+ # just create a result and we'll fill it out afterwards
+ return 1 if $rel_source->pk_depends_on($key, $us);
+ }
+ return 0;
+}
+
sub new {
my ($class, $attrs) = @_;
$class = ref $class if ref $class;
@@ -58,10 +128,16 @@
if (my $handle = delete $attrs->{-source_handle}) {
$new->_source_handle($handle);
}
- if (my $source = delete $attrs->{-result_source}) {
+
+ my $source;
+ if ($source = delete $attrs->{-result_source}) {
$new->result_source($source);
}
+ if (my $related = delete $attrs->{-from_resultset}) {
+ @{$new->{_ignore_at_insert}={}}{@$related} = ();
+ }
+
if ($attrs) {
$new->throw_exception("attrs must be a hashref")
unless ref($attrs) eq 'HASH';
@@ -73,33 +149,48 @@
foreach my $key (keys %$attrs) {
if (ref $attrs->{$key}) {
## Can we extract this lot to use with update(_or .. ) ?
- my $info = $class->relationship_info($key);
+ confess "Can't do multi-create without result source" unless $source;
+ my $info = $source->relationship_info($key);
if ($info && $info->{attrs}{accessor}
&& $info->{attrs}{accessor} eq 'single')
{
my $rel_obj = delete $attrs->{$key};
if(!Scalar::Util::blessed($rel_obj)) {
- $rel_obj = $new->find_or_new_related($key, $rel_obj);
+ $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
}
- $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
+ if ($rel_obj->in_storage) {
+ $new->set_from_related($key, $rel_obj);
+ } else {
+ $new->{_rel_in_storage} = 0;
+ MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj\n";
+ }
- $new->set_from_related($key, $rel_obj);
$related->{$key} = $rel_obj;
next;
} elsif ($info && $info->{attrs}{accessor}
&& $info->{attrs}{accessor} eq 'multi'
&& ref $attrs->{$key} eq 'ARRAY') {
my $others = delete $attrs->{$key};
- foreach my $rel_obj (@$others) {
+ my $total = @$others;
+ my @objects;
+ foreach my $idx (0 .. $#$others) {
+ my $rel_obj = $others->[$idx];
if(!Scalar::Util::blessed($rel_obj)) {
- $rel_obj = $new->new_related($key, $rel_obj);
+ $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
+ }
+
+ if ($rel_obj->in_storage) {
+ $new->set_from_related($key, $rel_obj);
+ } else {
$new->{_rel_in_storage} = 0;
+ MULTICREATE_DEBUG and
+ warn "MC $new uninserted $key $rel_obj (${\($idx+1)} of $total)\n";
}
-
- $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
+ $new->set_from_related($key, $rel_obj) if $rel_obj->in_storage;
+ push(@objects, $rel_obj);
}
- $related->{$key} = $others;
+ $related->{$key} = \@objects;
next;
} elsif ($info && $info->{attrs}{accessor}
&& $info->{attrs}{accessor} eq 'filter')
@@ -107,9 +198,12 @@
## 'filter' should disappear and get merged in with 'single' above!
my $rel_obj = delete $attrs->{$key};
if(!Scalar::Util::blessed($rel_obj)) {
- $rel_obj = $new->find_or_new_related($key, $rel_obj);
- $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
+ $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
}
+ unless ($rel_obj->in_storage) {
+ $new->{_rel_in_storage} = 0;
+ MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj";
+ }
$inflated->{$key} = $rel_obj;
next;
} elsif ($class->has_column($key)
@@ -132,14 +226,22 @@
=head2 insert
- $obj->insert;
+ $row->insert;
-Inserts an object into the database if it isn't already in
-there. Returns the object itself. Requires the object's result source to
-be set, or the class to have a result_source_instance method. To insert
-an entirely new object into the database, use C<create> (see
-L<DBIx::Class::ResultSet/create>).
+=over
+=item Arguments: none
+
+=item Returns: The Row object
+
+=back
+
+Inserts an object previously created by L</new> into the database if
+it isn't already in there. Returns the object itself. Requires the
+object's result source to be set, or the class to have a
+result_source_instance method. To insert an entirely new row 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.
@@ -181,36 +283,31 @@
next REL unless (Scalar::Util::blessed($rel_obj)
&& $rel_obj->isa('DBIx::Class::Row'));
- my $cond = $source->relationship_info($relname)->{cond};
+ next REL unless $source->pk_depends_on(
+ $relname, { $rel_obj->get_columns }
+ );
- next REL unless ref($cond) eq 'HASH';
+ MULTICREATE_DEBUG and warn "MC $self pre-reconstructing $relname $rel_obj\n";
- # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
-
- my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
-
- # assume anything that references our PK probably is dependent on us
- # rather than vice versa, unless the far side is (a) defined or (b)
- # auto-increment
-
- foreach my $p (@pri) {
- if (exists $keyhash->{$p}) {
- unless (defined($rel_obj->get_column($keyhash->{$p}))
- || $rel_obj->column_info($keyhash->{$p})
- ->{is_auto_increment}) {
- next REL;
- }
- }
- }
-
- $rel_obj->insert();
+ my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_inflated_columns };
+ my $re = $self->result_source
+ ->related_source($relname)
+ ->resultset
+ ->find_or_create($them);
+ %{$rel_obj} = %{$re};
$self->set_from_related($relname, $rel_obj);
delete $related_stuff{$relname};
}
}
+ MULTICREATE_DEBUG and do {
+ no warnings 'uninitialized';
+ warn "MC $self inserting (".join(', ', $self->get_columns).")\n";
+ };
my $updated_cols = $source->storage->insert($source, { $self->get_columns });
- $self->set_columns($updated_cols);
+ foreach my $col (keys %$updated_cols) {
+ $self->store_column($col, $updated_cols->{$col});
+ }
## PK::Auto
my @auto_pri = grep {
@@ -221,7 +318,7 @@
if (@auto_pri) {
#$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
# if defined $too_many;
-
+ MULTICREATE_DEBUG and warn "MC $self fetching missing PKs ".join(', ', @auto_pri)."\n";
my $storage = $self->result_source->storage;
$self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
unless $storage->can('last_insert_id');
@@ -229,10 +326,15 @@
$self->throw_exception( "Can't get last insert id" )
unless (@ids == @auto_pri);
$self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
+#use Data::Dumper; warn Dumper($self);
}
+
+ $self->{_dirty_columns} = {};
+ $self->{related_resultsets} = {};
+
if(!$self->{_rel_in_storage}) {
- ## Now do the has_many rels, that need $selfs ID.
+ ## Now do the relationships that need our ID (has_many etc.)
foreach my $relname (keys %related_stuff) {
my $rel_obj = $related_stuff{$relname};
my @cands;
@@ -246,25 +348,48 @@
my $reverse = $source->reverse_relationship_info($relname);
foreach my $obj (@cands) {
$obj->set_from_related($_, $self) for keys %$reverse;
- $obj->insert() unless ($obj->in_storage || $obj->result_source->resultset->search({$obj->get_columns})->count);
+ my $them = { %{$obj->{_relationship_data} || {} }, $obj->get_inflated_columns };
+ if ($self->__their_pk_needs_us($relname, $them)) {
+ if (exists $self->{_ignore_at_insert}{$relname}) {
+ MULTICREATE_DEBUG and warn "MC $self skipping post-insert on $relname";
+ } else {
+ MULTICREATE_DEBUG and warn "MC $self re-creating $relname $obj";
+ my $re = $self->result_source
+ ->related_source($relname)
+ ->resultset
+ ->find_or_create($them);
+ %{$obj} = %{$re};
+ MULTICREATE_DEBUG and warn "MC $self new $relname $obj";
+ }
+ } else {
+ MULTICREATE_DEBUG and warn "MC $self post-inserting $obj";
+ $obj->insert();
+ }
}
}
}
+ delete $self->{_ignore_at_insert};
$rollback_guard->commit;
}
$self->in_storage(1);
- $self->{_dirty_columns} = {};
- $self->{related_resultsets} = {};
undef $self->{_orig_ident};
return $self;
}
=head2 in_storage
- $obj->in_storage; # Get value
- $obj->in_storage(1); # Set value
+ $row->in_storage; # Get value
+ $row->in_storage(1); # Set value
+=over
+
+=item Arguments: none or 1|0
+
+=item Returns: 1|0
+
+=back
+
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>
@@ -283,24 +408,35 @@
=head2 update
- $obj->update \%columns?;
+ $row->update(\%columns?)
-Must be run on an object that is already in the database; issues an SQL
-UPDATE query to commit any changes to the object to the database if
-required.
+=over
-Also takes an options hashref of C<< column_name => value> pairs >> to update
-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 } } )
+=item Arguments: none or a hashref
+=item Returns: The Row object
+
+=back
+
+Throws an exception if the row object is not yet in the database,
+according to L</in_storage>.
+
+This method issues an SQL UPDATE query to commit any changes to the
+object to the database if required.
+
+Also takes an optional hashref of C<< column_name => value> >> pairs
+to update on the object first. Be aware that the hashref will be
+passed to C<set_inflated_columns>, which might edit it in place, so
+don't 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 } } )
+
If the values passed or any of the column values set on the object
contain scalar references, eg:
- $obj->last_modified(\'NOW()');
+ $row->last_modified(\'NOW()');
# OR
- $obj->update({ last_modified => \'NOW()' });
+ $row->update({ last_modified => \'NOW()' });
The update will pass the values verbatim into SQL. (See
L<SQL::Abstract> docs). The values in your Row object will NOT change
@@ -308,8 +444,16 @@
with the actual values from the database, call L</discard_changes>
after the update.
- $obj->update()->discard_changes();
+ $row->update()->discard_changes();
+To determine before calling this method, which column values have
+changed and will be updated, call L</get_dirty_columns>.
+
+To check if any columns will be updated, call L</is_changed>.
+
+To force a column to be updated, call L</make_column_dirty> before
+this method.
+
=cut
sub update {
@@ -339,24 +483,48 @@
=head2 delete
- $obj->delete
+ $row->delete
-Deletes the object from the database. The object is still perfectly
-usable, but C<< ->in_storage() >> will now return 0 and the object must
-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>
-hashref. Any database-level cascade or restrict will take precedence
-over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
+=over
+=item Arguments: none
+
+=item Returns: The Row object
+
+=back
+
+Throws an exception if the object is not in the database according to
+L</in_storage>. Runs an SQL DELETE statement using the primary key
+values to locate the row.
+
+The object is still perfectly usable, but L</in_storage> will
+now return 0 and the object must be reinserted using L</insert>
+before it can be used to L</update> the row again.
+
+If you delete an object in a class with a C<has_many> relationship, an
+attempt is made to delete all the related objects as well. To turn
+this behaviour off, pass C<< cascade_delete => 0 >> in the C<$attr>
+hashref of the relationship, see L<DBIx::Class::Relationship>. Any
+database-level cascade or restrict will take precedence over a
+DBIx-Class-based cascading delete.
+
+If you delete an object within a txn_do() (see L<DBIx::Class::Storage/txn_do>)
+and the transaction subsequently fails, the row object will remain marked as
+not being in storage. If you know for a fact that the object is still in
+storage (i.e. by inspecting the cause of the transaction's failure), you can
+use C<< $obj->in_storage(1) >> to restore consistency between the object and
+the database. This would allow a subsequent C<< $obj->delete >> to work
+as expected.
+
+See also L<DBIx::Class::ResultSet/delete>.
+
=cut
sub delete {
my $self = shift;
if (ref $self) {
$self->throw_exception( "Not in database" ) unless $self->in_storage;
- my $ident_cond = $self->ident_condition;
+ my $ident_cond = $self->{_orig_ident} || $self->ident_condition;
$self->throw_exception("Cannot safely delete a row in a PK-less table")
if ! keys %$ident_cond;
foreach my $column (keys %$ident_cond) {
@@ -378,14 +546,32 @@
=head2 get_column
- my $val = $obj->get_column($col);
+ my $val = $row->get_column($col);
+=over
+
+=item Arguments: $columnname
+
+=item Returns: The value of the column
+
+=back
+
+Throws an exception if the column name given doesn't exist according
+to L</has_column>.
+
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.
+Note that if you used the C<columns> or the C<select/as>
+L<search attributes|DBIx::Class::ResultSet/ATTRIBUTES> on the resultset from
+which C<$row> was derived, and B<did not include> C<$columnname> in the list,
+this method will return C<undef> even if the database contains some value.
+
+To retrieve all loaded column values as a hash, use L</get_columns>.
+
=cut
sub get_column {
@@ -402,10 +588,18 @@
=head2 has_column_loaded
- if ( $obj->has_column_loaded($col) ) {
+ if ( $row->has_column_loaded($col) ) {
print "$col has been loaded from db";
}
+=over
+
+=item Arguments: $columnname
+
+=item Returns: 0|1
+
+=back
+
Returns a true value if the column value has been loaded from the
database (or set locally).
@@ -420,10 +614,19 @@
=head2 get_columns
- my %data = $obj->get_columns;
+ my %data = $row->get_columns;
-Does C<get_column>, for all loaded column values at once.
+=over
+=item Arguments: none
+
+=item Returns: A hash of columnname, value pairs.
+
+=back
+
+Returns all loaded column data as a hash, containing raw values. To
+get just one value for a particular column, use L</get_column>.
+
=cut
sub get_columns {
@@ -439,10 +642,21 @@
=head2 get_dirty_columns
- my %data = $obj->get_dirty_columns;
+ my %data = $row->get_dirty_columns;
-Identical to get_columns but only returns those that have been changed.
+=over
+=item Arguments: none
+
+=item Returns: A hash of column, value pairs
+
+=back
+
+Only returns the column, value pairs for those columns that have been
+changed on this object since the last L</update> or L</insert> call.
+
+See L</get_columns> to fetch all column/value pairs.
+
=cut
sub get_dirty_columns {
@@ -453,9 +667,21 @@
=head2 make_column_dirty
-Marks a column dirty regardless if it has really changed. Throws an
-exception if the column does not exist.
+ $row->make_column_dirty($col)
+=over
+
+=item Arguments: $columnname
+
+=item Returns: undefined
+
+=back
+
+Throws an exception if the column does not exist.
+
+Marks a column as having been changed regardless of whether it has
+really changed.
+
=cut
sub make_column_dirty {
my ($self, $column) = @_;
@@ -469,9 +695,21 @@
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.
+=over
+=item Arguments: none
+
+=item Returns: A hash of column, object|value pairs
+
+=back
+
+Returns a hash of all column keys and associated values. Values for any
+columns set to use inflation will be inflated and returns as objects.
+
+See L</get_columns> to get the uninflated values.
+
+See L<DBIx::Class::InflateColumn> for how to setup inflation.
+
=cut
sub get_inflated_columns {
@@ -479,43 +717,63 @@
return map {
my $accessor = $self->column_info($_)->{'accessor'} || $_;
($_ => $self->$accessor);
- } $self->columns;
+ } grep $self->has_column_loaded($_), $self->columns;
}
=head2 set_column
- $obj->set_column($col => $val);
+ $row->set_column($col => $val);
+=over
+
+=item Arguments: $columnname, $value
+
+=item Returns: $value
+
+=back
+
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.
+the column is marked as dirty for when you next call L</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.
+If passed an object or reference as a value, this method will happily
+attempt to store it, and a later L</insert> or L</update> will try and
+stringify/numify as appropriate. To set an object to be deflated
+instead, see L</set_inflated_columns>.
=cut
sub set_column {
- my $self = shift;
- my ($column) = @_;
+ my ($self, $column, $new_value) = @_;
+
$self->{_orig_ident} ||= $self->ident_condition;
- my $old = $self->get_column($column);
- my $ret = $self->store_column(@_);
+ my $old_value = $self->get_column($column);
+
+ $self->store_column($column, $new_value);
$self->{_dirty_columns}{$column} = 1
- if (defined $old xor defined $ret) || (defined $old && $old ne $ret);
+ if (defined $old_value xor defined $new_value) || (defined $old_value && $old_value ne $new_value);
# XXX clear out the relation cache for this column
delete $self->{related_resultsets}{$column};
- return $ret;
+ return $new_value;
}
=head2 set_columns
- my $copy = $orig->set_columns({ $col => $val, ... });
+ $row->set_columns({ $col => $val, ... });
-Sets more than one column value at once.
+=over
+=item Arguments: \%columndata
+
+=item Returns: The Row object
+
+=back
+
+Sets multiple column, raw value pairs at once.
+
+Works as L</set_column>.
+
=cut
sub set_columns {
@@ -528,14 +786,35 @@
=head2 set_inflated_columns
- my $copy = $orig->set_inflated_columns({ $col => $val, $rel => $obj, ... });
+ $row->set_inflated_columns({ $col => $val, $relname => $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 } } )
+=over
+=item Arguments: \%columndata
+
+=item Returns: The Row object
+
+=back
+
+Sets more than one column value at once. Any inflated values are
+deflated and the raw values stored.
+
+Any related values passed as Row objects, using the relation name as a
+key, are reduced to the appropriate foreign key values and stored. If
+instead of related row objects, a hashref of column, value data is
+passed, will create the related object first then store.
+
+Will even accept arrayrefs of data as a value to a
+L<DBIx::Class::Relationship/has_many> key, and create the related
+objects if necessary.
+
+Be aware that the input 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 } } )
+
+See also L<DBIx::Class::Relationship::Base/set_from_related>.
+
=cut
sub set_inflated_columns {
@@ -548,24 +827,17 @@
{
my $rel = delete $upd->{$key};
$self->set_from_related($key => $rel);
- $self->{_relationship_data}{$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;
+ && $info->{attrs}{accessor} eq 'multi') {
+ $self->throw_exception(
+ "Recursive update is not supported over relationships of type multi ($key)"
+ );
}
elsif ($self->has_column($key)
&& exists $self->column_info($key)->{_inflate_info})
{
- $self->set_inflated_column($key, delete $upd->{$key});
+ $self->set_inflated_column($key, delete $upd->{$key});
}
}
}
@@ -576,10 +848,23 @@
my $copy = $orig->copy({ change => $to, ... });
-Inserts a new row with the specified changes. If the row has related
-objects in a C<has_many> then those objects may be copied too depending
-on the C<cascade_copy> relationship attribute.
+=over
+=item Arguments: \%replacementdata
+
+=item Returns: The Row object copy
+
+=back
+
+Inserts a new row into the database, as a copy of the original
+object. If a hashref of replacement data is supplied, these will take
+precedence over data in the original.
+
+If the row has related objects in a
+L<DBIx::Class::Relationship/has_many> then those objects may be copied
+too depending on the L<cascade_copy|DBIx::Class::Relationship>
+relationship attribute.
+
=cut
sub copy {
@@ -626,10 +911,23 @@
=head2 store_column
- $obj->store_column($col => $val);
+ $row->store_column($col => $val);
-Sets a column value without marking it as dirty.
+=over
+=item Arguments: $columnname, $value
+
+=item Returns: The value sent to storage
+
+=back
+
+Set a raw value for a column without marking it as changed. This
+method is used internally by L</set_column> which you should probably
+be using.
+
+This is the lowest level at which data is set on a row object,
+extend this method to catch all data setting methods.
+
=cut
sub store_column {
@@ -645,8 +943,23 @@
Class->inflate_result($result_source, \%me, \%prefetch?)
-Called by ResultSet to inflate a result from storage
+=over
+=item Arguments: $result_source, \%columndata, \%prefetcheddata
+
+=item Returns: A Row object
+
+=back
+
+All L<DBIx::Class::ResultSet> methods that retrieve data from the
+database and turn it into row objects call this method.
+
+Extend this method in your Result classes to hook into this process,
+for example to rebless the result into a different class.
+
+Reblessing can also be done more easily by setting C<result_class> in
+your Result class. See L<DBIx::Class::ResultSource/result_class>.
+
=cut
sub inflate_result {
@@ -710,11 +1023,19 @@
=head2 update_or_insert
- $obj->update_or_insert
+ $row->update_or_insert
-Updates the object if it's already in the database, according to
-L</in_storage>, else inserts it.
+=over
+=item Arguments: none
+
+=item Returns: Result of update or insert operation
+
+=back
+
+L</Update>s the object if it's already in the database, according to
+L</in_storage>, else L</insert>s it.
+
=head2 insert_or_update
$obj->insert_or_update
@@ -723,7 +1044,8 @@
=cut
-*insert_or_update = \&update_or_insert;
+sub insert_or_update { shift->update_or_insert(@_) }
+
sub update_or_insert {
my $self = shift;
return ($self->in_storage ? $self->update : $self->insert);
@@ -731,10 +1053,18 @@
=head2 is_changed
- my @changed_col_names = $obj->is_changed();
- if ($obj->is_changed()) { ... }
+ my @changed_col_names = $row->is_changed();
+ if ($row->is_changed()) { ... }
-In array context returns a list of columns with uncommited changes, or
+=over
+
+=item Arguments: none
+
+=item Returns: 0|1 or @columnnames
+
+=back
+
+In list context returns a list of columns with uncommited changes, or
in scalar context returns a true value if there are uncommitted
changes.
@@ -746,8 +1076,16 @@
=head2 is_column_changed
- if ($obj->is_column_changed('col')) { ... }
+ if ($row->is_column_changed('col')) { ... }
+=over
+
+=item Arguments: $columname
+
+=item Returns: 0|1
+
+=back
+
Returns a true value if the column has uncommitted changes.
=cut
@@ -759,10 +1097,18 @@
=head2 result_source
- my $resultsource = $object->result_source;
+ my $resultsource = $row->result_source;
-Accessor to the ResultSource this object was created from
+=over
+=item Arguments: none
+
+=item Returns: a ResultSource instance
+
+=back
+
+Accessor to the L<DBIx::Class::ResultSource> this object was created from.
+
=cut
sub result_source {
@@ -780,6 +1126,14 @@
$column_info = { .... };
$class->register_column($column_name, $column_info);
+=over
+
+=item Arguments: $columnname, \%columninfo
+
+=item Returns: undefined
+
+=back
+
Registers a column on the class. If the column_info has an 'accessor'
key, creates an accessor named after the value if defined; if there is
no such key, creates an accessor with the same name as the column
@@ -799,33 +1153,50 @@
$class->mk_group_accessors('column' => $acc);
}
-=head2 get_from_storage ($attrs)
+=head2 get_from_storage
-Returns a new Row which is whatever the Storage has for the currently created
-Row object. You can use this to see if the storage has become inconsistent with
-whatever your Row object is.
+ my $copy = $row->get_from_storage($attrs)
-$attrs is expected to be a hashref of attributes suitable for passing as the
-second argument to $resultset->search($cond, $attrs);
+=over
+=item Arguments: \%attrs
+
+=item Returns: A Row object
+
+=back
+
+Fetches a fresh copy of the Row object from the database and returns it.
+
+If passed the \%attrs argument, will first apply these attributes to
+the resultset used to find the row.
+
+This copy can then be used to compare to an existing row object, to
+determine if any changes have been made in the database since it was
+created.
+
+To just update your Row object with any latest changes from the
+database, use L</discard_changes> instead.
+
+The \%attrs argument should be compatible with
+L<DBIx::Class::ResultSet/ATTRIBUTES>.
+
=cut
sub get_from_storage {
my $self = shift @_;
my $attrs = shift @_;
- my @primary_columns = map { $self->$_ } $self->primary_columns;
my $resultset = $self->result_source->resultset;
if(defined $attrs) {
$resultset = $resultset->search(undef, $attrs);
}
- return $resultset->find(@primary_columns);
+ return $resultset->find($self->{_orig_ident} || $self->ident_condition);
}
=head2 throw_exception
-See Schema's throw_exception.
+See L<DBIx::Class::Schema/throw_exception>.
=cut
@@ -840,14 +1211,34 @@
=head2 id
+ my @pk = $row->id;
+
+=over
+
+=item Arguments: none
+
+=item Returns: A list of primary key values
+
+=back
+
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.
+ $row->discard_changes
+=over
+
+=item Arguments: none
+
+=item Returns: nothing (updates object in-place)
+
+=back
+
+Retrieves and sets the row object data from the database, losing any
+local changes 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>
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Schema/Versioned.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Schema/Versioned.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Schema/Versioned.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -235,7 +235,7 @@
if ($new_version) {
# create versions table and version row
$self->{vschema}->deploy;
- $self->_set_db_version;
+ $self->_set_db_version({ version => $new_version });
}
}
@@ -251,6 +251,27 @@
$self->install();
}
+=head2 create_upgrade_path
+
+=over 4
+
+=item Arguments: { upgrade_file => $file }
+
+=back
+
+Virtual method that should be overriden to create an upgrade file.
+This is useful in the case of upgrading across multiple versions
+to concatenate several files to create one upgrade file.
+
+You'll probably want the db_version retrieved via $self->get_db_version
+and the schema_version which is retrieved via $self->schema_version
+
+=cut
+
+sub create_upgrade_path {
+ ## override this method
+}
+
=head2 upgrade
Call this to attempt to upgrade your database from the version it is at to the version
@@ -294,11 +315,15 @@
$db_version,
);
+ $self->create_upgrade_path({ upgrade_file => $upgrade_file });
+
unless (-f $upgrade_file) {
warn "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
return;
}
+ warn "\nDB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n";
+
# backup if necessary then apply upgrade
$self->_filedata($self->_read_sql_file($upgrade_file));
$self->backup() if($self->do_backup);
@@ -494,9 +519,9 @@
return;
}
- eval 'require SQL::Translator "0.09"';
+ eval 'require SQL::Translator "0.09003"';
if ($@) {
- $self->throw_exception("SQL::Translator 0.09 required");
+ $self->throw_exception("SQL::Translator 0.09003 required");
}
my $db_tr = SQL::Translator->new({
@@ -546,9 +571,12 @@
sub _set_db_version {
my $self = shift;
+ my ($params) = @_;
+ $params ||= {};
+ my $version = $params->{version} ? $params->{version} : $self->schema_version;
my $vtable = $self->{vschema}->resultset('Table');
- $vtable->create({ version => $self->schema_version,
+ $vtable->create({ version => $version,
installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
});
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Schema.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Schema.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Schema.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -29,12 +29,12 @@
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/);
+ # load all Result classes in Library/Schema/Result/
+ __PACKAGE__->load_namespaces();
- package Library::Schema::CD;
+ package Library::Schema::Result::CD;
use base qw/DBIx::Class/;
- __PACKAGE__->load_components(qw/PK::Auto Core/); # for example
+ __PACKAGE__->load_components(qw/Core/); # for example
__PACKAGE__->table('cd');
# Elsewhere in your code:
@@ -47,7 +47,7 @@
my $schema2 = Library::Schema->connect($coderef_returning_dbh);
- # fetch objects using Library::Schema::DVD
+ # fetch objects using Library::Schema::Result::DVD
my $resultset = $schema1->resultset('DVD')->search( ... );
my @dvd_objects = $schema2->resultset('DVD')->search( ... );
@@ -61,195 +61,191 @@
carefully, as DBIx::Class does things a little differently. Note in
particular which module inherits off which.
-=head1 METHODS
+=head1 SETUP METHODS
-=head2 register_class
+=head2 load_namespaces
=over 4
-=item Arguments: $moniker, $component_class
+=item Arguments: %options?
=back
-Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
-calling:
+ __PACKAGE__->load_namespaces();
- $schema->register_source($moniker, $component_class->result_source_instance);
+ __PACKAGE__->load_namespaces(
+ result_namespace => 'Res',
+ resultset_namespace => 'RSet',
+ default_resultset_class => '+MyDB::Othernamespace::RSet',
+ );
-=cut
+With no arguments, this method uses L<Module::Find> to load all your
+Result classes from a sub-namespace F<Result> under your Schema class'
+namespace. Eg. With a Schema of I<MyDB::Schema> all files in
+I<MyDB::Schema::Result> are assumed to be Result classes.
-sub register_class {
- my ($self, $moniker, $to_register) = @_;
- $self->register_source($moniker => $to_register->result_source_instance);
-}
+It also finds all ResultSet classes in the namespace F<ResultSet> and
+loads them into the appropriate Result classes using for you. The
+matching is done by assuming the package name of the ResultSet class
+is the same as that of the Result class.
-=head2 register_source
+You will be warned if ResultSet classes are discovered for which there
+are no matching Result classes like this:
-=over 4
+ load_namespaces found ResultSet class $classname with no corresponding Result class
-=item Arguments: $moniker, $result_source
+If a Result class is found to already have a ResultSet class set using
+L</resultset_class> to some other class, you will be warned like this:
-=back
+ We found ResultSet class '$rs_class' for '$result', but it seems
+ that you had already set '$result' to use '$rs_set' instead
-Registers the L<DBIx::Class::ResultSource> in the schema with the given
-moniker.
+Both of the sub-namespaces are configurable if you don't like the defaults,
+via the options C<result_namespace> and C<resultset_namespace>.
-=cut
+If (and only if) you specify the option C<default_resultset_class>, any found
+Result classes for which we do not find a corresponding
+ResultSet class will have their C<resultset_class> set to
+C<default_resultset_class>.
-sub register_source {
- my $self = shift;
+All of the namespace and classname options to this method are relative to
+the schema classname by default. To specify a fully-qualified name, prefix
+it with a literal C<+>.
- $self->_register_source(@_);
-}
+Examples:
-=head2 register_extra_source
+ # load My::Schema::Result::CD, My::Schema::Result::Artist,
+ # My::Schema::ResultSet::CD, etc...
+ My::Schema->load_namespaces;
-=over 4
+ # Override everything to use ugly names.
+ # In this example, if there is a My::Schema::Res::Foo, but no matching
+ # My::Schema::RSets::Foo, then Foo will have its
+ # resultset_class set to My::Schema::RSetBase
+ My::Schema->load_namespaces(
+ result_namespace => 'Res',
+ resultset_namespace => 'RSets',
+ default_resultset_class => 'RSetBase',
+ );
-=item Arguments: $moniker, $result_source
+ # Put things in other namespaces
+ My::Schema->load_namespaces(
+ result_namespace => '+Some::Place::Results',
+ resultset_namespace => '+Another::Place::RSets',
+ );
-=back
+If you'd like to use multiple namespaces of each type, simply use an arrayref
+of namespaces for that option. In the case that the same result
+(or resultset) class exists in multiple namespaces, the latter entries in
+your list of namespaces will override earlier ones.
-As L</register_source> but should be used if the result class already
-has a source and you want to register an extra one.
+ My::Schema->load_namespaces(
+ # My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo :
+ result_namespace => [ 'Results_A', 'Results_B', 'Results_C' ],
+ resultset_namespace => [ '+Some::Place::RSets', 'RSets' ],
+ );
=cut
-sub register_extra_source {
- my $self = shift;
-
- $self->_register_source(@_, { extra => 1 });
+# Pre-pends our classname to the given relative classname or
+# class namespace, unless there is a '+' prefix, which will
+# be stripped.
+sub _expand_relative_name {
+ my ($class, $name) = @_;
+ return if !$name;
+ $name = $class . '::' . $name if ! ($name =~ s/^\+//);
+ return $name;
}
-sub _register_source {
- my ($self, $moniker, $source, $params) = @_;
+# returns a hash of $shortname => $fullname for every package
+# found in the given namespaces ($shortname is with the $fullname's
+# namespace stripped off)
+sub _map_namespaces {
+ my ($class, @namespaces) = @_;
- %$source = %{ $source->new( { %$source, source_name => $moniker }) };
-
- my %reg = %{$self->source_registrations};
- $reg{$moniker} = $source;
- $self->source_registrations(\%reg);
-
- $source->schema($self);
- weaken($source->{schema}) if ref($self);
- return if ($params->{extra});
-
- if ($source->result_class) {
- my %map = %{$self->class_mappings};
- if (exists $map{$source->result_class}) {
- warn $source->result_class . ' already has a source, use register_extra_source for additional sources';
- }
- $map{$source->result_class} = $moniker;
- $self->class_mappings(\%map);
+ my @results_hash;
+ foreach my $namespace (@namespaces) {
+ push(
+ @results_hash,
+ map { (substr($_, length "${namespace}::"), $_) }
+ Module::Find::findallmod($namespace)
+ );
}
-}
-sub _unregister_source {
- my ($self, $moniker) = @_;
- my %reg = %{$self->source_registrations};
-
- my $source = delete $reg{$moniker};
- $self->source_registrations(\%reg);
- if ($source->result_class) {
- my %map = %{$self->class_mappings};
- delete $map{$source->result_class};
- $self->class_mappings(\%map);
- }
+ @results_hash;
}
-=head2 class
+sub load_namespaces {
+ my ($class, %args) = @_;
-=over 4
+ my $result_namespace = delete $args{result_namespace} || 'Result';
+ my $resultset_namespace = delete $args{resultset_namespace} || 'ResultSet';
+ my $default_resultset_class = delete $args{default_resultset_class};
-=item Arguments: $moniker
+ $class->throw_exception('load_namespaces: unknown option(s): '
+ . join(q{,}, map { qq{'$_'} } keys %args))
+ if scalar keys %args;
-=item Return Value: $classname
+ $default_resultset_class
+ = $class->_expand_relative_name($default_resultset_class);
-=back
+ for my $arg ($result_namespace, $resultset_namespace) {
+ $arg = [ $arg ] if !ref($arg) && $arg;
-Retrieves the result class name for the given moniker. For example:
+ $class->throw_exception('load_namespaces: namespace arguments must be '
+ . 'a simple string or an arrayref')
+ if ref($arg) ne 'ARRAY';
- my $class = $schema->class('CD');
+ $_ = $class->_expand_relative_name($_) for (@$arg);
+ }
-=cut
+ my %results = $class->_map_namespaces(@$result_namespace);
+ my %resultsets = $class->_map_namespaces(@$resultset_namespace);
-sub class {
- my ($self, $moniker) = @_;
- return $self->source($moniker)->result_class;
-}
+ my @to_register;
+ {
+ no warnings 'redefine';
+ local *Class::C3::reinitialize = sub { };
+ use warnings 'redefine';
-=head2 source
+ # ensure classes are loaded and fetch properly sorted classes
+ $class->ensure_class_loaded($_) foreach(values %results);
+ my @subclass_last = sort { $results{$a}->isa($results{$b}) } keys(%results);
+
+ foreach my $result (@subclass_last) {
+ my $result_class = $results{$result};
-=over 4
+ my $rs_class = delete $resultsets{$result};
+ my $rs_set = $result_class->resultset_class;
+
+ if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') {
+ if($rs_class && $rs_class ne $rs_set) {
+ warn "We found ResultSet class '$rs_class' for '$result', but it seems "
+ . "that you had already set '$result' to use '$rs_set' instead";
+ }
+ }
+ elsif($rs_class ||= $default_resultset_class) {
+ $class->ensure_class_loaded($rs_class);
+ $result_class->resultset_class($rs_class);
+ }
-=item Arguments: $moniker
+ my $source_name = $result_class->source_name || $result;
-=item Return Value: $result_source
+ push(@to_register, [ $source_name, $result_class ]);
+ }
+ }
-=back
+ foreach (sort keys %resultsets) {
+ warn "load_namespaces found ResultSet class $_ with no "
+ . 'corresponding Result class';
+ }
- my $source = $schema->source('Book');
+ Class::C3->reinitialize;
+ $class->register_class(@$_) for (@to_register);
-Returns the L<DBIx::Class::ResultSource> object for the registered moniker.
-
-=cut
-
-sub source {
- my ($self, $moniker) = @_;
- my $sreg = $self->source_registrations;
- return $sreg->{$moniker} if exists $sreg->{$moniker};
-
- # if we got here, they probably passed a full class name
- my $mapped = $self->class_mappings->{$moniker};
- $self->throw_exception("Can't find source for ${moniker}")
- unless $mapped && exists $sreg->{$mapped};
- return $sreg->{$mapped};
+ return;
}
-=head2 sources
-
-=over 4
-
-=item Return Value: @source_monikers
-
-=back
-
-Returns the source monikers of all source registrations on this schema.
-For example:
-
- my @source_monikers = $schema->sources;
-
-=cut
-
-sub sources { return keys %{shift->source_registrations}; }
-
-=head2 storage
-
- my $storage = $schema->storage;
-
-Returns the L<DBIx::Class::Storage> object for this Schema.
-
-=head2 resultset
-
-=over 4
-
-=item Arguments: $moniker
-
-=item Return Value: $result_set
-
-=back
-
- my $rs = $schema->resultset('DVD');
-
-Returns the L<DBIx::Class::ResultSet> object for the registered moniker.
-
-=cut
-
-sub resultset {
- my ($self, $moniker) = @_;
- return $self->source($moniker)->resultset;
-}
-
=head2 load_classes
=over 4
@@ -258,6 +254,9 @@
=back
+Alternative method to L</load_namespaces> which you should look at
+using if you can.
+
With no arguments, this method uses L<Module::Find> to find all classes under
the schema's namespace. Otherwise, this method loads the classes you specify
(using L<use>), and registers them (using L</"register_class">).
@@ -266,6 +265,13 @@
will think it's a mistake (trying to use a comment in a qw list), so you'll
need to add C<no warnings 'qw';> before your load_classes call.
+If any classes found do not appear to be Result class files, you will
+get the following warning:
+
+ Failed to load $comp_class. Can't find source_name method. Is
+ $comp_class really a full DBIC result class? Fix it, move it elsewhere,
+ or make your load_classes call more specific.
+
Example:
My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
@@ -347,428 +353,219 @@
}
}
-=head2 load_namespaces
+=head2 storage_type
=over 4
-=item Arguments: %options?
+=item Arguments: $storage_type|{$storage_type, \%args}
-=back
+=item Return value: $storage_type|{$storage_type, \%args}
-This is an alternative to L</load_classes> above which assumes an alternative
-layout for automatic class loading. It assumes that all result
-classes are underneath a sub-namespace of the schema called C<Result>, any
-corresponding ResultSet classes are underneath a sub-namespace of the schema
-called C<ResultSet>.
+=item Default value: DBIx::Class::Storage::DBI
-Both of the sub-namespaces are configurable if you don't like the defaults,
-via the options C<result_namespace> and C<resultset_namespace>.
+=back
-If (and only if) you specify the option C<default_resultset_class>, any found
-Result classes for which we do not find a corresponding
-ResultSet class will have their C<resultset_class> set to
-C<default_resultset_class>.
+Set the storage class that will be instantiated when L</connect> is called.
+If the classname starts with C<::>, the prefix C<DBIx::Class::Storage> is
+assumed by L</connect>.
-C<load_namespaces> takes care of calling C<resultset_class> for you where
-neccessary if you didn't do it for yourself.
+You want to use this to set subclasses of L<DBIx::Class::Storage::DBI>
+in cases where the appropriate subclass is not autodetected, such as
+when dealing with MSSQL via L<DBD::Sybase>, in which case you'd set it
+to C<::DBI::Sybase::MSSQL>.
-All of the namespace and classname options to this method are relative to
-the schema classname by default. To specify a fully-qualified name, prefix
-it with a literal C<+>.
+If your storage type requires instantiation arguments, those are
+defined as a second argument in the form of a hashref and the entire
+value needs to be wrapped into an arrayref or a hashref. We support
+both types of refs here in order to play nice with your
+Config::[class] or your choice. See
+L<DBIx::Class::Storage::DBI::Replicated> for an example of this.
-Examples:
+=head2 exception_action
- # load My::Schema::Result::CD, My::Schema::Result::Artist,
- # My::Schema::ResultSet::CD, etc...
- My::Schema->load_namespaces;
+=over 4
- # Override everything to use ugly names.
- # In this example, if there is a My::Schema::Res::Foo, but no matching
- # My::Schema::RSets::Foo, then Foo will have its
- # resultset_class set to My::Schema::RSetBase
- My::Schema->load_namespaces(
- result_namespace => 'Res',
- resultset_namespace => 'RSets',
- default_resultset_class => 'RSetBase',
- );
+=item Arguments: $code_reference
- # Put things in other namespaces
- My::Schema->load_namespaces(
- result_namespace => '+Some::Place::Results',
- resultset_namespace => '+Another::Place::RSets',
- );
+=item Return value: $code_reference
-If you'd like to use multiple namespaces of each type, simply use an arrayref
-of namespaces for that option. In the case that the same result
-(or resultset) class exists in multiple namespaces, the latter entries in
-your list of namespaces will override earlier ones.
+=item Default value: None
- My::Schema->load_namespaces(
- # My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo :
- result_namespace => [ 'Results_A', 'Results_B', 'Results_C' ],
- resultset_namespace => [ '+Some::Place::RSets', 'RSets' ],
- );
+=back
-=cut
+If C<exception_action> is set for this class/object, L</throw_exception>
+will prefer to call this code reference with the exception as an argument,
+rather than L<DBIx::Class::Exception/throw>.
-# Pre-pends our classname to the given relative classname or
-# class namespace, unless there is a '+' prefix, which will
-# be stripped.
-sub _expand_relative_name {
- my ($class, $name) = @_;
- return if !$name;
- $name = $class . '::' . $name if ! ($name =~ s/^\+//);
- return $name;
-}
+Your subroutine should probably just wrap the error in the exception
+object/class of your choosing and rethrow. If, against all sage advice,
+you'd like your C<exception_action> to suppress a particular exception
+completely, simply have it return true.
-# returns a hash of $shortname => $fullname for every package
-# found in the given namespaces ($shortname is with the $fullname's
-# namespace stripped off)
-sub _map_namespaces {
- my ($class, @namespaces) = @_;
+Example:
- my @results_hash;
- foreach my $namespace (@namespaces) {
- push(
- @results_hash,
- map { (substr($_, length "${namespace}::"), $_) }
- Module::Find::findallmod($namespace)
- );
- }
+ package My::Schema;
+ use base qw/DBIx::Class::Schema/;
+ use My::ExceptionClass;
+ __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
+ __PACKAGE__->load_classes;
- @results_hash;
-}
+ # or:
+ my $schema_obj = My::Schema->connect( .... );
+ $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
-sub load_namespaces {
- my ($class, %args) = @_;
+ # suppress all exceptions, like a moron:
+ $schema_obj->exception_action(sub { 1 });
- my $result_namespace = delete $args{result_namespace} || 'Result';
- my $resultset_namespace = delete $args{resultset_namespace} || 'ResultSet';
- my $default_resultset_class = delete $args{default_resultset_class};
+=head2 stacktrace
- $class->throw_exception('load_namespaces: unknown option(s): '
- . join(q{,}, map { qq{'$_'} } keys %args))
- if scalar keys %args;
+=over 4
- $default_resultset_class
- = $class->_expand_relative_name($default_resultset_class);
+=item Arguments: boolean
- for my $arg ($result_namespace, $resultset_namespace) {
- $arg = [ $arg ] if !ref($arg) && $arg;
+=back
- $class->throw_exception('load_namespaces: namespace arguments must be '
- . 'a simple string or an arrayref')
- if ref($arg) ne 'ARRAY';
+Whether L</throw_exception> should include stack trace information.
+Defaults to false normally, but defaults to true if C<$ENV{DBIC_TRACE}>
+is true.
- $_ = $class->_expand_relative_name($_) for (@$arg);
- }
+=head2 sqlt_deploy_hook
- my %results = $class->_map_namespaces(@$result_namespace);
- my %resultsets = $class->_map_namespaces(@$resultset_namespace);
+=over
- my @to_register;
- {
- no warnings 'redefine';
- local *Class::C3::reinitialize = sub { };
- use warnings 'redefine';
+=item Arguments: $sqlt_schema
- foreach my $result (keys %results) {
- my $result_class = $results{$result};
- $class->ensure_class_loaded($result_class);
- $result_class->source_name($result) unless $result_class->source_name;
+=back
- my $rs_class = delete $resultsets{$result};
- my $rs_set = $result_class->resultset_class;
- if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') {
- if($rs_class && $rs_class ne $rs_set) {
- warn "We found ResultSet class '$rs_class' for '$result', but it seems "
- . "that you had already set '$result' to use '$rs_set' instead";
- }
- }
- elsif($rs_class ||= $default_resultset_class) {
- $class->ensure_class_loaded($rs_class);
- $result_class->resultset_class($rs_class);
- }
+An optional sub which you can declare in your own Schema class that will get
+passed the L<SQL::Translator::Schema> object when you deploy the schema via
+L</create_ddl_dir> or L</deploy>.
- push(@to_register, [ $result_class->source_name, $result_class ]);
- }
- }
+For an example of what you can do with this, see
+L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
- foreach (sort keys %resultsets) {
- warn "load_namespaces found ResultSet class $_ with no "
- . 'corresponding Result class';
- }
+Note that sqlt_deploy_hook is called by L</deployment_statements>, which in turn
+is called before L</deploy>. Therefore the hook can be used only to manipulate
+the L<SQL::Translator::Schema> object before it is turned into SQL fed to the
+database. If you want to execute post-deploy statements which can not be generated
+by L<SQL::Translator>, the currently suggested method is to overload L</deploy>
+and use L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
- Class::C3->reinitialize;
- $class->register_class(@$_) for (@to_register);
+=head1 METHODS
- return;
-}
+=head2 connect
-=head2 compose_connection (DEPRECATED)
-
=over 4
-=item Arguments: $target_namespace, @db_info
+=item Arguments: @connectinfo
=item Return Value: $new_schema
=back
-DEPRECATED. You probably wanted compose_namespace.
+Creates and returns a new Schema object. The connection info set on it
+is used to create a new instance of the storage backend and set it on
+the Schema object.
-Actually, you probably just wanted to call connect.
+See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific
+syntax on the C<@connectinfo> argument, or L<DBIx::Class::Storage> in
+general.
-=begin hidden
+Note that C<connect_info> expects an arrayref of arguments, but
+C<connect> does not. C<connect> wraps it's arguments in an arrayref
+before passing them to C<connect_info>.
-(hidden due to deprecation)
-
-Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
-calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
-then injects the L<DBix::Class::ResultSetProxy> component and a
-resultset_instance classdata entry on all the new classes, in order to support
-$target_namespaces::$class->search(...) method calls.
-
-This is primarily useful when you have a specific need for class method access
-to a connection. In normal usage it is preferred to call
-L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
-on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
-more information.
-
-=end hidden
-
=cut
-{
- my $warn;
+sub connect { shift->clone->connection(@_) }
- sub compose_connection {
- my ($self, $target, @info) = @_;
+=head2 resultset
- warn "compose_connection deprecated as of 0.08000"
- unless ($INC{"DBIx/Class/CDBICompat.pm"} || $warn++);
-
- my $base = 'DBIx::Class::ResultSetProxy';
- eval "require ${base};";
- $self->throw_exception
- ("No arguments to load_classes and couldn't load ${base} ($@)")
- if $@;
-
- if ($self eq $target) {
- # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
- foreach my $moniker ($self->sources) {
- my $source = $self->source($moniker);
- my $class = $source->result_class;
- $self->inject_base($class, $base);
- $class->mk_classdata(resultset_instance => $source->resultset);
- $class->mk_classdata(class_resolver => $self);
- }
- $self->connection(@info);
- return $self;
- }
-
- my $schema = $self->compose_namespace($target, $base);
- {
- no strict 'refs';
- my $name = join '::', $target, 'schema';
- *$name = Sub::Name::subname $name, sub { $schema };
- }
-
- $schema->connection(@info);
- foreach my $moniker ($schema->sources) {
- my $source = $schema->source($moniker);
- my $class = $source->result_class;
- #warn "$moniker $class $source ".$source->storage;
- $class->mk_classdata(result_source_instance => $source);
- $class->mk_classdata(resultset_instance => $source->resultset);
- $class->mk_classdata(class_resolver => $schema);
- }
- return $schema;
- }
-}
-
-=head2 compose_namespace
-
=over 4
-=item Arguments: $target_namespace, $additional_base_class?
+=item Arguments: $source_name
-=item Return Value: $new_schema
+=item Return Value: $resultset
=back
-For each L<DBIx::Class::ResultSource> in the schema, this method creates a
-class in the target namespace (e.g. $target_namespace::CD,
-$target_namespace::Artist) that inherits from the corresponding classes
-attached to the current schema.
+ my $rs = $schema->resultset('DVD');
-It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
-new $schema object. If C<$additional_base_class> is given, the new composed
-classes will inherit from first the corresponding classe from the current
-schema then the base class.
+Returns the L<DBIx::Class::ResultSet> object for the registered source
+name.
-For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
-
- $schema->compose_namespace('My::DB', 'Base::Class');
- print join (', ', @My::DB::CD::ISA) . "\n";
- print join (', ', @My::DB::Artist::ISA) ."\n";
-
-will produce the output
-
- My::Schema::CD, Base::Class
- My::Schema::Artist, Base::Class
-
=cut
-# this might be oversimplified
-# sub compose_namespace {
-# my ($self, $target, $base) = @_;
-
-# my $schema = $self->clone;
-# foreach my $moniker ($schema->sources) {
-# my $source = $schema->source($moniker);
-# my $target_class = "${target}::${moniker}";
-# $self->inject_base(
-# $target_class => $source->result_class, ($base ? $base : ())
-# );
-# $source->result_class($target_class);
-# $target_class->result_source_instance($source)
-# if $target_class->can('result_source_instance');
-# $schema->register_source($moniker, $source);
-# }
-# return $schema;
-# }
-
-sub compose_namespace {
- my ($self, $target, $base) = @_;
- my $schema = $self->clone;
- {
- no warnings qw/redefine/;
-# local *Class::C3::reinitialize = sub { };
- foreach my $moniker ($schema->sources) {
- my $source = $schema->source($moniker);
- my $target_class = "${target}::${moniker}";
- $self->inject_base(
- $target_class => $source->result_class, ($base ? $base : ())
- );
- $source->result_class($target_class);
- $target_class->result_source_instance($source)
- if $target_class->can('result_source_instance');
- $schema->register_source($moniker, $source);
- }
- }
-# Class::C3->reinitialize();
- {
- no strict 'refs';
- no warnings 'redefine';
- foreach my $meth (qw/class source resultset/) {
- *{"${target}::${meth}"} =
- sub { shift->schema->$meth(@_) };
- }
- }
- return $schema;
+sub resultset {
+ my ($self, $moniker) = @_;
+ return $self->source($moniker)->resultset;
}
-sub setup_connection_class {
- my ($class, $target, @info) = @_;
- $class->inject_base($target => 'DBIx::Class::DB');
- #$target->load_components('DB');
- $target->connection(@info);
-}
+=head2 sources
-=head2 storage_type
-
=over 4
-=item Arguments: $storage_type|{$storage_type, \%args}
+=item Return Value: @source_names
-=item Return Value: $storage_type|{$storage_type, \%args}
-
=back
-Set the storage class that will be instantiated when L</connect> is called.
-If the classname starts with C<::>, the prefix C<DBIx::Class::Storage> is
-assumed by L</connect>. Defaults to C<::DBI>,
-which is L<DBIx::Class::Storage::DBI>.
+ my @source_names = $schema->sources;
-You want to use this to hardcoded subclasses of L<DBIx::Class::Storage::DBI>
-in cases where the appropriate subclass is not autodetected, such as when
-dealing with MSSQL via L<DBD::Sybase>, in which case you'd set it to
-C<::DBI::Sybase::MSSQL>.
+Lists names of all the sources registered on this Schema object.
-If your storage type requires instantiation arguments, those are defined as a
-second argument in the form of a hashref and the entire value needs to be
-wrapped into an arrayref or a hashref. We support both types of refs here in
-order to play nice with your Config::[class] or your choice.
+=cut
-See L<DBIx::Class::Storage::DBI::Replicated> for an example of this.
+sub sources { return keys %{shift->source_registrations}; }
-=head2 connection
+=head2 source
=over 4
-=item Arguments: @args
+=item Arguments: $source_name
-=item Return Value: $new_schema
+=item Return Value: $result_source
=back
-Instantiates a new Storage object of type
-L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
-$storage->connect_info. Sets the connection in-place on the schema.
+ my $source = $schema->source('Book');
-See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific syntax,
-or L<DBIx::Class::Storage> in general.
+Returns the L<DBIx::Class::ResultSource> object for the registered
+source name.
=cut
-sub connection {
- my ($self, @info) = @_;
- return $self if !@info && $self->storage;
-
- my ($storage_class, $args) = ref $self->storage_type ?
- ($self->_normalize_storage_type($self->storage_type),{}) : ($self->storage_type, {});
-
- $storage_class = 'DBIx::Class::Storage'.$storage_class
- if $storage_class =~ m/^::/;
- eval "require ${storage_class};";
- $self->throw_exception(
- "No arguments to load_classes and couldn't load ${storage_class} ($@)"
- ) if $@;
- my $storage = $storage_class->new($self=>$args);
- $storage->connect_info(\@info);
- $self->storage($storage);
- return $self;
-}
+sub source {
+ my ($self, $moniker) = @_;
+ my $sreg = $self->source_registrations;
+ return $sreg->{$moniker} if exists $sreg->{$moniker};
-sub _normalize_storage_type {
- my ($self, $storage_type) = @_;
- if(ref $storage_type eq 'ARRAY') {
- return @$storage_type;
- } elsif(ref $storage_type eq 'HASH') {
- return %$storage_type;
- } else {
- $self->throw_exception('Unsupported REFTYPE given: '. ref $storage_type);
- }
+ # if we got here, they probably passed a full class name
+ my $mapped = $self->class_mappings->{$moniker};
+ $self->throw_exception("Can't find source for ${moniker}")
+ unless $mapped && exists $sreg->{$mapped};
+ return $sreg->{$mapped};
}
-=head2 connect
+=head2 class
=over 4
-=item Arguments: @info
+=item Arguments: $source_name
-=item Return Value: $new_schema
+=item Return Value: $classname
=back
-This is a convenience method. It is equivalent to calling
-$schema->clone->connection(@info). See L</connection> and L</clone> for more
-information.
+ my $class = $schema->class('CD');
+Retrieves the Result class name for the given source name.
+
=cut
-sub connect { shift->clone->connection(@_) }
+sub class {
+ my ($self, $moniker) = @_;
+ return $self->source($moniker)->result_class;
+}
=head2 txn_do
@@ -787,6 +584,14 @@
This interface is preferred over using the individual methods L</txn_begin>,
L</txn_commit>, and L</txn_rollback> below.
+WARNING: If you are connected with C<AutoCommit => 0> the transaction is
+considered nested, and you will still need to call L</txn_commit> to write your
+changes when appropriate. You will also want to connect with C<auto_savepoint =>
+1> to get partial rollback to work, if the storage driver for your database
+supports it.
+
+Connecting with C<AutoCommit => 1> is recommended.
+
=cut
sub txn_do {
@@ -865,6 +670,210 @@
$self->storage->txn_rollback;
}
+=head2 storage
+
+ my $storage = $schema->storage;
+
+Returns the L<DBIx::Class::Storage> object for this Schema. Grab this
+if you want to turn on SQL statement debugging at runtime, or set the
+quote character. For the default storage, the documentation can be
+found in L<DBIx::Class::Storage::DBI>.
+
+=head2 populate
+
+=over 4
+
+=item Arguments: $source_name, \@data;
+
+=item Return value: \@$objects | nothing
+
+=back
+
+Pass this method a resultsource name, and an arrayref of
+arrayrefs. The arrayrefs should contain a list of column names,
+followed by one or many sets of matching data for the given columns.
+
+In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
+to insert the data, as this is a fast method. However, insert_bulk currently
+assumes that your datasets all contain the same type of values, using scalar
+references in a column in one row, and not in another will probably not work.
+
+Otherwise, each set of data is inserted into the database using
+L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
+objects is returned.
+
+i.e.,
+
+ $schema->populate('Artist', [
+ [ qw/artistid name/ ],
+ [ 1, 'Popular Band' ],
+ [ 2, 'Indie Band' ],
+ ...
+ ]);
+
+Since wantarray context is basically the same as looping over $rs->create(...)
+you won't see any performance benefits and in this case the method is more for
+convenience. Void context sends the column information directly to storage
+using <DBI>s bulk insert method. So the performance will be much better for
+storages that support this method.
+
+Because of this difference in the way void context inserts rows into your
+database you need to note how this will effect any loaded components that
+override or augment insert. For example if you are using a component such
+as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use
+wantarray context if you want the PKs automatically created.
+
+=cut
+
+sub populate {
+ my ($self, $name, $data) = @_;
+ if(my $rs = $self->resultset($name)) {
+ if(defined wantarray) {
+ return $rs->populate($data);
+ } else {
+ $rs->populate($data);
+ }
+ } else {
+ $self->throw_exception("$name is not a resultset");
+ }
+}
+
+=head2 connection
+
+=over 4
+
+=item Arguments: @args
+
+=item Return Value: $new_schema
+
+=back
+
+Similar to L</connect> except sets the storage object and connection
+data in-place on the Schema class. You should probably be calling
+L</connect> to get a proper Schema object instead.
+
+
+=cut
+
+sub connection {
+ my ($self, @info) = @_;
+ return $self if !@info && $self->storage;
+
+ my ($storage_class, $args) = ref $self->storage_type ?
+ ($self->_normalize_storage_type($self->storage_type),{}) : ($self->storage_type, {});
+
+ $storage_class = 'DBIx::Class::Storage'.$storage_class
+ if $storage_class =~ m/^::/;
+ eval "require ${storage_class};";
+ $self->throw_exception(
+ "No arguments to load_classes and couldn't load ${storage_class} ($@)"
+ ) if $@;
+ my $storage = $storage_class->new($self=>$args);
+ $storage->connect_info(\@info);
+ $self->storage($storage);
+ return $self;
+}
+
+sub _normalize_storage_type {
+ my ($self, $storage_type) = @_;
+ if(ref $storage_type eq 'ARRAY') {
+ return @$storage_type;
+ } elsif(ref $storage_type eq 'HASH') {
+ return %$storage_type;
+ } else {
+ $self->throw_exception('Unsupported REFTYPE given: '. ref $storage_type);
+ }
+}
+
+=head2 compose_namespace
+
+=over 4
+
+=item Arguments: $target_namespace, $additional_base_class?
+
+=item Retur Value: $new_schema
+
+=back
+
+For each L<DBIx::Class::ResultSource> in the schema, this method creates a
+class in the target namespace (e.g. $target_namespace::CD,
+$target_namespace::Artist) that inherits from the corresponding classes
+attached to the current schema.
+
+It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
+new $schema object. If C<$additional_base_class> is given, the new composed
+classes will inherit from first the corresponding classe from the current
+schema then the base class.
+
+For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
+
+ $schema->compose_namespace('My::DB', 'Base::Class');
+ print join (', ', @My::DB::CD::ISA) . "\n";
+ print join (', ', @My::DB::Artist::ISA) ."\n";
+
+will produce the output
+
+ My::Schema::CD, Base::Class
+ My::Schema::Artist, Base::Class
+
+=cut
+
+# this might be oversimplified
+# sub compose_namespace {
+# my ($self, $target, $base) = @_;
+
+# my $schema = $self->clone;
+# foreach my $moniker ($schema->sources) {
+# my $source = $schema->source($moniker);
+# my $target_class = "${target}::${moniker}";
+# $self->inject_base(
+# $target_class => $source->result_class, ($base ? $base : ())
+# );
+# $source->result_class($target_class);
+# $target_class->result_source_instance($source)
+# if $target_class->can('result_source_instance');
+# $schema->register_source($moniker, $source);
+# }
+# return $schema;
+# }
+
+sub compose_namespace {
+ my ($self, $target, $base) = @_;
+ my $schema = $self->clone;
+ {
+ no warnings qw/redefine/;
+# local *Class::C3::reinitialize = sub { };
+ foreach my $moniker ($schema->sources) {
+ my $source = $schema->source($moniker);
+ my $target_class = "${target}::${moniker}";
+ $self->inject_base(
+ $target_class => $source->result_class, ($base ? $base : ())
+ );
+ $source->result_class($target_class);
+ $target_class->result_source_instance($source)
+ if $target_class->can('result_source_instance');
+ $schema->register_source($moniker, $source);
+ }
+ }
+# Class::C3->reinitialize();
+ {
+ no strict 'refs';
+ no warnings 'redefine';
+ foreach my $meth (qw/class source resultset/) {
+ *{"${target}::${meth}"} =
+ sub { shift->schema->$meth(@_) };
+ }
+ }
+ return $schema;
+}
+
+sub setup_connection_class {
+ my ($class, $target, @info) = @_;
+ $class->inject_base($target => 'DBIx::Class::DB');
+ #$target->load_components('DB');
+ $target->connection(@info);
+}
+
=head2 svp_begin
Creates a new savepoint (does nothing outside a transaction).
@@ -947,118 +956,6 @@
return $clone;
}
-=head2 populate
-
-=over 4
-
-=item Arguments: $source_name, \@data;
-
-=back
-
-Pass this method a resultsource name, and an arrayref of
-arrayrefs. The arrayrefs should contain a list of column names,
-followed by one or many sets of matching data for the given columns.
-
-In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
-to insert the data, as this is a fast method. However, insert_bulk currently
-assumes that your datasets all contain the same type of values, using scalar
-references in a column in one row, and not in another will probably not work.
-
-Otherwise, each set of data is inserted into the database using
-L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
-objects is returned.
-
-i.e.,
-
- $schema->populate('Artist', [
- [ qw/artistid name/ ],
- [ 1, 'Popular Band' ],
- [ 2, 'Indie Band' ],
- ...
- ]);
-
-Since wantarray context is basically the same as looping over $rs->create(...)
-you won't see any performance benefits and in this case the method is more for
-convenience. Void context sends the column information directly to storage
-using <DBI>s bulk insert method. So the performance will be much better for
-storages that support this method.
-
-Because of this difference in the way void context inserts rows into your
-database you need to note how this will effect any loaded components that
-override or augment insert. For example if you are using a component such
-as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use
-wantarray context if you want the PKs automatically created.
-
-=cut
-
-sub populate {
- my ($self, $name, $data) = @_;
- my $rs = $self->resultset($name);
- my @names = @{shift(@$data)};
- if(defined wantarray) {
- my @created;
- foreach my $item (@$data) {
- my %create;
- @create{@names} = @$item;
- push(@created, $rs->create(\%create));
- }
- return @created;
- }
- my @results_to_create;
- foreach my $datum (@$data) {
- my %result_to_create;
- foreach my $index (0..$#names) {
- $result_to_create{$names[$index]} = $$datum[$index];
- }
- push @results_to_create, \%result_to_create;
- }
- $rs->populate(\@results_to_create);
-}
-
-=head2 exception_action
-
-=over 4
-
-=item Arguments: $code_reference
-
-=back
-
-If C<exception_action> is set for this class/object, L</throw_exception>
-will prefer to call this code reference with the exception as an argument,
-rather than its normal C<croak> or C<confess> action.
-
-Your subroutine should probably just wrap the error in the exception
-object/class of your choosing and rethrow. If, against all sage advice,
-you'd like your C<exception_action> to suppress a particular exception
-completely, simply have it return true.
-
-Example:
-
- package My::Schema;
- use base qw/DBIx::Class::Schema/;
- use My::ExceptionClass;
- __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
- __PACKAGE__->load_classes;
-
- # or:
- my $schema_obj = My::Schema->connect( .... );
- $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
-
- # suppress all exceptions, like a moron:
- $schema_obj->exception_action(sub { 1 });
-
-=head2 stacktrace
-
-=over 4
-
-=item Arguments: boolean
-
-=back
-
-Whether L</throw_exception> should include stack trace information.
-Defaults to false normally, but defaults to true if C<$ENV{DBIC_TRACE}>
-is true.
-
=head2 throw_exception
=over 4
@@ -1115,13 +1012,17 @@
=item Arguments: $rdbms_type, $sqlt_args, $dir
+=item Return value: $listofstatements
+
=back
-A convenient shortcut to storage->deployment_statements(). Returns the SQL statements
-used by L</deploy> and L<DBIx::Class::Schema::Storage/deploy>. C<$rdbms_type> provides
-the (optional) SQLT (not DBI) database driver name for which the SQL statements are produced.
-If not supplied, the type is determined by interrogating the current connection.
-The other two arguments are identical to those of L</deploy>.
+A convenient shortcut to storage->deployment_statements(). Returns the
+SQL statements used by L</deploy> and
+L<DBIx::Class::Schema::Storage/deploy>. C<$rdbms_type> provides the
+(optional) SQLT (not DBI) database driver name for which the SQL
+statements are produced. If not supplied, the type is determined by
+interrogating the current connection. The other two arguments are
+identical to those of L</deploy>.
=cut
@@ -1162,7 +1063,7 @@
=item databases - ['MySQL', 'SQLite', 'PostgreSQL']
-=item version - $schema->VERSION
+=item version - $schema->schema_version
=item directory - './'
@@ -1190,6 +1091,8 @@
=item Arguments: $database-type, $version, $directory, $preversion
+=item Return value: $normalised_filename
+
=back
my $filename = $table->ddl_filename($type, $version, $dir, $preversion)
@@ -1214,18 +1117,9 @@
return $filename;
}
-=head2 sqlt_deploy_hook($sqlt_schema)
-
-An optional sub which you can declare in your own Schema class that will get
-passed the L<SQL::Translator::Schema> object when you deploy the schema via
-L</create_ddl_dir> or L</deploy>.
-
-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
+Provided as the recommended 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
@@ -1263,7 +1157,7 @@
=head2 schema_version
-Returns the current schema class' $VERSION
+Returns the current schema class' $VERSION in a normalised way.
=cut
@@ -1284,6 +1178,192 @@
return $version;
}
+
+=head2 register_class
+
+=over 4
+
+=item Arguments: $moniker, $component_class
+
+=back
+
+This method is called by L</load_namespaces> and L</load_classes> to install the found classes into your Schema. You should be using those instead of this one.
+
+You will only need this method if you have your Result classes in
+files which are not named after the packages (or all in the same
+file). You may also need it to register classes at runtime.
+
+Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
+calling:
+
+ $schema->register_source($moniker, $component_class->result_source_instance);
+
+=cut
+
+sub register_class {
+ my ($self, $moniker, $to_register) = @_;
+ $self->register_source($moniker => $to_register->result_source_instance);
+}
+
+=head2 register_source
+
+=over 4
+
+=item Arguments: $moniker, $result_source
+
+=back
+
+This method is called by L</register_class>.
+
+Registers the L<DBIx::Class::ResultSource> in the schema with the given
+moniker.
+
+=cut
+
+sub register_source {
+ my $self = shift;
+
+ $self->_register_source(@_);
+}
+
+=head2 register_extra_source
+
+=over 4
+
+=item Arguments: $moniker, $result_source
+
+=back
+
+As L</register_source> but should be used if the result class already
+has a source and you want to register an extra one.
+
+=cut
+
+sub register_extra_source {
+ my $self = shift;
+
+ $self->_register_source(@_, { extra => 1 });
+}
+
+sub _register_source {
+ my ($self, $moniker, $source, $params) = @_;
+
+ $source = $source->new({ %$source, source_name => $moniker });
+
+ my %reg = %{$self->source_registrations};
+ $reg{$moniker} = $source;
+ $self->source_registrations(\%reg);
+
+ $source->schema($self);
+ weaken($source->{schema}) if ref($self);
+ return if ($params->{extra});
+
+ if ($source->result_class) {
+ my %map = %{$self->class_mappings};
+ if (exists $map{$source->result_class}) {
+ warn $source->result_class . ' already has a source, use register_extra_source for additional sources';
+ }
+ $map{$source->result_class} = $moniker;
+ $self->class_mappings(\%map);
+ }
+}
+
+sub _unregister_source {
+ my ($self, $moniker) = @_;
+ my %reg = %{$self->source_registrations};
+
+ my $source = delete $reg{$moniker};
+ $self->source_registrations(\%reg);
+ if ($source->result_class) {
+ my %map = %{$self->class_mappings};
+ delete $map{$source->result_class};
+ $self->class_mappings(\%map);
+ }
+}
+
+
+=head2 compose_connection (DEPRECATED)
+
+=over 4
+
+=item Arguments: $target_namespace, @db_info
+
+=item Return Value: $new_schema
+
+=back
+
+DEPRECATED. You probably wanted compose_namespace.
+
+Actually, you probably just wanted to call connect.
+
+=begin hidden
+
+(hidden due to deprecation)
+
+Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
+calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
+then injects the L<DBix::Class::ResultSetProxy> component and a
+resultset_instance classdata entry on all the new classes, in order to support
+$target_namespaces::$class->search(...) method calls.
+
+This is primarily useful when you have a specific need for class method access
+to a connection. In normal usage it is preferred to call
+L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
+on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
+more information.
+
+=end hidden
+
+=cut
+
+{
+ my $warn;
+
+ sub compose_connection {
+ my ($self, $target, @info) = @_;
+
+ warn "compose_connection deprecated as of 0.08000"
+ unless ($INC{"DBIx/Class/CDBICompat.pm"} || $warn++);
+
+ my $base = 'DBIx::Class::ResultSetProxy';
+ eval "require ${base};";
+ $self->throw_exception
+ ("No arguments to load_classes and couldn't load ${base} ($@)")
+ if $@;
+
+ if ($self eq $target) {
+ # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
+ foreach my $moniker ($self->sources) {
+ my $source = $self->source($moniker);
+ my $class = $source->result_class;
+ $self->inject_base($class, $base);
+ $class->mk_classdata(resultset_instance => $source->resultset);
+ $class->mk_classdata(class_resolver => $self);
+ }
+ $self->connection(@info);
+ return $self;
+ }
+
+ my $schema = $self->compose_namespace($target, $base);
+ {
+ no strict 'refs';
+ my $name = join '::', $target, 'schema';
+ *$name = Sub::Name::subname $name, sub { $schema };
+ }
+
+ $schema->connection(@info);
+ foreach my $moniker ($schema->sources) {
+ my $source = $schema->source($moniker);
+ my $class = $source->result_class;
+ #warn "$moniker $class $source ".$source->storage;
+ $class->mk_classdata(result_source_instance => $source);
+ $class->mk_classdata(resultset_instance => $source->resultset);
+ $class->mk_classdata(class_resolver => $schema);
+ }
+ return $schema;
+ }
+}
+
1;
=head1 AUTHORS
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/StartupCheck.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/StartupCheck.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/StartupCheck.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,35 +1,5 @@
package DBIx::Class::StartupCheck;
-BEGIN {
-
- { package # don't want this in PAUSE
- TestRHBug; use overload bool => sub { 0 } }
-
- sub _has_bug_34925 {
- my %thing;
- my $r1 = \%thing;
- my $r2 = \%thing;
- bless $r1 => 'TestRHBug';
- return !!$r2;
- }
-
- sub _possibly_has_bad_overload_performance {
- return $] < 5.008009 && ! _has_bug_34925();
- }
-
- unless ($ENV{DBIC_NO_WARN_BAD_PERL}) {
- if (_possibly_has_bad_overload_performance()) {
- print STDERR "\n\nWARNING: " . __PACKAGE__ . ": This version of Perl is likely to exhibit\n" .
- "extremely slow performance for certain critical operations.\n" .
- "Please consider recompiling Perl. For more information, see\n" .
- "https://bugzilla.redhat.com/show_bug.cgi?id=196836 and/or\n" .
- "http://lists.scsys.co.uk/pipermail/dbix-class/2007-October/005119.html.\n" .
- "You can suppress this message by setting DBIC_NO_WARN_BAD_PERL=1 in your\n" .
- "environment.\n\n";
- }
- }
-}
-
=head1 NAME
DBIx::Class::StartupCheck - Run environment checks on startup
@@ -40,15 +10,22 @@
=head1 DESCRIPTION
-Currently this module checks for, and if necessary issues a warning for, a
-particular bug found on RedHat systems from perl-5.8.8-10 and up. Other checks
-may be added from time to time.
+This module used to check for, and if necessary issue a warning for, a
+particular bug found on Red Hat and Fedora systems using their system
+perl build. As of September 2008 there are fixed versions of perl for
+all current Red Hat and Fedora distributions, but the old check still
+triggers, incorrectly flagging those versions of perl to be buggy. A
+more comprehensive check has been moved into the test suite in
+C<t/99rh_perl_perf_bug.t> and further information about the bug has been
+put in L<DBIx::Class::Manual::Troubleshooting>
+Other checks may be added from time to time.
+
Any checks herein can be disabled by setting an appropriate environment
-variable. If your system suffers from a particular bug, you will get a warning
-message on startup sent to STDERR, explaining what to do about it and how to
-suppress the message. If you don't see any messages, you have nothing to worry
-about.
+variable. If your system suffers from a particular bug, you will get a
+warning message on startup sent to STDERR, explaining what to do about
+it and how to suppress the message. If you don't see any messages, you
+have nothing to worry about.
=head1 CONTRIBUTORS
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Cursor.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Cursor.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Cursor.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -49,6 +49,32 @@
return bless ($new, $class);
}
+=head2 as_query
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: \[ $sql, @bind ]
+
+=back
+
+Returns the SQL statement and bind vars associated with the invocant.
+
+=cut
+
+sub as_query {
+ my $self = shift;
+
+ my $storage = $self->{storage};
+ my $sql_maker = $storage->sql_maker;
+ local $sql_maker->{for};
+
+ my @args = $storage->_select_args(@{$self->{args}});
+ my ($sql, $bind) = $storage->_prep_for_execute(@args[0 .. 2], [@args[4 .. $#args]]);
+ return \[ "($sql)", @$bind ];
+}
+
=head2 next
=over 4
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/MSSQL.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/MSSQL.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/MSSQL.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -7,7 +7,7 @@
sub _dbh_last_insert_id {
my ($self, $dbh, $source, $col) = @_;
- my ($id) = $dbh->selectrow_array('SELECT @@IDENTITY');
+ my ($id) = $dbh->selectrow_array('SELECT SCOPE_IDENTITY()');
return $id;
}
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -54,7 +54,7 @@
=head1 NAME
-DBIx::Class::Storage::ODBC::ACCESS - Support specific to MS Access over ODBC
+DBIx::Class::Storage::DBI::ODBC::ACCESS - Support specific to MS Access over ODBC
=head1 WARNING
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/ODBC.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/ODBC.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/ODBC.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -17,7 +17,15 @@
}
}
+sub _dbh_last_insert_id {
+ my ($self, $dbh, $source, $col) = @_;
+ # punt: if there is no derived class for the specific backend, attempt
+ # to use the DBI->last_insert_id, which may not be sufficient (see the
+ # discussion of last_insert_id in perldoc DBI)
+ return $dbh->last_insert_id(undef, undef, $source->from, $col);
+}
+
1;
=head1 NAME
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -6,7 +6,7 @@
=head1 NAME
-DBIx::Class::Storage::DBI::Oracle - Automatic primary key class for Oracle
+DBIx::Class::Storage::DBI::Oracle::Generic - Automatic primary key class for Oracle
=head1 SYNOPSIS
@@ -55,8 +55,23 @@
# trigger_body is a LONG
$dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
- my $sth = $dbh->prepare($sql);
- $sth->execute( uc($source->name) );
+ my $sth;
+
+ # check for fully-qualified name (eg. SCHEMA.TABLENAME)
+ if ( my ( $schema, $table ) = $source->name =~ /(\w+)\.(\w+)/ ) {
+ $sql = q{
+ SELECT trigger_body FROM ALL_TRIGGERS t
+ WHERE t.owner = ? AND t.table_name = ?
+ AND t.triggering_event = 'INSERT'
+ AND t.status = 'ENABLED'
+ };
+ $sth = $dbh->prepare($sql);
+ $sth->execute( uc($schema), uc($table) );
+ }
+ else {
+ $sth = $dbh->prepare($sql);
+ $sth->execute( uc( $source->name ) );
+ }
while (my ($insert_trigger) = $sth->fetchrow_array) {
return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
}
@@ -69,6 +84,72 @@
return $id;
}
+=head2 connected
+
+Returns true if we have an open (and working) database connection, false if it is not (yet)
+open (or does not work). (Executes a simple SELECT to make sure it works.)
+
+The reason this is needed is that L<DBD::Oracle>'s ping() does not do a real
+OCIPing but just gets the server version, which doesn't help if someone killed
+your session.
+
+=cut
+
+sub connected {
+ my $self = shift;
+
+ if (not $self->SUPER::connected(@_)) {
+ return 0;
+ }
+ else {
+ my $dbh = $self->_dbh;
+
+ local $dbh->{RaiseError} = 1;
+
+ eval {
+ my $ping_sth = $dbh->prepare_cached("select 1 from dual");
+ $ping_sth->execute;
+ $ping_sth->finish;
+ };
+
+ return $@ ? 0 : 1;
+ }
+}
+
+sub _dbh_execute {
+ my $self = shift;
+ my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
+
+ my $wantarray = wantarray;
+
+ my (@res, $exception, $retried);
+
+ RETRY: {
+ do {
+ eval {
+ if ($wantarray) {
+ @res = $self->SUPER::_dbh_execute(@_);
+ } else {
+ $res[0] = $self->SUPER::_dbh_execute(@_);
+ }
+ };
+ $exception = $@;
+ if ($exception =~ /ORA-01003/) {
+ # ORA-01003: no statement parsed (someone changed the table somehow,
+ # invalidating your cursor.)
+ my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
+ delete $dbh->{CachedKids}{$sql};
+ } else {
+ last RETRY;
+ }
+ } while (not $retried++);
+ }
+
+ $self->throw_exception($exception) if $exception;
+
+ wantarray ? @res : $res[0]
+}
+
=head2 get_autoinc_seq
Returns the sequence name for an autoincrement column
@@ -103,6 +184,22 @@
sub datetime_parser_type { return "DateTime::Format::Oracle"; }
+sub _svp_begin {
+ my ($self, $name) = @_;
+
+ $self->dbh->do("SAVEPOINT $name");
+}
+
+# Oracle automatically releases a savepoint when you start another one with the
+# same name.
+sub _svp_release { 1 }
+
+sub _svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->dbh->do("ROLLBACK TO SAVEPOINT $name")
+}
+
=head1 AUTHORS
Andy Grundman <andy at hybridized.org>
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Oracle.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Oracle.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Oracle.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -25,20 +25,6 @@
}
}
-sub _svp_begin {
- my ($self, $name) = @_;
-
- $self->dbh->do("SAVEPOINT $name");
-}
-
-# Would've implemented _svp_release here, but Oracle doesn't support it.
-
-sub _svp_rollback {
- my ($self, $name) = @_;
-
- $self->dbh->do("ROLLBACK TO SAVEPOINT $name")
-}
-
1;
=head1 NAME
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Pg.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Pg.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Pg.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -70,6 +70,7 @@
my $bind_attributes = {
bytea => { pg_type => DBD::Pg::PG_BYTEA },
+ blob => { pg_type => DBD::Pg::PG_BYTEA },
};
if( defined $bind_attributes->{$data_type} ) {
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -126,19 +126,20 @@
around 'next_storage' => sub {
my ($next_storage, $self, @args) = @_;
my $now = time;
-
+
## Do we need to validate the replicants?
if(
$self->has_auto_validate_every &&
($self->auto_validate_every + $self->pool->last_validated) <= $now
- ) {
+ ) {
$self->pool->validate_replicants;
}
-
+
## Get a replicant, or the master if none
if(my $next = $self->$next_storage(@args)) {
return $next;
} else {
+ $self->master->debugobj->print("No Replicants validate, falling back to master reads. ");
return $self->master;
}
};
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -168,14 +168,40 @@
sub connect_replicant {
my ($self, $schema, $connect_info) = @_;
my $replicant = $self->create_replicant($schema);
-
- $replicant->connect_info($connect_info);
- $replicant->ensure_connected;
- DBIx::Class::Storage::DBI::Replicated::Replicant->meta->apply($replicant);
-
+ $replicant->connect_info($connect_info);
+ $self->_safely_ensure_connected($replicant);
+ DBIx::Class::Storage::DBI::Replicated::Replicant->meta->apply($replicant);
return $replicant;
}
+=head2 _safely_ensure_connected ($replicant)
+
+The standard ensure_connected method with throw an exception should it fail to
+connect. For the master database this is desirable, but since replicants are
+allowed to fail, this behavior is not desirable. This method wraps the call
+to ensure_connected in an eval in order to catch any generated errors. That
+way a slave to go completely offline (ie, the box itself can die) without
+bringing down your entire pool of databases.
+
+=cut
+
+sub _safely_ensure_connected {
+ my ($self, $replicant, @args) = @_;
+ eval {
+ $replicant->ensure_connected(@args);
+ };
+ if ($@) {
+ $replicant
+ ->debugobj
+ ->print(
+ sprintf( "Exception trying to ->ensure_connected for replicant %s, error is %s",
+ $replicant->_dbi_connect_info->[0], $@)
+ );
+ return;
+ }
+ return 1;
+}
+
=head2 connected_replicants
Returns true if there are connected replicants. Actually is overloaded to
@@ -242,23 +268,43 @@
Calling this method will generate queries on the replicant databases so it is
not recommended that you run them very often.
+This method requires that your underlying storage engine supports some sort of
+native replication mechanism. Currently only MySQL native replication is
+supported. Your patches to make other replication types work are welcomed.
+
=cut
sub validate_replicants {
my $self = shift @_;
foreach my $replicant($self->all_replicants) {
- if(
- $replicant->is_replicating &&
- $replicant->lag_behind_master <= $self->maximum_lag &&
- $replicant->ensure_connected
- ) {
- $replicant->active(1)
+ if($self->_safely_ensure_connected($replicant)) {
+ my $is_replicating = $replicant->is_replicating;
+ unless(defined $is_replicating) {
+ $replicant->debugobj->print("Storage Driver ".ref $self." Does not support the 'is_replicating' method. Assuming you are manually managing.");
+ next;
+ } else {
+ if($is_replicating) {
+ my $lag_behind_master = $replicant->lag_behind_master;
+ unless(defined $lag_behind_master) {
+ $replicant->debugobj->print("Storage Driver ".ref $self." Does not support the 'lag_behind_master' method. Assuming you are manually managing.");
+ next;
+ } else {
+ if($lag_behind_master <= $self->maximum_lag) {
+ $replicant->active(1);
+ } else {
+ $replicant->active(0);
+ }
+ }
+ } else {
+ $replicant->active(0);
+ }
+ }
} else {
$replicant->active(0);
}
}
## Mark that we completed this validation.
- $self->_last_validated(time);
+ $self->_last_validated(time);
}
=head1 AUTHOR
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated/Replicant.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated/Replicant.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated/Replicant.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -52,7 +52,7 @@
This class defines the following methods.
-=head2 after: _query_start
+=head2 around: _query_start
advice iof the _query_start method to add more debuggin
@@ -60,7 +60,7 @@
around '_query_start' => sub {
my ($method, $self, $sql, @bind) = @_;
- my $dsn = $self->connect_info->[0];
+ my $dsn = $self->_dbi_connect_info->[0];
$self->$method("DSN: $dsn SQL: $sql", @bind);
};
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Replicated.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -99,7 +99,7 @@
Replicated Storage has additional requirements not currently part of L<DBIx::Class>
- Moose => 1.54
+ Moose => 0.54
MooseX::AttributeHelpers => 0.12
Moose::Util::TypeConstraints => 0.54
Class::MOP => 0.63
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/Role/QueryCounter.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -5,7 +5,7 @@
=head1 NAME
-DBIx::Class::Storage::DBI::Role::QueryCounter; Role to add a query counter
+DBIx::Class::Storage::DBI::Role::QueryCounter - Role to add a query counter
=head1 SYNOPSIS
@@ -78,4 +78,4 @@
=cut
-1;
\ No newline at end of file
+1;
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/SQLite.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/SQLite.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI/SQLite.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -19,7 +19,7 @@
$dir ||= './';
## Where is the db file?
- my $dsn = $self->connect_info()->[0];
+ my $dsn = $self->_dbi_connect_info()->[0];
my $dbname = $1 if($dsn =~ /dbname=([^;]+)/);
if(!$dbname)
@@ -45,7 +45,21 @@
return $backupfile;
}
+sub disconnect {
+ # As described in this node http://www.perlmonks.org/?node_id=666210
+ # there seems to be no sane way to ->disconnect a SQLite database with
+ # cached statement handles. As per mst we just zap the cache and
+ # proceed as normal.
+
+ my $self = shift;
+ if ($self->connected) {
+ $self->_dbh->{CachedKids} = {};
+ $self->next::method (@_);
+ }
+}
+
+
1;
=head1 NAME
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class/Storage/DBI.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -14,11 +14,18 @@
__PACKAGE__->mk_group_accessors('simple' =>
qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts
- _conn_pid _conn_tid disable_sth_caching on_connect_do
- on_disconnect_do transaction_depth unsafe _dbh_autocommit
- auto_savepoint savepoints/
+ _conn_pid _conn_tid transaction_depth _dbh_autocommit savepoints/
);
+# the values for these accessors are picked out (and deleted) from
+# the attribute hashref passed to connect_info
+my @storage_options = qw/
+ on_connect_do on_disconnect_do disable_sth_caching unsafe auto_savepoint
+/;
+__PACKAGE__->mk_group_accessors('simple' => @storage_options);
+
+
+# default cursor class, overridable in connect_info attributes
__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
__PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/);
@@ -43,6 +50,9 @@
$self;
}
+# DB2 is the only remaining DB using this. Even though we are not sure if
+# RowNumberOver is still needed here (should be part of SQLA) leave the
+# code in place
sub _RowNumberOver {
my ($self, $sql, $order, $rows, $offset ) = @_;
@@ -50,7 +60,7 @@
my $last = $rows + $offset;
my ( $order_by ) = $self->_order_by( $order );
- $sql = <<"";
+ $sql = <<"SQL";
SELECT * FROM
(
SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
@@ -60,6 +70,8 @@
) Q2
WHERE ROW_NUM BETWEEN $offset AND $last
+SQL
+
return $sql;
}
@@ -69,17 +81,26 @@
use Scalar::Util 'blessed';
sub _find_syntax {
my ($self, $syntax) = @_;
- my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
+
+ # DB2 is the only remaining DB using this. Even though we are not sure if
+ # RowNumberOver is still needed here (should be part of SQLA) leave the
+ # code in place
+ my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
if(ref($self) && $dbhname && $dbhname eq 'DB2') {
return 'RowNumberOver';
}
-
+
$self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
}
sub select {
my ($self, $table, $fields, $where, $order, @rest) = @_;
- $table = $self->_quote($table) unless ref($table);
+ if (ref $table eq 'SCALAR') {
+ $table = $$table;
+ }
+ elsif (not ref $table) {
+ $table = $self->_quote($table);
+ }
local $self->{rownum_hack_count} = 1
if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
@rest = (-1) unless defined $rest[0];
@@ -150,6 +171,13 @@
.'( '.$self->_recurse_fields($fields->{$func}).' )';
}
}
+ # Is the second check absolutely necessary?
+ elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
+ return $self->_bind_to_sql( $fields );
+ }
+ else {
+ Carp::croak($ref . qq{ unexpected in _recurse_fields()})
+ }
}
sub _order_by {
@@ -170,6 +198,9 @@
if (defined $_[0]->{order_by}) {
$ret .= $self->_order_by($_[0]->{order_by});
}
+ if (grep { $_ =~ /^-(desc|asc)/i } keys %{$_[0]}) {
+ return $self->SUPER::_order_by($_[0]);
+ }
} elsif (ref $_[0] eq 'SCALAR') {
$ret = $self->_sqlcase(' order by ').${ $_[0] };
} elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
@@ -235,10 +266,20 @@
return join('', @sqlf);
}
+sub _bind_to_sql {
+ my $self = shift;
+ my $arr = shift;
+ my $sql = shift @$$arr;
+ $sql =~ s/\?/$self->_quote((shift @$$arr)->[1])/eg;
+ return $sql
+}
+
sub _make_as {
my ($self, $from) = @_;
- return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
- reverse each %{$self->_skip_options($from)});
+ return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
+ : ref $_ eq 'REF' ? $self->_bind_to_sql($_)
+ : $self->_quote($_))
+ } reverse each %{$self->_skip_options($from)});
}
sub _skip_options {
@@ -315,6 +356,15 @@
=head1 SYNOPSIS
+ my $schema = MySchema->connect('dbi:SQLite:my.db');
+
+ $schema->storage->debug(1);
+ $schema->dbh_do("DROP TABLE authors");
+
+ $schema->resultset('Book')->search({
+ written_on => $schema->storage->datetime_parser(DateTime->now)
+ });
+
=head1 DESCRIPTION
This class represents the connection to an RDBMS via L<DBI>. See
@@ -339,28 +389,81 @@
=head2 connect_info
-The arguments of C<connect_info> are always a single array reference.
+This method is normally called by L<DBIx::Class::Schema/connection>, which
+encapsulates its argument list in an arrayref before passing them here.
-This is normally accessed via L<DBIx::Class::Schema/connection>, which
-encapsulates its argument list in an arrayref before calling
-C<connect_info> here.
+The argument list may contain:
-The arrayref can either contain the same set of arguments one would
-normally pass to L<DBI/connect>, or a lone code reference which returns
-a connected database handle. Please note that the L<DBI> docs
-recommend that you always explicitly set C<AutoCommit> to either
-C<0> or C<1>. L<DBIx::Class> further recommends that it be set
-to C<1>, and that you perform transactions via our L</txn_do>
-method. L<DBIx::Class> will set it to C<1> if you do not do explicitly
-set it to zero. This is the default for most DBDs. See below for more
-details.
+=over
-In either case, if the final argument in your connect_info happens
-to be a hashref, C<connect_info> will look there for several
-connection-specific options:
+=item *
-=over 4
+The same 4-element argument set one would normally pass to
+L<DBI/connect>, optionally followed by
+L<extra attributes|/DBIx::Class specific connection attributes>
+recognized by DBIx::Class:
+ $connect_info_args = [ $dsn, $user, $password, \%dbi_attributes?, \%extra_attributes? ];
+
+=item *
+
+A single code reference which returns a connected
+L<DBI database handle|DBI/connect> optionally followed by
+L<extra attributes|/DBIx::Class specific connection attributes> recognized
+by DBIx::Class:
+
+ $connect_info_args = [ sub { DBI->connect (...) }, \%extra_attributes? ];
+
+=item *
+
+A single hashref with all the attributes and the dsn/user/password
+mixed together:
+
+ $connect_info_args = [{
+ dsn => $dsn,
+ user => $user,
+ password => $pass,
+ %dbi_attributes,
+ %extra_attributes,
+ }];
+
+This is particularly useful for L<Catalyst> based applications, allowing the
+following config (L<Config::General> style):
+
+ <Model::DB>
+ schema_class App::DB
+ <connect_info>
+ dsn dbi:mysql:database=test
+ user testuser
+ password TestPass
+ AutoCommit 1
+ </connect_info>
+ </Model::DB>
+
+=back
+
+Please note that the L<DBI> docs recommend that you always explicitly
+set C<AutoCommit> to either I<0> or I<1>. L<DBIx::Class> further
+recommends that it be set to I<1>, and that you perform transactions
+via our L<DBIx::Class::Schema/txn_do> method. L<DBIx::Class> will set it
+to I<1> if you do not do explicitly set it to zero. This is the default
+for most DBDs. See L</DBIx::Class and AutoCommit> for details.
+
+=head3 DBIx::Class specific connection attributes
+
+In addition to the standard L<DBI|DBI/ATTRIBUTES_COMMON_TO_ALL_HANDLES>
+L<connection|DBI/Database_Handle_Attributes> attributes, DBIx::Class recognizes
+the following connection options. These options can be mixed in with your other
+L<DBI> connection attributes, or placed in a seperate hashref
+(C<\%extra_attributes>) as shown above.
+
+Every time C<connect_info> is invoked, any previous settings for
+these options will be cleared before setting the new ones, regardless of
+whether any options are specified in the new C<connect_info>.
+
+
+=over
+
=item on_connect_do
Specifies things to do immediately after connecting or re-connecting to
@@ -382,10 +485,10 @@
=item on_disconnect_do
-Takes arguments in the same form as L<on_connect_do> and executes them
+Takes arguments in the same form as L</on_connect_do> and executes them
immediately before disconnecting from the database.
-Note, this only runs if you explicitly call L<disconnect> on the
+Note, this only runs if you explicitly call L</disconnect> on the
storage object.
=item disable_sth_caching
@@ -397,26 +500,31 @@
Sets the limit dialect. This is useful for JDBC-bridge among others
where the remote SQL-dialect cannot be determined by the name of the
-driver alone.
+driver alone. See also L<SQL::Abstract::Limit>.
=item quote_char
Specifies what characters to use to quote table and column names. If
-you use this you will want to specify L<name_sep> as well.
+you use this you will want to specify L</name_sep> as well.
-quote_char expects either a single character, in which case is it is placed
-on either side of the table/column, or an arrayref of length 2 in which case the
-table/column name is placed between the elements.
+C<quote_char> expects either a single character, in which case is it
+is placed on either side of the table/column name, or an arrayref of length
+2 in which case the table/column name is placed between the elements.
-For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
-use C<quote_char =E<gt> [qw/[ ]/]>.
+For example under MySQL you should use C<< quote_char => '`' >>, and for
+SQL Server you should use C<< quote_char => [qw/[ ]/] >>.
=item name_sep
-This only needs to be used in conjunction with L<quote_char>, and is used to
+This only needs to be used in conjunction with C<quote_char>, and is used to
specify the charecter that seperates elements (schemas, tables, columns) from
each other. In most cases this is simply a C<.>.
+The consequences of not supplying this value is that L<SQL::Abstract>
+will assume DBIx::Class' uses of aliases to be complete column
+names. The output will look like I<"me.name"> when it should actually
+be I<"me"."name">.
+
=item unsafe
This Storage driver normally installs its own C<HandleError>, sets
@@ -439,33 +547,16 @@
transactions, making it possible to recover from failure in the inner
transaction without having to abort all outer transactions.
-=back
+=item cursor_class
-These options can be mixed in with your other L<DBI> connection attributes,
-or placed in a seperate hashref after all other normal L<DBI> connection
-arguments.
+Use this argument to supply a cursor class other than the default
+L<DBIx::Class::Storage::DBI::Cursor>.
-Every time C<connect_info> is invoked, any previous settings for
-these options will be cleared before setting the new ones, regardless of
-whether any options are specified in the new C<connect_info>.
+=back
-Another Important Note:
+Some real-life examples of arguments to L</connect_info> and
+L<DBIx::Class::Schema/connect>
-DBIC can do some wonderful magic with handling exceptions,
-disconnections, and transactions when you use C<< AutoCommit => 1 >>
-combined with C<txn_do> for transaction support.
-
-If you set C<< AutoCommit => 0 >> in your connect info, then you are always
-in an assumed transaction between commits, and you're telling us you'd
-like to manage that manually. A lot of DBIC's magic protections
-go away. We can't protect you from exceptions due to database
-disconnects because we don't know anything about how to restart your
-transactions. You're on your own for handling all sorts of exceptional
-cases if you choose the C<< AutoCommit => 0 >> path, just as you would
-be with raw DBI.
-
-Examples:
-
# Simple SQLite connection
->connect_info([ 'dbi:SQLite:./foo.db' ]);
@@ -493,8 +584,21 @@
]
);
- # Subref + DBIC-specific connection options
+ # Same, but with hashref as argument
+ # See parse_connect_info for explanation
->connect_info(
+ [{
+ dsn => 'dbi:Pg:dbname=foo',
+ user => 'postgres',
+ password => 'my_pg_password',
+ AutoCommit => 1,
+ quote_char => q{"},
+ name_sep => q{.},
+ }]
+ );
+
+ # Subref + DBIx::Class-specific connection options
+ ->connect_info(
[
sub { DBI->connect(...) },
{
@@ -506,6 +610,8 @@
]
);
+
+
=cut
sub connect_info {
@@ -513,46 +619,61 @@
return $self->_connect_info if !$info_arg;
+ my @args = @$info_arg; # take a shallow copy for further mutilation
+ $self->_connect_info([@args]); # copy for _connect_info
+
+
+ # combine/pre-parse arguments depending on invocation style
+
+ my %attrs;
+ if (ref $args[0] eq 'CODE') { # coderef with optional \%extra_attributes
+ %attrs = %{ $args[1] || {} };
+ @args = $args[0];
+ }
+ elsif (ref $args[0] eq 'HASH') { # single hashref (i.e. Catalyst config)
+ %attrs = %{$args[0]};
+ @args = ();
+ for (qw/password user dsn/) {
+ unshift @args, delete $attrs{$_};
+ }
+ }
+ else { # otherwise assume dsn/user/password + \%attrs + \%extra_attrs
+ %attrs = (
+ % { $args[3] || {} },
+ % { $args[4] || {} },
+ );
+ @args = @args[0,1,2];
+ }
+
# Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
# the new set of options
$self->_sql_maker(undef);
$self->_sql_maker_opts({});
- $self->_connect_info([@$info_arg]); # copy for _connect_info
- my $dbi_info = [@$info_arg]; # copy for _dbi_connect_info
-
- my $last_info = $dbi_info->[-1];
- if(ref $last_info eq 'HASH') {
- $last_info = { %$last_info }; # so delete is non-destructive
- my @storage_option = qw(
- on_connect_do on_disconnect_do disable_sth_caching unsafe cursor_class
- auto_savepoint
- );
- for my $storage_opt (@storage_option) {
- if(my $value = delete $last_info->{$storage_opt}) {
+ if(keys %attrs) {
+ for my $storage_opt (@storage_options, 'cursor_class') { # @storage_options is declared at the top of the module
+ if(my $value = delete $attrs{$storage_opt}) {
$self->$storage_opt($value);
}
}
for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
- if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
+ if(my $opt_val = delete $attrs{$sql_maker_opt}) {
$self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
}
}
- # re-insert modified hashref
- $dbi_info->[-1] = $last_info;
-
- # Get rid of any trailing empty hashref
- pop(@$dbi_info) if !keys %$last_info;
}
- $self->_dbi_connect_info($dbi_info);
+ %attrs = () if (ref $args[0] eq 'CODE'); # _connect() never looks past $args[0] in this case
+
+ $self->_dbi_connect_info([@args, keys %attrs ? \%attrs : ()]);
$self->_connect_info;
}
=head2 on_connect_do
-This method is deprecated in favor of setting via L</connect_info>.
+This method is deprecated in favour of setting via L</connect_info>.
+
=head2 dbh_do
Arguments: ($subref | $method_name), @extra_coderef_args?
@@ -788,7 +909,7 @@
sub _sql_maker_args {
my ($self) = @_;
- return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
+ return ( bindtype=>'columns', array_datatypes => 1, limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
}
sub sql_maker {
@@ -819,11 +940,11 @@
}
}
+ $self->_conn_pid($$);
+ $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
+
my $connection_do = $self->on_connect_do;
$self->_do_connection_actions($connection_do) if ref($connection_do);
-
- $self->_conn_pid($$);
- $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
}
sub _do_connection_actions {
@@ -834,7 +955,7 @@
$self->_do_query($_) foreach @$connection_do;
}
elsif (ref $connection_do eq 'CODE') {
- $connection_do->();
+ $connection_do->($self);
}
return $self;
@@ -848,10 +969,18 @@
$self->_do_query($_) foreach @$action;
}
else {
- my @to_run = (ref $action eq 'ARRAY') ? (@$action) : ($action);
- $self->_query_start(@to_run);
- $self->_dbh->do(@to_run);
- $self->_query_end(@to_run);
+ # Most debuggers expect ($sql, @bind), so we need to exclude
+ # the attribute hash which is the second argument to $dbh->do
+ # furthermore the bind values are usually to be presented
+ # as named arrayref pairs, so wrap those here too
+ my @do_args = (ref $action eq 'ARRAY') ? (@$action) : ($action);
+ my $sql = shift @do_args;
+ my $attrs = shift @do_args;
+ my @bind = map { [ undef, $_ ] } @do_args;
+
+ $self->_query_start($sql, @bind);
+ $self->_dbh->do($sql, $attrs, @do_args);
+ $self->_query_end($sql, @bind);
}
return $self;
@@ -882,7 +1011,12 @@
my $weak_self = $self;
weaken($weak_self);
$dbh->{HandleError} = sub {
- $weak_self->throw_exception("DBI Exception: $_[0]")
+ if ($weak_self) {
+ $weak_self->throw_exception("DBI Exception: $_[0]");
+ }
+ else {
+ croak ("DBI Exception: $_[0]");
+ }
};
$dbh->{ShowErrorStatement} = 1;
$dbh->{RaiseError} = 1;
@@ -1055,16 +1189,16 @@
# all of _execute's args, and emits $sql, @bind.
sub _prep_for_execute {
my ($self, $op, $extra_bind, $ident, $args) = @_;
-
+
if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
$ident = $ident->from();
}
my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
+
unshift(@bind,
map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
if $extra_bind;
-
return ($sql, \@bind);
}
@@ -1124,7 +1258,8 @@
}
foreach my $data (@data) {
- $data = ref $data ? ''.$data : $data; # stringify args
+ my $ref = ref $data;
+ $data = $ref && $ref ne 'ARRAY' ? ''.$data : $data; # stringify args (except arrayrefs)
$sth->bind_param($placeholder_index, $data, $attributes);
$placeholder_index++;
@@ -1239,16 +1374,27 @@
}
sub _select {
+ my $self = shift;
+ my $sql_maker = $self->sql_maker;
+ local $sql_maker->{for};
+ return $self->_execute($self->_select_args(@_));
+}
+
+sub _select_args {
my ($self, $ident, $select, $condition, $attrs) = @_;
my $order = $attrs->{order_by};
if (ref $condition eq 'SCALAR') {
- $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
+ my $unwrap = ${$condition};
+ if ($unwrap =~ s/ORDER BY (.*)$//i) {
+ $order = $1;
+ $condition = \$unwrap;
+ }
}
my $for = delete $attrs->{for};
my $sql_maker = $self->sql_maker;
- local $sql_maker->{for} = $for;
+ $sql_maker->{for} = $for;
if (exists $attrs->{group_by} || $attrs->{having}) {
$order = {
@@ -1270,8 +1416,7 @@
$attrs->{rows} = 2**48 if not defined $attrs->{rows} and defined $attrs->{offset};
push @args, $attrs->{rows}, $attrs->{offset};
}
-
- return $self->_execute(@args);
+ return @args;
}
sub source_bind_attributes {
@@ -1310,7 +1455,8 @@
my $self = shift;
my ($rv, $sth, @bind) = $self->_select(@_);
my @row = $sth->fetchrow_array;
- if(@row && $sth->fetchrow_array) {
+ my @nextrow = $sth->fetchrow_array if @row;
+ if(@row && @nextrow) {
carp "Query returned more than one row. SQL that returns multiple rows is DEPRECATED for ->find and ->single";
}
# Need to call finish() to work round broken DBDs
@@ -1439,9 +1585,9 @@
=head2 bind_attribute_by_data_type
-Given a datatype from column info, returns a database specific bind attribute for
-$dbh->bind_param($val,$attribute) or nothing if we will let the database planner
-just handle it.
+Given a datatype from column info, returns a database specific bind
+attribute for C<< $dbh->bind_param($val,$attribute) >> or nothing if we will
+let the database planner just handle it.
Generally only needed for special case column types, like bytea in postgres.
@@ -1482,7 +1628,10 @@
}
$databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
$databases = [ $databases ] if(ref($databases) ne 'ARRAY');
- $version ||= $schema->VERSION || '1.x';
+
+ my $schema_version = $schema->schema_version || '1.x';
+ $version ||= $schema_version;
+
$sqltargs = {
add_drop_table => 1,
ignore_constraint_names => 1,
@@ -1490,7 +1639,7 @@
%{$sqltargs || {}}
};
- $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.09: '}
+ $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.09003: '}
. $self->_check_sqlt_message . q{'})
if !$self->_check_sqlt_version;
@@ -1507,7 +1656,7 @@
my $file;
my $filename = $schema->ddl_filename($db, $version, $dir);
- if (-e $filename && (!$version || ($version == $schema->schema_version()))) {
+ if (-e $filename && ($version eq $schema_version )) {
# if we are dumping the current version, overwrite the DDL
warn "Overwriting existing DDL file - $filename";
unlink($filename);
@@ -1624,9 +1773,9 @@
# Need to be connected to get the correct sqlt_type
$self->ensure_connected() unless $type;
$type ||= $self->sqlt_type;
- $version ||= $schema->VERSION || '1.x';
+ $version ||= $schema->schema_version || '1.x';
$dir ||= './';
- my $filename = $schema->ddl_filename($type, $dir, $version);
+ my $filename = $schema->ddl_filename($type, $version, $dir);
if(-f $filename)
{
my $file;
@@ -1637,7 +1786,7 @@
return join('', @rows);
}
- $self->throw_exception(q{Can't deploy without SQL::Translator 0.09: '}
+ $self->throw_exception(q{Can't deploy without SQL::Translator 0.09003: '}
. $self->_check_sqlt_message . q{'})
if !$self->_check_sqlt_version;
@@ -1657,24 +1806,34 @@
sub deploy {
my ($self, $schema, $type, $sqltargs, $dir) = @_;
- foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
- foreach my $line ( split(";\n", $statement)) {
- next if($line =~ /^--/);
- next if(!$line);
-# next if($line =~ /^DROP/m);
- next if($line =~ /^BEGIN TRANSACTION/m);
- next if($line =~ /^COMMIT/m);
- next if $line =~ /^\s+$/; # skip whitespace only
- $self->_query_start($line);
- eval {
- $self->dbh->do($line); # shouldn't be using ->dbh ?
- };
- if ($@) {
- warn qq{$@ (running "${line}")};
- }
- $self->_query_end($line);
+ my $deploy = sub {
+ my $line = shift;
+ return if($line =~ /^--/);
+ return if(!$line);
+ # next if($line =~ /^DROP/m);
+ return if($line =~ /^BEGIN TRANSACTION/m);
+ return if($line =~ /^COMMIT/m);
+ return if $line =~ /^\s+$/; # skip whitespace only
+ $self->_query_start($line);
+ eval {
+ $self->dbh->do($line); # shouldn't be using ->dbh ?
+ };
+ if ($@) {
+ warn qq{$@ (running "${line}")};
}
+ $self->_query_end($line);
+ };
+ my @statements = $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } );
+ if (@statements > 1) {
+ foreach my $statement (@statements) {
+ $deploy->( $statement );
+ }
}
+ elsif (@statements == 1) {
+ foreach my $line ( split(";\n", $statements[0])) {
+ $deploy->( $line );
+ }
+ }
}
=head2 datetime_parser
@@ -1719,7 +1878,7 @@
my $_check_sqlt_message; # private
sub _check_sqlt_version {
return $_check_sqlt_version if defined $_check_sqlt_version;
- eval 'use SQL::Translator "0.09"';
+ eval 'use SQL::Translator "0.09003"';
$_check_sqlt_message = $@ || '';
$_check_sqlt_version = !$@;
}
@@ -1764,6 +1923,24 @@
1;
+=head1 USAGE NOTES
+
+=head2 DBIx::Class and AutoCommit
+
+DBIx::Class can do some wonderful magic with handling exceptions,
+disconnections, and transactions when you use C<< AutoCommit => 1 >>
+combined with C<txn_do> for transaction support.
+
+If you set C<< AutoCommit => 0 >> in your connect info, then you are always
+in an assumed transaction between commits, and you're telling us you'd
+like to manage that manually. A lot of the magic protections offered by
+this module will go away. We can't protect you from exceptions due to database
+disconnects because we don't know anything about how to restart your
+transactions. You're on your own for handling all sorts of exceptional
+cases if you choose the C<< AutoCommit => 0 >> path, just as you would
+be with raw DBI.
+
+
=head1 SQL METHODS
The module defines a set of methods within the DBIC::SQL::Abstract
@@ -1785,17 +1962,14 @@
=item limit_dialect
See L</connect_info> for details.
-For setting, this method is deprecated in favor of L</connect_info>.
=item quote_char
See L</connect_info> for details.
-For setting, this method is deprecated in favor of L</connect_info>.
=item name_sep
See L</connect_info> for details.
-For setting, this method is deprecated in favor of L</connect_info>.
=back
Modified: DBIx-Class/0.08/branches/sybase/lib/DBIx/Class.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/DBIx/Class.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/DBIx/Class.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -24,7 +24,7 @@
# i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
# brain damage and presumably various other packaging systems too
-$VERSION = '0.08099_04';
+$VERSION = '0.08099_06';
$VERSION = eval $VERSION; # numify for warning-free dev releases
@@ -68,28 +68,28 @@
package MyDB::Schema;
use base qw/DBIx::Class::Schema/;
- __PACKAGE__->load_classes();
+ __PACKAGE__->load_namespaces();
1;
Create a table class to represent artists, who have many CDs, in
-MyDB/Schema/Artist.pm:
+MyDB/Schema/Result/Artist.pm:
- package MyDB::Schema::Artist;
+ package MyDB::Schema::Result::Artist;
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/Core/);
__PACKAGE__->table('artist');
__PACKAGE__->add_columns(qw/ artistid name /);
__PACKAGE__->set_primary_key('artistid');
- __PACKAGE__->has_many(cds => 'MyDB::Schema::CD');
+ __PACKAGE__->has_many(cds => 'MyDB::Schema::Result::CD');
1;
A table class to represent a CD, which belongs to an artist, in
-MyDB/Schema/CD.pm:
+MyDB/Schema/Result/CD.pm:
- package MyDB::Schema::CD;
+ package MyDB::Schema::Result::CD;
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/Core/);
@@ -121,7 +121,7 @@
# Execute a joined query to get the cds.
my @all_john_cds = $johns_rs->search_related('cds')->all;
- # Fetch only the next row.
+ # Fetch the next available row.
my $first_john = $johns_rs->next;
# Specify ORDER BY on the query.
@@ -217,6 +217,8 @@
bricas: Brian Cassidy <bricas at cpan.org>
+caelum: Rafael Kitover <rkitover at cpan.org>
+
captainL: Luke Saunders <luke.saunders at gmail.com>
castaway: Jess Robinson
@@ -243,6 +245,8 @@
jesper: Jesper Krogh
+jgoulah: John Goulah <jgoulah at cpan.org>
+
jguenther: Justin Guenther <jguenther at cpan.org>
jnapiorkowski: John Napiorkowski <jjn1056 at yahoo.com>
@@ -257,6 +261,8 @@
mattlaw: Matt Lawrence
+michaelr: Michael Reddick <michael.reddick at gmail.com>
+
ned: Neil de Carteret
nigel: Nigel Metheringham <nigelm at cpan.org>
@@ -275,10 +281,20 @@
phaylon: Robert Sedlacek <phaylon at dunkelheit.at>
+plu: Johannes Plunien <plu at cpan.org>
+
quicksilver: Jules Bean
+rafl: Florian Ragwitz <rafl at debian.org>
+
rdj: Ryan D Johnson <ryan at innerfence.com>
+ribasushi: Peter Rabbitson <rabbit+dbic at rabbit.us>
+
+rjbs: Ricardo Signes <rjbs at cpan.org>
+
+robkinyon: Rob Kinyon <rkinyon at cpan.org>
+
sc_: Just Another Perl Hacker
scotty: Scotty Allen <scotty at scottyallen.com>
@@ -303,6 +319,8 @@
zamolxes: Bogdan Lucaciu <bogdan at wiz.ro>
+norbi: Norbert Buchmuller <norbi at nix.hu>
+
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
Modified: DBIx-Class/0.08/branches/sybase/lib/SQL/Translator/Parser/DBIx/Class.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/lib/SQL/Translator/Parser/DBIx/Class.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/lib/SQL/Translator/Parser/DBIx/Class.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,5 +1,4 @@
-package # hide from PAUSE
- SQL::Translator::Parser::DBIx::Class;
+package SQL::Translator::Parser::DBIx::Class;
# AUTHOR: Jess Robinson
@@ -9,7 +8,8 @@
use strict;
use warnings;
-use vars qw($DEBUG @EXPORT_OK);
+use vars qw($DEBUG $VERSION @EXPORT_OK);
+$VERSION = '1.10';
$DEBUG = 0 unless defined $DEBUG;
use Exporter;
@@ -45,7 +45,7 @@
my $schema = $tr->schema;
my $table_no = 0;
- $schema->name( ref($dbicschema) . " v" . ($dbicschema->VERSION || '1.x'))
+ $schema->name( ref($dbicschema) . " v" . ($dbicschema->schema_version || '1.x'))
unless ($schema->name);
my %seen_tables;
@@ -66,7 +66,18 @@
}
- foreach my $moniker (sort @monikers)
+ my(@table_monikers, @view_monikers);
+ for my $moniker (@monikers){
+ my $source = $dbicschema->source($moniker);
+ if ( $source->isa('DBIx::Class::ResultSource::Table') ) {
+ push(@table_monikers, $moniker);
+ } elsif( $source->isa('DBIx::Class::ResultSource::View') ){
+ next if $source->is_virtual;
+ push(@view_monikers, $moniker);
+ }
+ }
+
+ foreach my $moniker (sort @table_monikers)
{
my $source = $dbicschema->source($moniker);
@@ -149,7 +160,8 @@
$fk_constraint = $rel_info->{attrs}{is_foreign_key_constraint};
}
# it can not be multi
- elsif ( $rel_info->{attrs}{accessor} eq 'multi' ) {
+ elsif ( $rel_info->{attrs}{accessor}
+ && $rel_info->{attrs}{accessor} eq 'multi' ) {
$fk_constraint = 0;
}
# if indeed single, check if all self.columns are our primary keys.
@@ -198,8 +210,8 @@
fields => \@keys,
reference_fields => \@refkeys,
reference_table => $rel_table,
- on_delete => $cascade->{delete},
- on_update => $cascade->{update},
+ on_delete => uc ($cascade->{delete} || ''),
+ on_update => uc ($cascade->{update} || ''),
(defined $is_deferrable ? ( deferrable => $is_deferrable ) : ()),
);
@@ -214,8 +226,25 @@
}
}
+ $source->_invoke_sqlt_deploy_hook($table);
+ }
+
+ foreach my $moniker (sort @view_monikers)
+ {
+ my $source = $dbicschema->source($moniker);
+ # Skip custom query sources
+ next if ref($source->name);
+
+ # Its possible to have multiple DBIC source using same table
+ next if $seen_tables{$source->name}++;
+
+ my $view = $schema->add_view(
+ name => $source->name,
+ fields => [ $source->columns ],
+ $source->view_definition ? ( 'sql' => $source->view_definition ) : ()
+ );
if ($source->result_class->can('sqlt_deploy_hook')) {
- $source->result_class->sqlt_deploy_hook($table);
+ $source->result_class->sqlt_deploy_hook($view);
}
}
@@ -227,3 +256,58 @@
}
1;
+
+=head1 NAME
+
+SQL::Translator::Parser::DBIx::Class - Create a SQL::Translator schema
+from a DBIx::Class::Schema instance
+
+=head1 SYNOPSIS
+
+ ## Via DBIx::Class
+ use MyApp::Schema;
+ my $schema = MyApp::Schema->connect("dbi:SQLite:something.db");
+ $schema->create_ddl_dir();
+ ## or
+ $schema->deploy();
+
+ ## Standalone
+ use MyApp::Schema;
+ use SQL::Translator;
+
+ my $schema = MyApp::Schema->connect;
+ my $trans = SQL::Translator->new (
+ parser => 'SQL::Translator::Parser::DBIx::Class',
+ parser_args => { package => $schema },
+ producer => 'SQLite',
+ ) or die SQL::Translator->error;
+ my $out = $trans->translate() or die $trans->error;
+
+=head1 DESCRIPTION
+
+This class requires L<SQL::Translator> installed to work.
+
+C<SQL::Translator::Parser::DBIx::Class> reads a DBIx::Class schema,
+interrogates the columns, and stuffs it all in an $sqlt_schema object.
+
+It's primary use is in deploying database layouts described as a set
+of L<DBIx::Class> classes, to a database. To do this, see the
+L<DBIx::Class::Schema/deploy> method.
+
+This can also be achieved by having DBIx::Class export the schema as a
+set of SQL files ready for import into your database, or passed to
+other machines that need to have your application installed but don't
+have SQL::Translator installed. To do this see the
+L<DBIx::Class::Schema/create_ddl_dir> method.
+
+=head1 SEE ALSO
+
+L<SQL::Translator>, L<DBIx::Class::Schema>
+
+=head1 AUTHORS
+
+Jess Robinson
+
+Matt S Trout
+
+Ash Berlin
Modified: DBIx-Class/0.08/branches/sybase/maint/benchmark_hashrefinflator.pl
===================================================================
--- DBIx-Class/0.08/branches/sybase/maint/benchmark_hashrefinflator.pl 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/maint/benchmark_hashrefinflator.pl 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,56 +1,45 @@
#!/usr/bin/perl
-use warnings;
-use strict;
-
-use FindBin;
-
#
# So you wrote a new mk_hash implementation which passed all tests (particularly
# t/68inflate_resultclass_hashrefinflator) and would like to see how it holds up
-# against older versions of the same. Just add your subroutine somewhere below and
-# add its name to the @bench array. Happy testing.
+# against older versions of the same. Just add your coderef to the HRI::Bench
+# namespace and add a name/ref pair to the %bench_list hash. Happy testing.
-my @bench = qw/current_mk_hash old_mk_hash/;
+package DBIx::Class::ResultClass::HashRefInflator::Bench;
-use Benchmark qw/timethis cmpthese/;
+use warnings;
+use strict;
-use lib ("$FindBin::Bin/../lib", "$FindBin::Bin/../t/lib");
-use DBICTest;
-use DBIx::Class::ResultClass::HashRefInflator;
+my $current_mk_hash;
+$current_mk_hash = sub {
+ if (ref $_[0] eq 'ARRAY') { # multi relationship
+ return [ map { $current_mk_hash->(@$_) || () } (@_) ];
+ }
+ else {
+ my $hash = {
+ # the main hash could be an undef if we are processing a skipped-over join
+ $_[0] ? %{$_[0]} : (),
-chdir ("$FindBin::Bin/..");
-my $schema = DBICTest->init_schema();
+ # the second arg is a hash of arrays for each prefetched relation
+ map
+ { $_ => $current_mk_hash->( @{$_[1]->{$_}} ) }
+ ( $_[1] ? (keys %{$_[1]}) : () )
+ };
-my $test_sub = sub {
- my $rs_hashrefinf = $schema->resultset ('Artist')->search ({}, {
- prefetch => { cds => 'tracks' },
- });
- $rs_hashrefinf->result_class('DBIx::Class::ResultClass::HashRefInflator');
- my @stuff = $rs_hashrefinf->all;
+ # if there is at least one defined column consider the resultset real
+ # (and not an emtpy has_many rel containing one empty hashref)
+ for (values %$hash) {
+ return $hash if defined $_;
+ }
+
+ return undef;
+ }
};
-
-my $results;
-for my $b (@bench) {
- die "No such subroutine '$b' defined!\n" if not __PACKAGE__->can ($b);
- print "Timing $b... ";
-
- # switch the inflator
- no warnings qw/redefine/;
- no strict qw/refs/;
- local *DBIx::Class::ResultClass::HashRefInflator::mk_hash = \&$b;
-
- $results->{$b} = timethis (-2, $test_sub);
-}
-cmpthese ($results);
-
-#-----------------------------
-# mk_hash implementations
-#-----------------------------
-
# the (incomplete, fails a test) implementation before svn:4760
-sub old_mk_hash {
+my $old_mk_hash;
+$old_mk_hash = sub {
my ($me, $rest) = @_;
# $me is the hashref of cols/data from the immediate resultsource
@@ -74,35 +63,56 @@
map {
( $_ =>
ref($rest->{$_}[0]) eq 'ARRAY'
- ? [ grep defined, map old_mk_hash(@$_), @{$rest->{$_}} ]
- : old_mk_hash( @{$rest->{$_}} )
+ ? [ grep defined, map $old_mk_hash->(@$_), @{$rest->{$_}} ]
+ : $old_mk_hash->( @{$rest->{$_}} )
)
} keys %$rest
};
-}
+};
-# current implementation as of svn:4760
-sub current_mk_hash {
- if (ref $_[0] eq 'ARRAY') { # multi relationship
- return [ map { current_mk_hash (@$_) || () } (@_) ];
- }
- else {
- my $hash = {
- # the main hash could be an undef if we are processing a skipped-over join
- $_[0] ? %{$_[0]} : (),
- # the second arg is a hash of arrays for each prefetched relation
- map
- { $_ => current_mk_hash( @{$_[1]->{$_}} ) }
- ( $_[1] ? (keys %{$_[1]}) : () )
- };
+our %bench_list = (
+ current_implementation => $current_mk_hash,
+ old_implementation => $old_mk_hash,
+);
- # if there is at least one defined column consider the resultset real
- # (and not an emtpy has_many rel containing one empty hashref)
- for (values %$hash) {
- return $hash if defined $_;
- }
+1;
- return undef;
- }
+package benchmark_hashrefinflator;
+
+use warnings;
+use strict;
+
+use FindBin;
+use lib ("$FindBin::Bin/../lib", "$FindBin::Bin/../t/lib");
+
+use Benchmark qw/timethis cmpthese/;
+use DBICTest;
+
+chdir ("$FindBin::Bin/..");
+my $schema = DBICTest->init_schema();
+
+my $test_sub = sub {
+ my $rs_hashrefinf = $schema->resultset ('Artist')->search ({}, {
+ prefetch => { cds => 'tracks' },
+ });
+ $rs_hashrefinf->result_class('DBIx::Class::ResultClass::HashRefInflator::Bench');
+ my @stuff = $rs_hashrefinf->all;
+};
+
+
+my $results;
+for my $b (keys %DBIx::Class::ResultClass::HashRefInflator::Bench::bench_list) {
+
+ print "Timing $b... ";
+
+ # switch the inflator
+ no warnings qw/redefine once/;
+ no strict qw/refs/;
+ local *DBIx::Class::ResultClass::HashRefInflator::Bench::inflate_result = sub {
+ return $DBIx::Class::ResultClass::HashRefInflator::Bench::bench_list{$b}->(@_[2,3]);
+ };
+
+ $results->{$b} = timethis (-2, $test_sub);
}
+cmpthese ($results);
Modified: DBIx-Class/0.08/branches/sybase/maint/gen-schema.pl
===================================================================
--- DBIx-Class/0.08/branches/sybase/maint/gen-schema.pl 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/maint/gen-schema.pl 2009-02-26 23:40:04 UTC (rev 5651)
@@ -5,7 +5,7 @@
use lib qw(lib t/lib);
use DBICTest::Schema;
+use SQL::Translator;
my $schema = DBICTest::Schema->connect;
-
-print $schema->storage->deployment_statements($schema, 'SQLite');
+print scalar ($schema->storage->deployment_statements($schema, 'SQLite'));
Modified: DBIx-Class/0.08/branches/sybase/t/03podcoverage.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/03podcoverage.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/03podcoverage.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -29,6 +29,11 @@
mk_classaccessor/
]
},
+ 'DBIx::Class::Row' => {
+ ignore => [
+ qw( MULTICREATE_DEBUG )
+ ],
+ },
'DBIx::Class::Storage' => {
ignore => [
qw(cursor)
Modified: DBIx-Class/0.08/branches/sybase/t/100populate.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/100populate.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/100populate.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -5,7 +5,7 @@
use lib qw(t/lib);
use DBICTest;
-plan tests => 22;
+plan tests => 21;
# perl -le'my $letter = 'a'; for my $i (4..10000) { $letter++; print "[ $i, \"$letter\" ]," }' > tests.txt
@@ -10081,5 +10081,3 @@
is($link7->url, undef, 'Link 7 url');
is($link7->title, 'gtitle', 'Link 7 title');
-
-ok(-f "t/var/DBIxClass.db", 'Database created');
Modified: DBIx-Class/0.08/branches/sybase/t/101populate_rs.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/101populate_rs.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/101populate_rs.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -15,7 +15,7 @@
use lib qw(t/lib);
use DBICTest;
-plan tests => 134;
+plan tests => 142;
## ----------------------------------------------------------------------------
@@ -601,4 +601,30 @@
ok( $cd2->title eq "VOID_Yet More Tweeny-Pop crap", "Got Expected CD Title");
}
+}
+
+ARRAYREF_OF_ARRAYREF_STYLE: {
+ $art_rs->populate([
+ [qw/artistid name/],
+ [1000, 'A Formally Unknown Singer'],
+ [1001, 'A singer that jumped the shark two albums ago'],
+ [1002, 'An actually cool singer.'],
+ ]);
+
+ ok my $unknown = $art_rs->find(1000), "got Unknown";
+ ok my $jumped = $art_rs->find(1001), "got Jumped";
+ ok my $cool = $art_rs->find(1002), "got Cool";
+
+ is $unknown->name, 'A Formally Unknown Singer', 'Correct Name';
+ is $jumped->name, 'A singer that jumped the shark two albums ago', 'Correct Name';
+ is $cool->name, 'An actually cool singer.', 'Correct Name';
+
+ my ($cooler, $lamer) = $art_rs->populate([
+ [qw/artistid name/],
+ [1003, 'Cooler'],
+ [1004, 'Lamer'],
+ ]);
+
+ is $cooler->name, 'Cooler', 'Correct Name';
+ is $lamer->name, 'Lamer', 'Correct Name';
}
\ No newline at end of file
Added: DBIx-Class/0.08/branches/sybase/t/103many_to_many_warning.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/103many_to_many_warning.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/103many_to_many_warning.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,108 @@
+use strict;
+use warnings;
+use Test::More;
+
+use lib qw(t/lib);
+use Data::Dumper;
+
+plan ( ($] >= 5.009000 and $] < 5.010001)
+ ? (skip_all => 'warnings::register broken under 5.10: http://rt.perl.org/rt3/Public/Bug/Display.html?id=62522')
+ : (tests => 4)
+);
+
+{
+ my @w;
+ local $SIG{__WARN__} = sub { push @w, @_ };
+ my $code = gen_code ( suffix => 1 );
+ eval "$code";
+ ok (! $@, 'Eval code without warnings suppression')
+ || diag $@;
+
+ ok ( (grep { $_ =~ /The many-to-many relationship bars is trying to create/ } @w), "Warning triggered without relevant 'no warnings'");
+}
+
+{
+ my @w;
+ local $SIG{__WARN__} = sub { push @w, @_ };
+
+ my $code = gen_code ( suffix => 2, no_warn => 1 );
+ eval "$code";
+ ok (! $@, 'Eval code with warnings suppression')
+ || diag $@;
+
+ ok ( (not grep { $_ =~ /The many-to-many relationship bars is trying to create/ } @w), "No warning triggered with relevant 'no warnings'");
+}
+
+sub gen_code {
+
+ my $args = { @_ };
+ my $suffix = $args->{suffix};
+ my $no_warn = ( $args->{no_warn}
+ ? "no warnings 'DBIx::Class::Relationship::ManyToMany';"
+ : '',
+ );
+
+ return <<EOF;
+use strict;
+use warnings;
+
+{
+ package #
+ DBICTest::Schema::Foo${suffix};
+ use base 'DBIx::Class::Core';
+
+ __PACKAGE__->table('foo');
+ __PACKAGE__->add_columns(
+ 'fooid' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ );
+ __PACKAGE__->set_primary_key('fooid');
+
+
+ __PACKAGE__->has_many('foo_to_bar' => 'DBICTest::Schema::FooToBar${suffix}' => 'bar');
+ __PACKAGE__->many_to_many( foos => foo_to_bar => 'bar' );
+}
+{
+ package #
+ DBICTest::Schema::FooToBar${suffix};
+
+ use base 'DBIx::Class::Core';
+ __PACKAGE__->table('foo_to_bar');
+ __PACKAGE__->add_columns(
+ 'foo' => {
+ data_type => 'integer',
+ },
+ 'bar' => {
+ data_type => 'integer',
+ },
+ );
+ __PACKAGE__->belongs_to('foo' => 'DBICTest::Schema::Foo${suffix}');
+ __PACKAGE__->belongs_to('bar' => 'DBICTest::Schema::Foo${suffix}');
+}
+{
+ package #
+ DBICTest::Schema::Bar${suffix};
+
+ use base 'DBIx::Class::Core';
+
+ __PACKAGE__->table('bar');
+ __PACKAGE__->add_columns(
+ 'barid' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ );
+
+ ${no_warn}
+ __PACKAGE__->set_primary_key('barid');
+ __PACKAGE__->has_many('foo_to_bar' => 'DBICTest::Schema::FooToBar${suffix}' => 'foo');
+
+ __PACKAGE__->many_to_many( bars => foo_to_bar => 'foo' );
+
+ sub add_to_bars {}
+}
+EOF
+
+}
Added: DBIx-Class/0.08/branches/sybase/t/104view.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/104view.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/104view.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,28 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 2;
+
+## Real view
+my $cds_rs_2000 = $schema->resultset('CD')->search( { year => 2000 });
+my $year2kcds_rs = $schema->resultset('Year2000CDs');
+
+is($cds_rs_2000->count, $year2kcds_rs->count, 'View Year2000CDs sees all CDs in year 2000');
+
+
+## Virtual view
+my $cds_rs_1999 = $schema->resultset('CD')->search( { year => 1999 });
+my $year1999cds_rs = $schema->resultset('Year1999CDs');
+
+is($cds_rs_1999->count, $year1999cds_rs->count, 'View Year1999CDs sees all CDs in year 1999');
+
+
+
+
Modified: DBIx-Class/0.08/branches/sybase/t/18inserterror.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/18inserterror.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/18inserterror.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -24,6 +24,6 @@
->create({ title => 'vacation in antarctica' })
};
like $@, qr/NULL/; # as opposed to some other error
- ok( $warnings !~ /uninitialized value/, "No warning from Storage" );
+ unlike( $warnings, qr/uninitialized value/, "No warning from Storage" );
}
Modified: DBIx-Class/0.08/branches/sybase/t/19quotes.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/19quotes.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/19quotes.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -4,29 +4,28 @@
use Test::More;
use IO::File;
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+
BEGIN {
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 6 );
+ : ( tests => 7 );
}
-use lib qw(t/lib);
use_ok('DBICTest');
+use_ok('DBIC::DebugObj');
my $schema = DBICTest->init_schema();
-my $orig_debugcb = $schema->storage->debugcb;
-my $orig_debug = $schema->storage->debug;
-
diag('Testing against ' . join(' ', map { $schema->storage->dbh->get_info($_) } qw/17 18/));
$schema->storage->sql_maker->quote_char('`');
$schema->storage->sql_maker->name_sep('.');
-my $sql = '';
-
-$schema->storage->debugcb(sub { $sql = $_[1] });
+my ($sql, @bind) = ('');
+$schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind));
$schema->storage->debug(1);
my $rs;
@@ -35,7 +34,11 @@
{ 'me.year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
{ join => 'artist' });
eval { $rs->count };
-like($sql, qr/\QSELECT COUNT( * ) FROM `cd` `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )\E/, 'got correct SQL for count query with quoting');
+is_same_sql_bind(
+ $sql, \@bind,
+ "SELECT COUNT( * ) FROM `cd` `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )", ["'Caterwauler McCrae'", "'2001'"],
+ 'got correct SQL for count query with quoting'
+);
my $order = 'year DESC';
$rs = $schema->resultset('CD')->search({},
@@ -55,7 +58,11 @@
{ 'me.year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
{ join => 'artist' });
eval { $rs->count };
-like($sql, qr/\QSELECT COUNT( * ) FROM [cd] [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )\E/, 'got correct SQL for count query with bracket quoting');
+is_same_sql_bind(
+ $sql, \@bind,
+ "SELECT COUNT( * ) FROM [cd] [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )", ["'Caterwauler McCrae'", "'2001'"],
+ 'got correct SQL for count query with bracket quoting'
+);
my %data = (
name => 'Bill',
@@ -66,6 +73,3 @@
$schema->storage->sql_maker->name_sep('.');
is($schema->storage->sql_maker->update('group', \%data), 'UPDATE `group` SET `name` = ?, `order` = ?', 'quoted table names for UPDATE');
-
-$schema->storage->debugcb($orig_debugcb);
-$schema->storage->debug($orig_debug);
Modified: DBIx-Class/0.08/branches/sybase/t/19quotes_newstyle.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/19quotes_newstyle.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/19quotes_newstyle.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -4,24 +4,24 @@
use Test::More;
use IO::File;
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+
BEGIN {
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 6 );
+ : ( tests => 7 );
}
-use lib qw(t/lib);
+use_ok('DBICTest');
+use_ok('DBIC::DebugObj');
-use_ok('DBICTest');
my $schema = DBICTest->init_schema();
-my $orig_debugcb = $schema->storage->debugcb;
-my $orig_debug = $schema->storage->debug;
-
diag('Testing against ' . join(' ', map { $schema->storage->dbh->get_info($_) } qw/17 18/));
-my $dsn = $schema->storage->connect_info->[0];
+my $dsn = $schema->storage->_dbi_connect_info->[0];
$schema->connection(
$dsn,
undef,
@@ -30,8 +30,8 @@
{ quote_char => '`', name_sep => '.' },
);
-my $sql = '';
-$schema->storage->debugcb(sub { $sql = $_[1] });
+my ($sql, @bind) = ('');
+$schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind)),
$schema->storage->debug(1);
my $rs;
@@ -40,7 +40,11 @@
{ 'me.year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
{ join => 'artist' });
eval { $rs->count };
-like($sql, qr/\QSELECT COUNT( * ) FROM `cd` `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )\E/, 'got correct SQL for count query with quoting');
+is_same_sql_bind(
+ $sql, \@bind,
+ "SELECT COUNT( * ) FROM `cd` `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )", ["'Caterwauler McCrae'", "'2001'"],
+ 'got correct SQL for count query with quoting'
+);
my $order = 'year DESC';
$rs = $schema->resultset('CD')->search({},
@@ -59,14 +63,19 @@
undef,
{ AutoCommit => 1, quote_char => [qw/[ ]/], name_sep => '.' }
);
-$schema->storage->debugcb(sub { $sql = $_[1] });
+
+$schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind)),
$schema->storage->debug(1);
$rs = $schema->resultset('CD')->search(
{ 'me.year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
{ join => 'artist' });
eval { $rs->count };
-like($sql, qr/\QSELECT COUNT( * ) FROM [cd] [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )\E/, 'got correct SQL for count query with bracket quoting');
+is_same_sql_bind(
+ $sql, \@bind,
+ "SELECT COUNT( * ) FROM [cd] [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )", ["'Caterwauler McCrae'", "'2001'"],
+ 'got correct SQL for count query with bracket quoting'
+);
my %data = (
name => 'Bill',
@@ -81,6 +90,3 @@
);
is($schema->storage->sql_maker->update('group', \%data), 'UPDATE `group` SET `name` = ?, `order` = ?', 'quoted table names for UPDATE');
-
-$schema->storage->debugcb($orig_debugcb);
-$schema->storage->debug($orig_debug);
Modified: DBIx-Class/0.08/branches/sybase/t/32connect_code_ref.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/32connect_code_ref.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/32connect_code_ref.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -8,10 +8,10 @@
plan tests => 1;
# Set up the "usual" sqlite for DBICTest
-my $normal_schema = DBICTest->init_schema;
+my $normal_schema = DBICTest->init_schema( sqlite_use_file => 1 );
# Steal the dsn, which should be like 'dbi:SQLite:t/var/DBIxClass.db'
-my $normal_dsn = $normal_schema->storage->connect_info->[0];
+my $normal_dsn = $normal_schema->storage->_dbi_connect_info->[0];
# Make sure we have no active connection
$normal_schema->storage->disconnect;
Modified: DBIx-Class/0.08/branches/sybase/t/33storage_reconnect.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/33storage_reconnect.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/33storage_reconnect.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -7,20 +7,27 @@
use lib qw(t/lib);
use DBICTest;
-plan tests => 5;
+plan tests => 6;
my $db_orig = "$FindBin::Bin/var/DBIxClass.db";
my $db_tmp = "$db_orig.tmp";
# Set up the "usual" sqlite for DBICTest
-my $schema = DBICTest->init_schema;
+my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
# Make sure we're connected by doing something
my @art = $schema->resultset("Artist")->search({ }, { order_by => 'name DESC'});
cmp_ok(@art, '==', 3, "Three artists returned");
# Disconnect the dbh, and be sneaky about it
-$schema->storage->_dbh->disconnect;
+# Also test if DBD::SQLite finaly knows how to ->disconnect properly
+TODO: {
+ local $TODO = 'SQLite is evil/braindead. Once this test starts passing, remove the related atrocity from DBIx::Class::Storage::DBI::SQLite';
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ $schema->storage->_dbh->disconnect;
+ ok ($w !~ /active statement handles/, 'SQLite can disconnect properly \o/');
+}
# Try the operation again - What should happen here is:
# 1. S::DBI blindly attempts the SELECT, which throws an exception
@@ -40,10 +47,14 @@
chmod 0000, $db_orig;
### Try the operation again... it should fail, since there's no db
-eval {
- my @art_three = $schema->resultset("Artist")->search( {}, { order_by => 'name DESC' } );
-};
-ok( $@, 'The operation failed' );
+{
+ # Catch the DBI connection error
+ local $SIG{__WARN__} = sub {};
+ eval {
+ my @art_three = $schema->resultset("Artist")->search( {}, { order_by => 'name DESC' } );
+ };
+ ok( $@, 'The operation failed' );
+}
### Now, move the db file back to the correct name
unlink($db_orig);
Modified: DBIx-Class/0.08/branches/sybase/t/34exception_action.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/34exception_action.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/34exception_action.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -5,7 +5,7 @@
use lib qw(t/lib);
use DBICTest;
-plan tests => 8;
+plan tests => 9;
# Set up the "usual" sqlite for DBICTest
my $schema = DBICTest->init_schema;
@@ -68,3 +68,15 @@
# While we're at it, lets throw a custom exception through Storage::DBI
eval { $schema->storage->throw_exception('floob') };
like($@, qr/DBICTest::Exception is handling this: floob/);
+
+
+# This usage is a bit unusual but it was actually seen in the wild
+eval {
+
+ my $dbh = $schema->storage->dbh;
+ undef $schema;
+
+ $dbh->do ('glaring_syntax_error;');
+};
+like($@, qr/DBI Exception.+do failed/, 'Exception thrown even after $storage is destroyed');
+
Modified: DBIx-Class/0.08/branches/sybase/t/39load_namespaces_1.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/39load_namespaces_1.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/39load_namespaces_1.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -6,7 +6,7 @@
unshift(@INC, './t/lib');
-plan tests => 6;
+plan tests => 8;
my $warnings;
eval {
@@ -27,3 +27,8 @@
isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
my $rset_b = DBICNSTest->resultset('B');
isa_ok($rset_b, 'DBIx::Class::ResultSet');
+
+for my $moniker (qw/A B/) {
+ my $class = "DBICNSTest::Result::$moniker";
+ ok(!defined($class->result_source_instance->source_name));
+}
Added: DBIx-Class/0.08/branches/sybase/t/39load_namespaces_rt41083.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/39load_namespaces_rt41083.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/39load_namespaces_rt41083.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,42 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+
+use lib 't/lib';
+
+plan tests => 4;
+
+sub _chk_warning {
+ defined $_[0]?
+ $_[0] !~ qr/We found ResultSet class '([^']+)' for '([^']+)', but it seems that you had already set '([^']+)' to use '([^']+)' instead/ :
+ 1
+}
+
+my $warnings;
+eval {
+ local $SIG{__WARN__} = sub { $warnings .= shift };
+ package DBICNSTest::RtBug41083;
+ use base 'DBIx::Class::Schema';
+ __PACKAGE__->load_namespaces(
+ result_namespace => 'Schema_A',
+ resultset_namespace => 'ResultSet_A',
+ default_resultset_class => 'ResultSet'
+ );
+};
+ok(!$@) or diag $@;
+ok(_chk_warning($warnings), 'expected no complaint');
+
+eval {
+ local $SIG{__WARN__} = sub { $warnings .= shift };
+ package DBICNSTest::RtBug41083;
+ use base 'DBIx::Class::Schema';
+ __PACKAGE__->load_namespaces(
+ result_namespace => 'Schema',
+ resultset_namespace => 'ResultSet',
+ default_resultset_class => 'ResultSet'
+ );
+};
+ok(!$@) or diag $@;
+ok(_chk_warning($warnings), 'expected no complaint') or diag $warnings;
Modified: DBIx-Class/0.08/branches/sybase/t/41orrible.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/41orrible.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/41orrible.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -2,9 +2,11 @@
use warnings;
use Test::More;
-#use DBIx::Class::Storage::DBI;
use DBIx::Class::Storage::DBI::Oracle::WhereJoins;
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+
plan tests => 4;
my $sa = new DBIC::SQL::Abstract::Oracle;
@@ -29,7 +31,8 @@
# search with undefined or empty $cond
# my ($self, $table, $fields, $where, $order, @rest) = @_;
-is($sa->select([
+my ($sql, @bind) = $sa->select(
+ [
{ me => "cd" },
[
{ "-join_type" => "LEFT", artist => "artist" },
@@ -38,10 +41,16 @@
],
[ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
undef,
- undef),
- 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( artist.artistid(+) = me.artist )', 'WhereJoins search with empty where clause');
+ undef
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( artist.artistid(+) = me.artist )', [],
+ 'WhereJoins search with empty where clause'
+);
-is($sa->select([
+($sql, @bind) = $sa->select(
+ [
{ me => "cd" },
[
{ "-join_type" => "", artist => "artist" },
@@ -50,10 +59,16 @@
],
[ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
{ 'artist.artistid' => 3 },
- undef),
- 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid = me.artist ) AND ( artist.artistid = ? ) ) )', 'WhereJoins search with where clause');
+ undef
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid = me.artist ) AND ( artist.artistid = ? ) ) )', [3],
+ 'WhereJoins search with where clause'
+);
-is($sa->select([
+($sql, @bind) = $sa->select(
+ [
{ me => "cd" },
[
{ "-join_type" => "LEFT", artist => "artist" },
@@ -62,7 +77,12 @@
],
[ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
[{ 'artist.artistid' => 3 }, { 'me.cdid' => 5 }],
- undef),
- 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid(+) = me.artist ) AND ( ( ( artist.artistid = ? ) OR ( me.cdid = ? ) ) ) ) )', 'WhereJoins search with or in where clause');
+ undef
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid(+) = me.artist ) AND ( ( ( artist.artistid = ? ) OR ( me.cdid = ? ) ) ) ) )', [3, 5],
+ 'WhereJoins search with or in where clause'
+);
Modified: DBIx-Class/0.08/branches/sybase/t/47bind_attribute.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/47bind_attribute.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/47bind_attribute.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -73,6 +73,10 @@
is ( $rs->count, 1, '...cookbook (bind first) + chained search' );
TODO: {
+ # not sure what causes an uninit warning here, please remove when the TODO starts to pass,
+ # so the real reason for the warning can be found and fixed
+ local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /uninitialized/ };
+
local $TODO = 'bind args order needs fixing (semifor)';
$rs = $schema->resultset('Complex')->search({}, { bind => [ 1999 ] })
->search({ 'artistid' => 1 }, {
Modified: DBIx-Class/0.08/branches/sybase/t/50fork.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/50fork.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/50fork.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -34,7 +34,7 @@
{
local $SIG{__WARN__} = sub {};
eval { $dbh->do("DROP TABLE cd") };
- $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(255) NOT NULL UNIQUE, year VARCHAR(255));");
+ $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(100) NOT NULL UNIQUE, year VARCHAR(100) NOT NULL, genreid INTEGER, single_track INTEGER);");
}
$schema->resultset('CD')->create({ title => 'vacation in antarctica', artist => 123, year => 1901 });
Modified: DBIx-Class/0.08/branches/sybase/t/51threads.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/51threads.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/51threads.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -44,7 +44,7 @@
{
local $SIG{__WARN__} = sub {};
eval { $dbh->do("DROP TABLE cd") };
- $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(255) NOT NULL UNIQUE, year VARCHAR(255));");
+ $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(100) NOT NULL UNIQUE, year VARCHAR(100) NOT NULL, genreid INTEGER, single_track INTEGER);");
}
$schema->resultset('CD')->create({ title => 'vacation in antarctica', artist => 123, year => 1901 });
Modified: DBIx-Class/0.08/branches/sybase/t/51threadtxn.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/51threadtxn.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/51threadtxn.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -44,7 +44,7 @@
{
local $SIG{__WARN__} = sub {};
eval { $dbh->do("DROP TABLE cd") };
- $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(255) NOT NULL UNIQUE, year VARCHAR(255));");
+ $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(100) NOT NULL UNIQUE, year VARCHAR(100) NOT NULL, genreid INTEGER, single_track INTEGER);");
}
$schema->resultset('CD')->create({ title => 'vacation in antarctica', artist => 123, year => 1901 });
Added: DBIx-Class/0.08/branches/sybase/t/53delete_chained.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/53delete_chained.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/53delete_chained.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,45 @@
+use Test::More;
+use strict;
+use warnings;
+use lib qw(t/lib);
+use DBICTest;
+
+plan tests => 9;
+
+# This set of tests attempts to do a delete on a chained resultset, which
+# would lead to SQL DELETE with a JOIN, which is not supported by the
+# SQL generator right now.
+# So it currently checks that these operations fail with a warning.
+# When the SQL generator is fixed this test will need fixing up appropriately.
+
+my $schema = DBICTest->init_schema();
+my $total_tracks = $schema->resultset('Track')->count;
+cmp_ok($total_tracks, '>', 0, 'need track records');
+
+# test that delete_related w/o conditions deletes all related records only
+{
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+
+ my $artist = $schema->resultset("Artist")->find(3);
+ my $artist_tracks = $artist->cds->search_related('tracks')->count;
+ cmp_ok($artist_tracks, '<', $total_tracks, 'need more tracks than just related tracks');
+
+ ok(!eval{$artist->cds->search_related('tracks')->delete});
+ cmp_ok($schema->resultset('Track')->count, '==', $total_tracks, 'No tracks should be deleted');
+ like ($w, qr/Currently \$rs->delete\(\) does not generate proper SQL/, 'Delete join warning');
+}
+
+# test that delete_related w/conditions deletes just the matched related records only
+{
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+
+ my $artist2 = $schema->resultset("Artist")->find(2);
+ my $artist2_tracks = $artist2->search_related('cds')->search_related('tracks')->count;
+ cmp_ok($artist2_tracks, '<', $total_tracks, 'need more tracks than related tracks');
+
+ ok(!eval{$artist2->search_related('cds')->search_related('tracks')->delete});
+ cmp_ok($schema->resultset('Track')->count, '==', $total_tracks, 'No tracks should be deleted');
+ like ($w, qr/Currently \$rs->delete\(\) does not generate proper SQL/, 'Delete join warning');
+}
Modified: DBIx-Class/0.08/branches/sybase/t/53delete_related.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/53delete_related.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/53delete_related.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -16,7 +16,7 @@
cmp_ok($artist_cds, '<', $total_cds, 'need more cds than just related cds');
ok($artist->delete_related('cds'));
-cmp_ok($schema->resultset('CD')->count, '==', ($total_cds - $artist_cds), 'too many cds were deleted');
+cmp_ok($schema->resultset('CD')->count, '==', ($total_cds - $artist_cds), 'wrong number of cds were deleted');
$total_cds -= $artist_cds;
@@ -26,5 +26,5 @@
cmp_ok($artist2_cds, '<', $total_cds, 'need more cds than related cds');
ok($artist2->delete_related('cds', {title => {like => '%'}}));
-cmp_ok($schema->resultset('CD')->count, '==', ($total_cds - $artist2_cds), 'too many cds were deleted');
+cmp_ok($schema->resultset('CD')->count, '==', ($total_cds - $artist2_cds), 'wrong number of cds were deleted');
Modified: DBIx-Class/0.08/branches/sybase/t/54taint.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/54taint.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/54taint.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -13,11 +13,11 @@
: ( tests => 2 );
}
-package DBICTest::Schema;
+package DBICTest::Plain;
-# Use the default test class namespace to avoid the need for a
+# Use the Plain test class namespace to avoid the need for a
# new test infrastructure. If invalid classes will be introduced to
-# 't/lib/DBICTest/Schema/' someday, this has to be reworked.
+# 't/lib/DBICTest/Plain/' someday, this has to be reworked.
use lib qw(t/lib);
@@ -28,6 +28,6 @@
eval{ __PACKAGE__->load_classes() };
cmp_ok( $@, 'eq', '',
'Loading classes with Module::Find worked in taint mode' );
-ok( __PACKAGE__->sources(), 'At least on source has been registered' );
+ok( __PACKAGE__->source('Test'), 'The Plain::Test source has been registered' );
1;
Modified: DBIx-Class/0.08/branches/sybase/t/60core.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/60core.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/60core.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -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 => 84;
+plan tests => 95;
eval { require DateTime::Format::MySQL };
my $NO_DTFM = $@ ? 1 : 0;
@@ -71,7 +72,7 @@
cmp_ok($art[0]->artistid, '==', 3,'Correct artist too');
-$art->delete;
+lives_ok (sub { $art->delete }, 'Cascading delete on Ordered has_many works' ); # real test in ordered.t
@art = $schema->resultset("Artist")->search({ });
@@ -79,10 +80,8 @@
ok(!$art->in_storage, "It knows it's dead");
-eval { $art->delete; };
+dies_ok ( sub { $art->delete }, "Can't delete twice");
-ok($@, "Can't delete twice: $@");
-
is($art->name, 'We Are In Rehab', 'But the object is still live');
$art->insert;
@@ -153,7 +152,7 @@
my $cd = $schema->resultset("CD")->find(1);
my %cols = $cd->get_columns;
-cmp_ok(keys %cols, '==', 4, 'get_columns number of columns ok');
+cmp_ok(keys %cols, '==', 6, 'get_columns number of columns ok');
is($cols{title}, 'Spoonful of bees', 'get_columns values ok');
@@ -169,7 +168,7 @@
# check whether ResultSource->columns returns columns in order originally supplied
my @cd = $schema->source("CD")->columns;
-is_deeply( \@cd, [qw/cdid artist title year/], 'column order');
+is_deeply( \@cd, [qw/cdid artist title year genreid single_track/], 'column order');
$cd = $schema->resultset("CD")->search({ title => 'Spoonful of bees' }, { columns => ['title'] })->next;
is($cd->title, 'Spoonful of bees', 'subset of columns returned correctly');
@@ -179,11 +178,22 @@
is($cd->title, 'Spoonful of bees', 'Correct CD returned with include');
is($cd->get_column('name'), 'Caterwauler McCrae', 'Additional column returned');
+# check if new syntax +columns also works for this
+$cd = $schema->resultset("CD")->search(undef, { '+columns' => [ 'artist.name' ], join => [ 'artist' ] })->find(1);
+
+is($cd->title, 'Spoonful of bees', 'Correct CD returned with include');
+is($cd->get_column('name'), 'Caterwauler McCrae', 'Additional column returned');
+
+# check if new syntax for +columns select specifiers works for this
+$cd = $schema->resultset("CD")->search(undef, { '+columns' => [ {artist_name => 'artist.name'} ], join => [ 'artist' ] })->find(1);
+
+is($cd->title, 'Spoonful of bees', 'Correct CD returned with include');
+is($cd->get_column('artist_name'), 'Caterwauler McCrae', 'Additional column returned');
+
# update_or_insert
$new = $schema->resultset("Track")->new( {
trackid => 100,
cd => 1,
- position => 4,
title => 'Insert or Update',
last_updated_on => '1973-07-19 12:01:02'
} );
@@ -191,9 +201,9 @@
ok($new->in_storage, 'update_or_insert insert ok');
# test in update mode
-$new->pos(5);
+$new->title('Insert or Update - updated');
$new->update_or_insert;
-is( $schema->resultset("Track")->find(100)->pos, 5, 'update_or_insert update ok');
+is( $schema->resultset("Track")->find(100)->title, 'Insert or Update - updated', 'update_or_insert update ok');
# get_inflated_columns w/relation and accessor alias
SKIP: {
@@ -204,8 +214,12 @@
is($tdata{'trackid'}, 100, 'got id');
isa_ok($tdata{'cd'}, 'DBICTest::CD', 'cd is CD object');
is($tdata{'cd'}->id, 1, 'cd object is id 1');
- is($tdata{'position'}, 5, 'got position from pos');
- is($tdata{'title'}, 'Insert or Update');
+ is(
+ $tdata{'position'},
+ $schema->resultset ('Track')->search ({cd => 1})->count,
+ 'Ordered assigned proper position',
+ );
+ is($tdata{'title'}, 'Insert or Update - updated');
is($tdata{'last_updated_on'}, '1973-07-19T12:01:02');
isa_ok($tdata{'last_updated_on'}, 'DateTime', 'inflated accessored column');
}
@@ -227,7 +241,7 @@
cmp_ok($distinct_rs->all, '==', 4, 'DISTINCT search with OR ok');
SKIP: {
- skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
+ skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 2
if $is_broken_sqlite;
my $tcount = $schema->resultset("Track")->search(
@@ -239,7 +253,15 @@
);
cmp_ok($tcount->next->get_column('count'), '==', 13, 'multiple column COUNT DISTINCT ok');
+ $tcount = $schema->resultset("Track")->search(
+ {},
+ {
+ columns => {count => {count => {distinct => ['position', 'title']}}},
+ }
+ );
+ cmp_ok($tcount->next->get_column('count'), '==', 13, 'multiple column COUNT DISTINCT using column syntax ok');
}
+
my $tag_rs = $schema->resultset('Tag')->search(
[ { 'me.tag' => 'Cheesy' }, { 'me.tag' => 'Blue' } ]);
@@ -295,16 +317,12 @@
my $newbook = $schema->resultset( 'Bookmark' )->find(1);
-$@ = '';
-eval {
-my $newlink = $newbook->link;
-};
-ok(!$@, "stringify to false value doesn't cause error");
+lives_ok (sub { my $newlink = $newbook->link}, "stringify to false value doesn't cause error");
# test cascade_delete through many_to_many relations
{
my $art_del = $schema->resultset("Artist")->find({ artistid => 1 });
- $art_del->delete;
+ lives_ok (sub { $art_del->delete }, 'Cascading delete on Ordered has_many works' ); # real test in ordered.t
cmp_ok( $schema->resultset("CD")->search({artist => 1}), '==', 0, 'Cascading through has_many top level.');
cmp_ok( $schema->resultset("CD_to_Producer")->search({cd => 1}), '==', 0, 'Cascading through has_many children.');
}
@@ -335,10 +353,29 @@
# test remove_columns
{
- is_deeply([$schema->source('CD')->columns], [qw/cdid artist title year/]);
- $schema->source('CD')->remove_columns('year');
- is_deeply([$schema->source('CD')->columns], [qw/cdid artist title/]);
- ok(! exists $schema->source('CD')->_columns->{'year'}, 'year still exists in _columns');
+ is_deeply(
+ [$schema->source('CD')->columns],
+ [qw/cdid artist title year genreid single_track/],
+ 'initial columns',
+ );
+
+ $schema->source('CD')->remove_columns('coolyear'); #should not delete year
+ is_deeply(
+ [$schema->source('CD')->columns],
+ [qw/cdid artist title year genreid single_track/],
+ 'nothing removed when removing a non-existent column',
+ );
+
+ $schema->source('CD')->remove_columns('genreid', 'year');
+ is_deeply(
+ [$schema->source('CD')->columns],
+ [qw/cdid artist title single_track/],
+ 'removed two columns',
+ );
+
+ my $priv_columns = $schema->source('CD')->_columns;
+ ok(! exists $priv_columns->{'year'}, 'year purged from _columns');
+ ok(! exists $priv_columns->{'genreid'}, 'genreid purged from _columns');
}
# test get_inflated_columns with objects
@@ -356,7 +393,14 @@
# test resultsource->table return value when setting
{
my $class = $schema->class('Event');
- diag $class;
my $table = $class->table($class->table);
is($table, $class->table, '->table($table) returns $table');
}
+
+#make sure insert doesn't use set_column
+{
+ my $en_row = $schema->resultset('Encoded')->new_result({encoded => 'wilma'});
+ is($en_row->encoded, 'amliw', 'new encodes');
+ $en_row->insert;
+ is($en_row->encoded, 'amliw', 'insert does not encode again');
+}
Modified: DBIx-Class/0.08/branches/sybase/t/63register_class.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/63register_class.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/63register_class.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,17 +1,25 @@
use strict;
use warnings;
-use Test::More tests => 2;
+use Test::More tests => 3;
use lib qw(t/lib);
use DBICTest;
use DBICTest::Schema;
use DBICTest::Schema::Artist;
DBICTest::Schema::Artist->source_name('MyArtist');
-DBICTest::Schema->register_class('FooA', 'DBICTest::Schema::Artist');
+{
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ DBICTest::Schema->register_class('FooA', 'DBICTest::Schema::Artist');
+ like ($w, qr/use register_extra_source/, 'Complain about using register_class on an already-registered class');
+}
my $schema = DBICTest->init_schema();
my $a = $schema->resultset('FooA')->search;
is($a->count, 3, 'have 3 artists');
is($schema->class('FooA'), 'DBICTest::FooA', 'Correct artist class');
+
+# clean up
+DBICTest::Schema->_unregister_source('FooA');
Modified: DBIx-Class/0.08/branches/sybase/t/64db.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/64db.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/64db.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -7,7 +7,7 @@
my $schema = DBICTest->init_schema();
-plan tests => 3;
+plan tests => 4;
# add some rows inside a transaction and commit it
# XXX: Is storage->dbh the only way to get a dbh?
@@ -34,23 +34,64 @@
($artist) = $schema->resultset("Artist")->search( artistid => 25 );
is($artist, undef, "Rollback ok");
-my $type_info = $schema->storage->columns_info_for('artist');
+is_deeply (
+ get_storage_column_info ($schema->storage, 'collection', qw/size is_nullable/),
+ {
+ collectionid => {
+ data_type => 'INTEGER',
+ },
+ name => {
+ data_type => 'varchar',
+ },
+ },
+ 'Correctly retrieve column info (no size or is_nullable)'
+);
-# I know this is gross but SQLite reports the size differently from release
-# to release. At least this way the test still passes.
+TODO: {
+ local $TODO = 'All current versions of SQLite seem to mis-report is_nullable';
-delete $type_info->{artistid}{size};
-delete $type_info->{name}{size};
-
-my $test_type_info = {
- 'artistid' => {
- 'data_type' => 'INTEGER',
- 'is_nullable' => 0,
+ is_deeply (
+ get_storage_column_info ($schema->storage, 'artist', qw/size/),
+ {
+ 'artistid' => {
+ 'data_type' => 'INTEGER',
+ 'is_nullable' => 0,
+ },
+ 'name' => {
+ 'data_type' => 'varchar',
+ 'is_nullable' => 1,
+ },
+ 'rank' => {
+ 'data_type' => 'integer',
+ 'is_nullable' => 0,
+ },
},
- 'name' => {
- 'data_type' => 'varchar',
- 'is_nullable' => 0,
- },
+ 'Correctly retrieve column info (mixed null and non-null columns)'
+ );
};
-is_deeply($type_info, $test_type_info, 'columns_info_for - column data types');
+
+# Depending on test we need to strip away certain column info.
+# - SQLite is known to report the size differently from release to release
+# - Current DBD::SQLite versions do not implement NULLABLE
+# - Some SQLite releases report stuff that isn't there as undef
+
+sub get_storage_column_info {
+ my ($storage, $table, @ignore) = @_;
+
+ my $type_info = $storage->columns_info_for($table);
+
+ for my $col (keys %$type_info) {
+ for my $type (keys %{$type_info->{$col}}) {
+ if (
+ grep { $type eq $_ } (@ignore)
+ or
+ not defined $type_info->{$col}{$type}
+ ) {
+ delete $type_info->{$col}{$type};
+ }
+ }
+ }
+
+ return $type_info;
+}
Modified: DBIx-Class/0.08/branches/sybase/t/66relationship.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/66relationship.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/66relationship.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,13 +1,14 @@
use strict;
-use warnings;
+use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
my $schema = DBICTest->init_schema();
-plan tests => 63;
+plan tests => 70;
# has_a test
my $cd = $schema->resultset("CD")->find(4);
@@ -40,8 +41,21 @@
} );
}
-is( ($artist->search_related('cds'))[3]->title, 'Big Flop', 'create_related ok' );
+my $big_flop_cd = ($artist->search_related('cds'))[3];
+is( $big_flop_cd->title, 'Big Flop', 'create_related ok' );
+{ # make sure we are not making pointless select queries when a FK IS NULL
+ my $queries = 0;
+ $schema->storage->debugcb(sub { $queries++; });
+ $schema->storage->debug(1);
+ $big_flop_cd->genre; #should not trigger a select query
+ is($queries, 0, 'No SELECT made for belongs_to if key IS NULL');
+ $big_flop_cd->genre_inefficient; #should trigger a select query
+ is($queries, 1, 'SELECT made for belongs_to if key IS NULL when undef_on_null_fk disabled');
+ $schema->storage->debug(0);
+ $schema->storage->debugcb(undef);
+}
+
my( $rs_from_list ) = $artist->search_related_rs('cds');
is( ref($rs_from_list), 'DBIx::Class::ResultSet', 'search_related_rs in list context returns rs' );
@@ -78,12 +92,11 @@
$track = $schema->resultset("Track")->create( {
trackid => 2,
cd => 3,
- position => 99,
title => 'Hidden Track 2'
} );
$track->update_from_related( cd => $cd );
-my $t_cd = ($schema->resultset("Track")->search( cd => 4, position => 99 ))[0]->cd;
+my $t_cd = ($schema->resultset("Track")->search( cd => 4, title => 'Hidden Track 2' ))[0]->cd;
is( $t_cd->cdid, 4, 'update_from_related ok' );
@@ -117,19 +130,25 @@
is( $cd->title, 'Greatest Hits 2: Louder Than Ever', 'find_or_new_related new record ok' );
ok( ! $cd->in_storage, 'find_or_new_related on a new record: not in_storage' );
-# print STDERR Data::Dumper::Dumper($cd->get_columns);
-# $cd->result_source->schema->storage->debug(1);
$cd->artist(undef);
my $newartist = $cd->find_or_new_related( 'artist', {
name => 'Random Boy Band Two',
artistid => 200,
} );
-# $cd->result_source->schema->storage->debug(0);
is($newartist->name, 'Random Boy Band Two', 'find_or_new_related new artist record with id');
is($newartist->id, 200, 'find_or_new_related new artist id set');
-SKIP: {
- skip "relationship checking needs fixing", 1;
+lives_ok(
+ sub {
+ my $new_bookmark = $schema->resultset("Bookmark")->new_result( {} );
+ my $new_related_link = $new_bookmark->new_related( 'link', {} );
+ },
+ 'No back rel'
+);
+
+
+TODO: {
+ local $TODO = "relationship checking needs fixing";
# try to add a bogus relationship using the wrong cols
eval {
DBICTest::Schema::Artist->add_relationship(
@@ -212,7 +231,14 @@
my $undef_artist_cd = $schema->resultset("CD")->new_result({ 'title' => 'badgers', 'year' => 2007 });
is($undef_artist_cd->has_column_loaded('artist'), '', 'FK not loaded');
-is($undef_artist_cd->search_related('artist')->count, 3, 'open search on undef FK');
+is($undef_artist_cd->search_related('artist')->count, 0, '0=1 search when FK does not exist and object not yet in db');
+eval{
+ $undef_artist_cd->related_resultset('artist')->new({name => 'foo'});
+};
+is( $@, '', "Object created on a resultset related to not yet inserted object");
+lives_ok{
+ $schema->resultset('Artwork')->new_result({})->cd;
+} 'undef_on_null_fk does not choke on empty conds';
my $def_artist_cd = $schema->resultset("CD")->new_result({ 'title' => 'badgers', 'year' => 2007, artist => undef });
is($def_artist_cd->has_column_loaded('artist'), 1, 'FK loaded');
@@ -250,3 +276,11 @@
cmp_ok($artist->cds->count, '==', 0, "Correct new #cds for artist");
cmp_ok($nartist->cds->count, '==', 2, "Correct new #cds for artist");
+# check if is_foreign_key_constraint attr is set
+my $rs_normal = $schema->source('Track');
+my $relinfo = $rs_normal->relationship_info ('cd');
+cmp_ok($relinfo->{attrs}{is_foreign_key_constraint}, '==', 1, "is_foreign_key_constraint defined for belongs_to relationships.");
+
+my $rs_overridden = $schema->source('ForceForeign');
+my $relinfo_with_attr = $rs_overridden->relationship_info ('cd_3');
+cmp_ok($relinfo_with_attr->{attrs}{is_foreign_key_constraint}, '==', 0, "is_foreign_key_constraint defined for belongs_to relationships with attr.");
Deleted: DBIx-Class/0.08/branches/sybase/t/68inflate_has_a.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/68inflate_has_a.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/68inflate_has_a.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,61 +0,0 @@
-use strict;
-use warnings;
-
-use Test::More;
-use lib qw(t/lib);
-use DBICTest;
-
-my $schema = DBICTest->init_schema();
-
-eval { require DateTime };
-plan skip_all => "Need DateTime for inflation tests" if $@;
-
-eval { require Clone };
-plan skip_all => "Need Clone for CDBICompat inflation tests" if $@;
-
-plan tests => 6;
-
-DBICTest::Schema::CD->load_components(qw/CDBICompat::Relationships/);
-
-DBICTest::Schema::CD->has_a( 'year', 'DateTime',
- inflate => sub { DateTime->new( year => shift ) },
- deflate => sub { shift->year }
-);
-Class::C3->reinitialize;
-
-# inflation test
-my $cd = $schema->resultset("CD")->find(3);
-
-is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' );
-
-is( $cd->year->month, 1, 'inflated month ok' );
-
-# deflate test
-my $now = DateTime->now;
-$cd->year( $now );
-$cd->update;
-
-($cd) = $schema->resultset("CD")->search( year => $now->year );
-is( $cd->year->year, $now->year, 'deflate ok' );
-
-# re-test using alternate deflate syntax
-$schema->class("CD")->has_a( 'year', 'DateTime',
- inflate => sub { DateTime->new( year => shift ) },
- deflate => 'year'
-);
-
-# inflation test
-$cd = $schema->resultset("CD")->find(3);
-
-is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' );
-
-is( $cd->year->month, 1, 'inflated month ok' );
-
-# deflate test
-$now = DateTime->now;
-$cd->year( $now );
-$cd->update;
-
-($cd) = $schema->resultset("CD")->search( year => $now->year );
-is( $cd->year->year, $now->year, 'deflate ok' );
-
Modified: DBIx-Class/0.08/branches/sybase/t/68inflate_resultclass_hashrefinflator.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/68inflate_resultclass_hashrefinflator.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/68inflate_resultclass_hashrefinflator.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -3,10 +3,7 @@
use Test::More qw(no_plan);
use lib qw(t/lib);
-use Scalar::Util qw/blessed/;
-use DateTime;
use DBICTest;
-use DBIx::Class::ResultClass::HashRefInflator;
my $schema = DBICTest->init_schema();
@@ -64,6 +61,7 @@
$schema->resultset('CD')->create({ title => 'Silence is golden', artist => 3, year => 2006 });
# order_by to ensure both resultsets have the rows in the same order
+# also check result_class-as-an-attribute syntax
my $rs_dbic = $schema->resultset('CD')->search(undef,
{
prefetch => [ qw/ artist tracks / ],
@@ -74,9 +72,9 @@
{
prefetch => [ qw/ artist tracks / ],
order_by => [ 'me.cdid', 'tracks.position' ],
+ result_class => 'DBIx::Class::ResultClass::HashRefInflator',
}
);
-$rs_hashrefinf->result_class('DBIx::Class::ResultClass::HashRefInflator');
my @dbic = $rs_dbic->all;
my @hashrefinf = $rs_hashrefinf->all;
@@ -100,8 +98,8 @@
select => [qw/name tracks.title tracks.cd /],
as => [qw/name cds.tracks.title cds.tracks.cd /],
order_by => [qw/cds.cdid tracks.trackid/],
+ result_class => 'DBIx::Class::ResultClass::HashRefInflator',
});
-$rs_hashrefinf->result_class('DBIx::Class::ResultClass::HashRefInflator');
@dbic = map { $_->tracks->all } ($rs_dbic->first->cds->all);
@hashrefinf = $rs_hashrefinf->all;
@@ -118,22 +116,11 @@
}
}
-# Test the data inflator
-
-$schema->class('CD')->inflate_column( 'year',
- { inflate => sub { DateTime->new( year => shift ) },
- deflate => sub { shift->year } }
-);
-
-my $cd_rs = $schema->resultset("CD")->search ({cdid => 3});
-$cd_rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
-
-my $cd = $cd_rs->first;
-ok ( (not blessed $cd->{year}), "Plain string returned for year");
-is ( $cd->{year}, '1997', "We are looking at the right year");
-
-# try it again with inflation requested
-local $DBIx::Class::ResultClass::HashRefInflator::inflate_data = 1;
-my $cd2 = $cd_rs->first;
-isa_ok ($cd2->{year}, 'DateTime', "Inflated object");
-is ($cd2->{year}, DateTime->new ( year => 1997 ), "Correct year was inflated");
+# check for same query as above but using extended columns syntax
+$rs_hashrefinf = $schema->resultset ('Artist')->search ({ 'me.artistid' => 1}, {
+ join => { cds => 'tracks' },
+ columns => {name => 'name', 'cds.tracks.title' => 'tracks.title', 'cds.tracks.cd' => 'tracks.cd'},
+ order_by => [qw/cds.cdid tracks.trackid/],
+});
+$rs_hashrefinf->result_class('DBIx::Class::ResultClass::HashRefInflator');
+is_deeply [$rs_hashrefinf->all], \@hashrefinf, 'Check query using extended columns syntax';
Modified: DBIx-Class/0.08/branches/sybase/t/71mysql.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/71mysql.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/71mysql.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -21,7 +21,7 @@
$dbh->do("DROP TABLE IF EXISTS artist;");
-$dbh->do("CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(255), charfield CHAR(10));");
+$dbh->do("CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10));");
#'dbi:mysql:host=localhost;database=dbic_test', 'dbic_test', '');
@@ -57,9 +57,15 @@
'name' => {
'data_type' => 'VARCHAR',
'is_nullable' => 1,
- 'size' => 255,
+ 'size' => 100,
'default_value' => undef,
},
+ 'rank' => {
+ 'data_type' => 'INT',
+ 'is_nullable' => 0,
+ 'size' => 11,
+ 'default_value' => 13,
+ },
'charfield' => {
'data_type' => 'CHAR',
'is_nullable' => 1,
Modified: DBIx-Class/0.08/branches/sybase/t/72pg.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/72pg.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/72pg.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -2,6 +2,7 @@
use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
@@ -13,23 +14,40 @@
use base 'DBIx::Class';
__PACKAGE__->load_components(qw/Core/);
- __PACKAGE__->table('casecheck');
+ __PACKAGE__->table('testschema.casecheck');
__PACKAGE__->add_columns(qw/id name NAME uc_name/);
__PACKAGE__->column_info_from_storage(1);
__PACKAGE__->set_primary_key('id');
}
+{
+ package DBICTest::Schema::ArrayTest;
+
+ use strict;
+ use warnings;
+ use base 'DBIx::Class';
+
+ __PACKAGE__->load_components(qw/Core/);
+ __PACKAGE__->table('testschema.array_test');
+ __PACKAGE__->add_columns(qw/id arrayfield/);
+ __PACKAGE__->column_info_from_storage(1);
+ __PACKAGE__->set_primary_key('id');
+
+}
+
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-#warn "$dsn $user $pass";
+plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test '.
+ '(note: This test drops and creates tables called \'artist\', \'casecheck\', \'array_test\' and \'sequence_test\''.
+ ' as well as following sequences: \'pkid1_seq\', \'pkid2_seq\' and \'nonpkid_seq\''.
+ ' as well as following schemas: \'testschema\'!)'
+ unless ($dsn && $user);
-plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
- . ' (note: creates and drops tables named artist and casecheck!)' unless ($dsn && $user);
-plan tests => 32;
+plan tests => 37;
-DBICTest::Schema->load_classes( 'Casecheck' );
+DBICTest::Schema->load_classes( 'Casecheck', 'ArrayTest' );
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
# Check that datetime_parser returns correctly before we explicitly connect.
@@ -47,13 +65,17 @@
my $dbh = $schema->storage->dbh;
$schema->source("Artist")->name("testschema.artist");
$schema->source("SequenceTest")->name("testschema.sequence_test");
-$dbh->do("CREATE SCHEMA testschema;");
-$dbh->do("CREATE TABLE testschema.artist (artistid serial PRIMARY KEY, name VARCHAR(100), charfield CHAR(10));");
-$dbh->do("CREATE TABLE testschema.sequence_test (pkid1 integer, pkid2 integer, nonpkid integer, name VARCHAR(100), CONSTRAINT pk PRIMARY KEY(pkid1, pkid2));");
-$dbh->do("CREATE SEQUENCE pkid1_seq START 1 MAXVALUE 999999 MINVALUE 0");
-$dbh->do("CREATE SEQUENCE pkid2_seq START 10 MAXVALUE 999999 MINVALUE 0");
-$dbh->do("CREATE SEQUENCE nonpkid_seq START 20 MAXVALUE 999999 MINVALUE 0");
-ok ( $dbh->do('CREATE TABLE testschema.casecheck (id serial PRIMARY KEY, "name" VARCHAR(1), "NAME" VARCHAR(2), "UC_NAME" VARCHAR(3));'), 'Creation of casecheck table');
+{
+ local $SIG{__WARN__} = sub {};
+ $dbh->do("CREATE SCHEMA testschema;");
+ $dbh->do("CREATE TABLE testschema.artist (artistid serial PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10), arrayfield INTEGER[]);");
+ $dbh->do("CREATE TABLE testschema.sequence_test (pkid1 integer, pkid2 integer, nonpkid integer, name VARCHAR(100), CONSTRAINT pk PRIMARY KEY(pkid1, pkid2));");
+ $dbh->do("CREATE SEQUENCE pkid1_seq START 1 MAXVALUE 999999 MINVALUE 0");
+ $dbh->do("CREATE SEQUENCE pkid2_seq START 10 MAXVALUE 999999 MINVALUE 0");
+ $dbh->do("CREATE SEQUENCE nonpkid_seq START 20 MAXVALUE 999999 MINVALUE 0");
+ ok ( $dbh->do('CREATE TABLE testschema.casecheck (id serial PRIMARY KEY, "name" VARCHAR(1), "NAME" VARCHAR(2), "UC_NAME" VARCHAR(3));'), 'Creation of casecheck table');
+ ok ( $dbh->do('CREATE TABLE testschema.array_test (id serial PRIMARY KEY, arrayfield INTEGER[]);'), 'Creation of array_test table');
+}
# This is in Core now, but it's here just to test that it doesn't break
$schema->class('Artist')->load_components('PK::Auto');
@@ -78,12 +100,25 @@
'size' => 100,
'default_value' => undef,
},
+ 'rank' => {
+ 'data_type' => 'integer',
+ 'is_nullable' => 0,
+ 'size' => 4,
+ 'default_value' => 13,
+
+ },
'charfield' => {
'data_type' => 'character',
'is_nullable' => 1,
'size' => 10,
'default_value' => undef,
},
+ 'arrayfield' => {
+ 'data_type' => 'integer[]',
+ 'is_nullable' => 1,
+ 'size' => undef,
+ 'default_value' => undef,
+ },
};
@@ -95,6 +130,36 @@
is_deeply($type_info, $test_type_info,
'columns_info_for - column data types');
+SKIP: {
+ skip "SQL::Abstract < 1.49 does not pass through arrayrefs", 4
+ if $SQL::Abstract::VERSION < 1.49;
+
+ lives_ok {
+ $schema->resultset('ArrayTest')->create({
+ arrayfield => [1, 2],
+ });
+ } 'inserting arrayref as pg array data';
+
+ lives_ok {
+ $schema->resultset('ArrayTest')->update({
+ arrayfield => [3, 4],
+ });
+ } 'updating arrayref as pg array data';
+
+ $schema->resultset('ArrayTest')->create({
+ arrayfield => [5, 6],
+ });
+
+ my $count;
+ lives_ok {
+ $count = $schema->resultset('ArrayTest')->search({
+ arrayfield => \[ '= ?' => [arrayfield => [3, 4]] ], #TODO anything less ugly than this?
+ })->count;
+ } 'comparing arrayref to pg array data does not blow up';
+ is($count, 1, 'comparing arrayref to pg array data gives correct result');
+}
+
+
my $name_info = $schema->source('Casecheck')->column_info( 'name' );
is( $name_info->{size}, 1, "Case sensitive matching info for 'name'" );
@@ -200,6 +265,7 @@
$dbh->do("DROP TABLE testschema.artist;");
$dbh->do("DROP TABLE testschema.casecheck;");
$dbh->do("DROP TABLE testschema.sequence_test;");
+ $dbh->do("DROP TABLE testschema.array_test;");
$dbh->do("DROP SEQUENCE pkid1_seq");
$dbh->do("DROP SEQUENCE pkid2_seq");
$dbh->do("DROP SEQUENCE nonpkid_seq");
Modified: DBIx-Class/0.08/branches/sybase/t/73oracle.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/73oracle.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/73oracle.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,3 +1,30 @@
+{
+ package # hide from PAUSE
+ DBICTest::Schema::ArtistFQN;
+
+ use base 'DBIx::Class::Core';
+
+ __PACKAGE__->table(
+ defined $ENV{DBICTEST_ORA_USER}
+ ? $ENV{DBICTEST_ORA_USER} . '.artist'
+ : 'artist'
+ );
+ __PACKAGE__->add_columns(
+ 'artistid' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'name' => {
+ data_type => 'varchar',
+ size => 100,
+ is_nullable => 1,
+ },
+ );
+ __PACKAGE__->set_primary_key('artistid');
+
+ 1;
+}
+
use strict;
use warnings;
@@ -12,8 +39,9 @@
' as well as following sequences: \'pkid1_seq\', \'pkid2_seq\' and \'nonpkid_seq\''
unless ($dsn && $user && $pass);
-plan tests => 23;
+plan tests => 24;
+DBICTest::Schema->load_classes('ArtistFQN');
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
my $dbh = $schema->storage->dbh;
@@ -32,7 +60,7 @@
$dbh->do("CREATE SEQUENCE pkid1_seq START WITH 1 MAXVALUE 999999 MINVALUE 0");
$dbh->do("CREATE SEQUENCE pkid2_seq START WITH 10 MAXVALUE 999999 MINVALUE 0");
$dbh->do("CREATE SEQUENCE nonpkid_seq START WITH 20 MAXVALUE 999999 MINVALUE 0");
-$dbh->do("CREATE TABLE artist (artistid NUMBER(12), name VARCHAR(255))");
+$dbh->do("CREATE TABLE artist (artistid NUMBER(12), name VARCHAR(255), rank NUMBER(38), charfield VARCHAR2(10))");
$dbh->do("CREATE TABLE sequence_test (pkid1 NUMBER(12), pkid2 NUMBER(12), nonpkid NUMBER(12), name VARCHAR(255))");
$dbh->do("CREATE TABLE cd (cdid NUMBER(12), artist NUMBER(12), title VARCHAR(255), year VARCHAR(4))");
$dbh->do("CREATE TABLE track (trackid NUMBER(12), cd NUMBER(12), position NUMBER(12), title VARCHAR(255), last_updated_on DATE)");
@@ -62,6 +90,10 @@
my $new = $schema->resultset('Artist')->create({ name => 'foo' });
is($new->artistid, 1, "Oracle Auto-PK worked");
+# test again with fully-qualified table name
+$new = $schema->resultset('ArtistFQN')->create( { name => 'bar' } );
+is( $new->artistid, 2, "Oracle Auto-PK worked with fully-qualified tablename" );
+
# test join with row count ambiguity
my $cd = $schema->resultset('CD')->create({ cdid => 1, artist => 1, title => 'EP C', year => '2003' });
my $track = $schema->resultset('Track')->create({ trackid => 1, cd => 1, position => 1, title => 'Track1' });
@@ -90,7 +122,7 @@
}
my $it = $schema->resultset('Artist')->search( {},
{ rows => 3,
- offset => 2,
+ offset => 3,
order_by => 'artistid' }
);
is( $it->count, 3, "LIMIT count ok" );
@@ -117,7 +149,7 @@
# clean up our mess
END {
- if($dbh) {
+ if($schema && ($dbh = $schema->storage->dbh)) {
$dbh->do("DROP SEQUENCE artist_seq");
$dbh->do("DROP SEQUENCE pkid1_seq");
$dbh->do("DROP SEQUENCE pkid2_seq");
Modified: DBIx-Class/0.08/branches/sybase/t/73oracle_inflate.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/73oracle_inflate.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/73oracle_inflate.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -7,16 +7,18 @@
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
-eval "use DateTime; use DateTime::Format::Oracle;";
-if ($@) {
- plan skip_all => 'needs DateTime and DateTime::Format::Oracle for testing';
-}
-elsif (not ($dsn && $user && $pass)) {
+if (not ($dsn && $user && $pass)) {
plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test. ' .
'Warning: This test drops and creates a table called \'track\'';
}
else {
- plan tests => 4;
+ eval "use DateTime; use DateTime::Format::Oracle;";
+ if ($@) {
+ plan skip_all => 'needs DateTime and DateTime::Format::Oracle for testing';
+ }
+ else {
+ plan tests => 4;
+ }
}
# DateTime::Format::Oracle needs this set
Modified: DBIx-Class/0.08/branches/sybase/t/745db2.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/745db2.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/745db2.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -20,7 +20,7 @@
eval { $dbh->do("DROP TABLE artist") };
-$dbh->do("CREATE TABLE artist (artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1), name VARCHAR(255), charfield CHAR(10));");
+$dbh->do("CREATE TABLE artist (artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1), name VARCHAR(255), charfield CHAR(10), rank INTEGER DEFAULT 13);");
# This is in core, just testing that it still loads ok
$schema->class('Artist')->load_components('PK::Auto');
@@ -60,6 +60,11 @@
'is_nullable' => 1,
'size' => 10
},
+ 'rank' => {
+ 'data_type' => 'INTEGER',
+ 'is_nullable' => 1,
+ 'size' => 10
+ },
};
Modified: DBIx-Class/0.08/branches/sybase/t/746db2_400.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/746db2_400.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/746db2_400.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -23,7 +23,13 @@
eval { $dbh->do("DROP TABLE artist") };
-$dbh->do("CREATE TABLE artist (artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1), name VARCHAR(255), charfield CHAR(10))");
+$dbh->do(<<'');
+CREATE TABLE artist (
+ artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1),
+ name VARCHAR(255),
+ rank INTEGER default 13 not null,
+ charfield CHAR(10)
+)
# Just to test loading, already in Core
$schema->class('Artist')->load_components('PK::Auto');
@@ -58,6 +64,11 @@
'is_nullable' => 1,
'size' => 255
},
+ 'rank' => {
+ 'data_type' => 'INTEGER',
+ 'is_nullable' => 0,
+ 'size' => 10,
+ },
'charfield' => {
'data_type' => 'CHAR',
'is_nullable' => 1,
Modified: DBIx-Class/0.08/branches/sybase/t/746mssql.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/746mssql.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/746mssql.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -17,18 +17,23 @@
$schema->storage->ensure_connected;
isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server' );
-my $dbh = $schema->storage->_dbh;
+$schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ eval { $dbh->do("DROP TABLE artist") };
+ $dbh->do(<<'SQL');
-eval { $dbh->do("DROP TABLE artist") };
-
- $dbh->do(<<'');
CREATE TABLE artist (
artistid INT IDENTITY NOT NULL,
- name VARCHAR(255),
+ name VARCHAR(100),
+ rank INT NOT NULL DEFAULT '13',
charfield CHAR(10) NULL,
primary key(artistid)
)
+SQL
+
+});
+
my %seen_id;
# fresh $schema so we start unconnected
@@ -61,7 +66,7 @@
# clean up our mess
END {
- $dbh = eval { $schema->storage->_dbh };
+ my $dbh = eval { $schema->storage->_dbh };
$dbh->do('DROP TABLE artist') if $dbh;
}
Modified: DBIx-Class/0.08/branches/sybase/t/74mssql.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/74mssql.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/74mssql.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -26,10 +26,11 @@
$dbh->do("IF OBJECT_ID('artist', 'U') IS NOT NULL
DROP TABLE artist");
+$dbh->do("IF OBJECT_ID('cd', 'U') IS NOT NULL
+ DROP TABLE cd");
-$dbh->do("CREATE TABLE artist (artistid INT IDENTITY PRIMARY KEY, name VARCHAR(255));");
-$dbh->do("CREATE TABLE cd (cdid INT IDENTITY PRIMARY KEY, artist INT, title VARCHAR(100), year VARCHAR(100));");
-
+$dbh->do("CREATE TABLE artist (artistid INT IDENTITY PRIMARY KEY, name VARCHAR(100), rank INT DEFAULT '13', charfield CHAR(10) NULL);");
+$dbh->do("CREATE TABLE cd (cdid INT IDENTITY PRIMARY KEY, artist INT, title VARCHAR(100), year VARCHAR(100), genreid INT NULL, single_track INT NULL);");
# Just to test compat shim, Auto is in Core
$schema->class('Artist')->load_components('PK::Auto::MSSQL');
Modified: DBIx-Class/0.08/branches/sybase/t/76joins.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/76joins.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/76joins.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -5,6 +5,7 @@
use lib qw(t/lib);
use DBICTest;
use Data::Dumper;
+use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
@@ -16,7 +17,7 @@
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 16 );
+ : ( tests => 18 );
}
# figure out if we've got a version of sqlite that is older than 3.2.6, in
@@ -43,7 +44,11 @@
. 'child.father_id ) JOIN person mother ON ( mother.person_id '
. '= child.mother_id )'
;
-is( $sa->_recurse_from(@j), $match, 'join 1 ok' );
+is_same_sql_bind(
+ $sa->_recurse_from(@j), [],
+ $match, [],
+ 'join 1 ok'
+);
my @j2 = (
{ mother => 'person' },
@@ -59,8 +64,13 @@
. ' father.person_id = child.father_id )) ON ( mother.person_id = '
. 'child.mother_id )'
;
-is( $sa->_recurse_from(@j2), $match, 'join 2 ok' );
+is_same_sql_bind(
+ $sa->_recurse_from(@j2), [],
+ $match, [],
+ 'join 2 ok'
+);
+
my @j3 = (
{ child => 'person' },
[ { father => 'person', -join_type => 'inner' }, { 'father.person_id' => 'child.father_id' }, ],
@@ -71,7 +81,11 @@
. '= child.mother_id )'
;
-is( $sa->_recurse_from(@j3), $match, 'join 3 (inner join) ok');
+is_same_sql_bind(
+ $sa->_recurse_from(@j3), [],
+ $match, [],
+ 'join 3 (inner join) ok'
+);
my @j4 = (
{ mother => 'person' },
@@ -87,7 +101,11 @@
. ' father.person_id = child.father_id )) ON ( mother.person_id = '
. 'child.mother_id )'
;
-is( $sa->_recurse_from(@j4), $match, 'join 4 (nested joins + join types) ok');
+is_same_sql_bind(
+ $sa->_recurse_from(@j4), [],
+ $match, [],
+ 'join 4 (nested joins + join types) ok'
+);
my @j5 = (
{ child => 'person' },
@@ -98,7 +116,11 @@
. 'child.father_id ) JOIN person mother ON ( mother.person_id '
. '= child.mother_id )'
;
-is( $sa->_recurse_from(@j5), $match, 'join 5 (SCALAR reference for ON statement) ok' );
+is_same_sql_bind(
+ $sa->_recurse_from(@j5), [],
+ $match, [],
+ 'join 5 (SCALAR reference for ON statement) ok'
+);
my @j6 = (
{ child => 'person' },
@@ -157,3 +179,28 @@
is($rs->first->name, 'We Are Goth', 'Correct record returned');
+# test for warnings on delete of joined resultset
+$rs = $schema->resultset("CD")->search(
+ { 'artist.name' => 'Caterwauler McCrae' },
+ { join => [qw/artist/]}
+);
+my $tst_delete_warning;
+eval {
+ local $SIG{__WARN__} = sub { $tst_delete_warning = shift };
+ $rs->delete();
+};
+
+ok( ($@ || $tst_delete_warning), 'fail/warning on attempt to delete a join-ed resultset');
+
+# test for warnings on update of joined resultset
+$rs = $schema->resultset("CD")->search(
+ { 'artist.name' => 'Random Boy Band' },
+ { join => [qw/artist/]}
+);
+my $tst_update_warning;
+eval {
+ local $SIG{__WARN__} = sub { $tst_update_warning = shift };
+ $rs->update({ 'artist' => 1 });
+};
+
+ok( ($@ || $tst_update_warning), 'fail/warning on attempt to update a join-ed resultset');
Added: DBIx-Class/0.08/branches/sybase/t/76select.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/76select.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/76select.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,65 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 12;
+
+my $rs = $schema->resultset('CD')->search({},
+ {
+ '+select' => \ 'COUNT(*)',
+ '+as' => 'count'
+ }
+);
+lives_ok(sub { $rs->first->get_column('count') }, 'additional count rscolumn present');
+dies_ok(sub { $rs->first->get_column('nonexistent_column') }, 'nonexistant column requests still throw exceptions');
+
+$rs = $schema->resultset('CD')->search({},
+ {
+ '+select' => [ \ 'COUNT(*)', 'title' ],
+ '+as' => [ 'count', 'addedtitle' ]
+ }
+);
+lives_ok(sub { $rs->first->get_column('count') }, 'multiple +select/+as columns, 1st rscolumn present');
+lives_ok(sub { $rs->first->get_column('addedtitle') }, 'multiple +select/+as columns, 2nd rscolumn present');
+
+$rs = $schema->resultset('CD')->search({},
+ {
+ '+select' => [ \ 'COUNT(*)', 'title' ],
+ '+as' => [ 'count', 'addedtitle' ]
+ }
+)->search({},
+ {
+ '+select' => 'title',
+ '+as' => 'addedtitle2'
+ }
+);
+lives_ok(sub { $rs->first->get_column('count') }, '+select/+as chained search 1st rscolumn present');
+lives_ok(sub { $rs->first->get_column('addedtitle') }, '+select/+as chained search 1st rscolumn present');
+lives_ok(sub { $rs->first->get_column('addedtitle2') }, '+select/+as chained search 3rd rscolumn present');
+
+
+# test the from search attribute (gets between the FROM and WHERE keywords, allows arbitrary subselects)
+# also shows that outer select attributes are ok (i.e. order_by)
+#
+# from doesn't seem to be useful without using a scalarref - there were no initial tests >:(
+#
+my $cds = $schema->resultset ('CD')->search ({}, { order_by => 'me.cdid'}); # make sure order is consistent
+cmp_ok ($cds->count, '>', 2, 'Initially populated with more than 2 CDs');
+
+my $table = $cds->result_source->name;
+my $subsel = $cds->search ({}, {
+ columns => [qw/cdid title/],
+ from => \ "(SELECT cdid, title FROM $table LIMIT 2) me",
+});
+
+is ($subsel->count, 2, 'Subselect correctly limited the rs to 2 cds');
+is ($subsel->next->title, $cds->next->title, 'First CD title match');
+is ($subsel->next->title, $cds->next->title, 'Second CD title match');
+
+is($schema->resultset('CD')->current_source_alias, "me", '$rs->current_source_alias returns "me"');
Property changes on: DBIx-Class/0.08/branches/sybase/t/76select.t
___________________________________________________________________
Name: svn:mergeinfo
+
Modified: DBIx-Class/0.08/branches/sybase/t/77prefetch.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/77prefetch.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/77prefetch.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -2,6 +2,7 @@
use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
use Data::Dumper;
@@ -16,7 +17,7 @@
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 58 );
+ : ( tests => 74 );
}
# figure out if we've got a version of sqlite that is older than 3.2.6, in
@@ -45,6 +46,49 @@
is(Dumper($attr), $attr_str, 'Attribute hash untouched after search()');
cmp_ok($rs + 0, '==', 3, 'Correct number of records returned');
+# A search() with prefetch seems to pollute an already joined resultset
+# in a way that offsets future joins (adapted from a test case by Debolaz)
+{
+ my ($cd_rs, $attrs);
+
+ # test a real-life case - rs is obtained by an implicit m2m join
+ $cd_rs = $schema->resultset ('Producer')->first->cds;
+ $attrs = Dumper $cd_rs->{attrs};
+
+ $cd_rs->search ({})->all;
+ is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search');
+
+ lives_ok (sub {
+ $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
+ is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch');
+ }, 'first prefetching search ok');
+
+ lives_ok (sub {
+ $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
+ is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch')
+ }, 'second prefetching search ok');
+
+
+ # test a regular rs with an empty seen_join injected - it should still work!
+ $cd_rs = $schema->resultset ('CD');
+ $cd_rs->{attrs}{seen_join} = {};
+ $attrs = Dumper $cd_rs->{attrs};
+
+ $cd_rs->search ({})->all;
+ is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search');
+
+ lives_ok (sub {
+ $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
+ is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch');
+ }, 'first prefetching search ok');
+
+ lives_ok (sub {
+ $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
+ is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch')
+ }, 'second prefetching search ok');
+}
+
+
my $queries = 0;
$schema->storage->debugcb(sub { $queries++; });
$schema->storage->debug(1);
@@ -69,7 +113,7 @@
# test for partial prefetch via columns attr
my $cd = $schema->resultset('CD')->find(1,
{
- columns => [qw/title artist.name/],
+ columns => [qw/title artist artist.name/],
join => { 'artist' => {} }
}
);
@@ -344,11 +388,10 @@
is($queries, 0, 'chained search_related after has_many->has_many prefetch ran no queries');
-# once the following TODO is complete, remove the 2 stop-gap tests immediately after the TODO block
-# (the TODO block itself contains tests ensuring that the stop-gaps are removed)
+# once the following TODO is complete, remove the 2 warning tests immediately after the TODO block
+# (the TODO block itself contains tests ensuring that the warns are removed)
TODO: {
- local $TODO = 'Prefetch of multiple has_many rels at the same level (currently must die to protect the clueless git)';
- use DBIx::Class::ResultClass::HashRefInflator;
+ local $TODO = 'Prefetch of multiple has_many rels at the same level (currently warn to protect the clueless git)';
#( 1 -> M + M )
my $cd_rs = $schema->resultset('CD')->search ({ 'me.title' => 'Forkful of bees' });
@@ -364,26 +407,24 @@
$queries = 0;
$schema->storage->debugcb(sub { $queries++ });
$schema->storage->debug(1);
- eval {
+
+ my $o_mm_warn;
+ {
+ local $SIG{__WARN__} = sub { $o_mm_warn = shift };
$pr_tracks_rs = $pr_cd_rs->first->tracks;
- $pr_tracks_count = $pr_tracks_rs->count;
};
+ $pr_tracks_count = $pr_tracks_rs->count;
- my $o_mm_exc = $@;
- ok(! $o_mm_exc, 'exception on attempt to prefetch several same level has_many\'s (1 -> M + M)');
+ ok(! $o_mm_warn, 'no warning on attempt to prefetch several same level has_many\'s (1 -> M + M)');
- SKIP: {
- skip "1 -> M + M prefetch died", 3 if $o_mm_exc;
-
- is($queries, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query');
- is($pr_tracks_count, $tracks_count, 'equal count of prefetched relations over several same level has_many\'s (1 -> M + M)');
+ is($queries, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query');
+ is($pr_tracks_count, $tracks_count, 'equal count of prefetched relations over several same level has_many\'s (1 -> M + M)');
- for ($pr_tracks_rs, $tracks_rs) {
- $_->result_class ('DBIx::Class::ResultClass::HashRefInflator');
- }
+ for ($pr_tracks_rs, $tracks_rs) {
+ $_->result_class ('DBIx::Class::ResultClass::HashRefInflator');
+ }
- is_deeply ([$pr_tracks_rs->all], [$tracks_rs->all], 'same structure returned with and without prefetch over several same level has_many\'s (1 -> M + M)');
- };
+ is_deeply ([$pr_tracks_rs->all], [$tracks_rs->all], 'same structure returned with and without prefetch over several same level has_many\'s (1 -> M + M)');
#( M -> 1 -> M + M )
my $note_rs = $schema->resultset('LinerNotes')->search ({ notes => 'Buy Whiskey!' });
@@ -401,30 +442,44 @@
$queries = 0;
$schema->storage->debugcb(sub { $queries++ });
$schema->storage->debug(1);
- eval {
+
+ my $m_o_mm_warn;
+ {
+ local $SIG{__WARN__} = sub { $m_o_mm_warn = shift };
$pr_tags_rs = $pr_note_rs->first->cd->tags;
- $pr_tags_count = $pr_tags_rs->count;
};
+ $pr_tags_count = $pr_tags_rs->count;
- my $m_o_mm_exc = $@;
- ok(! $m_o_mm_exc, 'exception on attempt to prefetch several same level has_many\'s (M -> 1 -> M + M)');
+ ok(! $m_o_mm_warn, 'no warning on attempt to prefetch several same level has_many\'s (M -> 1 -> M + M)');
- SKIP: {
- skip "M -> 1 -> M + M prefetch died", 3 if $m_o_mm_exc;
-
- is($queries, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query');
+ is($queries, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query');
- is($pr_tags_count, $tags_count, 'equal count of prefetched relations over several same level has_many\'s (M -> 1 -> M + M)');
+ is($pr_tags_count, $tags_count, 'equal count of prefetched relations over several same level has_many\'s (M -> 1 -> M + M)');
- for ($pr_tags_rs, $tags_rs) {
- $_->result_class ('DBIx::Class::ResultClass::HashRefInflator');
- }
+ for ($pr_tags_rs, $tags_rs) {
+ $_->result_class ('DBIx::Class::ResultClass::HashRefInflator');
+ }
- is_deeply ([$pr_tags_rs->all], [$tags_rs->all], 'same structure returned with and without prefetch over several same level has_many\'s (M -> 1 -> M + M)');
- };
+ is_deeply ([$pr_tags_rs->all], [$tags_rs->all], 'same structure returned with and without prefetch over several same level has_many\'s (M -> 1 -> M + M)');
};
-eval { my $track = $schema->resultset('CD')->search ({ 'me.title' => 'Forkful of bees' }, { prefetch => [qw/tracks tags/] })->first->tracks->first };
-ok ($@, 'exception on attempt to prefetch several same level has_many\'s (1 -> M + M)');
-eval { my $tag = $schema->resultset('LinerNotes')->search ({ notes => 'Buy Whiskey!' }, { prefetch => { cd => [qw/tags tracks/] } })->first->cd->tags->first };
-ok ($@, 'exception on attempt to prefetch several same level has_many\'s (M -> 1 -> M + M)');
+# remove this closure once the TODO above is working
+my $w;
+{
+ local $SIG{__WARN__} = sub { $w = shift };
+
+ my $rs = $schema->resultset('CD')->search ({ 'me.title' => 'Forkful of bees' }, { prefetch => [qw/tracks tags/] });
+ for (qw/all count next first/) {
+ undef $w;
+ my @stuff = $rs->search()->$_;
+ like ($w, qr/will currently disrupt both the functionality of .rs->count\(\), and the amount of objects retrievable via .rs->next\(\)/,
+ "warning on ->$_ attempt prefetching several same level has_manys (1 -> M + M)");
+ }
+ my $rs2 = $schema->resultset('LinerNotes')->search ({ notes => 'Buy Whiskey!' }, { prefetch => { cd => [qw/tags tracks/] } });
+ for (qw/all count next first/) {
+ undef $w;
+ my @stuff = $rs2->search()->$_;
+ like ($w, qr/will currently disrupt both the functionality of .rs->count\(\), and the amount of objects retrievable via .rs->next\(\)/,
+ "warning on ->$_ attempt prefetching several same level has_manys (M -> 1 -> M + M)");
+ }
+}
Modified: DBIx-Class/0.08/branches/sybase/t/81transactions.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/81transactions.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/81transactions.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -8,7 +8,7 @@
my $schema = DBICTest->init_schema();
-plan tests => 63;
+plan tests => 64;
my $code = sub {
my ($artist, @cd_titles) = @_;
@@ -235,7 +235,11 @@
$schema2->txn_begin();
};
my $err = $@;
- ok(($err eq ''), 'Pre-connection nested transactions.');
+ ok(! $err, 'Pre-connection nested transactions.');
+
+ # although not connected DBI would still warn about rolling back at disconnect
+ $schema2->txn_rollback;
+ $schema2->txn_rollback;
$schema2->storage->disconnect;
}
$schema->storage->disconnect;
@@ -256,7 +260,7 @@
});
$guard->commit;
- } qr/No such column made_up_column .*? at .*?81transactions.t line \d+/, "Error propogated okay";
+ } qr/No such column made_up_column .*? at .*?81transactions.t line \d+/s, "Error propogated okay";
ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
@@ -268,12 +272,17 @@
ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+ eval {
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
- eval {
- # The 0 arg says done die, just let the scope guard go out of scope
+ # The 0 arg says don't die, just let the scope guard go out of scope
# forcing a txn_rollback to happen
outer($schema, 0);
+
+ like ($w, qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or an error/, 'Out of scope warning detected');
};
+
local $TODO = "Work out how this should work";
is($@, "Not sure what we want here, but something", "Rollback okay");
Modified: DBIx-Class/0.08/branches/sybase/t/85utf8.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/85utf8.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/85utf8.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -16,7 +16,7 @@
eval 'use utf8; 1' or plan skip_all => 'Need utf8 run this test';
}
-plan tests => 3;
+plan tests => 5;
DBICTest::Schema::CD->load_components('UTF8Columns');
DBICTest::Schema::CD->utf8_columns('title');
@@ -43,3 +43,13 @@
$cd->title($utf8_char);
ok( !utf8::is_utf8( $cd->{_column_data}{title} ), 'store utf8-less chars' );
}
+
+my $v_utf8 = "\x{219}";
+
+$cd->update ({ title => $v_utf8 });
+$cd->title($v_utf8);
+ok( !$cd->is_column_changed('title'), 'column is not dirty after setting the same unicode value' );
+
+$cd->update ({ title => $v_utf8 });
+$cd->title('something_else');
+ok( $cd->is_column_changed('title'), 'column is dirty after setting to something completely different');
Modified: DBIx-Class/0.08/branches/sybase/t/86sqlt.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/86sqlt.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/86sqlt.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -10,7 +10,7 @@
my $schema = DBICTest->init_schema;
-plan tests => 131;
+plan tests => 133;
my $translator = SQL::Translator->new(
parser_args => {
@@ -26,6 +26,17 @@
my $relinfo = $schema->source('Artist')->relationship_info ('cds');
local $relinfo->{attrs}{on_delete} = 'restrict';
+ $schema->source('Track')->sqlt_deploy_callback(sub {
+ my ($self, $sqlt_table) = @_;
+
+ if ($schema->storage->sqlt_type eq 'SQLite' ) {
+ $sqlt_table->add_index( name => 'track_title', fields => ['title'] )
+ or die $sqlt_table->error;
+ }
+
+ $self->default_sqlt_deploy_hook($sqlt_table);
+ });
+
$translator->parser('SQL::Translator::Parser::DBIx::Class');
$translator->producer('SQLite');
@@ -126,7 +137,7 @@
'name' => 'cd_fk_artist', 'index_name' => 'cd_idx_artist',
'selftable' => 'cd', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
- on_delete => '', on_update => 'SET NULL', deferrable => 1,
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
@@ -258,7 +269,12 @@
{
'fields' => ['name']
},
- ]
+ ],
+ track => [
+ {
+ 'fields' => ['title']
+ }
+ ],
);
my $tschema = $translator->schema();
@@ -266,6 +282,18 @@
# the 'dummy' table
ok( !defined($tschema->get_table('dummy')), "Dummy table was removed by hook");
+# Test that the Artist resultsource sqlt_deploy_hook was called okay and added
+# an index
+SKIP: {
+ skip ('Artist sqlt_deploy_hook is only called with an SQLite backend', 1)
+ if $schema->storage->sqlt_type ne 'SQLite';
+
+ ok( ( grep
+ { $_->name eq 'artist_name_hookidx' }
+ $tschema->get_table('artist')->get_indices
+ ), 'sqlt_deploy_hook fired within a resultsource');
+}
+
# Test that nonexistent constraints are not found
my $constraint = get_constraint('FOREIGN KEY', 'cd', ['title'], 'cd', ['year']);
ok( !defined($constraint), 'nonexistent FOREIGN KEY constraint not found' );
@@ -300,7 +328,6 @@
for my $table_index (keys %indexes) {
for my $expected_index ( @{ $indexes{$table_index} } ) {
-
ok ( get_index($table_index, $expected_index), "Got a matching index on $table_index table");
}
}
Modified: DBIx-Class/0.08/branches/sybase/t/87ordered.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/87ordered.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/87ordered.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -10,7 +10,7 @@
my $schema = DBICTest->init_schema();
-plan tests => 879;
+plan tests => 1269;
my $employees = $schema->resultset('Employee');
$employees->delete();
@@ -42,10 +42,15 @@
my $group_3 = $employees->search({group_id=>3});
my $to_group = 1;
my $to_pos = undef;
-while (my $employee = $group_3->next) {
- $employee->move_to_group($to_group, $to_pos);
- $to_pos++;
- $to_group = $to_group==1 ? 2 : 1;
+# now that we have transactions we need to work around stupid sqlite
+{
+ my @empl = $group_3->all;
+ while (my $employee = shift @empl) {
+ $employee->discard_changes; # since we are effective shift()ing the $rs while doing this
+ $employee->move_to_group($to_group, $to_pos);
+ $to_pos++;
+ $to_group = $to_group==1 ? 2 : 1;
+ }
}
foreach my $group_id (1..4) {
my $group_employees = $employees->search({group_id=>$group_id});
@@ -97,20 +102,20 @@
);
# multicol tests begin here
-DBICTest::Employee->grouping_column(['group_id', 'group_id_2']);
+DBICTest::Employee->grouping_column(['group_id_2', 'group_id_3']);
$employees->delete();
-foreach my $group_id (1..4) {
- foreach my $group_id_2 (1..4) {
+foreach my $group_id_2 (1..4) {
+ foreach my $group_id_3 (1..4) {
foreach (1..4) {
- $employees->create({ name=>'temp', group_id=>$group_id, group_id_2=>$group_id_2 });
+ $employees->create({ name=>'temp', group_id_2=>$group_id_2, group_id_3=>$group_id_3 });
}
}
}
-$employees = $employees->search(undef,{order_by=>'group_id,group_id_2,position'});
+$employees = $employees->search(undef,{order_by=>[qw/group_id_2 group_id_3 position/]});
-foreach my $group_id (1..3) {
- foreach my $group_id_2 (1..3) {
- my $group_employees = $employees->search({group_id=>$group_id, group_id_2=>$group_id_2});
+foreach my $group_id_2 (1..3) {
+ foreach my $group_id_3 (1..3) {
+ my $group_employees = $employees->search({group_id_2=>$group_id_2, group_id_3=>$group_id_3});
$group_employees->all();
ok( check_rs($group_employees), "group intial positions" );
hammer_rs( $group_employees );
@@ -118,72 +123,77 @@
}
# move_to_group, specifying group by hash
-my $group_4 = $employees->search({group_id=>4});
+my $group_4 = $employees->search({group_id_2=>4});
$to_group = 1;
my $to_group_2_base = 7;
my $to_group_2 = 1;
$to_pos = undef;
-while (my $employee = $group_4->next) {
- $employee->move_to_group({group_id=>$to_group, group_id_2=>$to_group_2}, $to_pos);
- $to_pos++;
+
+# now that we have transactions we need to work around stupid sqlite
+{
+ my @empl = $group_3->all;
+ while (my $employee = shift @empl) {
+ $employee->move_to_group({group_id_2=>$to_group, group_id_3=>$to_group_2}, $to_pos);
+ $to_pos++;
$to_group = ($to_group % 3) + 1;
$to_group_2_base++;
$to_group_2 = (ceil($to_group_2_base/3.0) %3) +1
+ }
}
-foreach my $group_id (1..4) {
- foreach my $group_id_2 (1..4) {
- my $group_employees = $employees->search({group_id=>$group_id,group_id_2=>$group_id_2});
+foreach my $group_id_2 (1..4) {
+ foreach my $group_id_3 (1..4) {
+ my $group_employees = $employees->search({group_id_2=>$group_id_2,group_id_3=>$group_id_3});
$group_employees->all();
ok( check_rs($group_employees), "group positions after move_to_group" );
}
}
$employees->delete();
-foreach my $group_id (1..4) {
- foreach my $group_id_2 (1..4) {
+foreach my $group_id_2 (1..4) {
+ foreach my $group_id_3 (1..4) {
foreach (1..4) {
- $employees->create({ name=>'temp', group_id=>$group_id, group_id_2=>$group_id_2 });
+ $employees->create({ name=>'temp', group_id_2=>$group_id_2, group_id_3=>$group_id_3 });
}
}
}
-$employees = $employees->search(undef,{order_by=>'group_id,group_id_2,position'});
+$employees = $employees->search(undef,{order_by=>[qw/group_id_2 group_id_3 position/]});
-$employee = $employees->search({group_id=>4, group_id_2=>1})->first;
-$employee->group_id(1);
+$employee = $employees->search({group_id_2=>4, group_id_3=>1})->first;
+$employee->group_id_2(1);
$employee->update;
ok(
- check_rs($employees->search_rs({group_id=>4, group_id_2=>1}))
- && check_rs($employees->search_rs({group_id=>1, group_id_2=>1})),
+ check_rs($employees->search_rs({group_id_2=>4, group_id_3=>1}))
+ && check_rs($employees->search_rs({group_id_2=>1, group_id_3=>1})),
"overloaded multicol update 1"
);
-$employee = $employees->search({group_id=>4, group_id_2=>1})->first;
-$employee->update({group_id=>2});
-ok( check_rs($employees->search_rs({group_id=>4, group_id_2=>1}))
- && check_rs($employees->search_rs({group_id=>2, group_id_2=>1})),
- "overloaded multicol update 2"
+$employee = $employees->search({group_id_2=>4, group_id_3=>1})->first;
+$employee->update({group_id_2=>2});
+ok( check_rs($employees->search_rs({group_id_2=>4, group_id_3=>1}))
+ && check_rs($employees->search_rs({group_id_2=>2, group_id_3=>1})),
+ "overloaded multicol update 2"
);
-$employee = $employees->search({group_id=>3, group_id_2=>1})->first;
-$employee->group_id(1);
-$employee->group_id_2(3);
+$employee = $employees->search({group_id_2=>3, group_id_3=>1})->first;
+$employee->group_id_2(1);
+$employee->group_id_3(3);
$employee->update();
-ok( check_rs($employees->search_rs({group_id=>3, group_id_2=>1}))
- && check_rs($employees->search_rs({group_id=>1, group_id_2=>3})),
+ok( check_rs($employees->search_rs({group_id_2=>3, group_id_3=>1}))
+ && check_rs($employees->search_rs({group_id_2=>1, group_id_3=>3})),
"overloaded multicol update 3"
);
-$employee = $employees->search({group_id=>3, group_id_2=>1})->first;
-$employee->update({group_id=>2, group_id_2=>3});
-ok( check_rs($employees->search_rs({group_id=>3, group_id_2=>1}))
- && check_rs($employees->search_rs({group_id=>2, group_id_2=>3})),
+$employee = $employees->search({group_id_2=>3, group_id_3=>1})->first;
+$employee->update({group_id_2=>2, group_id_3=>3});
+ok( check_rs($employees->search_rs({group_id_2=>3, group_id_3=>1}))
+ && check_rs($employees->search_rs({group_id_2=>2, group_id_3=>3})),
"overloaded multicol update 4"
);
-$employee = $employees->search({group_id=>3, group_id_2=>2})->first;
-$employee->update({group_id=>2, group_id_2=>4, position=>2});
-ok( check_rs($employees->search_rs({group_id=>3, group_id_2=>2}))
- && check_rs($employees->search_rs({group_id=>2, group_id_2=>4})),
+$employee = $employees->search({group_id_2=>3, group_id_3=>2})->first;
+$employee->update({group_id_2=>2, group_id_3=>4, position=>2});
+ok( check_rs($employees->search_rs({group_id_2=>3, group_id_3=>2}))
+ && check_rs($employees->search_rs({group_id_2=>2, group_id_3=>4})),
"overloaded multicol update 5"
);
@@ -218,22 +228,34 @@
ok( check_rs($rs), "move_to( $position => $to_position )" );
}
- ($row) = $rs->search({ position=>$position })->all();
+ $row = $rs->find({ position => $position });
if ($position==1) {
ok( !$row->previous_sibling(), 'no previous sibling' );
ok( !$row->first_sibling(), 'no first sibling' );
+ ok( $row->next_sibling->position > $position, 'next sibling position > than us');
+ is( $row->next_sibling->previous_sibling->position, $position, 'next-prev sibling is us');
+ ok( $row->last_sibling->position > $position, 'last sibling position > than us');
}
else {
ok( $row->previous_sibling(), 'previous sibling' );
ok( $row->first_sibling(), 'first sibling' );
+ ok( $row->previous_sibling->position < $position, 'prev sibling position < than us');
+ is( $row->previous_sibling->next_sibling->position, $position, 'prev-next sibling is us');
+ ok( $row->first_sibling->position < $position, 'first sibling position < than us');
}
if ($position==$count) {
ok( !$row->next_sibling(), 'no next sibling' );
ok( !$row->last_sibling(), 'no last sibling' );
+ ok( $row->previous_sibling->position < $position, 'prev sibling position < than us');
+ is( $row->previous_sibling->next_sibling->position, $position, 'prev-next sibling is us');
+ ok( $row->first_sibling->position < $position, 'first sibling position < than us');
}
else {
ok( $row->next_sibling(), 'next sibling' );
ok( $row->last_sibling(), 'last sibling' );
+ ok( $row->next_sibling->position > $row->position, 'next sibling position > than us');
+ is( $row->next_sibling->previous_sibling->position, $position, 'next-prev sibling is us');
+ ok( $row->last_sibling->position > $row->position, 'last sibling position > than us');
}
}
Modified: DBIx-Class/0.08/branches/sybase/t/88result_set_column.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/88result_set_column.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/88result_set_column.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -2,22 +2,24 @@
use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
my $schema = DBICTest->init_schema();
-plan tests => 10;
+plan tests => 18;
my $cd;
-my $rs = $cd = $schema->resultset("CD")->search({});
+my $rs = $cd = $schema->resultset("CD")->search({}, { order_by => 'cdid' });
my $rs_title = $rs->get_column('title');
my $rs_year = $rs->get_column('year');
+my $max_year = $rs->get_column(\'MAX (year)');
is($rs_title->next, 'Spoonful of bees', "next okay");
-
is_deeply( [ sort $rs_year->func('DISTINCT') ], [ 1997, 1998, 1999, 2001 ], "wantarray context okay");
+ok ($max_year->next == $rs_year->max, q/get_column (\'FUNC') ok/);
my @all = $rs_title->all;
cmp_ok(scalar @all, '==', 5, "five titles returned");
@@ -27,25 +29,50 @@
cmp_ok($rs_year->sum, '==', 9996, "three artists returned");
+$rs_year->reset;
+is($rs_year->next, 1999, "reset okay");
+
+is($rs_year->first, 1999, "first okay");
+
+# test +select/+as for single column
my $psrs = $schema->resultset('CD')->search({},
{
'+select' => \'COUNT(*)',
'+as' => 'count'
}
);
-ok(defined($psrs->get_column('count')), '+select/+as count');
+lives_ok(sub { $psrs->get_column('count')->next }, '+select/+as additional column "count" present (scalar)');
+dies_ok(sub { $psrs->get_column('noSuchColumn')->next }, '+select/+as nonexistent column throws exception');
+# test +select/+as for multiple columns
$psrs = $schema->resultset('CD')->search({},
{
'+select' => [ \'COUNT(*)', 'title' ],
'+as' => [ 'count', 'addedtitle' ]
}
);
-ok(defined($psrs->get_column('count')), '+select/+as arrayref count');
-ok(defined($psrs->get_column('addedtitle')), '+select/+as title');
+lives_ok(sub { $psrs->get_column('count')->next }, '+select/+as multiple additional columns, "count" column present');
+lives_ok(sub { $psrs->get_column('addedtitle')->next }, '+select/+as multiple additional columns, "addedtitle" column present');
+# test +select/+as for overriding a column
+$psrs = $schema->resultset('CD')->search({},
+ {
+ 'select' => \"'The Final Countdown'",
+ 'as' => 'title'
+ }
+);
+is($psrs->get_column('title')->next, 'The Final Countdown', '+select/+as overridden column "title"');
+
{
my $rs = $schema->resultset("CD")->search({}, { prefetch => 'artist' });
my $rsc = $rs->get_column('year');
is( $rsc->{_parent_resultset}->{attrs}->{prefetch}, undef, 'prefetch wiped' );
}
+
+# test sum()
+is ($schema->resultset('BooksInLibrary')->get_column ('price')->sum, 125, 'Sum of a resultset works correctly');
+
+# test sum over search_related
+my $owner = $schema->resultset('Owners')->find ({ name => 'Newton' });
+ok ($owner->books->count > 1, 'Owner Newton has multiple books');
+is ($owner->search_related ('books')->get_column ('price')->sum, 60, 'Correctly calculated price of all owned books');
Modified: DBIx-Class/0.08/branches/sybase/t/89dbicadmin.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/89dbicadmin.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/89dbicadmin.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -6,7 +6,6 @@
use lib qw(t/lib);
use DBICTest;
-my $schema = DBICTest->init_schema();
eval 'require JSON::Any';
plan skip_all => 'Install JSON::Any to run this test' if ($@);
@@ -17,33 +16,75 @@
plan skip_all => 'Install Text::CSV_XS or Text::CSV_PP to run this test' if ($@);
}
-plan tests => 5;
+my @json_backends = qw/XS JSON DWIW Syck/;
+my $tests_per_run = 5;
-# the script supports double quotes round the arguments and single-quote within
-# to make sure it runs on windows as well, but only if JSON::Any picks the right module
+plan tests => $tests_per_run * @json_backends;
+use JSON::Any;
+for my $js (@json_backends) {
+ eval {JSON::Any->import ($js) };
+ SKIP: {
+ skip ("Json backend $js is not available, skip testing", $tests_per_run) if $@;
-my $employees = $schema->resultset('Employee');
-my @cmd = ($^X, qw|script/dbicadmin --quiet --schema=DBICTest::Schema --class=Employee --tlibs|, q|--connect=["dbi:SQLite:dbname=t/var/DBIxClass.db","","",{"AutoCommit":1}]|, qw|--force --tlibs|);
+ $ENV{JSON_ANY_ORDER} = $js;
+ eval { test_dbicadmin () };
+ diag $@ if $@;
+ }
+}
-system(@cmd, qw|--op=insert --set={"name":"Matt"}|);
-ok( ($employees->count()==1), 'insert count' );
+sub test_dbicadmin {
+ my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); # reinit a fresh db for every run
-my $employee = $employees->find(1);
-ok( ($employee->name() eq 'Matt'), 'insert valid' );
+ my $employees = $schema->resultset('Employee');
-system(@cmd, qw|--op=update --set={"name":"Trout"}|);
-$employee = $employees->find(1);
-ok( ($employee->name() eq 'Trout'), 'update' );
+ system( _prepare_system_args( qw|--op=insert --set={"name":"Matt"}| ) );
+ ok( ($employees->count()==1), "$ENV{JSON_ANY_ORDER}: insert count" );
-system(@cmd, qw|--op=insert --set={"name":"Aran"}|);
+ my $employee = $employees->find(1);
+ ok( ($employee->name() eq 'Matt'), "$ENV{JSON_ANY_ORDER}: insert valid" );
-open(my $fh, "-|", @cmd, qw|--op=select --attrs={"order_by":"name"}|) or die $!;
-my $data = do { local $/; <$fh> };
-close($fh);
-ok( ($data=~/Aran.*Trout/s), 'select with attrs' );
+ system( _prepare_system_args( qw|--op=update --set={"name":"Trout"}| ) );
+ $employee = $employees->find(1);
+ ok( ($employee->name() eq 'Trout'), "$ENV{JSON_ANY_ORDER}: update" );
-system(@cmd, qw|--op=delete --where={"name":"Trout"}|);
-ok( ($employees->count()==1), 'delete' );
+ system( _prepare_system_args( qw|--op=insert --set={"name":"Aran"}| ) );
+ SKIP: {
+ skip ("MSWin32 doesn't support -| either", 1) if $^O eq 'MSWin32';
+
+ open(my $fh, "-|", _prepare_system_args( qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!;
+ my $data = do { local $/; <$fh> };
+ close($fh);
+ ok( ($data=~/Aran.*Trout/s), "$ENV{JSON_ANY_ORDER}: select with attrs" );
+ }
+
+ system( _prepare_system_args( qw|--op=delete --where={"name":"Trout"}| ) );
+ ok( ($employees->count()==1), "$ENV{JSON_ANY_ORDER}: delete" );
+}
+
+# Why do we need this crap? Apparently MSWin32 can not pass through quotes properly
+# (sometimes it will and sometimes not, depending on what compiler was used to build
+# perl). So we go the extra mile to escape all the quotes. We can't also use ' instead
+# of ", because JSON::XS (proudly) does not support "malformed JSON" as the author
+# calls it. Bleh.
+#
+sub _prepare_system_args {
+ my $perl = $^X;
+ my @args = (
+ qw|script/dbicadmin --quiet --schema=DBICTest::Schema --class=Employee --tlibs|,
+ q|--connect=["dbi:SQLite:dbname=t/var/DBIxClass.db","","",{"AutoCommit":1}]|,
+ qw|--force --tlibs|,
+ @_,
+ );
+
+ if ( $^O eq 'MSWin32' ) {
+ $perl = qq|"$perl"|; # execution will fail if $^X contains paths
+ for (@args) {
+ $_ =~ s/"/\\"/g;
+ }
+ }
+
+ return ($perl, @args);
+}
Modified: DBIx-Class/0.08/branches/sybase/t/89inflate_datetime.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/89inflate_datetime.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/89inflate_datetime.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -10,7 +10,7 @@
eval { require DateTime::Format::MySQL };
plan skip_all => "Need DateTime::Format::MySQL for inflation tests" if $@;
-plan tests => 21;
+plan tests => 32;
# inflation test
my $event = $schema->resultset("Event")->find(1);
@@ -34,6 +34,13 @@
## timestamp field
isa_ok($event->created_on, 'DateTime', 'DateTime returned');
+## varchar fields
+isa_ok($event->varchar_date, 'DateTime', 'DateTime returned');
+isa_ok($event->varchar_datetime, 'DateTime', 'DateTime returned');
+
+## skip inflation field
+isnt(ref($event->skip_inflation), 'DateTime', 'No DateTime returned for skip inflation column');
+
# klunky, but makes older Test::More installs happy
my $createo = $event->created_on;
is("$createo", '2006-06-22T21:00:05', 'Correct date/time');
@@ -51,6 +58,11 @@
hour => 13, minute => 34, second => 56, time_zone => "America/New_York" ),
});
+is ($event_tz->starts_at->day_name, "Montag", 'Locale de_DE loaded: day_name');
+is ($event_tz->starts_at->month_name, "Dezember", 'Locale de_DE loaded: month_name');
+is ($event_tz->created_on->day_name, "Tuesday", 'Default locale loaded: day_name');
+is ($event_tz->created_on->month_name, "January", 'Default locale loaded: month_name');
+
my $starts_at = $event_tz->starts_at;
is("$starts_at", '2007-12-31T00:00:00', 'Correct date/time using timezone');
@@ -70,6 +82,25 @@
is("$created_on", '2006-01-31T12:34:56', 'Loaded correct timestamp using timezone');
is($created_on->time_zone->name, 'America/Chicago', 'Correct timezone');
+# Test floating timezone warning
+# We expect one warning
+SKIP: {
+ skip "ENV{DBIC_FLOATING_TZ_OK} was set, skipping", 1 if $ENV{DBIC_FLOATING_TZ_OK};
+ local $SIG{__WARN__} = sub {
+ like(
+ shift,
+ qr/You're using a floating timezone, please see the documentation of DBIx::Class::InflateColumn::DateTime for an explanation/,
+ 'Floating timezone warning'
+ );
+ };
+ my $event_tz_floating = $schema->resultset('EventTZ')->create({
+ starts_at => DateTime->new(year=>2007, month=>12, day=>31, ),
+ created_on => DateTime->new(year=>2006, month=>1, day=>31,
+ hour => 13, minute => 34, second => 56, ),
+ });
+ delete $SIG{__WARN__};
+};
+
# This should fail to set
my $prev_str = "$created_on";
$loaded_event->update({ created_on => '0000-00-00' });
@@ -92,3 +123,14 @@
like( $@, qr/invalid date format/i, "Invalid date format exception");
}
+## varchar field using inflate_date => 1
+my $varchar_date = $event->varchar_date;
+is("$varchar_date", '2006-07-23T00:00:00', 'Correct date/time');
+
+## varchar field using inflate_datetime => 1
+my $varchar_datetime = $event->varchar_datetime;
+is("$varchar_datetime", '2006-05-22T19:05:07', 'Correct date/time');
+
+## skip inflation field
+my $skip_inflation = $event->skip_inflation;
+is ("$skip_inflation", '2006-04-21 18:04:06', 'Correct date/time');
Modified: DBIx-Class/0.08/branches/sybase/t/90ensure_class_loaded.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/90ensure_class_loaded.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/90ensure_class_loaded.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -13,7 +13,7 @@
my $schema = DBICTest->init_schema();
-plan tests => 20;
+plan tests => 28;
# Test ensure_class_found
ok( $schema->ensure_class_found('DBIx::Class::Schema'),
@@ -40,6 +40,50 @@
like( $@, qr/did not return a true value/,
'DBICTest::ErrorComponent threw ok' );
+# Simulate a PAR environment
+{
+ my @code;
+ local @INC = @INC;
+ unshift @INC, sub {
+ if ($_[1] eq 'VIRTUAL/PAR/PACKAGE.pm') {
+ return (sub { return 0 unless @code; $_ = shift @code; 1; } );
+ }
+ else {
+ return ();
+ }
+ };
+
+ $retval = eval { $schema->load_optional_class('FAKE::PAR::PACKAGE') };
+ ok( !$@, 'load_optional_class on a nonexistent PAR class did not throw' );
+ ok( !$retval, 'nonexistent PAR package not loaded' );
+
+
+ # simulate a class which does load but does not return true
+ @code = (
+ q/package VIRTUAL::PAR::PACKAGE;/,
+ q/0;/,
+ );
+
+ $retval = eval { $schema->load_optional_class('VIRTUAL::PAR::PACKAGE') };
+ ok( $@, 'load_optional_class of a no-true-returning PAR module did throw' );
+ ok( !$retval, 'no-true-returning PAR package not loaded' );
+
+ # simulate a normal class (no one adjusted %INC so it will be tried again
+ @code = (
+ q/package VIRTUAL::PAR::PACKAGE;/,
+ q/1;/,
+ );
+
+ $retval = eval { $schema->load_optional_class('VIRTUAL::PAR::PACKAGE') };
+ ok( !$@, 'load_optional_class of a PAR module did not throw' );
+ ok( $retval, 'PAR package "loaded"' );
+
+ # see if we can still load stuff with the coderef present
+ $retval = eval { $schema->load_optional_class('DBIx::Class::ResultClass::HashRefInflator') };
+ ok( !$@, 'load_optional_class did not throw' ) || diag $@;
+ ok( $retval, 'DBIx::Class::ResultClass::HashRefInflator loaded' );
+}
+
# Test ensure_class_loaded
ok( Class::Inspector->loaded('TestPackage::A'), 'anonymous package exists' );
eval { $schema->ensure_class_loaded('TestPackage::A'); };
Modified: DBIx-Class/0.08/branches/sybase/t/91debug.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/91debug.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/91debug.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -4,10 +4,12 @@
use Test::More;
use lib qw(t/lib);
use DBICTest;
+use DBIC::DebugObj;
+use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
-plan tests => 6;
+plan tests => 7;
ok ( $schema->storage->debug(1), 'debug' );
ok ( defined(
@@ -49,15 +51,24 @@
# test trace output correctness for bind params
{
- my $sql = '';
+ my ($sql, @bind) = ('');
$schema->storage->debugcb( sub { $sql = $_[1] } );
my @cds = $schema->resultset('CD')->search( { artist => 1, cdid => { -between => [ 1, 3 ] }, } );
- like(
- $sql,
- qr/\QSELECT me.cdid, me.artist, me.title, me.year FROM cd me WHERE ( artist = ? AND cdid BETWEEN ? AND ? ): '1', '1', '3'\E/,
- 'got correct SQL with all bind parameters'
+ is_same_sql_bind(
+ $sql, [],
+ "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( artist = ? AND cdid BETWEEN ? AND ? ): '1', '1', '3'", [],
+ 'got correct SQL with all bind parameters (debugcb)'
);
+
+ $schema->storage->debugcb(undef);
+ $schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind));
+ @cds = $schema->resultset('CD')->search( { artist => 1, cdid => { -between => [ 1, 3 ] }, } );
+ is_same_sql_bind(
+ $sql, \@bind,
+ "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( artist = ? AND cdid BETWEEN ? AND ? )", ["'1'", "'1'", "'3'"],
+ 'got correct SQL with all bind parameters (debugobj)'
+ );
}
1;
Modified: DBIx-Class/0.08/branches/sybase/t/92storage.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/92storage.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/92storage.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -4,6 +4,7 @@
use Test::More;
use lib qw(t/lib);
use DBICTest;
+use Data::Dumper;
{
package DBICTest::ExplodingStorage::Sth;
@@ -32,9 +33,9 @@
}
}
-plan tests => 6;
+plan tests => 17;
-my $schema = DBICTest->init_schema();
+my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
is( ref($schema->storage), 'DBIx::Class::Storage::DBI::SQLite',
'Storage reblessed correctly into DBIx::Class::Storage::DBI::SQLite' );
@@ -64,10 +65,106 @@
is(1, $schema->resultset('Artist')->search({name => "Exploding Sheep" })->count,
"And the STH was retired");
-my $info = { on_connect_do => [] };
-$storage->connect_info(['foo','bar','baz',$info]);
+# testing various invocations of connect_info ([ ... ])
-ok(exists($info->{on_connect_do}), q{Didn't kill key passed to storage});
+my $coderef = sub { 42 };
+my $invocations = {
+ 'connect_info ([ $d, $u, $p, \%attr, \%extra_attr])' => {
+ args => [
+ 'foo',
+ 'bar',
+ undef,
+ {
+ on_connect_do => [qw/a b c/],
+ PrintError => 0,
+ },
+ {
+ AutoCommit => 1,
+ on_disconnect_do => [qw/d e f/],
+ },
+ {
+ unsafe => 1,
+ auto_savepoint => 1,
+ },
+ ],
+ dbi_connect_info => [
+ 'foo',
+ 'bar',
+ undef,
+ {
+ PrintError => 0,
+ AutoCommit => 1,
+ },
+ ],
+ },
+ 'connect_info ([ \%code, \%extra_attr ])' => {
+ args => [
+ $coderef,
+ {
+ on_connect_do => [qw/a b c/],
+ PrintError => 0,
+ AutoCommit => 1,
+ on_disconnect_do => [qw/d e f/],
+ },
+ {
+ unsafe => 1,
+ auto_savepoint => 1,
+ },
+ ],
+ dbi_connect_info => [
+ $coderef,
+ ],
+ },
+
+ 'connect_info ([ \%attr ])' => {
+ args => [
+ {
+ on_connect_do => [qw/a b c/],
+ PrintError => 0,
+ AutoCommit => 1,
+ on_disconnect_do => [qw/d e f/],
+ user => 'bar',
+ dsn => 'foo',
+ },
+ {
+ unsafe => 1,
+ auto_savepoint => 1,
+ },
+ ],
+ dbi_connect_info => [
+ 'foo',
+ 'bar',
+ undef,
+ {
+ PrintError => 0,
+ AutoCommit => 1,
+ },
+ ],
+ },
+};
+
+for my $type (keys %$invocations) {
+
+ # we can not use a cloner portably because of the coderef
+ # so compare dumps instead
+ local $Data::Dumper::Sortkeys = 1;
+ my $arg_dump = Dumper ($invocations->{$type}{args});
+
+ $storage->connect_info ($invocations->{$type}{args});
+
+ is ($arg_dump, Dumper ($invocations->{$type}{args}), "$type didn't modify passed arguments");
+
+
+ is_deeply ($storage->_dbi_connect_info, $invocations->{$type}{dbi_connect_info}, "$type produced correct _dbi_connect_info");
+ ok ( (not $storage->auto_savepoint and not $storage->unsafe), "$type correctly ignored extra hashref");
+
+ is_deeply (
+ [$storage->on_connect_do, $storage->on_disconnect_do ],
+ [ [qw/a b c/], [qw/d e f/] ],
+ "$type correctly parsed DBIC specific on_[dis]connect_do",
+ );
+}
+
1;
Modified: DBIx-Class/0.08/branches/sybase/t/92storage_on_connect_do.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/92storage_on_connect_do.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/92storage_on_connect_do.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,7 +1,7 @@
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More tests => 10;
use lib qw(t/lib);
use base 'DBICTest';
@@ -33,11 +33,11 @@
$schema->storage->disconnect();
-my($connected, $disconnected);
+my($connected, $disconnected, @cb_args);
ok $schema->connection(
DBICTest->_database,
{
- on_connect_do => sub { $connected = 1 },
+ on_connect_do => sub { $connected = 1; @cb_args = @_; },
on_disconnect_do => sub { $disconnected = 1 },
},
), 'second connection()';
@@ -47,6 +47,7 @@
$schema->storage->disconnect();
ok $disconnected, 'on_disconnect_do() called after disconnect()';
+isa_ok($cb_args[0], 'DBIx::Class::Storage', 'first arg to on_connect_do hook');
sub check_exists {
my $storage = shift;
Modified: DBIx-Class/0.08/branches/sybase/t/93nobindvars.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/93nobindvars.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/93nobindvars.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -40,7 +40,7 @@
$dbh->do("DROP TABLE IF EXISTS artist;");
-$dbh->do("CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(255), charfield CHAR(10));");
+$dbh->do("CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10));");
$schema->class('Artist')->load_components('PK::Auto');
Modified: DBIx-Class/0.08/branches/sybase/t/93single_accessor_object.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/93single_accessor_object.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/93single_accessor_object.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -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 => 7;
+plan tests => 10;
# Test various uses of passing an object to find, create, and update on a single
# rel accessor
@@ -40,3 +41,24 @@
$track->update({ disc => $another_cd });
is($track->get_column('cd'), $another_cd->cdid, 'track matches another CD after update');
}
+
+$schema = DBICTest->init_schema();
+
+{
+ my $artist = $schema->resultset('Artist')->create({ artistid => 666, name => 'bad religion' });
+ my $cd = $schema->resultset('CD')->create({ cdid => 187, artist => 1, title => 'how could hell be any worse?', year => 1982, genreid => undef });
+
+ ok(!defined($cd->genreid), 'genreid is NULL');
+ ok(!defined($cd->genre), 'genre accessor returns undef');
+}
+
+$schema = DBICTest->init_schema();
+
+{
+ my $artist = $schema->resultset('Artist')->create({ artistid => 666, name => 'bad religion' });
+ my $genre = $schema->resultset('Genre')->create({ genreid => 88, name => 'disco' });
+ my $cd = $schema->resultset('CD')->create({ cdid => 187, artist => 1, title => 'how could hell be any worse?', year => 1982 });
+
+ dies_ok { $cd->genre } 'genre accessor throws without column';
+}
+
Modified: DBIx-Class/0.08/branches/sybase/t/93storage_replication.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/93storage_replication.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/93storage_replication.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -59,9 +59,13 @@
## Get the Schema and set the replication storage type
sub init_schema {
+ # current SQLT SQLite producer does not handle DROP TABLE IF EXISTS, trap warnings here
+ local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /no such table.+DROP TABLE/ };
+
my $class = shift @_;
-
+
my $schema = DBICTest->init_schema(
+ sqlite_use_file => 1,
storage_type=>{
'::DBI::Replicated' => {
balancer_type=>'::Random',
@@ -245,6 +249,7 @@
$replicated->replicate;
$replicated->schema->storage->replicants->{$replicant_names[0]}->active(1);
$replicated->schema->storage->replicants->{$replicant_names[1]}->active(1);
+$replicated->schema->storage->pool->validate_replicants;
## Make sure we can read the data.
@@ -307,7 +312,7 @@
=> 'Found expected name for first result';
is $replicated->schema->storage->pool->connected_replicants => 1
- => "One replicant reconnected to handle the job";
+ => "At Least One replicant reconnected to handle the job";
## What happens when we try to select something that doesn't exist?
@@ -351,6 +356,7 @@
$replicated->schema->storage->replicants->{$replicant_names[0]}->active(1);
$replicated->schema->storage->replicants->{$replicant_names[1]}->active(1);
+$replicated->schema->storage->pool->validate_replicants;
ok $replicated->schema->resultset('Artist')->find(2)
=> 'Returned to replicates';
@@ -572,8 +578,11 @@
## Delete the old database files
$replicated->cleanup;
+use Data::Dump qw/dump/;
+#warn dump $replicated->schema->storage->read_handler;
+
Modified: DBIx-Class/0.08/branches/sybase/t/94versioning.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/94versioning.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/94versioning.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -4,6 +4,7 @@
use Test::More;
use File::Spec;
use File::Copy;
+use Time::HiRes qw/time sleep/;
#warn "$dsn $user $pass";
my ($dsn, $user, $pass);
@@ -15,15 +16,22 @@
unless ($dsn);
- eval "use DBD::mysql; use SQL::Translator 0.09;";
+ eval "use DBD::mysql; use SQL::Translator 0.09003;";
plan $@
- ? ( skip_all => 'needs DBD::mysql and SQL::Translator 0.09 for testing' )
- : ( tests => 17 );
+ ? ( skip_all => 'needs DBD::mysql and SQL::Translator 0.09003 for testing' )
+ : ( tests => 22 );
}
my $version_table_name = 'dbix_class_schema_versions';
my $old_table_name = 'SchemaVersions';
+my $ddl_dir = File::Spec->catdir ('t', 'var');
+my $fn = {
+ v1 => File::Spec->catfile($ddl_dir, 'DBICVersion-Schema-1.0-MySQL.sql'),
+ v2 => File::Spec->catfile($ddl_dir, 'DBICVersion-Schema-2.0-MySQL.sql'),
+ trans => File::Spec->catfile($ddl_dir, 'DBICVersion-Schema-1.0-2.0-MySQL.sql'),
+};
+
use lib qw(t/lib);
use_ok('DBICVersionOrig');
@@ -31,27 +39,40 @@
eval { $schema_orig->storage->dbh->do('drop table ' . $version_table_name) };
eval { $schema_orig->storage->dbh->do('drop table ' . $old_table_name) };
-is($schema_orig->ddl_filename('MySQL', '1.0', 't/var'), 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('MySQL', '1.0', $ddl_dir), $fn->{v1}, 'Filename creation working');
+unlink( $fn->{v1} ) if ( -e $fn->{v1} );
+$schema_orig->create_ddl_dir('MySQL', undef, $ddl_dir);
-ok(-f 't/var/DBICVersion-Schema-1.0-MySQL.sql', 'Created DDL file');
+ok(-f $fn->{v1}, 'Created DDL file');
$schema_orig->deploy({ add_drop_table => 1 });
my $tvrs = $schema_orig->{vschema}->resultset('Table');
is($schema_orig->_source_exists($tvrs), 1, 'Created schema from DDL file');
+# loading a new module defining a new version of the same table
+DBICVersion::Schema->_unregister_source ('Table');
eval "use DBICVersionNew";
+
+my $schema_upgrade = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 });
{
- unlink('t/var/DBICVersion-Schema-2.0-MySQL.sql');
- unlink('t/var/DBICVersion-Schema-1.0-2.0-MySQL.sql');
+ unlink($fn->{v2});
+ unlink($fn->{trans});
- my $schema_upgrade = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 });
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();
+ $schema_upgrade->create_ddl_dir('MySQL', '2.0', $ddl_dir, '1.0');
+ ok(-f $fn->{trans}, 'Created DDL file');
+
+ {
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+
+ sleep 1; # remove this when TODO below is completed
+
+ $schema_upgrade->upgrade();
+ like ($w, qr/Attempting upgrade\.$/, 'Warn before upgrade');
+ }
+
is($schema_upgrade->get_db_version(), '2.0', 'db version number upgraded');
eval {
@@ -59,8 +80,21 @@
};
is($@, '', 'new column created');
- # should overwrite files
- $schema_upgrade->create_ddl_dir('MySQL', '2.0', 't/var', '1.0');
+ # should overwrite files and warn about it
+ my @w;
+ local $SIG{__WARN__} = sub {
+ if ($_[0] =~ /^Overwriting/) {
+ push @w, $_[0];
+ }
+ else {
+ warn @_;
+ }
+ };
+ $schema_upgrade->create_ddl_dir('MySQL', '2.0', $ddl_dir, '1.0');
+
+ is (2, @w, 'A warning generated for both the DDL and the diff');
+ like ($w[0], qr/^Overwriting existing DDL file - $fn->{v2}/, 'New version DDL overwrite warning');
+ like ($w[1], qr/^Overwriting existing diff file - $fn->{trans}/, 'Upgrade diff overwrite warning');
}
{
@@ -106,7 +140,7 @@
is($warn, '', 'warning not detected with attr set');
# should not warn
- $ENV{DBIC_NO_VERSION_CHECK} = 1;
+ local $ENV{DBIC_NO_VERSION_CHECK} = 1;
$warn = '';
$schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
is($warn, '', 'warning not detected with env var set');
@@ -117,3 +151,32 @@
like($warn, qr/Your DB is currently unversioned/, 'warning detected without env var or attr');
# should warn
}
+
+# attempt a deploy/upgrade cycle within one second
+TODO: {
+
+ local $TODO = 'To fix this properly the table must be extended with an autoinc column, mst will not accept anything less';
+
+ eval { $schema_orig->storage->dbh->do('drop table ' . $version_table_name) };
+ eval { $schema_orig->storage->dbh->do('drop table ' . $old_table_name) };
+ eval { $schema_orig->storage->dbh->do('drop table TestVersion') };
+
+ # this attempts to sleep until the turn of the second
+ my $t = time();
+ sleep (int ($t) + 1 - $t);
+ diag ('Fast deploy/upgrade start: ', time() );
+
+ {
+ local $DBICVersion::Schema::VERSION = '1.0';
+ $schema_orig->deploy;
+ }
+
+ local $SIG{__WARN__} = sub { warn if $_[0] !~ /Attempting upgrade\.$/ };
+ $schema_upgrade->upgrade();
+
+ is($schema_upgrade->get_db_version(), '2.0', 'Fast deploy/upgrade');
+};
+
+unless ($ENV{DBICTEST_KEEP_VERSIONING_DDL}) {
+ unlink $_ for (values %$fn);
+}
Added: DBIx-Class/0.08/branches/sybase/t/95sql_maker.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/95sql_maker.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/95sql_maker.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,57 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+
+BEGIN {
+ eval "use DBD::SQLite";
+ plan $@
+ ? ( skip_all => 'needs DBD::SQLite for testing' )
+ : ( tests => 3 );
+}
+
+use_ok('DBICTest');
+
+my $schema = DBICTest->init_schema();
+
+my $sql_maker = $schema->storage->sql_maker;
+
+
+SKIP: {
+ skip "SQL::Abstract < 1.49 does not pass through arrayrefs", 2
+ if $SQL::Abstract::VERSION < 1.49;
+
+ my ($sql, @bind) = $sql_maker->insert(
+ 'lottery',
+ {
+ 'day' => '2008-11-16',
+ 'numbers' => [13, 21, 34, 55, 89]
+ }
+ );
+
+ is_same_sql_bind(
+ $sql, \@bind,
+ q/INSERT INTO lottery (day, numbers) VALUES (?, ?)/,
+ [ ['day' => '2008-11-16'], ['numbers' => [13, 21, 34, 55, 89]] ],
+ 'sql_maker passes arrayrefs in insert'
+ );
+
+
+ ($sql, @bind) = $sql_maker->update(
+ 'lottery',
+ {
+ 'day' => '2008-11-16',
+ 'numbers' => [13, 21, 34, 55, 89]
+ }
+ );
+
+ is_same_sql_bind(
+ $sql, \@bind,
+ q/UPDATE lottery SET day = ?, numbers = ?/,
+ [ ['day' => '2008-11-16'], ['numbers' => [13, 21, 34, 55, 89]] ],
+ 'sql_maker passes arrayrefs in update'
+ );
+}
Modified: DBIx-Class/0.08/branches/sybase/t/95sql_maker_quote.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/95sql_maker_quote.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/95sql_maker_quote.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -3,16 +3,16 @@
use Test::More;
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
BEGIN {
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 8 );
+ : ( tests => 12 );
}
-use lib qw(t/lib);
-
use_ok('DBICTest');
my $schema = DBICTest->init_schema();
@@ -22,7 +22,7 @@
$sql_maker->quote_char('`');
$sql_maker->name_sep('.');
-my ($sql,) = $sql_maker->select(
+my ($sql, @bind) = $sql_maker->select(
[
{
'me' => 'cd'
@@ -51,11 +51,14 @@
undef
);
-is($sql,
- q/SELECT COUNT( * ) FROM `cd` `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )/,
- 'got correct SQL for count query with quoting');
+is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT COUNT( * ) FROM `cd` `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )/, [ ['artist.name' => 'Caterwauler McCrae'], ['me.year' => 2001] ],
+ 'got correct SQL and bind parameters for count query with quoting'
+);
-($sql,) = $sql_maker->select(
+
+($sql, @bind) = $sql_maker->select(
[
{
'me' => 'cd'
@@ -68,43 +71,130 @@
'me.year'
],
undef,
+ 'year DESC',
+ undef,
+ undef
+);
+
+is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year DESC`/, [],
+ 'scalar ORDER BY okay (single value)'
+);
+
+
+($sql, @bind) = $sql_maker->select(
[
- 'year DESC'
+ {
+ 'me' => 'cd'
+ }
],
+ [
+ 'me.cdid',
+ 'me.artist',
+ 'me.title',
+ 'me.year'
+ ],
undef,
+ [
+ 'year DESC',
+ 'title ASC'
+ ],
+ undef,
undef
);
-TODO: {
- local $TODO = "order_by with quoting needs fixing (ash/castaway)";
+is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year DESC`, `title ASC`/, [],
+ 'scalar ORDER BY okay (multiple values)'
+);
- is($sql,
- q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year` DESC/,
- 'quoted ORDER BY with DESC okay');
+SKIP: {
+ skip "SQL::Abstract < 1.49 does not support hashrefs in order_by", 2
+ if $SQL::Abstract::VERSION < 1.49;
+
+ ($sql, @bind) = $sql_maker->select(
+ [
+ {
+ 'me' => 'cd'
+ }
+ ],
+ [
+ 'me.cdid',
+ 'me.artist',
+ 'me.title',
+ 'me.year'
+ ],
+ undef,
+ { -desc => 'year' },
+ undef,
+ undef
+ );
+
+ is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year` DESC/, [],
+ 'hashref ORDER BY okay (single value)'
+ );
+
+
+ ($sql, @bind) = $sql_maker->select(
+ [
+ {
+ 'me' => 'cd'
+ }
+ ],
+ [
+ 'me.cdid',
+ 'me.artist',
+ 'me.title',
+ 'me.year'
+ ],
+ undef,
+ [
+ { -desc => 'year' },
+ { -asc => 'title' }
+ ],
+ undef,
+ undef
+ );
+
+ is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year` DESC, `title` ASC/, [],
+ 'hashref ORDER BY okay (multiple values)'
+ );
+
}
-TODO: {
- local $TODO = "select attr with star needs fixing (mst/nate)";
- ($sql,) = $sql_maker->select(
+($sql, @bind) = $sql_maker->select(
[
{
'me' => 'cd'
}
],
[
- 'me.*'
+ 'me.cdid',
+ 'me.artist',
+ 'me.title',
+ 'me.year'
],
undef,
- [],
+ \'year DESC',
undef,
- undef
- );
+ undef
+);
- is($sql, q/SELECT `me`.* FROM `cd` `me`/, 'select attr with me.* is right');
-}
+is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY year DESC/, [],
+ 'did not quote ORDER BY with scalarref (single value)'
+);
-($sql,) = $sql_maker->select(
+
+($sql, @bind) = $sql_maker->select(
[
{
'me' => 'cd'
@@ -118,24 +208,21 @@
],
undef,
[
- \'year DESC'
+ \'year DESC',
+ \'title ASC'
],
undef,
undef
);
-is($sql,
- q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY year DESC/,
- 'did not quote ORDER BY with scalarref');
-
-my %data = (
- name => 'Bill',
- order => 12
+is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY year DESC, title ASC/, [],
+ 'did not quote ORDER BY with scalarref (multiple values)'
);
-my @binds;
-($sql, at binds) = $sql_maker->update(
+($sql, @bind) = $sql_maker->update(
'group',
{
'order' => '12',
@@ -143,13 +230,42 @@
}
);
-is($sql,
- q/UPDATE `group` SET `name` = ?, `order` = ?/,
- 'quoted table names for UPDATE');
+is_same_sql_bind(
+ $sql, \@bind,
+ q/UPDATE `group` SET `name` = ?, `order` = ?/, [ ['name' => 'Bill'], ['order' => '12'] ],
+ 'quoted table names for UPDATE'
+);
+SKIP: {
+ skip "select attr with star does not work in SQL::Abstract < 1.49", 1
+ if $SQL::Abstract::VERSION < 1.49;
+
+ ($sql, @bind) = $sql_maker->select(
+ [
+ {
+ 'me' => 'cd'
+ }
+ ],
+ [
+ 'me.*'
+ ],
+ undef,
+ [],
+ undef,
+ undef
+ );
+
+ is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.* FROM `cd` `me`/, [],
+ 'select attr with me.* is right'
+ );
+}
+
+
$sql_maker->quote_char([qw/[ ]/]);
-($sql,) = $sql_maker->select(
+($sql, @bind) = $sql_maker->select(
[
{
'me' => 'cd'
@@ -178,12 +294,14 @@
undef
);
-is($sql,
- q/SELECT COUNT( * ) FROM [cd] [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )/,
- 'got correct SQL for count query with bracket quoting');
+is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT COUNT( * ) FROM [cd] [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )/, [ ['artist.name' => 'Caterwauler McCrae'], ['me.year' => 2001] ],
+ 'got correct SQL and bind parameters for count query with bracket quoting'
+);
-($sql, at binds) = $sql_maker->update(
+($sql, @bind) = $sql_maker->update(
'group',
{
'order' => '12',
@@ -191,6 +309,8 @@
}
);
-is($sql,
- q/UPDATE [group] SET [name] = ?, [order] = ?/,
- 'bracket quoted table names for UPDATE');
+is_same_sql_bind(
+ $sql, \@bind,
+ q/UPDATE [group] SET [name] = ?, [order] = ?/, [ ['name' => 'Bill'], ['order' => '12'] ],
+ 'bracket quoted table names for UPDATE'
+);
Modified: DBIx-Class/0.08/branches/sybase/t/96_is_deteministic_value.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/96_is_deteministic_value.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/96_is_deteministic_value.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -6,7 +6,7 @@
use Test::More;
use lib qw(t/lib);
use DBICTest;
-use DateTime;
+plan skip_all => "DateTime required" unless eval { require DateTime };
eval "use DateTime::Format::Strptime";
plan skip_all => 'DateTime::Format::Strptime required' if $@;
plan 'no_plan';
Modified: DBIx-Class/0.08/branches/sybase/t/96file_column.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/96file_column.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/96file_column.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -10,7 +10,7 @@
my $schema = DBICTest->init_schema();
-plan tests => 9;
+plan tests => 10;
my $rs = $schema->resultset('FileColumn');
my $fname = '96file_column.t';
@@ -65,3 +65,21 @@
$fc->delete;
ok ( ! -e $storage, 'storage deleted' );
+
+$fh = $source_file->openr or die "failed to open $source_file: $!\n";
+$fc = $rs->create({ file => { handle => $fh, filename => $fname } });
+
+# read it back
+$fc->discard_changes;
+
+$storage = file(
+ $fc->column_info('file')->{file_column_path},
+ $fc->id,
+ $fc->file->{filename},
+);
+
+TODO: {
+ local $TODO = 'need resultset delete override to delete_all';
+ $rs->delete;
+ ok ( ! -e $storage, 'storage does not exist after $rs->delete' );
+};
Added: DBIx-Class/0.08/branches/sybase/t/96multi_create/cd_single.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/96multi_create/cd_single.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/96multi_create/cd_single.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,34 @@
+use strict;
+use warnings;
+
+use Test::More qw(no_plan);
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+eval {
+ my $cd = $schema->resultset('CD')->first;
+ my $track = $schema->resultset('Track')->new_result({
+ cd => $cd,
+ title => 'Multicreate rocks',
+ cd_single => {
+ artist => $cd->artist,
+ year => 2008,
+ title => 'Disemboweling MultiCreate',
+ },
+ });
+
+ isa_ok ($track, 'DBICTest::Track', 'Main Track object created');
+
+ $track->insert;
+
+ ok(1, 'created track');
+
+ is($track->title, 'Multicreate rocks', 'Correct Track title');
+
+ my $single = $track->cd_single;
+
+ ok($single->cdid, 'Got cdid');
+};
Added: DBIx-Class/0.08/branches/sybase/t/96multi_create/multilev_might_have_PKeqFK.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/96multi_create/multilev_might_have_PKeqFK.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/96multi_create/multilev_might_have_PKeqFK.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,65 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+sub mc_diag { diag (@_) if $ENV{DBIC_MULTICREATE_DEBUG} };
+
+plan tests => 8;
+
+my $schema = DBICTest->init_schema();
+
+mc_diag (<<'DG');
+* Test a multilevel might-have with a PK == FK in the might_have/has_many table
+
+CD -> might have -> Artwork
+ \
+ \-> has_many \
+ --> Artwork_to_Artist
+ /-> has_many /
+ /
+ Artist
+DG
+
+lives_ok (sub {
+ my $someartist = $schema->resultset('Artist')->first;
+ my $cd = $schema->resultset('CD')->create ({
+ artist => $someartist,
+ title => 'Music to code by until the cows come home',
+ year => 2008,
+ artwork => {
+ artwork_to_artist => [
+ { artist => { name => 'cowboy joe' } },
+ { artist => { name => 'billy the kid' } },
+ ],
+ },
+ });
+
+ isa_ok ($cd, 'DBICTest::CD', 'Main CD object created');
+ is ($cd->title, 'Music to code by until the cows come home', 'Correct CD title');
+
+ my $art_obj = $cd->artwork;
+ ok ($art_obj->has_column_loaded ('cd_id'), 'PK/FK present on artwork object');
+ is ($art_obj->artists->count, 2, 'Correct artwork creator count via the new object');
+ is_deeply (
+ [ sort $art_obj->artists->get_column ('name')->all ],
+ [ 'billy the kid', 'cowboy joe' ],
+ 'Artists named correctly when queried via object',
+ );
+
+ my $artwork = $schema->resultset('Artwork')->search (
+ { 'cd.title' => 'Music to code by until the cows come home' },
+ { join => 'cd' },
+ )->single;
+ is ($artwork->artists->count, 2, 'Correct artwork creator count via a new search');
+ is_deeply (
+ [ sort $artwork->artists->get_column ('name')->all ],
+ [ 'billy the kid', 'cowboy joe' ],
+ 'Artists named correctly queried via a new search',
+ );
+}, 'multilevel might-have with a PK == FK in the might_have/has_many table ok');
+
+1;
Modified: DBIx-Class/0.08/branches/sybase/t/96multi_create.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/96multi_create.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/96multi_create.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,76 +1,354 @@
use strict;
use warnings;
-use Test::More qw(no_plan);
+use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
+plan tests => 93;
+
my $schema = DBICTest->init_schema();
-my $cd2 = $schema->resultset('CD')->create({ artist =>
- { name => 'Fred Bloggs' },
- title => 'Some CD',
- year => 1996
- });
+lives_ok ( sub {
+ my $cd = $schema->resultset('CD')->create({
+ artist => {
+ name => 'Fred Bloggs'
+ },
+ title => 'Some CD',
+ year => 1996
+ });
-is(ref $cd2->artist, 'DBICTest::Artist', 'Created CD and Artist object');
-is($cd2->artist->name, 'Fred Bloggs', 'Artist created correctly');
+ isa_ok($cd, 'DBICTest::CD', 'Created CD object');
+ isa_ok($cd->artist, 'DBICTest::Artist', 'Created related Artist');
+ is($cd->artist->name, 'Fred Bloggs', 'Artist created correctly');
+}, 'simple create + parent (the stuff $rs belongs_to) ok');
-my $artist = $schema->resultset('Artist')->create({ name => 'Fred 2',
- cds => [
- { title => 'Music to code by',
- year => 2007,
- },
- ],
- });
-is(ref $artist->cds->first, 'DBICTest::CD', 'Created Artist with CDs');
-is($artist->cds->first->title, 'Music to code by', 'CD created correctly');
+lives_ok ( sub {
+ my $bm_rs = $schema->resultset('Bookmark');
+ my $bookmark = $bm_rs->create({
+ link => {
+ id => 66,
+ },
+ });
-# Add a new CD
-$artist->update({cds => [ $artist->cds,
- { title => 'Yet another CD',
- year => 2006,
- },
- ],
- });
-is(($artist->cds->search({}, { order_by => 'year' }))[0]->title, 'Yet another CD', 'Updated and added another CD');
+ isa_ok($bookmark, 'DBICTest::Bookmark', 'Created Bookrmark object');
+ isa_ok($bookmark->link, 'DBICTest::Link', 'Created related Link');
+ is (
+ $bm_rs->search (
+ { 'link.title' => $bookmark->link->title },
+ { join => 'link' },
+ )->count,
+ 1,
+ 'Bookmark and link made it to the DB',
+ );
+}, 'simple create where the child and parent have no values, except for an explicit parent pk ok');
-my $newartist = $schema->resultset('Artist')->find_or_create({ name => 'Fred 2'});
+lives_ok ( sub {
+ my $artist = $schema->resultset('Artist')->first;
+ my $cd = $artist->create_related (cds => {
+ title => 'Music to code by',
+ year => 2007,
+ tags => [
+ { 'tag' => 'rock' },
+ ],
+ });
-is($newartist->name, 'Fred 2', 'Retrieved the artist');
+ isa_ok($cd, 'DBICTest::CD', 'Created CD');
+ is($cd->title, 'Music to code by', 'CD created correctly');
+ is($cd->tags->count, 1, 'One tag created for CD');
+ is($cd->tags->first->tag, 'rock', 'Tag created correctly');
+}, 'create over > 1 levels of has_many create (A => { has_many => { B => has_many => C } } )');
-my $newartist2 = $schema->resultset('Artist')->find_or_create({ name => 'Fred 3',
- cds => [
- { title => 'Noah Act',
- year => 2007,
- },
- ],
+throws_ok (
+ sub {
+ # Create via update - add a new CD <--- THIS SHOULD HAVE NEVER WORKED!
+ $schema->resultset('Artist')->first->update({
+ cds => [
+ { title => 'Yet another CD',
+ year => 2006,
+ },
+ ],
+ });
+ },
+ qr/Recursive update is not supported over relationships of type multi/,
+ 'create via update of multi relationships throws an exception'
+);
- });
+lives_ok ( sub {
+ my $artist = $schema->resultset('Artist')->first;
+ my $c2p = $schema->resultset('CD_to_Producer')->create ({
+ cd => {
+ artist => $artist,
+ title => 'Bad investment',
+ year => 2008,
+ tracks => [
+ { title => 'Just buy' },
+ { title => 'Why did we do it' },
+ { title => 'Burn baby burn' },
+ ],
+ },
+ producer => {
+ name => 'Lehman Bros.',
+ },
+ });
-is($newartist2->name, 'Fred 3', 'Created new artist with cds via find_or_create');
+ isa_ok ($c2p, 'DBICTest::CD_to_Producer', 'Linker object created');
+ my $prod = $schema->resultset ('Producer')->find ({ name => 'Lehman Bros.' });
+ isa_ok ($prod, 'DBICTest::Producer', 'Producer row found');
+ is ($prod->cds->count, 1, 'Producer has one production');
+ my $cd = $prod->cds->first;
+ is ($cd->title, 'Bad investment', 'CD created correctly');
+ is ($cd->tracks->count, 3, 'CD has 3 tracks');
+}, 'Create m2m while originating in the linker table');
-my $artist2 = $schema->resultset('Artist')->create({ artistid => 1000,
- name => 'Fred 3',
- cds => [
- { artist => 1000,
- title => 'Music to code by',
- year => 2007,
- },
- ],
- cds_unordered => [
- { artist => 1000,
- title => 'Music to code by',
- year => 2007,
- },
- ]
- });
-is($artist2->in_storage, 1, 'artist with duplicate rels inserted okay');
+#CD -> has_many -> Tracks -> might have -> Single -> has_many -> Tracks
+# \
+# \-> has_many \
+# --> CD2Producer
+# /-> has_many /
+# /
+# Producer
+lives_ok ( sub {
+ my $artist = $schema->resultset('Artist')->first;
+ my $cd = $schema->resultset('CD')->create ({
+ artist => $artist,
+ title => 'Music to code by at night',
+ year => 2008,
+ tracks => [
+ {
+ title => 'Off by one again',
+ },
+ {
+ title => 'The dereferencer',
+ cd_single => {
+ artist => $artist,
+ year => 2008,
+ title => 'Was that a null (Single)',
+ tracks => [
+ { title => 'The dereferencer' },
+ { title => 'The dereferencer II' },
+ ],
+ cd_to_producer => [
+ {
+ producer => {
+ name => 'K&R',
+ }
+ },
+ {
+ producer => {
+ name => 'Don Knuth',
+ }
+ },
+ ]
+ },
+ },
+ ],
+ });
-CREATE_RELATED1 :{
+ isa_ok ($cd, 'DBICTest::CD', 'Main CD object created');
+ is ($cd->title, 'Music to code by at night', 'Correct CD title');
+ is ($cd->tracks->count, 2, 'Two tracks on main CD');
+ my ($t1, $t2) = $cd->tracks->all;
+ is ($t1->title, 'Off by one again', 'Correct 1st track name');
+ is ($t1->cd_single, undef, 'No single for 1st track');
+ is ($t2->title, 'The dereferencer', 'Correct 2nd track name');
+ isa_ok ($t2->cd_single, 'DBICTest::CD', 'Created a single for 2nd track');
+
+ my $single = $t2->cd_single;
+ is ($single->tracks->count, 2, 'Two tracks on single CD');
+ is ($single->tracks->find ({ position => 1})->title, 'The dereferencer', 'Correct 1st track title');
+ is ($single->tracks->find ({ position => 2})->title, 'The dereferencer II', 'Correct 2nd track title');
+
+ is ($single->cd_to_producer->count, 2, 'Two producers created for the single cd');
+ is_deeply (
+ [ sort map { $_->producer->name } ($single->cd_to_producer->all) ],
+ ['Don Knuth', 'K&R'],
+ 'Producers named correctly',
+ );
+}, 'Create over > 1 levels of might_have with multiple has_many and multiple m2m but starting at a has_many level');
+
+#Track -> might have -> Single -> has_many -> Tracks
+# \
+# \-> has_many \
+# --> CD2Producer
+# /-> has_many /
+# /
+# Producer
+lives_ok ( sub {
+ my $cd = $schema->resultset('CD')->first;
+ my $track = $schema->resultset('Track')->create ({
+ cd => $cd,
+ title => 'Multicreate rocks',
+ cd_single => {
+ artist => $cd->artist,
+ year => 2008,
+ title => 'Disemboweling MultiCreate',
+ tracks => [
+ { title => 'Why does mst write this way' },
+ { title => 'Chainsaw celebration' },
+ { title => 'Purl cleans up' },
+ ],
+ cd_to_producer => [
+ {
+ producer => {
+ name => 'mst',
+ }
+ },
+ {
+ producer => {
+ name => 'castaway',
+ }
+ },
+ {
+ producer => {
+ name => 'theorbtwo',
+ }
+ },
+ ]
+ },
+ });
+
+ isa_ok ($track, 'DBICTest::Track', 'Main Track object created');
+ is ($track->title, 'Multicreate rocks', 'Correct Track title');
+
+ my $single = $track->cd_single;
+ isa_ok ($single, 'DBICTest::CD', 'Created a single with the track');
+ is ($single->tracks->count, 3, '3 tracks on single CD');
+ is ($single->tracks->find ({ position => 1})->title, 'Why does mst write this way', 'Correct 1st track title');
+ is ($single->tracks->find ({ position => 2})->title, 'Chainsaw celebration', 'Correct 2nd track title');
+ is ($single->tracks->find ({ position => 3})->title, 'Purl cleans up', 'Correct 3rd track title');
+
+ is ($single->cd_to_producer->count, 3, '3 producers created for the single cd');
+ is_deeply (
+ [ sort map { $_->producer->name } ($single->cd_to_producer->all) ],
+ ['castaway', 'mst', 'theorbtwo'],
+ 'Producers named correctly',
+ );
+}, 'Create over > 1 levels of might_have with multiple has_many and multiple m2m but starting at the might_have directly');
+
+lives_ok ( sub {
+ my $artist = $schema->resultset('Artist')->first;
+ my $cd = $schema->resultset('CD')->create ({
+ artist => $artist,
+ title => 'Music to code by at twilight',
+ year => 2008,
+ artwork => {
+ images => [
+ { name => 'recursive descent' },
+ { name => 'tail packing' },
+ ],
+ },
+ });
+
+ isa_ok ($cd, 'DBICTest::CD', 'Main CD object created');
+ is ($cd->title, 'Music to code by at twilight', 'Correct CD title');
+ isa_ok ($cd->artwork, 'DBICTest::Artwork', 'Artwork created');
+
+ # this test might look weird, but it failed at one point, keep it there
+ my $art_obj = $cd->artwork;
+ ok ($art_obj->has_column_loaded ('cd_id'), 'PK/FK present on artwork object');
+ is ($art_obj->images->count, 2, 'Correct artwork image count via the new object');
+ is_deeply (
+ [ sort $art_obj->images->get_column ('name')->all ],
+ [ 'recursive descent', 'tail packing' ],
+ 'Images named correctly in objects',
+ );
+
+ my $artwork = $schema->resultset('Artwork')->search (
+ { 'cd.title' => 'Music to code by at twilight' },
+ { join => 'cd' },
+ )->single;
+
+ is ($artwork->images->count, 2, 'Correct artwork image count via a new search');
+
+ is_deeply (
+ [ sort $artwork->images->get_column ('name')->all ],
+ [ 'recursive descent', 'tail packing' ],
+ 'Images named correctly after search',
+ );
+}, 'Test might_have again but with a PK == FK in the middle (obviously not specified)');
+
+lives_ok ( sub {
+ my $cd = $schema->resultset('CD')->first;
+ my $track = $schema->resultset ('Track')->create ({
+ cd => $cd,
+ title => 'Black',
+ lyrics => {
+ lyric_versions => [
+ { text => 'The color black' },
+ { text => 'The colour black' },
+ ],
+ },
+ });
+
+ isa_ok ($track, 'DBICTest::Track', 'Main track object created');
+ is ($track->title, 'Black', 'Correct track title');
+ isa_ok ($track->lyrics, 'DBICTest::Lyrics', 'Lyrics created');
+
+ # this test might look weird, but it was failing at one point, keep it there
+ my $lyric_obj = $track->lyrics;
+ ok ($lyric_obj->has_column_loaded ('lyric_id'), 'PK present on lyric object');
+ ok ($lyric_obj->has_column_loaded ('track_id'), 'FK present on lyric object');
+ is ($lyric_obj->lyric_versions->count, 2, 'Correct lyric versions count via the new object');
+ is_deeply (
+ [ sort $lyric_obj->lyric_versions->get_column ('text')->all ],
+ [ 'The color black', 'The colour black' ],
+ 'Lyrics text in objects matches',
+ );
+
+
+ my $lyric = $schema->resultset('Lyrics')->search (
+ { 'track.title' => 'Black' },
+ { join => 'track' },
+ )->single;
+
+ is ($lyric->lyric_versions->count, 2, 'Correct lyric versions count via a new search');
+
+ is_deeply (
+ [ sort $lyric->lyric_versions->get_column ('text')->all ],
+ [ 'The color black', 'The colour black' ],
+ 'Lyrics text via search matches',
+ );
+}, 'Test might_have again but with just a PK and FK (neither specified) in the mid-table');
+
+lives_ok ( sub {
+ my $newartist2 = $schema->resultset('Artist')->find_or_create({
+ name => 'Fred 3',
+ cds => [
+ {
+ title => 'Noah Act',
+ year => 2007,
+ },
+ ],
+ });
+ is($newartist2->name, 'Fred 3', 'Created new artist with cds via find_or_create');
+}, 'Nested find_or_create');
+
+lives_ok ( sub {
+ my $artist2 = $schema->resultset('Artist')->create({
+ name => 'Fred 4',
+ cds => [
+ {
+ title => 'Music to code by',
+ year => 2007,
+ },
+ ],
+ cds_unordered => [
+ {
+ title => 'Music to code by',
+ year => 2007,
+ },
+ ]
+ });
+
+ is($artist2->in_storage, 1, 'artist with duplicate rels inserted okay');
+}, 'Multiple same level has_many create');
+
+lives_ok ( sub {
my $artist = $schema->resultset('Artist')->first;
my $cd_result = $artist->create_related('cds', {
@@ -78,13 +356,8 @@
title => 'TestOneCD1',
year => 2007,
tracks => [
-
- { position=>111,
- title => 'TrackOne',
- },
- { position=>112,
- title => 'TrackTwo',
- }
+ { title => 'TrackOne' },
+ { title => 'TrackTwo' },
],
});
@@ -100,10 +373,9 @@
{
ok( $track && ref $track eq 'DBICTest::Track', 'Got Expected Track Class');
}
-}
+}, 'First create_related pass');
-CREATE_RELATED2 :{
-
+lives_ok ( sub {
my $artist = $schema->resultset('Artist')->first;
my $cd_result = $artist->create_related('cds', {
@@ -111,13 +383,8 @@
title => 'TestOneCD2',
year => 2007,
tracks => [
-
- { position=>111,
- title => 'TrackOne',
- },
- { position=>112,
- title => 'TrackTwo',
- }
+ { title => 'TrackOne' },
+ { title => 'TrackTwo' },
],
liner_notes => { notes => 'I can haz liner notes?' },
@@ -136,16 +403,17 @@
{
ok( $track && ref $track eq 'DBICTest::Track', 'Got Expected Track Class');
}
-}
+}, 'second create_related with same arguments');
-my $cdp = $schema->resultset('CD_to_Producer')->create({
- cd => { artist => 1, title => 'foo', year => 2000 },
- producer => { name => 'jorge' }
- });
+lives_ok ( sub {
+ my $cdp = $schema->resultset('CD_to_Producer')->create({
+ cd => { artist => 1, title => 'foo', year => 2000 },
+ producer => { name => 'jorge' }
+ });
+ ok($cdp, 'join table record created ok');
+}, 'create of parents of a record linker table');
-ok($cdp, 'join table record created ok');
-
-SPECIAL_CASE: {
+lives_ok ( sub {
my $kurt_cobain = { name => 'Kurt Cobain' };
my $in_utero = $schema->resultset('CD')->new({
@@ -162,58 +430,58 @@
is($a->name, 'Kurt Cobain', 'Artist insertion ok');
is($a->cds && $a->cds->first && $a->cds->first->title,
'In Utero', 'CD insertion ok');
-}
+}, 'populate');
-SPECIAL_CASE2: {
- my $pink_floyd = { name => 'Pink Floyd' };
-
- my $the_wall = { title => 'The Wall', year => 1979 };
-
- $pink_floyd->{cds} = [ $the_wall ];
-
-
- $schema->resultset('Artist')->populate([ $pink_floyd ]); # %)
- $a = $schema->resultset('Artist')->find({name => 'Pink Floyd'});
-
- is($a->name, 'Pink Floyd', 'Artist insertion ok');
- is($a->cds && $a->cds->first->title, 'The Wall', 'CD insertion ok');
-}
-
## Create foreign key col obj including PK
## See test 20 in 66relationships.t
-my $new_cd_hashref = {
- cdid => 27,
- title => 'Boogie Woogie',
- year => '2007',
- artist => { artistid => 17, name => 'king luke' }
- };
+lives_ok ( sub {
+ my $new_cd_hashref = {
+ cdid => 27,
+ title => 'Boogie Woogie',
+ year => '2007',
+ artist => { artistid => 17, name => 'king luke' }
+ };
-my $cd = $schema->resultset("CD")->find(1);
+ my $cd = $schema->resultset("CD")->find(1);
-is($cd->artist->id, 1, 'rel okay');
+ is($cd->artist->id, 1, 'rel okay');
-my $new_cd = $schema->resultset("CD")->create($new_cd_hashref);
-is($new_cd->artist->id, 17, 'new id retained okay');
+ my $new_cd = $schema->resultset("CD")->create($new_cd_hashref);
+ is($new_cd->artist->id, 17, 'new id retained okay');
+}, 'Create foreign key col obj including PK');
-
-# Test find or create related functionality
-my $new_artist = $schema->resultset("Artist")->create({ artistid => 18, name => 'larry' });
-
-eval {
+lives_ok ( sub {
$schema->resultset("CD")->create({
cdid => 28,
- title => 'Boogie Wiggle',
+ title => 'Boogie Wiggle',
year => '2007',
artist => { artistid => 18, name => 'larry' }
});
-};
-is($@, '', 'new cd created without clash on related artist');
+}, 'new cd created without clash on related artist');
-# Make sure exceptions from errors in created rels propogate
-eval {
- my $t = $schema->resultset("Track")->new({});
- $t->cd($t->new_related('cd', { artist => undef } ) );
- $t->{_rel_in_storage} = 0;
+throws_ok ( sub {
+ my $t = $schema->resultset("Track")->new({ cd => { artist => undef } });
+ #$t->cd($t->new_related('cd', { artist => undef } ) );
+ #$t->{_rel_in_storage} = 0;
$t->insert;
-};
-like($@, qr/cd.artist may not be NULL/, "Exception propogated properly");
+}, qr/cd.artist may not be NULL/, "Exception propogated properly");
+
+lives_ok ( sub {
+ $schema->resultset('CD')->create ({
+ artist => {
+ name => 'larry', # should already exist
+ },
+ title => 'Warble Marble',
+ year => '2009',
+ cd_to_producer => [
+ { producer => { name => 'Cowboy Neal' } },
+ ],
+ });
+
+ my $m2m_cd = $schema->resultset('CD')->search ({ title => 'Warble Marble'});
+ is ($m2m_cd->count, 1, 'One CD row created via M2M create');
+ is ($m2m_cd->first->producers->count, 1, 'CD row created with one producer');
+ is ($m2m_cd->first->producers->first->name, 'Cowboy Neal', 'Correct producer row created');
+}, 'Test multi create over many_to_many');
+
+1;
Added: DBIx-Class/0.08/branches/sybase/t/96multi_create_new.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/96multi_create_new.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/96multi_create_new.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,74 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+plan tests => 12;
+
+my $schema = DBICTest->init_schema();
+
+# Test various new() invocations - this is all about backcompat, making
+# sure that insert() still works as expected by legacy code.
+#
+# What we essentially do is multi-instantiate objects, making sure nothing
+# gets inserted. Then we add some more objects to the mix either via
+# new_related() or by setting an accessor directly (or both) - again
+# expecting no inserts. Then after calling insert() on the starter object
+# we expect everything supplied to new() to get inserted, as well as any
+# relations whose PK's are necessary to complete the objects supplied
+# to new(). All other objects should be insert()able afterwards too.
+
+
+{
+ my $new_artist = $schema->resultset("Artist")->new_result({ 'name' => 'Depeche Mode' });
+ my $new_related_cd = $new_artist->new_related('cds', { 'title' => 'Leave in Silence', 'year' => 1982});
+ eval {
+ $new_artist->insert;
+ $new_related_cd->insert;
+ };
+ is ($@, '', 'Staged insertion successful');
+ ok($new_artist->in_storage, 'artist inserted');
+ ok($new_related_cd->in_storage, 'new_related_cd inserted');
+}
+
+{
+ my $new_artist = $schema->resultset("Artist")->new_result({ 'name' => 'Depeche Mode' });
+ my $new_related_cd = $new_artist->new_related('cds', { 'title' => 'Leave Slightly Noisily', 'year' => 1982});
+ eval {
+ $new_related_cd->insert;
+ };
+ is ($@, '', 'CD insertion survives by finding artist');
+ ok($new_artist->in_storage, 'artist inserted');
+ ok($new_related_cd->in_storage, 'new_related_cd inserted');
+}
+
+{
+ my $new_artist = $schema->resultset("Artist")->new_result({ 'name' => 'Depeche Mode 2: Insertion Boogaloo' });
+ my $new_related_cd = $new_artist->new_related('cds', { 'title' => 'Leave Loudly While Singing Off Key', 'year' => 1982});
+ eval {
+ $new_related_cd->insert;
+ };
+ is ($@, '', 'CD insertion survives by inserting artist');
+ ok($new_artist->in_storage, 'artist inserted');
+ ok($new_related_cd->in_storage, 'new_related_cd inserted');
+}
+
+{
+ my $new_cd = $schema->resultset("CD")->new_result({});
+ my $new_related_artist = $new_cd->new_related('artist', { 'name' => 'Marillion',});
+ lives_ok (
+ sub {
+ $new_related_artist->insert;
+ $new_cd->title( 'Misplaced Childhood' );
+ $new_cd->year ( 1985 );
+ $new_cd->artist( $new_related_artist ); # For exact backward compatibility
+ $new_cd->insert;
+ },
+ 'Reversed staged insertion successful'
+ );
+ ok($new_related_artist->in_storage, 'related artist inserted');
+ ok($new_cd->in_storage, 'cd inserted');
+}
Added: DBIx-Class/0.08/branches/sybase/t/96multi_create_torture.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/96multi_create_torture.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/96multi_create_torture.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,224 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+plan tests => 23;
+
+# an insane multicreate
+# (should work, despite the fact that no one will probably use it this way)
+
+my $schema = DBICTest->init_schema();
+
+# first count how many rows do we initially have
+my $counts;
+$counts->{$_} = $schema->resultset($_)->count for qw/Artist CD Genre Producer Tag/;
+
+# do the crazy create
+eval {
+ $schema->resultset('CD')->create ({
+ artist => {
+ name => 'james',
+ },
+ title => 'Greatest hits 1',
+ year => '2012',
+ genre => {
+ name => '"Greatest" collections',
+ },
+ tags => [
+ { tag => 'A' },
+ { tag => 'B' },
+ ],
+ cd_to_producer => [
+ {
+ producer => {
+ name => 'bob',
+ producer_to_cd => [
+ {
+ cd => {
+ artist => {
+ name => 'lars',
+ cds => [
+ {
+ title => 'Greatest hits 2',
+ year => 2012,
+ genre => {
+ name => '"Greatest" collections',
+ },
+ tags => [
+ { tag => 'A' },
+ { tag => 'B' },
+ ],
+ # This cd is created via artist so it doesn't know about producers
+ cd_to_producer => [
+ { producer => { name => 'bob' } },
+ { producer => { name => 'paul' } },
+ { producer => {
+ name => 'flemming',
+ producer_to_cd => [
+ { cd => {
+ artist => {
+ name => 'kirk',
+ cds => [
+ {
+ title => 'Greatest hits 3',
+ year => 2012,
+ genre => {
+ name => '"Greatest" collections',
+ },
+ tags => [
+ { tag => 'A' },
+ { tag => 'B' },
+ ],
+ },
+ {
+ title => 'Greatest hits 4',
+ year => 2012,
+ genre => {
+ name => '"Greatest" collections2',
+ },
+ tags => [
+ { tag => 'A' },
+ { tag => 'B' },
+ ],
+ },
+ ],
+ },
+ title => 'Greatest hits 5',
+ year => 2013,
+ genre => {
+ name => '"Greatest" collections2',
+ },
+ }},
+ ],
+ }},
+ ],
+ },
+ ],
+ },
+ title => 'Greatest hits 6',
+ year => 2012,
+ genre => {
+ name => '"Greatest" collections',
+ },
+ tags => [
+ { tag => 'A' },
+ { tag => 'B' },
+ ],
+ },
+ },
+ {
+ cd => {
+ artist => {
+ name => 'lars', # should already exist
+ # even though the artist 'name' is not uniquely constrained
+ # find_or_create will arguably DWIM
+ },
+ title => 'Greatest hits 7',
+ year => 2013,
+ },
+ },
+ ],
+ },
+ },
+ ],
+ });
+
+ is ($schema->resultset ('Artist')->count, $counts->{Artist} + 3, '3 new artists created');
+ is ($schema->resultset ('Genre')->count, $counts->{Genre} + 2, '2 additional genres created');
+ is ($schema->resultset ('Producer')->count, $counts->{Producer} + 3, '3 new producer');
+ is ($schema->resultset ('CD')->count, $counts->{CD} + 7, '7 new CDs');
+ is ($schema->resultset ('Tag')->count, $counts->{Tag} + 10, '10 new Tags');
+
+ my $cd_rs = $schema->resultset ('CD')
+ ->search ({ title => { -like => 'Greatest hits %' }}, { order_by => 'title'} );
+ is ($cd_rs->count, 7, '7 greatest hits created');
+
+ my $cds_2012 = $cd_rs->search ({ year => 2012});
+ is ($cds_2012->count, 5, '5 CDs created in 2012');
+
+ is (
+ $cds_2012->search(
+ { 'tags.tag' => { -in => [qw/A B/] } },
+ { join => 'tags', group_by => 'me.cdid' }
+ ),
+ 5,
+ 'All 10 tags were pairwise distributed between 5 year-2012 CDs'
+ );
+
+ my $paul_prod = $cd_rs->search (
+ { 'producer.name' => 'paul'},
+ { join => { cd_to_producer => 'producer' } }
+ );
+ is ($paul_prod->count, 1, 'Paul had 1 production');
+ my $pauls_cd = $paul_prod->single;
+ is ($pauls_cd->cd_to_producer->count, 3, 'Paul had two co-producers');
+ is (
+ $pauls_cd->search_related ('cd_to_producer',
+ { 'producer.name' => 'flemming'},
+ { join => 'producer' }
+ )->count,
+ 1,
+ 'The second producer is flemming',
+ );
+
+ my $kirk_cds = $cd_rs->search ({ 'artist.name' => 'kirk' }, { join => 'artist' });
+ is ($kirk_cds, 3, 'Kirk had 3 CDs');
+ is (
+ $kirk_cds->search (
+ { 'cd_to_producer.cd' => { '!=', undef } },
+ { join => 'cd_to_producer' },
+ ),
+ 1,
+ 'Kirk had a producer only on one cd',
+ );
+
+ my $lars_cds = $cd_rs->search ({ 'artist.name' => 'lars' }, { join => 'artist' });
+ is ($lars_cds->count, 3, 'Lars had 3 CDs');
+ is (
+ $lars_cds->search (
+ { 'cd_to_producer.cd' => undef },
+ { join => 'cd_to_producer' },
+ ),
+ 0,
+ 'Lars always had a producer',
+ );
+ is (
+ $lars_cds->search_related ('cd_to_producer',
+ { 'producer.name' => 'flemming'},
+ { join => 'producer' }
+ )->count,
+ 1,
+ 'Lars produced 1 CD with flemming',
+ );
+ is (
+ $lars_cds->search_related ('cd_to_producer',
+ { 'producer.name' => 'bob'},
+ { join => 'producer' }
+ )->count,
+ 3,
+ 'Lars produced 3 CDs with bob',
+ );
+
+ my $bob_prod = $cd_rs->search (
+ { 'producer.name' => 'bob'},
+ { join => { cd_to_producer => 'producer' } }
+ );
+ is ($bob_prod->count, 4, 'Bob produced a total of 4 CDs');
+ ok ($bob_prod->find ({ title => 'Greatest hits 1'}), '1st Bob production name correct');
+ ok ($bob_prod->find ({ title => 'Greatest hits 6'}), '2nd Bob production name correct');
+ ok ($bob_prod->find ({ title => 'Greatest hits 2'}), '3rd Bob production name correct');
+ ok ($bob_prod->find ({ title => 'Greatest hits 7'}), '4th Bob production name correct');
+
+ is (
+ $bob_prod->search ({ 'artist.name' => 'james' }, { join => 'artist' })->count,
+ 1,
+ "Bob produced james' only CD",
+ );
+};
+diag $@ if $@;
+
+1;
Modified: DBIx-Class/0.08/branches/sybase/t/97result_class.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/97result_class.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/97result_class.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -2,20 +2,39 @@
use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
my $schema = DBICTest->init_schema();
-plan tests => 9;
+plan tests => 12;
{
my $cd_rc = $schema->resultset("CD")->result_class;
+ throws_ok {
+ $schema->resultset("Artist")
+ ->search_rs({}, {result_class => "IWillExplode"})
+ } qr/Can't locate IWillExplode/, 'nonexistant result_class exception';
+
+# to make ensure_class_loaded happy, dies on inflate
+ eval 'package IWillExplode; sub dummy {}';
+
my $artist_rs = $schema->resultset("Artist")
->search_rs({}, {result_class => "IWillExplode"});
is($artist_rs->result_class, 'IWillExplode', 'Correct artist result_class');
-
+
+ throws_ok {
+ $artist_rs->result_class('mtfnpy')
+ } qr/Can't locate mtfnpy/,
+ 'nonexistant result_access exception (from accessor)';
+
+ throws_ok {
+ $artist_rs->first
+ } qr/Can't locate object method "inflate_result" via package "IWillExplode"/,
+ 'IWillExplode explodes on inflate';
+
my $cd_rs = $artist_rs->related_resultset('cds');
is($cd_rs->result_class, $cd_rc, 'Correct cd result_class');
Modified: DBIx-Class/0.08/branches/sybase/t/98savepoints.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/98savepoints.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/98savepoints.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -11,11 +11,11 @@
if (exists $ENV{DBICTEST_PG_DSN}) {
($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
- $create_sql = "CREATE TABLE artist (artistid serial PRIMARY KEY, name VARCHAR(100), charfield CHAR(10))";
+ $create_sql = "CREATE TABLE artist (artistid serial PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10))";
} elsif (exists $ENV{DBICTEST_MYSQL_DSN}) {
($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
- $create_sql = "CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(255), charfield CHAR(10)) ENGINE=InnoDB";
+ $create_sql = "CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10)) ENGINE=InnoDB";
} else {
plan skip_all => 'Set DBICTEST_(PG|MYSQL)_DSN _USER and _PASS if you want to run savepoint tests';
}
@@ -30,7 +30,11 @@
$schema->storage->debug(1);
-$schema->storage->dbh->do ($create_sql);
+{
+ local $SIG{__WARN__} = sub {};
+ $schema->storage->dbh->do ('DROP TABLE IF EXISTS artist');
+ $schema->storage->dbh->do ($create_sql);
+}
$schema->resultset('Artist')->create({ name => 'foo' });
Modified: DBIx-Class/0.08/branches/sybase/t/99dbic_sqlt_parser.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/99dbic_sqlt_parser.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/99dbic_sqlt_parser.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -5,19 +5,26 @@
use lib qw(t/lib);
use DBICTest;
+
BEGIN {
- eval "use DBD::mysql; use SQL::Translator 0.09;";
- plan $@
- ? ( skip_all => 'needs SQL::Translator 0.09 for testing' )
- : ( tests => 99 );
+ eval "use DBD::mysql; use SQL::Translator 0.09003;";
+ if ($@) {
+ plan skip_all => 'needs DBD::mysql and SQL::Translator 0.09003 for testing';
+ }
}
my $schema = DBICTest->init_schema();
+# Dummy was yanked out by the sqlt hook test
+# YearXXXXCDs are views
+my @sources = grep { $_ ne 'Dummy' && $_ !~ /^Year\d{4}CDs$/ }
+ $schema->sources;
+plan tests => ( @sources * 3);
+
{
my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { } } });
- foreach my $source ($schema->sources) {
+ foreach my $source (@sources) {
my $table = $sqlt_schema->get_table($schema->source($source)->from);
my $fk_count = scalar(grep { $_->type eq 'FOREIGN KEY' } $table->get_constraints);
@@ -31,7 +38,7 @@
{
my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { add_fk_index => 1 } } });
- foreach my $source ($schema->sources) {
+ foreach my $source (@sources) {
my $table = $sqlt_schema->get_table($schema->source($source)->from);
my $fk_count = scalar(grep { $_->type eq 'FOREIGN KEY' } $table->get_constraints);
@@ -45,7 +52,7 @@
{
my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { add_fk_index => 0 } } });
- foreach my $source ($schema->sources) {
+ foreach my $source (@sources) {
my $table = $sqlt_schema->get_table($schema->source($source)->from);
my @indices = $table->get_indices;
Added: DBIx-Class/0.08/branches/sybase/t/99rh_perl_perf_bug.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/99rh_perl_perf_bug.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/99rh_perl_perf_bug.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,121 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Test::More;
+use lib qw(t/lib);
+
+# This is a rather unusual test.
+# It does not test any aspect of DBIx::Class, but instead tests the
+# perl installation this is being run under to see if it is:-
+# 1. Potentially affected by a RH perl build bug
+# 2. If so we do a performance test for the effect of
+# that bug.
+#
+# You can skip these tests by setting the DBIC_NO_WARN_BAD_PERL env
+# variable
+#
+# If these tests fail then please read the section titled
+# Perl Performance Issues on Red Hat Systems in
+# L<DBIx::Class::Manual::Troubleshooting>
+
+plan skip_all =>
+ 'Skipping RH perl performance bug tests as DBIC_NO_WARN_BAD_PERL set'
+ if ( $ENV{DBIC_NO_WARN_BAD_PERL} );
+
+plan skip_all => 'Skipping as AUTOMATED_TESTING is set'
+ if ( $ENV{AUTOMATED_TESTING} );
+
+eval "use Benchmark ':all'";
+plan skip_all => 'needs Benchmark for testing' if $@;
+
+plan tests => 3;
+
+ok( 1, 'Dummy - prevents next test timing out' );
+
+# we do a benchmark test filling an array with blessed/overloaded references,
+# against an array filled with array refs.
+# On a sane system the ratio between these operation sets is 1 - 1.5,
+# whereas a bugged system gives a ratio of around 8
+# we therefore consider there to be a problem if the ratio is >= 2
+
+my $results = timethese(
+ -1, # run for 1 CPU second each
+ {
+ no_bless => sub {
+ my %h;
+ for ( my $i = 0 ; $i < 10000 ; $i++ ) {
+ $h{$i} = [];
+ }
+ },
+ bless_overload => sub {
+ use overload q(<) => sub { };
+ my %h;
+ for ( my $i = 0 ; $i < 10000 ; $i++ ) {
+ $h{$i} = bless [] => 'main';
+ }
+ },
+ },
+);
+
+my $ratio = $results->{no_bless}->iters / $results->{bless_overload}->iters;
+
+ok( ( $ratio < 2 ), 'Overload/bless performance acceptable' )
+ || diag(
+ "\n",
+ "This perl has a substantial slow down when handling large numbers\n",
+ "of blessed/overloaded objects. This can severely adversely affect\n",
+ "the performance of DBIx::Class programs. Please read the section\n",
+ "in the Troubleshooting POD documentation entitled\n",
+ "'Perl Performance Issues on Red Hat Systems'\n",
+ "As this is an extremely serious condition, the only way to skip\n",
+ "over this test is to --force the installation, or to edit the test\n",
+ "file " . __FILE__ . "\n",
+ );
+
+# We will only check for the difference in bless handling (whether the
+# bless applies to the reference or the referent) if we have seen a
+# performance issue...
+
+SKIP: {
+ skip "Not checking for bless handling as performance is OK", 1
+ if ( $ratio < 2 );
+
+ {
+ package # don't want this in PAUSE
+ TestRHBug;
+ use overload bool => sub { 0 }
+ }
+
+ sub _has_bug_34925 {
+ my %thing;
+ my $r1 = \%thing;
+ my $r2 = \%thing;
+ bless $r1 => 'TestRHBug';
+ return !!$r2;
+ }
+
+ sub _possibly_has_bad_overload_performance {
+ return $] < 5.008009 && !_has_bug_34925();
+ }
+
+ # If this next one fails then you almost certainly have a RH derived
+ # perl with the performance bug
+ # if this test fails, look at the section titled
+ # "Perl Performance Issues on Red Hat Systems" in
+ # L<DBIx::Class::Manual::Troubleshooting>
+ # Basically you may suffer severe performance issues when running
+ # DBIx::Class (and many other) modules. Look at getting a fixed
+ # version of the perl interpreter for your system.
+ #
+ ok( !_possibly_has_bad_overload_performance(),
+ 'Checking whether bless applies to reference not object' )
+ || diag(
+ "\n",
+ "This perl is probably derived from a buggy Red Hat perl build\n",
+ "Please read the section in the Troubleshooting POD documentation\n",
+ "entitled 'Perl Performance Issues on Red Hat Systems'\n",
+ "As this is an extremely serious condition, the only way to skip\n",
+ "over this test is to --force the installation, or to edit the test\n",
+ "file " . __FILE__ . "\n",
+ );
+}
Modified: DBIx-Class/0.08/branches/sybase/t/bindtype_columns.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/bindtype_columns.t 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/bindtype_columns.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -10,51 +10,79 @@
plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
unless ($dsn && $dbuser);
-plan tests => 3;
+plan tests => 6;
my $schema = DBICTest::Schema->connection($dsn, $dbuser, $dbpass, { AutoCommit => 1 });
my $dbh = $schema->storage->dbh;
-$dbh->do(qq[
+{
+ local $SIG{__WARN__} = sub {};
+ $dbh->do('DROP TABLE IF EXISTS bindtype_test');
- CREATE TABLE artist
- (
- artistid serial NOT NULL PRIMARY KEY,
- media bytea NOT NULL,
- name varchar NULL
- );
-],{ RaiseError => 1, PrintError => 1 });
+ # the blob/clob are for reference only, will be useful when we switch to SQLT and can test Oracle along the way
+ $dbh->do(qq[
+ CREATE TABLE bindtype_test
+ (
+ id serial NOT NULL PRIMARY KEY,
+ bytea bytea NULL,
+ blob bytea NULL,
+ clob text NULL
+ );
+ ],{ RaiseError => 1, PrintError => 1 });
+}
+my $big_long_string = "\x00\x01\x02 abcd" x 125000;
-$schema->class('Artist')->load_components(qw/
+my $new;
+# test inserting a row
+{
+ $new = $schema->resultset('BindType')->create({ bytea => $big_long_string });
- PK::Auto
- Core
-/);
+ ok($new->id, "Created a bytea row");
+ is($new->bytea, $big_long_string, "Set the blob correctly.");
+}
-$schema->class('Artist')->add_columns(
-
- "media", {
-
- data_type => "bytea",
- is_nullable => 0,
- },
-);
+# test retrieval of the bytea column
+{
+ my $row = $schema->resultset('BindType')->find({ id => $new->id });
+ is($row->get_column('bytea'), $big_long_string, "Created the blob correctly.");
+}
-# test primary key handling
-my $big_long_string = 'abcd' x 250000;
+TODO: {
+ local $TODO =
+ 'Passing bind attributes to $sth->bind_param() should be implemented (it only works in $storage->insert ATM)';
-my $new = $schema->resultset('Artist')->create({ media => $big_long_string });
+ my $rs = $schema->resultset('BindType')->search({ bytea => $big_long_string });
-ok($new->artistid, "Created a blob row");
-is($new->media, $big_long_string, "Set the blob correctly.");
+ # search on the bytea column (select)
+ {
+ my $row = $rs->first;
+ is($row ? $row->id : undef, $new->id, "Found the row searching on the bytea column.");
+ }
-my $rs = $schema->resultset('Artist')->find({artistid=>$new->artistid});
+ # search on the bytea column (update)
+ {
+ my $new_big_long_string = $big_long_string . "2";
+ $schema->txn_do(sub {
+ $rs->update({ bytea => $new_big_long_string });
+ my $row = $schema->resultset('BindType')->find({ id => $new->id });
+ is($row ? $row->get_column('bytea') : undef, $new_big_long_string,
+ "Updated the row correctly (searching on the bytea column)."
+ );
+ $schema->txn_rollback;
+ });
+ }
-is($rs->get_column('media'), $big_long_string, "Created the blob correctly.");
+ # search on the bytea column (delete)
+ {
+ $schema->txn_do(sub {
+ $rs->delete;
+ my $row = $schema->resultset('BindType')->find({ id => $new->id });
+ is($row, undef, "Deleted the row correctly (searching on the bytea column).");
+ $schema->txn_rollback;
+ });
+ }
+}
-$dbh->do("DROP TABLE artist");
-
-
-
+$dbh->do("DROP TABLE bindtype_test");
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/01-columns.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/01-columns.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/01-columns.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/01-columns.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,153 @@
+use strict;
+
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@") : (tests=> 24);
+}
+
+
+#-----------------------------------------------------------------------
+# Make sure that we can set up columns properly
+#-----------------------------------------------------------------------
+package State;
+
+use base 'DBIx::Class::Test::SQLite';
+
+State->table('State');
+State->columns(Essential => qw/Abbreviation Name/);
+State->columns(Primary => 'Name');
+State->columns(Weather => qw/Rain Snowfall/);
+State->columns(Other => qw/Capital Population/);
+#State->has_many(cities => "City");
+
+sub accessor_name_for {
+ my ($class, $column) = @_;
+ my $return = $column eq "Rain" ? "Rainfall" : $column;
+ return $return;
+}
+
+sub mutator_name_for {
+ my ($class, $column) = @_;
+ my $return = $column eq "Rain" ? "set_Rainfall" : "set_$column";
+ return $return;
+}
+
+sub Snowfall { 1 }
+
+
+package City;
+
+use base 'DBIx::Class::Test::SQLite';
+
+City->table('City');
+City->columns(All => qw/Name State Population/);
+
+{
+ # Disable the `no such table' warning
+ local $SIG{__WARN__} = sub {
+ my $warning = shift;
+ warn $warning unless ($warning =~ /\Qno such table: City(1)\E/);
+ };
+
+ City->has_a(State => 'State');
+}
+
+#-------------------------------------------------------------------------
+package CD;
+use base 'DBIx::Class::Test::SQLite';
+
+CD->table('CD');
+CD->columns('All' => qw/artist title length/);
+
+#-------------------------------------------------------------------------
+
+package main;
+
+is(State->table, 'State', 'State table()');
+is(State->primary_column, 'name', 'State primary()');
+is_deeply [ State->columns('Primary') ] => [qw/name/],
+ 'State Primary:' . join ", ", State->columns('Primary');
+is_deeply [ sort State->columns('Essential') ] => [qw/abbreviation name/],
+ 'State Essential:' . join ", ", State->columns('Essential');
+is_deeply [ sort State->columns('All') ] =>
+ [ sort qw/name abbreviation rain snowfall capital population/ ],
+ 'State All:' . join ", ", State->columns('All');
+
+is(CD->primary_column, 'artist', 'CD primary()');
+is_deeply [ CD->columns('Primary') ] => [qw/artist/],
+ 'CD primary:' . join ", ", CD->columns('Primary');
+is_deeply [ sort CD->columns('All') ] => [qw/artist length title/],
+ 'CD all:' . join ", ", CD->columns('All');
+is_deeply [ sort CD->columns('Essential') ] => [qw/artist/],
+ 'CD essential:' . join ", ", CD->columns('Essential');
+
+ok(State->find_column('Rain'), 'find_column Rain');
+ok(State->find_column('rain'), 'find_column rain');
+ok(!State->find_column('HGLAGAGlAG'), '!find_column HGLAGAGlAG');
+
+{
+
+ can_ok +State => qw/Rainfall _Rainfall_accessor set_Rainfall
+ _set_Rainfall_accessor Snowfall _Snowfall_accessor set_Snowfall
+ _set_Snowfall_accessor/;
+
+ foreach my $method (qw/Rain _Rain_accessor rain snowfall/) {
+ ok !State->can($method), "State can't $method";
+ }
+
+}
+
+{
+ SKIP: {
+ skip "No column objects", 1;
+
+ eval { my @grps = State->__grouper->groups_for("Huh"); };
+ ok $@, "Huh not in groups";
+ }
+
+ my @grps = sort State->__grouper->groups_for(State->_find_columns(qw/rain capital/));
+ is @grps, 2, "Rain and Capital = 2 groups";
+ @grps = sort @grps; # Because the underlying API is hash-based
+ is $grps[0], 'Other', " - Other";
+ is $grps[1], 'Weather', " - Weather";
+}
+
+#{
+#
+# package DieTest;
+# @DieTest::ISA = qw(DBIx::Class);
+# DieTest->load_components(qw/CDBICompat::Retrieve Core/);
+# package main;
+# local $SIG{__WARN__} = sub { };
+# eval { DieTest->retrieve(1) };
+# like $@, qr/unless primary columns are defined/, "Need primary key for retrieve";
+#}
+
+#-----------------------------------------------------------------------
+# Make sure that columns inherit properly
+#-----------------------------------------------------------------------
+package State;
+
+package A;
+ at A::ISA = qw(DBIx::Class);
+__PACKAGE__->load_components(qw/CDBICompat Core/);
+__PACKAGE__->table('dummy');
+__PACKAGE__->columns(Primary => 'id');
+
+package A::B;
+ at A::B::ISA = 'A';
+__PACKAGE__->table('dummy2');
+__PACKAGE__->columns(All => qw(id b1));
+
+package A::C;
+ at A::C::ISA = 'A';
+__PACKAGE__->table('dummy3');
+__PACKAGE__->columns(All => qw(id c1 c2 c3));
+
+package main;
+is join (' ', sort A->columns), 'id', "A columns";
+is join (' ', sort A::B->columns), 'b1 id', "A::B columns";
+is join (' ', sort A::C->columns), 'c1 c2 c3 id', "A::C columns";
+
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/01-columns.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/02-Film.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/02-Film.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/02-Film.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/02-Film.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,417 @@
+use strict;
+use Test::More;
+$| = 1;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 98);
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+ use Film;
+}
+
+ok(Film->can('db_Main'), 'set_db()');
+is(Film->__driver, "SQLite", "Driver set correctly");
+
+{
+ my $nul = eval { Film->retrieve() };
+ is $nul, undef, "Can't retrieve nothing";
+ like $@, qr/./, "retrieve needs parameters"; # TODO fix this...
+}
+
+{
+ eval { my $id = Film->id };
+ like $@, qr/class method/, "Can't get id with no object";
+}
+
+{
+ eval { my $id = Film->title };
+ #like $@, qr/class method/, "Can't get title with no object";
+ ok $@, "Can't get title with no object";
+}
+
+eval { my $duh = Film->insert; };
+like $@, qr/create needs a hashref/, "needs a hashref";
+
+ok +Film->create_test_film;
+
+my $btaste = Film->retrieve('Bad Taste');
+isa_ok $btaste, 'Film';
+is($btaste->Title, 'Bad Taste', 'Title() get');
+is($btaste->Director, 'Peter Jackson', 'Director() get');
+is($btaste->Rating, 'R', 'Rating() get');
+is($btaste->NumExplodingSheep, 1, 'NumExplodingSheep() get');
+
+{
+ my $bt2 = Film->find_or_create(Title => 'Bad Taste');
+ is $bt2->Director, $btaste->Director, "find_or_create";
+ my @bt = Film->search(Title => 'Bad Taste');
+ is @bt, 1, " doesn't create a new one";
+}
+
+ok my $gone = Film->find_or_create(
+ {
+ Title => 'Gone With The Wind',
+ Director => 'Bob Baggadonuts',
+ Rating => 'PG',
+ NumExplodingSheep => 0
+ }
+ ),
+ "Add Gone With The Wind";
+isa_ok $gone, 'Film';
+ok $gone = Film->retrieve(Title => 'Gone With The Wind'),
+ "Fetch it back again";
+isa_ok $gone, 'Film';
+
+# Shocking new footage found reveals bizarre Scarlet/sheep scene!
+is($gone->NumExplodingSheep, 0, 'NumExplodingSheep() get again');
+$gone->NumExplodingSheep(5);
+is($gone->NumExplodingSheep, 5, 'NumExplodingSheep() set');
+is($gone->numexplodingsheep, 5, 'numexplodingsheep() set');
+
+is($gone->Rating, 'PG', 'Rating() get again');
+$gone->Rating('NC-17');
+is($gone->Rating, 'NC-17', 'Rating() set');
+$gone->update;
+
+{
+ my @films = eval { Film->retrieve_all };
+ cmp_ok(@films, '==', 2, "We have 2 films in total");
+}
+
+# EXTRA TEST: added by mst to check a bug found by Numa
+cmp_ok(Film->count_all, '==', 2, "count_all confirms 2 films");
+
+my $gone_copy = Film->retrieve('Gone With The Wind');
+ok($gone->NumExplodingSheep == 5, 'update()');
+ok($gone->Rating eq 'NC-17', 'update() again');
+
+# Grab the 'Bladerunner' entry.
+Film->create(
+ {
+ Title => 'Bladerunner',
+ Director => 'Bob Ridley Scott',
+ Rating => 'R'
+ }
+);
+
+my $blrunner = Film->retrieve('Bladerunner');
+is(ref $blrunner, 'Film', 'retrieve() again');
+is $blrunner->Title, 'Bladerunner', "Correct title";
+is $blrunner->Director, 'Bob Ridley Scott', " and Director";
+is $blrunner->Rating, 'R', " and Rating";
+is $blrunner->NumExplodingSheep, undef, " and sheep";
+
+# Make a copy of 'Bladerunner' and create an entry of the directors cut
+my $blrunner_dc = $blrunner->copy(
+ {
+ title => "Bladerunner: Director's Cut",
+ rating => "15",
+ }
+);
+is(ref $blrunner_dc, 'Film', "copy() produces a film");
+is($blrunner_dc->Title, "Bladerunner: Director's Cut", 'Title correct');
+is($blrunner_dc->Director, 'Bob Ridley Scott', 'Director correct');
+is($blrunner_dc->Rating, '15', 'Rating correct');
+is($blrunner_dc->NumExplodingSheep, undef, 'Sheep correct');
+
+# Set up own SQL:
+{
+ Film->add_constructor(title_asc => "title LIKE ? ORDER BY title");
+ Film->add_constructor(title_desc => "title LIKE ? ORDER BY title DESC");
+ Film->add_constructor(title_asc_nl => q{
+ title LIKE ?
+ ORDER BY title
+ LIMIT 1
+ });
+
+ {
+ my @films = Film->title_asc("Bladerunner%");
+ is @films, 2, "We have 2 Bladerunners";
+ is $films[0]->Title, $blrunner->Title, "Ordered correctly";
+ }
+ {
+ my @films = Film->title_desc("Bladerunner%");
+ is @films, 2, "We have 2 Bladerunners";
+ is $films[0]->Title, $blrunner_dc->Title, "Ordered correctly";
+ }
+ {
+ my @films = Film->title_asc_nl("Bladerunner%");
+ is @films, 1, "We have 2 Bladerunners";
+ is $films[0]->Title, $blrunner->Title, "Ordered correctly";
+ }
+}
+
+# Multi-column search
+{
+ my @films = $blrunner->search_like(title => "Bladerunner%", rating => '15');
+ is @films, 1, "Only one Bladerunner is a 15";
+}
+
+# Inline SQL
+{
+ my @films = Film->retrieve_from_sql("numexplodingsheep > 0 ORDER BY title");
+ is @films, 2, "Inline SQL";
+ is $films[0]->id, $btaste->id, "Correct film";
+ is $films[1]->id, $gone->id, "Correct film";
+}
+
+# Inline SQL removes WHERE
+{
+ my @films =
+ Film->retrieve_from_sql(" WHErE numexplodingsheep > 0 ORDER BY title");
+ is @films, 2, "Inline SQL";
+ is $films[0]->id, $btaste->id, "Correct film";
+ is $films[1]->id, $gone->id, "Correct film";
+}
+
+eval {
+ my $ishtar = Film->insert({ Title => 'Ishtar', Director => 'Elaine May' });
+ my $mandn =
+ Film->insert({ Title => 'Mikey and Nicky', Director => 'Elaine May' });
+ my $new_leaf =
+ Film->insert({ Title => 'A New Leaf', Director => 'Elaine May' });
+
+#use Data::Dumper; die Dumper(Film->search( Director => 'Elaine May' ));
+ cmp_ok(Film->search(Director => 'Elaine May'), '==', 3,
+ "3 Films by Elaine May");
+ ok(Film->retrieve('Ishtar')->delete,
+ "Ishtar doesn't deserve an entry any more");
+ ok(!Film->retrieve('Ishtar'), 'Ishtar no longer there');
+ {
+ my $deprecated = 0;
+ #local $SIG{__WARN__} = sub { $deprecated++ if $_[0] =~ /deprecated/ };
+ ok(
+ Film->delete(Director => 'Elaine May'),
+ "In fact, delete all films by Elaine May"
+ );
+ cmp_ok(Film->search(Director => 'Elaine May'), '==',
+ 0, "0 Films by Elaine May");
+ SKIP: {
+ skip "No deprecated warnings from compat layer", 1;
+ is $deprecated, 1, "Got a deprecated warning";
+ }
+ }
+};
+is $@, '', "No problems with deletes";
+
+# Find all films which have a rating of NC-17.
+my @films = Film->search('Rating', 'NC-17');
+is(scalar @films, 1, ' search returns one film');
+is($films[0]->id, $gone->id, ' ... the correct one');
+
+# Find all films which were directed by Bob
+ at films = Film->search_like('Director', 'Bob %');
+is(scalar @films, 3, ' search_like returns 3 films');
+ok(
+ eq_array(
+ [ sort map { $_->id } @films ],
+ [ sort map { $_->id } $blrunner_dc, $gone, $blrunner ]
+ ),
+ 'the correct ones'
+);
+
+# Find Ridley Scott films which don't have vomit
+ at films =
+ Film->search(numExplodingSheep => undef, Director => 'Bob Ridley Scott');
+is(scalar @films, 2, ' search where attribute is null returns 2 films');
+ok(
+ eq_array(
+ [ sort map { $_->id } @films ],
+ [ sort map { $_->id } $blrunner_dc, $blrunner ]
+ ),
+ 'the correct ones'
+);
+
+# Test that a disconnect doesnt harm anything.
+{
+ # SQLite is loud on disconnect/reconnect.
+ # This is solved in DBIC but not in ContextualFetch
+ local $SIG{__WARN__} = sub {
+ warn @_ unless $_[0] =~
+ /active statement handles|inactive database handle/;
+ };
+
+ Film->db_Main->disconnect;
+ @films = Film->search({ Rating => 'NC-17' });
+ ok(@films == 1 && $films[0]->id eq $gone->id, 'auto reconnection');
+
+ # Test discard_changes().
+ my $orig_director = $btaste->Director;
+ $btaste->Director('Lenny Bruce');
+ is($btaste->Director, 'Lenny Bruce', 'set new Director');
+ $btaste->discard_changes;
+ is($btaste->Director, $orig_director, 'discard_changes()');
+}
+
+SKIP: {
+ skip "ActiveState perl produces additional warnings", 3
+ if ($^O eq 'MSWin32');
+
+ Film->autoupdate(1);
+ my $btaste2 = Film->retrieve($btaste->id);
+ $btaste->NumExplodingSheep(18);
+ my @warnings;
+ local $SIG{__WARN__} = sub { push(@warnings, @_); };
+ {
+
+ # unhook from live object cache, so next one is not from cache
+ $btaste2->remove_from_object_index;
+ my $btaste3 = Film->retrieve($btaste->id);
+ is $btaste3->NumExplodingSheep, 18, "Class based AutoCommit";
+ $btaste3->autoupdate(0); # obj a/c should override class a/c
+ is @warnings, 0, "No warnings so far";
+ $btaste3->NumExplodingSheep(13);
+ }
+ is @warnings, 1, "DESTROY without update warns";
+ Film->autoupdate(0);
+}
+
+{ # update unchanged object
+ my $film = Film->retrieve($btaste->id);
+ my $retval = $film->update;
+ is $retval, -1, "Unchanged object";
+}
+
+{ # update deleted object
+ my $rt = "Royal Tenenbaums";
+ my $ten = Film->insert({ title => $rt, Rating => "R" });
+ $ten->rating(18);
+ Film->set_sql(drt => "DELETE FROM __TABLE__ WHERE title = ?");
+ Film->sql_drt->execute($rt);
+ my @films = Film->search({ title => $rt });
+ is @films, 0, "RT gone";
+ my $retval = eval { $ten->update };
+ like $@, qr/row not found/, "Update deleted object throws error";
+ $ten->discard_changes;
+}
+
+{
+ $btaste->autoupdate(1);
+ $btaste->NumExplodingSheep(32);
+ my $btaste2 = Film->retrieve($btaste->id);
+ is $btaste2->NumExplodingSheep, 32, "Object based AutoCommit";
+ $btaste->autoupdate(0);
+}
+
+# Primary key of 0
+{
+ my $zero = Film->insert({ Title => 0, Rating => "U" });
+ ok defined $zero, "Create 0";
+ ok my $ret = Film->retrieve(0), "Retrieve 0";
+ is $ret->Title, 0, "Title OK";
+ is $ret->Rating, "U", "Rating OK";
+}
+
+# Change after_update policy
+SKIP: {
+ skip "DBIx::Class compat doesn't handle the exists stuff quite right yet", 4;
+ my $bt = Film->retrieve($btaste->id);
+ $bt->autoupdate(1);
+
+ $bt->rating("17");
+ ok !$bt->_attribute_exists('rating'), "changed column needs reloaded";
+ ok $bt->_attribute_exists('title'), "but we still have the title";
+
+ # Don't re-load
+ $bt->add_trigger(
+ after_update => sub {
+ my ($self, %args) = @_;
+ my $discard_columns = $args{discard_columns};
+ @$discard_columns = qw/title/;
+ }
+ );
+ $bt->rating("19");
+ ok $bt->_attribute_exists('rating'), "changed column needs reloaded";
+ ok !$bt->_attribute_exists('title'), "but no longer have the title";
+}
+
+# Make sure that we can have other accessors. (Bugfix in 0.28)
+if (0) {
+ Film->mk_accessors(qw/temp1 temp2/);
+ my $blrunner = Film->retrieve('Bladerunner');
+ $blrunner->temp1("Foo");
+ $blrunner->NumExplodingSheep(2);
+ eval { $blrunner->update };
+ ok(!$@, "Other accessors");
+}
+
+# overloading
+{
+ is "$blrunner", "Bladerunner", "stringify";
+
+ ok(Film->columns(Stringify => 'rating'), "Can change stringify column");
+ is "$blrunner", "R", "And still stringifies correctly";
+
+ ok(
+ Film->columns(Stringify => qw/title rating/),
+ "Can have multiple stringify columns"
+ );
+ is "$blrunner", "Bladerunner/R", "And still stringifies correctly";
+
+ no warnings 'once';
+ local *Film::stringify_self = sub { join ":", $_[0]->title, $_[0]->rating };
+ is "$blrunner", "Bladerunner:R", "Provide stringify_self()";
+}
+
+{
+ {
+ ok my $byebye = DeletingFilm->insert(
+ {
+ Title => 'Goodbye Norma Jean',
+ Rating => 'PG',
+ }
+ ),
+ "Add a deleting Film";
+
+ isa_ok $byebye, 'DeletingFilm';
+ isa_ok $byebye, 'Film';
+ ok(Film->retrieve('Goodbye Norma Jean'), "Fetch it back again");
+ }
+ my $film;
+ eval { $film = Film->retrieve('Goodbye Norma Jean') };
+ ok !$film, "It destroys itself";
+}
+
+SKIP: {
+ skip "Caching has been removed", 5
+ if Film->isa("DBIx::Class::CDBICompat::NoObjectIndex");
+
+ # my bad taste is your bad taste
+ my $btaste = Film->retrieve('Bad Taste');
+ my $btaste2 = Film->retrieve('Bad Taste');
+ is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste2),
+ "Retrieving twice gives ref to same object";
+
+ my ($btaste5) = Film->search(title=>'Bad Taste');
+ is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste5),
+ "Searching also gives ref to same object";
+
+ $btaste2->remove_from_object_index;
+ my $btaste3 = Film->retrieve('Bad Taste');
+ isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste3),
+ "Removing from object_index and retrieving again gives new object";
+
+ $btaste3->clear_object_index;
+ my $btaste4 = Film->retrieve('Bad Taste');
+ isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste4),
+ "Clearing cache and retrieving again gives new object";
+
+ $btaste=Film->insert({
+ Title => 'Bad Taste 2',
+ Director => 'Peter Jackson',
+ Rating => 'R',
+ NumExplodingSheep => 2,
+ });
+ $btaste2 = Film->retrieve('Bad Taste 2');
+ is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste2),
+ "Creating and retrieving gives ref to same object";
+
+}
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/02-Film.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/03-subclassing.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/03-subclassing.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/03-subclassing.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/03-subclassing.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,31 @@
+use strict;
+use Test::More;
+
+#----------------------------------------------------------------------
+# Make sure subclasses can be themselves subclassed
+#----------------------------------------------------------------------
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 6);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+INIT { @Film::Threat::ISA = qw/Film/; }
+
+ok(Film::Threat->db_Main->ping, 'subclass db_Main()');
+is_deeply [ sort Film::Threat->columns ], [ sort Film->columns ],
+ 'has the same columns';
+
+my $bt = Film->create_test_film;
+ok my $btaste = Film::Threat->retrieve('Bad Taste'), "subclass retrieve";
+isa_ok $btaste => "Film::Threat";
+isa_ok $btaste => "Film";
+is $btaste->Title, 'Bad Taste', 'subclass get()';
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/03-subclassing.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/04-lazy.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/04-lazy.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/04-lazy.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/04-lazy.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,184 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+use Test::Warn;
+
+#----------------------------------------------------------------------
+# Test lazy loading
+#----------------------------------------------------------------------
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 36);
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+ use Lazy;
+}
+
+is_deeply [ Lazy->columns('Primary') ], [qw/this/], "Pri";
+is_deeply [ sort Lazy->columns('Essential') ], [qw/opop this/], "Essential";
+is_deeply [ sort Lazy->columns('things') ], [qw/that this/], "things";
+is_deeply [ sort Lazy->columns('horizon') ], [qw/eep orp/], "horizon";
+is_deeply [ sort Lazy->columns('vertical') ], [qw/oop opop/], "vertical";
+is_deeply [ sort Lazy->columns('All') ], [qw/eep oop opop orp that this/], "All";
+
+{
+ my @groups = Lazy->__grouper->groups_for(Lazy->find_column('this'));
+ is_deeply [ sort @groups ], [sort qw/things Essential Primary/], "this (@groups)";
+}
+
+{
+ my @groups = Lazy->__grouper->groups_for(Lazy->find_column('that'));
+ is_deeply \@groups, [qw/things/], "that (@groups)";
+}
+
+Lazy->create({ this => 1, that => 2, oop => 3, opop => 4, eep => 5 });
+
+ok(my $obj = Lazy->retrieve(1), 'Retrieve by Primary');
+ok($obj->_attribute_exists('this'), "Gets primary");
+ok($obj->_attribute_exists('opop'), "Gets other essential");
+ok(!$obj->_attribute_exists('that'), "But other things");
+ok(!$obj->_attribute_exists('eep'), " nor eep");
+ok(!$obj->_attribute_exists('orp'), " nor orp");
+ok(!$obj->_attribute_exists('oop'), " nor oop");
+
+ok(my $val = $obj->eep, 'Fetch eep');
+ok($obj->_attribute_exists('orp'), 'Gets orp too');
+ok(!$obj->_attribute_exists('oop'), 'But still not oop');
+ok(!$obj->_attribute_exists('that'), 'nor that');
+
+{
+ Lazy->columns(All => qw/this that eep orp oop opop/);
+ ok(my $obj = Lazy->retrieve(1), 'Retrieve by Primary');
+ ok !$obj->_attribute_exists('oop'), " Don't have oop";
+ my $null = $obj->eep;
+ ok !$obj->_attribute_exists('oop'),
+ " Don't have oop - even after getting eep";
+}
+
+# Test contructor breaking.
+
+eval { # Need a hashref
+ Lazy->create(this => 10, that => 20, oop => 30, opop => 40, eep => 50);
+};
+ok($@, $@);
+
+eval { # False column
+ Lazy->create({ this => 10, that => 20, theother => 30 });
+};
+ok($@, $@);
+
+eval { # Multiple false columns
+ Lazy->create({ this => 10, that => 20, theother => 30, andanother => 40 });
+};
+ok($@, $@);
+
+
+warning_is {
+ Lazy->columns( TEMP => qw(that) );
+} "Declaring column that as TEMP but it already exists";
+
+# Test that create() and update() throws out columns that changed
+{
+ my $l = Lazy->create({
+ this => 99,
+ that => 2,
+ oop => 3,
+ opop => 4,
+ });
+
+ ok $l->db_Main->do(qq{
+ UPDATE @{[ $l->table ]}
+ SET oop = ?
+ WHERE this = ?
+ }, undef, 87, $l->this);
+
+ is $l->oop, 87;
+
+ $l->oop(32);
+ $l->update;
+
+ ok $l->db_Main->do(qq{
+ UPDATE @{[ $l->table ]}
+ SET oop = ?
+ WHERE this = ?
+ }, undef, 23, $l->this);
+
+ is $l->oop, 23;
+
+ $l->delete;
+}
+
+
+# Now again for inflated values
+SKIP: {
+ skip "Requires Date::Simple", 5 unless eval "use Date::Simple; 1; ";
+ Lazy->has_a(
+ orp => 'Date::Simple',
+ inflate => sub { Date::Simple->new($_[0] . '-01-01') },
+ deflate => 'format'
+ );
+
+ my $l = Lazy->create({
+ this => 89,
+ that => 2,
+ orp => 1998,
+ });
+
+ ok $l->db_Main->do(qq{
+ UPDATE @{[ $l->table ]}
+ SET orp = ?
+ WHERE this = ?
+ }, undef, 1987, $l->this);
+
+ is $l->orp, '1987-01-01';
+
+ $l->orp(2007);
+ is $l->orp, '2007-01-01'; # make sure it's inflated
+ $l->update;
+
+ ok $l->db_Main->do(qq{
+ UPDATE @{[ $l->table ]}
+ SET orp = ?
+ WHERE this = ?
+ }, undef, 1942, $l->this);
+
+ is $l->orp, '1942-01-01';
+
+ $l->delete;
+}
+
+
+# Test that a deleted object works
+{
+ Lazy->search()->delete_all;
+ my $l = Lazy->create({
+ this => 99,
+ that => 2,
+ oop => 3,
+ opop => 4,
+ });
+
+ # Delete the object without it knowing.
+ Lazy->db_Main->do(qq[
+ DELETE
+ FROM @{[ Lazy->table ]}
+ WHERE this = 99
+ ]);
+
+ $l->eep;
+
+ # The problem was when an object had an inflated object
+ # loaded. _flesh() would set _column_data to undef and
+ # get_column() would think nothing was there.
+ # I'm too lazy to set up the proper inflation test.
+ ok !exists $l->{_column_data}{orp};
+}
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/04-lazy.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/06-hasa.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/06-hasa.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/06-hasa.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/06-hasa.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,170 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 24);
+}
+
+ at YA::Film::ISA = 'Film';
+
+#local $SIG{__WARN__} = sub { };
+
+INIT {
+ use lib 't/cdbi/testlib';
+ use Film;
+ use Director;
+}
+
+Film->create_test_film;
+ok(my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste");
+ok(my $pj = $btaste->Director, "Bad taste has_a() director");
+ok(!ref($pj), ' ... which is not an object');
+
+ok(Film->has_a('Director' => 'Director'), "Link Director table");
+ok(
+ Director->create(
+ {
+ Name => 'Peter Jackson',
+ Birthday => -300000000,
+ IsInsane => 1
+ }
+ ),
+ 'create Director'
+);
+
+$btaste = Film->retrieve('Bad Taste');
+
+ok($pj = $btaste->Director, "Bad taste now has_a() director");
+isa_ok($pj => 'Director');
+is($pj->id, 'Peter Jackson', ' ... and is the correct director');
+
+# Oh no! Its Peter Jacksons even twin, Skippy! Born one minute after him.
+my $sj = Director->create(
+ {
+ Name => 'Skippy Jackson',
+ Birthday => (-300000000 + 60),
+ IsInsane => 1,
+ }
+);
+
+is($sj->id, 'Skippy Jackson', 'We have a new director');
+
+Film->has_a(CoDirector => 'Director');
+
+$btaste->CoDirector($sj);
+$btaste->update;
+is($btaste->CoDirector->Name, 'Skippy Jackson', 'He co-directed');
+is(
+ $btaste->Director->Name,
+ 'Peter Jackson',
+ "Didnt interfere with each other"
+);
+
+{ # Ensure search can take an object
+ my @films = Film->search(Director => $pj);
+ is @films, 1, "1 Film directed by $pj";
+ is $films[0]->id, "Bad Taste", "Bad Taste";
+}
+
+inheriting_hasa();
+
+{
+
+ # Skippy directs a film and Peter helps!
+ $sj = Director->retrieve('Skippy Jackson');
+ $pj = Director->retrieve('Peter Jackson');
+
+ fail_with_bad_object($sj, $btaste);
+ taste_bad($sj, $pj);
+}
+
+sub inheriting_hasa {
+ my $btaste = YA::Film->retrieve('Bad Taste');
+ is(ref($btaste->Director), 'Director', 'inheriting has_a()');
+ is(ref($btaste->CoDirector), 'Director', 'inheriting has_a()');
+ is($btaste->CoDirector->Name, 'Skippy Jackson', ' ... correctly');
+}
+
+sub taste_bad {
+ my ($dir, $codir) = @_;
+ my $tastes_bad = YA::Film->create(
+ {
+ Title => 'Tastes Bad',
+ Director => $dir,
+ CoDirector => $codir,
+ Rating => 'R',
+ NumExplodingSheep => 23
+ }
+ );
+ is($tastes_bad->_Director_accessor, 'Skippy Jackson', 'Director_accessor');
+ is($tastes_bad->Director->Name, 'Skippy Jackson', 'Director');
+ is($tastes_bad->CoDirector->Name, 'Peter Jackson', 'CoDirector');
+ is(
+ $tastes_bad->_CoDirector_accessor,
+ 'Peter Jackson',
+ 'CoDirector_accessor'
+ );
+}
+
+sub fail_with_bad_object {
+ my ($dir, $codir) = @_;
+ eval {
+ YA::Film->create(
+ {
+ Title => 'Tastes Bad',
+ Director => $dir,
+ CoDirector => $codir,
+ Rating => 'R',
+ NumExplodingSheep => 23
+ }
+ );
+ };
+ ok $@, $@;
+}
+
+package Foo;
+use base 'CDBase';
+__PACKAGE__->table('foo');
+__PACKAGE__->columns('All' => qw/ id fav /);
+# fav is a film
+__PACKAGE__->db_Main->do( qq{
+ CREATE TABLE foo (
+ id INTEGER,
+ fav VARCHAR(255)
+ )
+});
+
+
+package Bar;
+use base 'CDBase';
+__PACKAGE__->table('bar');
+__PACKAGE__->columns('All' => qw/ id fav /);
+# fav is a foo
+__PACKAGE__->db_Main->do( qq{
+ CREATE TABLE bar (
+ id INTEGER,
+ fav INTEGER
+ )
+});
+
+package main;
+Foo->has_a("fav" => "Film");
+Bar->has_a("fav" => "Foo");
+my $foo = Foo->create({ id => 6, fav => 'Bad Taste' });
+my $bar = Bar->create({ id => 2, fav => 6 });
+isa_ok($bar->fav, "Foo");
+isa_ok($foo->fav, "Film");
+
+{
+ my $foo;
+ Foo->add_trigger(after_create => sub { $foo = shift->fav });
+ my $gwh = Foo->create({ id => 93, fav => 'Good Will Hunting' });
+ isa_ok $foo, "Film", "Object in after_create trigger";
+}
+
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/06-hasa.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/08-inheritcols.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/08-inheritcols.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/08-inheritcols.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/08-inheritcols.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,25 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required')
+ : (tests=> 3);
+}
+
+package A;
+ at A::ISA = qw(DBIx::Class::CDBICompat);
+__PACKAGE__->columns(Primary => 'id');
+
+package A::B;
+ at A::B::ISA = 'A';
+__PACKAGE__->columns(All => qw(id b1));
+
+package A::C;
+ at A::C::ISA = 'A';
+__PACKAGE__->columns(All => qw(id c1 c2 c3));
+
+package main;
+is join (' ', sort A->columns), 'id', "A columns";
+is join (' ', sort A::B->columns), 'b1 id', "A::B columns";
+is join (' ', sort A::C->columns), 'c1 c2 c3 id', "A::C columns";
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/08-inheritcols.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/09-has_many.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/09-has_many.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/09-has_many.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/09-has_many.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,127 @@
+use strict;
+use Test::More;
+
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => 'Class::Trigger and DBIx::ContextualFetch required' if $@;
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 31);
+}
+
+
+use lib 't/cdbi/testlib';
+use Film;
+use Actor;
+Actor->has_a(Film => 'Film');
+Film->has_many(actors => 'Actor', { order_by => 'name' });
+is(Actor->primary_column, 'id', "Actor primary OK");
+
+ok(Actor->can('Salary'), "Actor table set-up OK");
+ok(Film->can('actors'), " and have a suitable method in Film");
+
+Film->create_test_film;
+
+ok(my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste");
+
+ok(
+ my $pvj = Actor->create(
+ {
+ Name => 'Peter Vere-Jones',
+ Film => undef,
+ Salary => '30_000', # For a voice!
+ }
+ ),
+ 'create Actor'
+);
+is $pvj->Name, "Peter Vere-Jones", "PVJ name ok";
+is $pvj->Film, undef, "No film";
+ok $pvj->set_Film($btaste), "Set film";
+$pvj->update;
+is $pvj->Film->id, $btaste->id, "Now film";
+{
+ my @actors = $btaste->actors;
+ is(@actors, 1, "Bad taste has one actor");
+ is($actors[0]->Name, $pvj->Name, " - the correct one");
+}
+
+my %pj_data = (
+ Name => 'Peter Jackson',
+ Salary => '0', # it's a labour of love
+);
+
+eval { my $pj = Film->add_to_actors(\%pj_data) };
+like $@, qr/class/, "add_to_actors must be object method";
+
+eval { my $pj = $btaste->add_to_actors(%pj_data) };
+like $@, qr/needs/, "add_to_actors takes hash";
+
+ok(
+ my $pj = $btaste->add_to_actors(
+ {
+ Name => 'Peter Jackson',
+ Salary => '0', # it's a labour of love
+ }
+ ),
+ 'add_to_actors'
+);
+is $pj->Name, "Peter Jackson", "PJ ok";
+is $pvj->Name, "Peter Vere-Jones", "PVJ still ok";
+
+{
+ my @actors = $btaste->actors;
+ is @actors, 2, " - so now we have 2";
+ is $actors[0]->Name, $pj->Name, "PJ first";
+ is $actors[1]->Name, $pvj->Name, "PVJ first";
+}
+
+eval {
+ my @actors = $btaste->actors(Name => $pj->Name);
+ is @actors, 1, "One actor from restricted (sorted) has_many";
+ is $actors[0]->Name, $pj->Name, "It's PJ";
+};
+is $@, '', "No errors";
+
+my $as = Actor->create(
+ {
+ Name => 'Arnold Schwarzenegger',
+ Film => 'Terminator 2',
+ Salary => '15_000_000'
+ }
+);
+
+eval { $btaste->actors($pj, $pvj, $as) };
+ok $@, $@;
+is($btaste->actors, 2, " - so we still only have 2 actors");
+
+my @bta_before = Actor->search(Film => 'Bad Taste');
+is(@bta_before, 2, "We have 2 actors in bad taste");
+ok($btaste->delete, "Delete bad taste");
+my @bta_after = Actor->search(Film => 'Bad Taste');
+is(@bta_after, 0, " - after deleting there are no actors");
+
+# While we're here, make sure Actors have unreadable mutators and
+# unwritable accessors
+
+eval { $as->Name("Paul Reubens") };
+ok $@, $@;
+eval { my $name = $as->set_Name };
+ok $@, $@;
+
+is($as->Name, 'Arnold Schwarzenegger', "Arnie's still Arnie");
+
+
+# Test infering of the foreign key of a has_many from an existing has_a
+{
+ use Thing;
+ use OtherThing;
+
+ Thing->has_a(that_thing => "OtherThing");
+ OtherThing->has_many(things => "Thing");
+
+ my $other_thing = OtherThing->create({ id => 1 });
+ Thing->create({ id => 1, that_thing => $other_thing });
+ Thing->create({ id => 2, that_thing => $other_thing });
+
+ is_deeply [sort map { $_->id } $other_thing->things], [1,2];
+}
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/09-has_many.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/11-triggers.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/11-triggers.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/11-triggers.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/11-triggers.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,66 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 13);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+sub create_trigger2 { ::ok(1, "Running create trigger 2"); }
+sub delete_trigger { ::ok(1, "Deleting " . shift->Title) }
+
+sub pre_up_trigger {
+ $_[0]->_attribute_set(numexplodingsheep => 1);
+ ::ok(1, "Running pre-update trigger");
+}
+sub pst_up_trigger { ::ok(1, "Running post-update trigger"); }
+
+sub default_rating { $_[0]->Rating(15); }
+
+Film->add_trigger(before_create => \&default_rating);
+Film->add_trigger(after_create => \&create_trigger2);
+Film->add_trigger(after_delete => \&delete_trigger);
+Film->add_trigger(before_update => \&pre_up_trigger);
+Film->add_trigger(after_update => \&pst_up_trigger);
+
+ok(
+ my $ver = Film->create({
+ title => 'La Double Vie De Veronique',
+ director => 'Kryzstof Kieslowski',
+
+ # rating => '15',
+ numexplodingsheep => 0,
+ }
+ ),
+ "Create Veronique"
+);
+
+is $ver->Rating, 15, "Default rating";
+is $ver->NumExplodingSheep, 0, "Original sheep count";
+ok $ver->Rating('12') && $ver->update, "Change the rating";
+is $ver->NumExplodingSheep, 1, "Updated object's sheep count";
+is + (
+ $ver->db_Main->selectall_arrayref(
+ 'SELECT numexplodingsheep FROM '
+ . $ver->table
+ . ' WHERE '
+ . $ver->primary_column . ' = '
+ . $ver->db_Main->quote($ver->id))
+)->[0]->[0], 1, "Updated database's sheep count";
+ok $ver->delete, "Delete";
+
+{
+ Film->add_trigger(before_create => sub {
+ my $self = shift;
+ ok !$self->_attribute_exists('title'), "PK doesn't auto-vivify";
+ });
+ Film->create({director => "Me"});
+}
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/11-triggers.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/12-filter.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/12-filter.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/12-filter.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/12-filter.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,181 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 50);
+}
+
+use lib 't/cdbi/testlib';
+use Actor;
+use Film;
+Film->has_many(actors => 'Actor');
+Actor->has_a('film' => 'Film');
+Actor->add_constructor(double_search => 'name = ? AND salary = ?');
+
+my $film = Film->create({ Title => 'MY Film' });
+my $film2 = Film->create({ Title => 'Another Film' });
+
+my @act = (
+ Actor->create(
+ {
+ name => 'Actor 1',
+ film => $film,
+ salary => 10,
+ }
+ ),
+ Actor->create(
+ {
+ name => 'Actor 2',
+ film => $film,
+ salary => 20,
+ }
+ ),
+ Actor->create(
+ {
+ name => 'Actor 3',
+ film => $film,
+ salary => 30,
+ }
+ ),
+ Actor->create(
+ {
+ name => 'Actor 4',
+ film => $film2,
+ salary => 50,
+ }
+ ),
+);
+
+eval {
+ my @actors = $film->actors(name => 'Actor 1');
+ is @actors, 1, "Got one actor from restricted has_many";
+ is $actors[0]->name, "Actor 1", "Correct name";
+};
+is $@, '', "No errors";
+
+{
+ my @actors = Actor->double_search("Actor 1", 10);
+ is @actors, 1, "Got one actor";
+ is $actors[0]->name, "Actor 1", "Correct name";
+}
+
+{
+ ok my @actors = Actor->salary_between(0, 100), "Range 0 - 100";
+ is @actors, 4, "Got all";
+}
+
+{
+ my @actors = Actor->salary_between(100, 200);
+ is @actors, 0, "None in Range 100 - 200";
+}
+
+{
+ ok my @actors = Actor->salary_between(0, 10), "Range 0 - 10";
+ is @actors, 1, "Got 1";
+ is $actors[0]->name, $act[0]->name, "Actor 1";
+}
+
+{
+ ok my @actors = Actor->salary_between(20, 30), "Range 20 - 20";
+ @actors = sort { $a->salary <=> $b->salary } @actors;
+ is @actors, 2, "Got 2";
+ is $actors[0]->name, $act[1]->name, "Actor 2";
+ is $actors[1]->name, $act[2]->name, "and Actor 3";
+}
+
+{
+ ok my @actors = Actor->search(Film => $film), "Search by object";
+ is @actors, 3, "3 actors in film 1";
+}
+
+#----------------------------------------------------------------------
+# Iterators
+#----------------------------------------------------------------------
+
+my $it_class = 'DBIx::Class::ResultSet';
+
+sub test_normal_iterator {
+ my $it = $film->actors;
+ isa_ok $it, $it_class;
+ is $it->count, 3, " - with 3 elements";
+ my $i = 0;
+ while (my $film = $it->next) {
+ is $film->name, $act[ $i++ ]->name, "Get $i";
+ }
+ ok !$it->next, "No more";
+ is $it->first->name, $act[0]->name, "Get first";
+}
+
+test_normal_iterator;
+{
+ Film->has_many(actor_ids => [ Actor => 'id' ]);
+ my $it = $film->actor_ids;
+ isa_ok $it, $it_class;
+ is $it->count, 3, " - with 3 elements";
+ my $i = 0;
+ while (my $film_id = $it->next) {
+ is $film_id, $act[ $i++ ]->id, "Get id $i";
+ }
+ ok !$it->next, "No more";
+ is $it->first, $act[0]->id, "Get first";
+}
+
+# make sure nothing gets clobbered;
+test_normal_iterator;
+
+SKIP: {
+ #skip "dbic iterators don't support slice yet", 12;
+
+
+{
+ my @acts = $film->actors->slice(1, 2);
+ is @acts, 2, "Slice gives 2 actor";
+ is $acts[0]->name, "Actor 2", "Actor 2";
+ is $acts[1]->name, "Actor 3", "and actor 3";
+}
+
+{
+ my @acts = $film->actors->slice(1);
+ is @acts, 1, "Slice of 1 actor";
+ is $acts[0]->name, "Actor 2", "Actor 2";
+}
+
+{
+ my @acts = $film->actors->slice(2, 8);
+ is @acts, 1, "Slice off the end";
+ is $acts[0]->name, "Actor 3", "Gets last actor only";
+}
+
+package Class::DBI::My::Iterator;
+
+use vars qw/@ISA/;
+
+ at ISA = ($it_class);
+
+sub slice { qw/fred barney/ }
+
+package main;
+
+Actor->iterator_class('Class::DBI::My::Iterator');
+
+delete $film->{related_resultsets};
+
+{
+ my @acts = $film->actors->slice(1, 2);
+ is @acts, 2, "Slice gives 2 results";
+ ok eq_set(\@acts, [qw/fred barney/]), "Fred and Barney";
+
+ ok $film->actors->delete_all, "Can delete via iterator";
+ is $film->actors, 0, "no actors left";
+
+ eval { $film->actors->delete_all };
+ is $@, '', "Deleting again does no harm";
+}
+
+} # end SKIP block
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/12-filter.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/13-constraint.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/13-constraint.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/13-constraint.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/13-constraint.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,121 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 23);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+sub valid_rating {
+ my $value = shift;
+ my $ok = grep $value eq $_, qw/U Uc PG 12 15 18/;
+ return $ok;
+}
+
+Film->add_constraint('valid rating', Rating => \&valid_rating);
+
+my %info = (
+ Title => 'La Double Vie De Veronique',
+ Director => 'Kryzstof Kieslowski',
+ Rating => '18',
+);
+
+{
+ local $info{Title} = "nonsense";
+ local $info{Rating} = 19;
+ eval { Film->create({%info}) };
+ ok $@, $@;
+ ok !Film->retrieve($info{Title}), "No film created";
+ is(Film->retrieve_all, 0, "So no films");
+}
+
+ok(my $ver = Film->create({%info}), "Can create with valid rating");
+is $ver->Rating, 18, "Rating 18";
+
+ok $ver->Rating(12), "Change to 12";
+ok $ver->update, "And update";
+is $ver->Rating, 12, "Rating now 12";
+
+eval {
+ $ver->Rating(13);
+ $ver->update;
+};
+ok $@, $@;
+is $ver->Rating, 12, "Rating still 12";
+ok $ver->delete, "Delete";
+
+# this threw an infinite loop in old versions
+Film->add_constraint('valid director', Director => sub { 1 });
+my $fred = Film->create({ Rating => '12' });
+
+# this test is a bit problematical because we don't supply a primary key
+# to the create() and the table doesn't use auto_increment or a sequence.
+ok $fred, "Got fred";
+
+{
+ ok +Film->constrain_column(rating => [qw/U PG 12 15 19/]),
+ "constraint_column";
+ my $narrower = eval { Film->create({ Rating => 'Uc' }) };
+ like $@, qr/fails.*constraint/, "Fails listref constraint";
+ my $ok = eval { Film->create({ Rating => 'U' }) };
+ is $@, '', "Can create with rating U";
+ SKIP: {
+ skip "No column objects", 2;
+ ok +Film->find_column('rating')->is_constrained, "Rating is constrained";
+ ok +Film->find_column('director')->is_constrained, "Director is not";
+ }
+}
+
+{
+ ok +Film->constrain_column(title => qr/The/), "constraint_column";
+ my $inferno = eval { Film->create({ Title => 'Towering Infero' }) };
+ like $@, qr/fails.*constraint/, "Can't create towering inferno";
+ my $the_inferno = eval { Film->create({ Title => 'The Towering Infero' }) };
+ is $@, '', "But can create THE towering inferno";
+}
+
+{
+
+ sub Film::_constrain_by_untaint {
+ my ($class, $col, $string, $type) = @_;
+ $class->add_constraint(
+ untaint => $col => sub {
+ my ($value, $self, $column_name, $changing) = @_;
+ $value eq "today" ? $changing->{$column_name} = "2001-03-03" : 0;
+ }
+ );
+ }
+ eval { Film->constrain_column(codirector => Untaint => 'date') };
+ is $@, '', 'Can constrain with untaint';
+ my $freeaa =
+ eval { Film->create({ title => "The Freaa", codirector => 'today' }) };
+ TODO: {
+ local $TODO = "no idea what this is supposed to do";
+ is $@, '', "Can create codirector";
+ is $freeaa && $freeaa->codirector, '2001-03-03', "Set the codirector";
+ }
+}
+
+__DATA__
+
+use CGI::Untaint;
+
+sub _constrain_by_untaint {
+ my ($class, $col, $string, $type) = @_;
+ $class->add_constraint(untaint => $col => sub {
+ my ($value, $self, $column_name, $changing) = @_;
+ my $h = CGI::Untaint->new({ %$changing });
+ return unless my $val = $h->extract("-as_$type" => $column_name);
+ $changing->{$column_name} = $val;
+ return 1;
+ });
+}
+
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/13-constraint.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/14-might_have.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/14-might_have.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/14-might_have.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/14-might_have.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,83 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 22);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+use Blurb;
+
+is(Blurb->primary_column, "title", "Primary key of Blurb = title");
+is_deeply [ Blurb->columns('Essential') ], [ Blurb->primary_column ], "Essential = Primary";
+
+eval { Blurb->retrieve(10) };
+is $@, "", "No problem retrieving non-existent Blurb";
+
+Film->might_have(info => Blurb => qw/blurb/);
+
+Film->create_test_film;
+
+{
+ ok my $bt = Film->retrieve('Bad Taste'), "Get Film";
+ isa_ok $bt, "Film";
+ is $bt->info, undef, "No blurb yet";
+ # bug where we couldn't write a class with a might_have that didn't_have
+ $bt->rating(16);
+ eval { $bt->update };
+ is $@, '', "No problems updating when don't have";
+ is $bt->rating, 16, "Updated OK";
+
+ is $bt->blurb, undef, "Bad taste has no blurb";
+ $bt->blurb("Wibble bar");
+ $bt->update;
+ is $bt->blurb, "Wibble bar", "And we can write the info";
+}
+
+{
+ my $bt = Film->retrieve('Bad Taste');
+ my $info = $bt->info;
+ isa_ok $info, 'Blurb';
+
+ is $bt->blurb, $info->blurb, "Blurb is the same as fetching the long way";
+ ok $bt->blurb("New blurb"), "We can set the blurb";
+ $bt->update;
+ is $bt->blurb, $info->blurb, "Blurb has been set";
+
+ $bt->rating(18);
+ eval { $bt->update };
+ is $@, '', "No problems updating when do have";
+ is $bt->rating, 18, "Updated OK";
+
+ # cascade delete?
+ {
+ my $blurb = Blurb->retrieve('Bad Taste');
+ isa_ok $blurb => "Blurb";
+ $bt->delete;
+ $blurb = Blurb->retrieve('Bad Taste');
+ is $blurb, undef, "Blurb has gone";
+ }
+
+}
+
+{
+ my $host = Film->create({ title => "Gwoemul" });
+ $host->blurb("Monsters are real.");
+ my $info = $host->info;
+ is $info->blurb, "Monsters are real.";
+
+ $host->discard_changes;
+ is $host->info->id, $info->id,
+ 'relationships still valid after discard_changes';
+
+ ok $host->info->delete;
+ $host->discard_changes;
+ ok !$host->info, 'relationships rechecked after discard_changes';
+}
\ No newline at end of file
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/14-might_have.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/15-accessor.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/15-accessor.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/15-accessor.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/15-accessor.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,268 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 75);
+}
+
+INIT {
+ #local $SIG{__WARN__} =
+ #sub { like $_[0], qr/clashes with built-in method/, $_[0] };
+ use lib 't/cdbi/testlib';
+ require Film;
+ require Actor;
+ require Director;
+
+ Actor->has_a(film => 'Film');
+ Film->has_a(director => 'Director');
+
+ sub Class::DBI::sheep { ok 0; }
+}
+
+sub Film::mutator_name {
+ my ($class, $col) = @_;
+ return "set_sheep" if lc $col eq "numexplodingsheep";
+ return $col;
+}
+
+sub Film::accessor_name {
+ my ($class, $col) = @_;
+ return "sheep" if lc $col eq "numexplodingsheep";
+ return $col;
+}
+
+sub Actor::accessor_name_for {
+ my ($class, $col) = @_;
+ return "movie" if lc $col eq "film";
+ return $col;
+}
+
+# This is a class with accessor_name_for() but no corresponding mutator_name_for()
+sub Director::accessor_name_for {
+ my($class, $col) = @_;
+ return "nutty_as_a_fruitcake" if lc $col eq "isinsane";
+ return $col;
+}
+
+my $data = {
+ Title => 'Bad Taste',
+ Director => 'Peter Jackson',
+ Rating => 'R',
+};
+
+eval {
+ my $data = { %$data };
+ $data->{NumExplodingSheep} = 1;
+ ok my $bt = Film->create($data), "Modified accessor - with column name";
+ isa_ok $bt, "Film";
+ is $bt->sheep, 1, 'sheep bursting violently';
+};
+is $@, '', "No errors";
+
+eval {
+ my $data = { %$data };
+ $data->{sheep} = 2;
+ ok my $bt = Film->create($data), "Modified accessor - with accessor";
+ isa_ok $bt, "Film";
+ is $bt->sheep, 2, 'sheep bursting violently';
+};
+is $@, '', "No errors";
+
+eval {
+ my $data = { %$data };
+ $data->{NumExplodingSheep} = 1;
+ ok my $bt = Film->find_or_create($data),
+ "find_or_create Modified accessor - find with column name";
+ isa_ok $bt, "Film";
+ is $bt->sheep, 1, 'sheep bursting violently';
+};
+is $@, '', "No errors";
+
+eval {
+ my $data = { %$data };
+ $data->{sheep} = 1;
+ ok my $bt = Film->find_or_create($data),
+ "find_or_create Modified accessor - find with accessor";
+ isa_ok $bt, "Film";
+ is $bt->sheep, 1, 'sheep bursting violently';
+};
+is $@, '', "No errors";
+
+TODO: { local $TODO = 'TODOifying failing tests, waiting for Schwern'; ok (1, 'remove me');
+eval {
+ my $data = { %$data };
+ $data->{NumExplodingSheep} = 3;
+ ok my $bt = Film->find_or_create($data),
+ "find_or_create Modified accessor - create with column name";
+ isa_ok $bt, "Film";
+ is $bt->sheep, 3, 'sheep bursting violently';
+};
+is $@, '', "No errors";
+
+eval {
+ my $data = { %$data };
+ $data->{sheep} = 4;
+ ok my $bt = Film->find_or_create($data),
+ "find_or_create Modified accessor - create with accessor";
+ isa_ok $bt, "Film";
+ is $bt->sheep, 4, 'sheep bursting violently';
+};
+is $@, '', "No errors";
+
+eval {
+ my @film = Film->search({ sheep => 1 });
+ is @film, 2, "Can search with modified accessor";
+};
+is $@, '', "No errors";
+
+}
+
+{
+
+ eval {
+ local $data->{set_sheep} = 1;
+ ok my $bt = Film->create($data), "Modified mutator - with mutator";
+ isa_ok $bt, "Film";
+ };
+ is $@, '', "No errors";
+
+ eval {
+ local $data->{NumExplodingSheep} = 1;
+ ok my $bt = Film->create($data), "Modified mutator - with column name";
+ isa_ok $bt, "Film";
+ };
+ is $@, '', "No errors";
+
+ eval {
+ local $data->{sheep} = 1;
+ ok my $bt = Film->create($data), "Modified mutator - with accessor";
+ isa_ok $bt, "Film";
+ };
+ is $@, '', "No errors";
+
+}
+
+{
+ my $p_data = {
+ name => 'Peter Jackson',
+ film => 'Bad Taste',
+ };
+ my $bt = Film->create($data);
+ my $ac = Actor->create($p_data);
+
+ ok !eval { my $f = $ac->film; 1 };
+ like $@, qr/film/, "no hasa film";
+
+ eval {
+ local $SIG{__WARN__} = sub {
+ warn @_ unless $_[0] =~ /Query returned more than one row/;
+ };
+ ok my $f = $ac->movie, "hasa movie";
+ isa_ok $f, "Film";
+ is $f->id, $bt->id, " - Bad Taste";
+ };
+ is $@, '', "No errors";
+
+ {
+ local $data->{Title} = "Another film";
+ my $film = Film->create($data);
+
+ eval { $ac->film($film) };
+ ok $@, $@;
+
+ eval { $ac->movie($film) };
+ ok $@, $@;
+
+ eval {
+ ok $ac->set_film($film), "Set movie through hasa";
+ $ac->update;
+ ok my $f = $ac->movie, "hasa movie";
+ isa_ok $f, "Film";
+ is $f->id, $film->id, " - Another Film";
+ };
+ is $@, '', "No problem";
+ }
+
+}
+
+
+# Make sure a class with an accessor_name() method has a similar mutator.
+{
+ my $aki = Director->create({
+ name => "Aki Kaurismaki",
+ });
+
+ $aki->nutty_as_a_fruitcake(1);
+ is $aki->nutty_as_a_fruitcake, 1,
+ "a custom accessor without a custom mutator is setable";
+ $aki->update;
+}
+
+{
+ Film->columns(TEMP => qw/nonpersistent/);
+ ok(Film->find_column('nonpersistent'), "nonpersistent is a column");
+ ok(!Film->has_real_column('nonpersistent'), " - but it's not real");
+
+ {
+ my $film = Film->create({ Title => "Veronique", nonpersistent => 42 });
+ is $film->title, "Veronique", "Title set OK";
+ is $film->nonpersistent, 42, "As is non persistent value";
+ $film->remove_from_object_index;
+ ok $film = Film->retrieve('Veronique'), "Re-retrieve film";
+ is $film->title, "Veronique", "Title still OK";
+ is $film->nonpersistent, undef, "Non persistent value gone";
+ ok $film->nonpersistent(40), "Can set it";
+ is $film->nonpersistent, 40, "And it's there again";
+ ok $film->update, "Commit the film";
+ is $film->nonpersistent, 40, "And it's still there";
+ }
+}
+
+{
+ is_deeply(
+ [Actor->columns('Essential')],
+ [Actor->columns('Primary')],
+ "Actor has no specific essential columns"
+ );
+ ok(Actor->find_column('nonpersistent'), "nonpersistent is a column");
+ ok(!Actor->has_real_column('nonpersistent'), " - but it's not real");
+ my $pj = eval { Actor->search(name => "Peter Jackson")->first };
+ is $@, '', "no problems retrieving actors";
+ isa_ok $pj => "Actor";
+}
+
+{
+ Film->autoupdate(1);
+ my $naked = Film->create({ title => 'Naked' });
+ my $sandl = Film->create({ title => 'Secrets and Lies' });
+
+ my $rating = 1;
+ my $update_failure = sub {
+ my $obj = shift;
+ eval { $obj->rating($rating++) };
+ return $@ =~ /read only/;
+ };
+
+ ok !$update_failure->($naked), "Can update Naked";
+ ok $naked->make_read_only, "Make Naked read only";
+ ok $update_failure->($naked), "Can't update Naked any more";
+ ok !$update_failure->($sandl), "But can still update Secrets and Lies";
+ my $july4 = eval { Film->create({ title => "4 Days in July" }) };
+ isa_ok $july4 => "Film", "And can still create new films";
+
+ ok(Film->make_read_only, "Make all Films read only");
+ ok $update_failure->($naked), "Still can't update Naked";
+ ok $update_failure->($sandl), "And can't update S&L any more";
+ eval { $july4->delete };
+ like $@, qr/read only/, "And can't delete 4 Days in July";
+ my $abigail = eval { Film->create({ title => "Abigail's Party" }) };
+ like $@, qr/read only/, "Or create new films";
+
+ $sandl->discard_changes;
+}
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/15-accessor.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/16-reserved.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/16-reserved.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/16-reserved.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/16-reserved.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,36 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 5);
+}
+
+use lib 't/cdbi/testlib';
+require Film;
+require Order;
+
+Film->has_many(orders => 'Order');
+Order->has_a(film => 'Film');
+
+Film->create_test_film;
+
+my $film = Film->retrieve('Bad Taste');
+isa_ok $film => 'Film';
+
+$film->add_to_orders({ orders => 10 });
+
+my $bto = (Order->search(film => 'Bad Taste'))[0];
+isa_ok $bto => 'Order';
+is $bto->orders, 10, "Correct number of orders";
+
+
+my $infilm = $bto->film;
+isa_ok $infilm, "Film";
+
+is $infilm->id, $film->id, "Orders hasa Film";
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/16-reserved.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/18-has_a.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/18-has_a.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/18-has_a.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/18-has_a.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,240 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 41);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+use Director;
+ at YA::Film::ISA = 'Film';
+
+Film->create_test_film;
+
+ok my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste";
+ok my $pj = $btaste->Director, "Bad taste has a director";
+ok !ref($pj), ' ... which is not an object';
+
+ok(Film->has_a('Director' => 'Director'), "Link Director table");
+ok(
+ Director->create({
+ Name => 'Peter Jackson',
+ Birthday => -300000000,
+ IsInsane => 1
+ }
+ ),
+ 'create Director'
+);
+
+{
+ ok $btaste = Film->retrieve('Bad Taste'), "Reretrieve Bad Taste";
+ ok $pj = $btaste->Director, "Bad taste now hasa() director";
+ isa_ok $pj => 'Director';
+ {
+ no warnings qw(redefine once);
+ local *Ima::DBI::st::execute =
+ sub { ::fail("Shouldn't need to query db"); };
+ is $pj->id, 'Peter Jackson', 'ID already stored';
+ }
+ ok $pj->IsInsane, "But we know he's insane";
+}
+
+# Oh no! Its Peter Jacksons even twin, Skippy! Born one minute after him.
+my $sj = Director->create({
+ Name => 'Skippy Jackson',
+ Birthday => (-300000000 + 60),
+ IsInsane => 1,
+ });
+
+{
+ eval { $btaste->Director($btaste) };
+ like $@, qr/Director/, "Can't set film as director";
+ is $btaste->Director->id, $pj->id, "PJ still the director";
+
+ # drop from cache so that next retrieve() is from db
+ $btaste->remove_from_object_index;
+}
+
+{ # Still inflated after update
+ my $btaste = Film->retrieve('Bad Taste');
+ isa_ok $btaste->Director, "Director";
+ $btaste->numexplodingsheep(17);
+ $btaste->update;
+ isa_ok $btaste->Director, "Director";
+
+ $btaste->Director('Someone Else');
+ $btaste->update;
+ isa_ok $btaste->Director, "Director";
+ is $btaste->Director->id, "Someone Else", "Can change director";
+}
+
+is $sj->id, 'Skippy Jackson', 'Create new director - Skippy';
+Film->has_a('CoDirector' => 'Director');
+{
+ eval { $btaste->CoDirector("Skippy Jackson") };
+ is $@, "", "Auto inflates";
+ isa_ok $btaste->CoDirector, "Director";
+ is $btaste->CoDirector->id, $sj->id, "To skippy";
+}
+
+$btaste->CoDirector($sj);
+$btaste->update;
+is($btaste->CoDirector->Name, 'Skippy Jackson', 'He co-directed');
+is(
+ $btaste->Director->Name,
+ 'Peter Jackson',
+ "Didnt interfere with each other"
+);
+
+{ # Inheriting hasa
+ my $btaste = YA::Film->retrieve('Bad Taste');
+ is(ref($btaste->Director), 'Director', 'inheriting hasa()');
+ is(ref($btaste->CoDirector), 'Director', 'inheriting hasa()');
+ is($btaste->CoDirector->Name, 'Skippy Jackson', ' ... correctly');
+}
+
+{
+ $sj = Director->retrieve('Skippy Jackson');
+ $pj = Director->retrieve('Peter Jackson');
+
+ my $fail;
+ eval {
+ $fail = YA::Film->create({
+ Title => 'Tastes Bad',
+ Director => $sj,
+ codirector => $btaste,
+ Rating => 'R',
+ NumExplodingSheep => 23
+ });
+ };
+ ok $@, "Can't have film as codirector: $@";
+ is $fail, undef, "We didn't get anything";
+
+ my $tastes_bad = YA::Film->create({
+ Title => 'Tastes Bad',
+ Director => $sj,
+ codirector => $pj,
+ Rating => 'R',
+ NumExplodingSheep => 23
+ });
+ is($tastes_bad->Director->Name, 'Skippy Jackson', 'Director');
+ is(
+ $tastes_bad->_director_accessor->Name,
+ 'Skippy Jackson',
+ 'director_accessor'
+ );
+ is($tastes_bad->codirector->Name, 'Peter Jackson', 'codirector');
+ is(
+ $tastes_bad->_codirector_accessor->Name,
+ 'Peter Jackson',
+ 'codirector_accessor'
+ );
+}
+
+SKIP: {
+ skip "Non-standard CDBI relationships not supported by compat", 9;
+ {
+
+ YA::Film->add_relationship_type(has_a => "YA::HasA");
+
+ package YA::HasA;
+ #use base 'Class::DBI::Relationship::HasA';
+
+ sub _inflator {
+ my $self = shift;
+ my $col = $self->accessor;
+ my $super = $self->SUPER::_inflator($col);
+
+ return $super
+ unless $col eq $self->class->find_column('Director');
+
+ return sub {
+ my $self = shift;
+ $self->_attribute_store($col, 'Ghostly Peter')
+ if $self->_attribute_exists($col)
+ and not defined $self->_attrs($col);
+ return &$super($self);
+ };
+ }
+ }
+ {
+
+ package Rating;
+
+ sub new {
+ my ($class, $mpaa, @details) = @_;
+ bless {
+ MPAA => $mpaa,
+ WHY => "@details"
+ }, $class;
+ }
+ sub mpaa { shift->{MPAA}; }
+ sub why { shift->{WHY}; }
+ }
+ local *Director::mapme = sub {
+ my ($class, $val) = @_;
+ $val =~ s/Skippy/Peter/;
+ $val;
+ };
+ no warnings 'once';
+ local *Director::sanity_check = sub { $_[0]->IsInsane ? undef: $_[0] };
+ YA::Film->has_a(
+ director => 'Director',
+ inflate => 'mapme',
+ deflate => 'sanity_check'
+ );
+ YA::Film->has_a(
+ rating => 'Rating',
+ inflate => sub {
+ my ($val, $parent) = @_;
+ my $sheep = $parent->find_column('NumexplodingSheep');
+ if ($parent->_attrs($sheep) || 0 > 20) {
+ return new Rating 'NC17', 'Graphic ovine violence';
+ } else {
+ return new Rating $val, 'Just because';
+ }
+ },
+ deflate => sub {
+ shift->mpaa;
+ });
+
+ my $tbad = YA::Film->retrieve('Tastes Bad');
+
+ isa_ok $tbad->Director, 'Director';
+ is $tbad->Director->Name, 'Peter Jackson', 'Director shuffle';
+ $tbad->Director('Skippy Jackson');
+ $tbad->update;
+ is $tbad->Director, 'Ghostly Peter', 'Sanity checked';
+
+ isa_ok $tbad->Rating, 'Rating';
+ is $tbad->Rating->mpaa, 'NC17', 'Rating bumped';
+ $tbad->Rating(new Rating 'NS17', 'Shaken sheep');
+ no warnings 'redefine';
+ local *Director::mapme = sub {
+ my ($class, $obj) = @_;
+ $obj->isa('Film') ? $obj->Director : $obj;
+ };
+
+ $pj->IsInsane(0);
+ $pj->update; # Hush warnings
+
+ ok $tbad->Director($btaste), 'Cross-class mapping';
+ is $tbad->Director, 'Peter Jackson', 'Yields PJ';
+ $tbad->update;
+
+ $tbad = Film->retrieve('Tastes Bad');
+ ok !ref($tbad->Rating), 'Unmagical rating';
+ is $tbad->Rating, 'NS17', 'but prior change stuck';
+}
+
+{ # Broken has_a declaration
+ eval { Film->has_a(driector => "Director") };
+ like $@, qr/driector/, "Sensible error from has_a with incorrect column: $@";
+}
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/18-has_a.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/19-set_sql.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/19-set_sql.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/19-set_sql.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/19-set_sql.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,132 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 20);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+use Actor;
+
+{ # Check __ESSENTIAL__ expansion (RT#13038)
+ my @cols = Film->columns('Essential');
+ is_deeply \@cols, ['title'], "1 Column in essential";
+ is +Film->transform_sql('__ESSENTIAL__'), 'title', '__ESSENTIAL__ expansion';
+
+ # This provides a more interesting test
+ Film->columns(Essential => qw(title rating));
+ is +Film->transform_sql('__ESSENTIAL__'), 'title, rating',
+ 'multi-col __ESSENTIAL__ expansion';
+}
+
+my $f1 = Film->create({ title => 'A', director => 'AA', rating => 'PG' });
+my $f2 = Film->create({ title => 'B', director => 'BA', rating => 'PG' });
+my $f3 = Film->create({ title => 'C', director => 'AA', rating => '15' });
+my $f4 = Film->create({ title => 'D', director => 'BA', rating => '18' });
+my $f5 = Film->create({ title => 'E', director => 'AA', rating => '18' });
+
+Film->set_sql(
+ pgs => qq{
+ SELECT __ESSENTIAL__
+ FROM __TABLE__
+ WHERE __TABLE__.rating = 'PG'
+ ORDER BY title DESC
+}
+);
+
+{
+ (my $sth = Film->sql_pgs())->execute;
+ my @pgs = Film->sth_to_objects($sth);
+ is @pgs, 2, "Execute our own SQL";
+ is $pgs[0]->id, $f2->id, "get F2";
+ is $pgs[1]->id, $f1->id, "and F1";
+}
+
+{
+ my @pgs = Film->search_pgs;
+ is @pgs, 2, "SQL creates search() method";
+ is $pgs[0]->id, $f2->id, "get F2";
+ is $pgs[1]->id, $f1->id, "and F1";
+};
+
+Film->set_sql(
+ rating => qq{
+ SELECT __ESSENTIAL__
+ FROM __TABLE__
+ WHERE rating = ?
+ ORDER BY title DESC
+}
+);
+
+{
+ my @pgs = Film->search_rating('18');
+ is @pgs, 2, "Can pass parameters to created search()";
+ is $pgs[0]->id, $f5->id, "F5";
+ is $pgs[1]->id, $f4->id, "and F4";
+};
+
+{
+ Film->set_sql(
+ by_id => qq{
+ SELECT __ESSENTIAL__
+ FROM __TABLE__
+ WHERE __IDENTIFIER__
+ }
+ );
+
+ my $film = Film->retrieve_all->first;
+ my @found = Film->search_by_id($film->id);
+ is @found, 1;
+ is $found[0]->id, $film->id;
+}
+
+
+{
+ Actor->has_a(film => "Film");
+ Film->set_sql(
+ namerate => qq{
+ SELECT __ESSENTIAL(f)__
+ FROM __TABLE(=f)__, __TABLE(Actor=a)__
+ WHERE __JOIN(a f)__
+ AND a.name LIKE ?
+ AND f.rating = ?
+ ORDER BY title
+ }
+ );
+
+ my $a1 = Actor->create({ name => "A1", film => $f1 });
+ my $a2 = Actor->create({ name => "A2", film => $f2 });
+ my $a3 = Actor->create({ name => "B1", film => $f1 });
+
+ my @apg = Film->search_namerate("A_", "PG");
+ is @apg, 2, "2 Films with A* that are PG";
+ is $apg[0]->title, "A", "A";
+ is $apg[1]->title, "B", "and B";
+}
+
+{ # join in reverse
+ Actor->has_a(film => "Film");
+ Film->set_sql(
+ ratename => qq{
+ SELECT __ESSENTIAL(f)__
+ FROM __TABLE(=f)__, __TABLE(Actor=a)__
+ WHERE __JOIN(f a)__
+ AND f.rating = ?
+ AND a.name LIKE ?
+ ORDER BY title
+ }
+ );
+
+ my @apg = Film->search_ratename(PG => "A_");
+ is @apg, 2, "2 Films with A* that are PG";
+ is $apg[0]->title, "A", "A";
+ is $apg[1]->title, "B", "and B";
+}
+
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/19-set_sql.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/21-iterator.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/21-iterator.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/21-iterator.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/21-iterator.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,96 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 37);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+my $it_class = "DBIx::Class::ResultSet";
+
+my @film = (
+ Film->create({ Title => 'Film 1' }),
+ Film->create({ Title => 'Film 2' }),
+ Film->create({ Title => 'Film 3' }),
+ Film->create({ Title => 'Film 4' }),
+ Film->create({ Title => 'Film 5' }),
+ Film->create({ Title => 'Film 6' }),
+);
+
+{
+ my $it1 = Film->retrieve_all;
+ isa_ok $it1, $it_class;
+
+ my $it2 = Film->retrieve_all;
+ isa_ok $it2, $it_class;
+
+ while (my $from1 = $it1->next) {
+ my $from2 = $it2->next;
+ is $from1->id, $from2->id, "Both iterators get $from1";
+ }
+}
+
+{
+ my $it = Film->retrieve_all;
+ is $it->first->title, "Film 1", "Film 1 first";
+ is $it->next->title, "Film 2", "Film 2 next";
+ is $it->first->title, "Film 1", "First goes back to 1";
+ is $it->next->title, "Film 2", "With 2 still next";
+ $it->reset;
+ is $it->next->title, "Film 1", "Reset brings us to film 1 again";
+ is $it->next->title, "Film 2", "And 2 is still next";
+}
+
+
+{
+ my $it = Film->retrieve_all;
+ my @slice = $it->slice(2,4);
+ is @slice, 3, "correct slice size (array)";
+ is $slice[0]->title, "Film 3", "Film 3 first";
+ is $slice[2]->title, "Film 5", "Film 5 last";
+}
+
+{
+ my $it = Film->retrieve_all;
+ my $slice = $it->slice(2,4);
+ isa_ok $slice, $it_class, "slice as iterator";
+ is $slice->count, 3,"correct slice size (array)";
+ is $slice->first->title, "Film 3", "Film 3 first";
+ is $slice->next->title, "Film 4", "Film 4 next";
+ is $slice->first->title, "Film 3", "First goes back to 3";
+ is $slice->next->title, "Film 4", "With 4 still next";
+ $slice->reset;
+ is $slice->next->title, "Film 3", "Reset brings us to film 3 again";
+ is $slice->next->title, "Film 4", "And 4 is still next";
+
+ # check if the original iterator still works
+ is $it->count, 6, "back to the original iterator, is of right size";
+ is $it->first->title, "Film 1", "Film 1 first";
+ is $it->next->title, "Film 2", "Film 2 next";
+ is $it->first->title, "Film 1", "First goes back to 1";
+ is $it->next->title, "Film 2", "With 2 still next";
+ is $it->next->title, "Film 3", "Film 3 is still in original Iterator";
+ $it->reset;
+ is $it->next->title, "Film 1", "Reset brings us to film 1 again";
+ is $it->next->title, "Film 2", "And 2 is still next";
+}
+
+{
+ my $it = Film->retrieve_all;
+ is $it, $it->count, "iterator returns count as a scalar";
+ ok $it, "iterator returns true when there are results";
+}
+
+{
+ my $it = Film->search( Title => "something which does not exist" );
+ is $it, 0;
+ ok !$it, "iterator returns false when no results";
+}
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/21-iterator.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/22-deflate_order.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/22-deflate_order.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/22-deflate_order.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/22-deflate_order.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,30 @@
+$| = 1;
+use strict;
+
+use Test::More;
+
+eval "use DBIx::Class::CDBICompat;";
+if ($@) {
+ plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
+ next;
+}
+
+eval { require Time::Piece::MySQL };
+plan skip_all => "Need Time::Piece::MySQL for this test" if $@;
+
+eval { require 't/cdbi/testlib/Log.pm' };
+plan skip_all => "Need MySQL for this test" if $@;
+
+plan tests => 2;
+
+package main;
+
+my $log = Log->insert( { message => 'initial message' } );
+ok eval { $log->datetime_stamp }, "Have datetime";
+diag $@ if $@;
+
+$log->message( 'a revised message' );
+$log->update;
+ok eval { $log->datetime_stamp }, "Have datetime after update";
+diag $@ if $@;
+
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/22-deflate_order.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/22-self_referential.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/22-self_referential.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/22-self_referential.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/22-self_referential.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,25 @@
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required') : (tests=> 2);
+}
+
+use strict;
+
+use lib 't/cdbi/testlib';
+use Actor;
+use ActorAlias;
+Actor->has_many( aliases => [ 'ActorAlias' => 'alias' ] );
+
+my $first = Actor->create( { Name => 'First' } );
+my $second = Actor->create( { Name => 'Second' } );
+
+ActorAlias->create( { actor => $first, alias => $second } );
+
+my @aliases = $first->aliases;
+
+is( scalar @aliases, 1, 'proper number of aliases' );
+is( $aliases[ 0 ]->name, 'Second', 'proper alias' );
+
+
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/22-self_referential.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/23-cascade.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/23-cascade.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/23-cascade.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/23-cascade.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,78 @@
+use strict;
+use Test::More;
+use Data::Dumper;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 12);
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+ use Film;
+ use Director;
+}
+
+{ # Cascade on delete
+ Director->has_many(nasties => 'Film');
+
+ my $dir = Director->insert({
+ name => "Lewis Teague",
+ });
+ my $kk = $dir->add_to_nasties({
+ Title => 'Alligator'
+ });
+ is $kk->director, $dir, "Director set OK";
+ is $dir->nasties, 1, "We have one nasty";
+
+ ok $dir->delete;
+ ok !Film->retrieve("Alligator"), "has_many cascade deletes by default";
+}
+
+
+# Two ways of saying not to cascade
+for my $args ({ no_cascade_delete => 1 }, { cascade => "None" }) {
+ Director->has_many(nasties => 'Film', $args);
+
+ my $dir = Director->insert({
+ name => "Lewis Teague",
+ });
+ my $kk = $dir->add_to_nasties({
+ Title => 'Alligator'
+ });
+ is $kk->director, $dir, "Director set OK";
+ is $dir->nasties, 1, "We have one nasty";
+
+ ok $dir->delete;
+ local $Data::Dumper::Terse = 1;
+ ok +Film->retrieve("Alligator"), 'has_many with ' . Dumper ($args);;
+ $kk->delete;
+}
+
+
+#{ # Fail on cascade
+# local $TODO = 'cascade => "Fail" unimplemented';
+#
+# Director->has_many(nasties => Film => { cascade => 'Fail' });
+#
+# my $dir = Director->insert({ name => "Nasty Noddy" });
+# my $kk = $dir->add_to_nasties({ Title => 'Killer Killers' });
+# is $kk->director, $dir, "Director set OK";
+# is $dir->nasties, 1, "We have one nasty";
+#
+# ok !eval { $dir->delete };
+# like $@, qr/1/, "Can't delete while films exist";
+#
+# my $rr = $dir->add_to_nasties({ Title => 'Revenge of the Revengers' });
+# ok !eval { $dir->delete };
+# like $@, qr/2/, "Still can't delete";
+#
+# $dir->nasties->delete_all;
+# ok eval { $dir->delete };
+# is $@, '', "Can delete once films are gone";
+#}
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/23-cascade.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/24-meta_info.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/24-meta_info.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/24-meta_info.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/24-meta_info.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,78 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
+ if $@;
+
+ plan skip_all => "Time::Piece required for this test"
+ unless eval { require Time::Piece };
+
+ plan tests => 12;
+}
+
+use Test::Warn;
+
+package Temp::DBI;
+use base qw(DBIx::Class::CDBICompat);
+Temp::DBI->columns(All => qw(id date));
+
+my $strptime_inflate = sub {
+ Time::Piece->strptime(shift, "%Y-%m-%d")
+};
+Temp::DBI->has_a(
+ date => 'Time::Piece',
+ inflate => $strptime_inflate
+);
+
+
+package Temp::Person;
+use base 'Temp::DBI';
+Temp::Person->table('people');
+Temp::Person->columns(Info => qw(name pet));
+Temp::Person->has_a( pet => 'Temp::Pet' );
+
+package Temp::Pet;
+use base 'Temp::DBI';
+Temp::Pet->table('pets');
+Temp::Pet->columns(Info => qw(name));
+Temp::Pet->has_many(owners => 'Temp::Person');
+
+package main;
+
+{
+ my $pn_meta = Temp::Person->meta_info('has_a');
+ is_deeply [sort keys %$pn_meta], [qw/date pet/], "Person has Date and Pet";
+}
+
+{
+ my $pt_meta = Temp::Pet->meta_info;
+ is_deeply [keys %{$pt_meta->{has_a}}], [qw/date/], "Pet has Date";
+ is_deeply [keys %{$pt_meta->{has_many}}], [qw/owners/], "And owners";
+}
+
+{
+ my $pet = Temp::Person->meta_info( has_a => 'pet' );
+ is $pet->class, 'Temp::Person';
+ is $pet->foreign_class, 'Temp::Pet';
+ is $pet->accessor, 'pet';
+ is $pet->name, 'has_a';
+}
+
+{
+ my $owners = Temp::Pet->meta_info( has_many => 'owners' );
+
+ is_deeply $owners->args, {
+ foreign_key => 'pet',
+ mapping => [],
+ };
+}
+
+{
+ my $date = Temp::Pet->meta_info( has_a => 'date' );
+ is $date->class, 'Temp::DBI';
+ is $date->foreign_class, 'Time::Piece';
+ is $date->accessor, 'date';
+ is $date->args->{inflate}, $strptime_inflate;
+}
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/24-meta_info.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/26-mutator.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/26-mutator.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/26-mutator.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/26-mutator.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,47 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
+ if $@;
+}
+
+BEGIN {
+ eval "use DBD::SQLite";
+ plan $@
+ ? (skip_all => 'needs DBD::SQLite for testing')
+ : (tests => 6);
+}
+
+use lib 't/cdbi/testlib';
+require Film;
+
+sub Film::accessor_name_for {
+ my ($class, $col) = @_;
+ return "sheep" if lc $col eq "numexplodingsheep";
+ return $col;
+}
+
+my $data = {
+ Title => 'Bad Taste',
+ Director => 'Peter Jackson',
+ Rating => 'R',
+};
+
+my $bt;
+eval {
+ my $data = $data;
+ $data->{sheep} = 1;
+ ok $bt = Film->insert($data), "Modified accessor - with
+accessor";
+ isa_ok $bt, "Film";
+};
+is $@, '', "No errors";
+
+eval {
+ ok $bt->sheep(2), 'Modified accessor, set';
+ ok $bt->update, 'Update';
+};
+is $@, '', "No errors";
+
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/26-mutator.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/30-pager.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/30-pager.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/30-pager.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/30-pager.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,52 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 6);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+my @film = (
+ Film->create({ Title => 'Film 1' }),
+ Film->create({ Title => 'Film 2' }),
+ Film->create({ Title => 'Film 3' }),
+ Film->create({ Title => 'Film 4' }),
+ Film->create({ Title => 'Film 5' }),
+);
+
+# first page
+my ( $pager, $it ) = Film->page(
+ {},
+ { rows => 3,
+ page => 1 }
+);
+
+is( $pager->entries_on_this_page, 3, "entries_on_this_page ok" );
+
+is( $pager->next_page, 2, "next_page ok" );
+
+is( $it->next->title, "Film 1", "iterator->next ok" );
+
+$it->next;
+$it->next;
+
+is( $it->next, undef, "next past end of page ok" );
+
+# second page
+( $pager, $it ) = Film->page(
+ {},
+ { rows => 3,
+ page => 2 }
+);
+
+is( $pager->entries_on_this_page, 2, "entries on second page ok" );
+
+is( $it->next->title, "Film 4", "second page first title ok" );
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/30-pager.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/68-inflate_has_a.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/68inflate_has_a.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/68-inflate_has_a.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/68-inflate_has_a.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,67 @@
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => "Class::Trigger and DBIx::ContextualFetch required"
+ if $@;
+
+ eval { require DateTime };
+ plan skip_all => "Need DateTime for inflation tests" if $@;
+
+ eval { require Clone };
+ plan skip_all => "Need Clone for CDBICompat inflation tests" if $@;
+}
+
+plan tests => 6;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+DBICTest::Schema::CD->load_components(qw/CDBICompat::Relationships/);
+
+DBICTest::Schema::CD->has_a( 'year', 'DateTime',
+ inflate => sub { DateTime->new( year => shift ) },
+ deflate => sub { shift->year }
+);
+Class::C3->reinitialize;
+
+# inflation test
+my $cd = $schema->resultset("CD")->find(3);
+
+is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' );
+
+is( $cd->year->month, 1, 'inflated month ok' );
+
+# deflate test
+my $now = DateTime->now;
+$cd->year( $now );
+$cd->update;
+
+($cd) = $schema->resultset("CD")->search( year => $now->year );
+is( $cd->year->year, $now->year, 'deflate ok' );
+
+# re-test using alternate deflate syntax
+$schema->class("CD")->has_a( 'year', 'DateTime',
+ inflate => sub { DateTime->new( year => shift ) },
+ deflate => 'year'
+);
+
+# inflation test
+$cd = $schema->resultset("CD")->find(3);
+
+is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' );
+
+is( $cd->year->month, 1, 'inflated month ok' );
+
+# deflate test
+$now = DateTime->now;
+$cd->year( $now );
+$cd->update;
+
+($cd) = $schema->resultset("CD")->search( year => $now->year );
+is( $cd->year->year, $now->year, 'deflate ok' );
+
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/68-inflate_has_a.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/98-failure.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/98-failure.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/98-failure.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/98-failure.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,62 @@
+use strict;
+use Test::More;
+
+#----------------------------------------------------------------------
+# Test database failures
+#----------------------------------------------------------------------
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 7);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+Film->create_test_film;
+
+{
+ my $btaste = Film->retrieve('Bad Taste');
+ isa_ok $btaste, 'Film', "We have Bad Taste";
+ {
+ no warnings 'redefine';
+ local *DBIx::ContextualFetch::st::execute = sub { die "Database died" };
+ eval { $btaste->delete };
+ ::like $@, qr/Database died/s, "We failed";
+ }
+ my $still = Film->retrieve('Bad Taste');
+ isa_ok $btaste, 'Film', "We still have Bad Taste";
+}
+
+{
+ my $btaste = Film->retrieve('Bad Taste');
+ isa_ok $btaste, 'Film', "We have Bad Taste";
+ $btaste->numexplodingsheep(10);
+ {
+ no warnings 'redefine';
+ local *DBIx::ContextualFetch::st::execute = sub { die "Database died" };
+ eval { $btaste->update };
+ ::like $@, qr/Database died/s, "We failed";
+ }
+ $btaste->discard_changes;
+ my $still = Film->retrieve('Bad Taste');
+ isa_ok $btaste, 'Film', "We still have Bad Taste";
+ is $btaste->numexplodingsheep, 1, "with 1 sheep";
+}
+
+if (0) {
+ my $sheep = Film->maximum_value_of('numexplodingsheep');
+ is $sheep, 1, "1 exploding sheep";
+ {
+ local *DBIx::ContextualFetch::st::execute = sub { die "Database died" };
+ my $sheep = eval { Film->maximum_value_of('numexplodingsheep') };
+ ::like $@, qr/select.*Database died/s,
+ "Handle database death in single value select";
+ }
+}
+
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/98-failure.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/DeepAbstractSearch (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-DeepAbstractSearch)
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/DeepAbstractSearch
___________________________________________________________________
Name: svn:mergeinfo
+
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/DeepAbstractSearch/01_search.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi-DeepAbstractSearch/01_search.t 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/DeepAbstractSearch/01_search.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -2,6 +2,12 @@
use Test::More;
BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
+ next;
+ }
+
plan skip_all => 'needs DBD::SQLite for testing'
unless eval { require DBD::SQLite };
@@ -11,7 +17,7 @@
plan tests => 19;
}
-my $DB = "t/testdb";
+my $DB = "t/var/cdbi_testdb";
unlink $DB if -e $DB;
my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 0 });
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/abstract (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-abstract)
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/abstract
___________________________________________________________________
Name: svn:mergeinfo
+
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/abstract/search_where.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi-abstract/search_where.t 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/abstract/search_where.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,5 +1,3 @@
-#!/usr/bin/perl -w
-
use Test::More;
use strict;
@@ -16,7 +14,7 @@
}
INIT {
- use lib 't/testlib';
+ use lib 't/cdbi/testlib';
use Film;
}
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/columns_as_hashes.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/columns_as_hashes.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/columns_as_hashes.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/columns_as_hashes.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,104 @@
+use strict;
+use Test::More;
+use Test::Warn;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : ('no_plan');
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+my $waves = Film->insert({
+ Title => "Breaking the Waves",
+ Director => 'Lars von Trier',
+ Rating => 'R'
+});
+
+local $ENV{DBIC_CDBICOMPAT_HASH_WARN} = 0;
+
+{
+ local $ENV{DBIC_CDBICOMPAT_HASH_WARN} = 1;
+
+ warnings_like {
+ my $rating = $waves->{rating};
+ $waves->Rating("PG");
+ is $rating, "R", 'evaluation of column value is not deferred';
+ } qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at \Q$0};
+
+ warnings_like {
+ is $waves->{title}, $waves->Title, "columns can be accessed as hashes";
+ } qr{^Column 'title' of 'Film/$waves' was fetched as a hash at\b};
+
+ $waves->Rating("G");
+
+ warnings_like {
+ is $waves->{rating}, "G", "updating via the accessor updates the hash";
+ } qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at\b};
+
+
+ warnings_like {
+ $waves->{rating} = "PG";
+ } qr{^Column 'rating' of 'Film/$waves' was stored as a hash at\b};
+
+ $waves->update;
+ my @films = Film->search( Rating => "PG", Title => "Breaking the Waves" );
+ is @films, 1, "column updated as hash was saved";
+}
+
+warning_is {
+ $waves->{rating}
+} '', 'DBIC_CDBICOMPAT_HASH_WARN controls warnings';
+
+
+{
+ $waves->rating("R");
+ $waves->update;
+
+ no warnings 'redefine';
+ local *Film::rating = sub {
+ return "wibble";
+ };
+
+ is $waves->{rating}, "R";
+}
+
+
+{
+ no warnings 'redefine';
+ no warnings 'once';
+ local *Actor::accessor_name_for = sub {
+ my($class, $col) = @_;
+ return "movie" if lc $col eq "film";
+ return $col;
+ };
+
+ require Actor;
+ Actor->has_a( film => "Film" );
+
+ my $actor = Actor->insert({
+ name => 'Emily Watson',
+ film => $waves,
+ });
+
+ ok !eval { $actor->film };
+ is $actor->{film}->id, $waves->id,
+ 'hash access still works despite lack of accessor';
+}
+
+
+# Emulate that Class::DBI inflates immediately
+SKIP: {
+ skip "Need MySQL to run this test", 3 unless eval { require MyFoo };
+
+ my $foo = MyFoo->insert({
+ name => 'Whatever',
+ tdate => '1949-02-01',
+ });
+ isa_ok $foo, 'MyFoo';
+
+ isa_ok $foo->{tdate}, 'Date::Simple';
+ is $foo->{tdate}->year, 1949;
+}
\ No newline at end of file
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/columns_as_hashes.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/columns_dont_override_custom_accessors.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/columns_dont_override_custom_accessors.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/columns_dont_override_custom_accessors.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/columns_dont_override_custom_accessors.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,32 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 5);
+}
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(TEMP => qw[foo bar]);
+ Thing->columns(All => qw[thing_id yarrow flower]);
+ sub foo { 42 }
+ sub yarrow { "hock" }
+}
+
+is_deeply( [sort Thing->columns("TEMP")],
+ [sort qw(foo bar)],
+ "TEMP columns set"
+);
+my $thing = Thing->construct(
+ { thing_id => 23, foo => "this", bar => "that" }
+);
+
+is( $thing->id, 23 );
+is( $thing->yarrow, "hock", 'custom accessor not overwritten by column' );
+is( $thing->foo, 42, 'custom routine not overwritten by temp column' );
+is( $thing->bar, "that", 'temp column accessor generated' );
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/columns_dont_override_custom_accessors.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/construct.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/construct.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/construct.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/construct.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,43 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 5);
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+ use Film;
+}
+
+{
+ Film->insert({
+ Title => "Breaking the Waves",
+ Director => 'Lars von Trier',
+ Rating => 'R'
+ });
+
+ my $film = Film->construct({
+ Title => "Breaking the Waves",
+ Director => 'Lars von Trier',
+ });
+
+ isa_ok $film, "Film";
+ is $film->title, "Breaking the Waves";
+ is $film->director, "Lars von Trier";
+ is $film->rating, "R",
+ "constructed objects can get missing data from the db";
+}
+
+{
+ package Foo;
+ use base qw(Film);
+ Foo->columns( TEMP => qw(temp_thing) );
+ my $film = Foo->construct({
+ temp_thing => 23
+ });
+
+ ::is $film->temp_thing, 23, "construct sets temp columns";
+}
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/construct.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/copy.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/copy.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/copy.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/copy.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,41 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 4);
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+}
+
+{
+ package # hide from PAUSE
+ MyFilm;
+
+ use base 'DBIx::Class::Test::SQLite';
+ use strict;
+
+ __PACKAGE__->set_table('Movies');
+ __PACKAGE__->columns(All => qw(id title));
+
+ sub create_sql {
+ return qq{
+ id INTEGER PRIMARY KEY AUTOINCREMENT,
+ title VARCHAR(255)
+ }
+ }
+}
+
+my $film = MyFilm->create({ title => "For Your Eyes Only" });
+ok $film->id;
+
+my $new_film = $film->copy;
+ok $new_film->id;
+isnt $new_film->id, $film->id, "copy() gets new primary key";
+
+$new_film = $film->copy(42);
+is $new_film->id, 42, "copy() with new id";
+
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/copy.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/early_column_heisenbug.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/early_column_heisenbug.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/early_column_heisenbug.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/early_column_heisenbug.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,28 @@
+use strict;
+
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : ('no_plan');
+}
+
+
+{
+ package Thing;
+ use base qw(DBIx::Class::CDBICompat);
+}
+
+{
+ package Stuff;
+ use base qw(DBIx::Class::CDBICompat);
+}
+
+# There was a bug where looking at a column group before any were
+# set would cause them to be shared across classes.
+is_deeply [Stuff->columns("Essential")], [];
+Thing->columns(Essential => qw(foo bar baz));
+is_deeply [Stuff->columns("Essential")], [];
+
+1;
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/early_column_heisenbug.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/has_many_loads_foreign_class.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/has_many_loads_foreign_class.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/has_many_loads_foreign_class.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/has_many_loads_foreign_class.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,37 @@
+use strict;
+use Test::More;
+
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => 'Class::Trigger and DBIx::ContextualFetch required' if $@;
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 3);
+}
+
+
+use lib 't/cdbi/testlib';
+use Director;
+
+# Test that has_many() will load the foreign class.
+ok !Class::Inspector->loaded( 'Film' );
+ok eval { Director->has_many( films => 'Film' ); 1; } || diag $@;
+
+my $shan_hua = Director->create({
+ Name => "Shan Hua",
+});
+
+my $inframan = Film->create({
+ Title => "Inframan",
+ Director => "Shan Hua",
+});
+my $guillotine2 = Film->create({
+ Title => "Flying Guillotine 2",
+ Director => "Shan Hua",
+});
+my $guillotine = Film->create({
+ Title => "Master of the Flying Guillotine",
+ Director => "Yu Wang",
+});
+
+is_deeply [sort $shan_hua->films], [sort $inframan, $guillotine2];
\ No newline at end of file
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/has_many_loads_foreign_class.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/hasa_without_loading.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/hasa_without_loading.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/hasa_without_loading.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/hasa_without_loading.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,21 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required')
+ : (tests=> 2);
+}
+
+package Foo;
+
+use base qw(DBIx::Class::CDBICompat);
+
+eval {
+ Foo->table("foo");
+ Foo->columns(Essential => qw(foo bar));
+ #Foo->has_a( bar => "This::Does::Not::Exist::Yet" );
+};
+#::is $@, '';
+::is(Foo->table, "foo");
+::is_deeply [sort map lc, Foo->columns], [sort map lc, qw(foo bar)];
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/hasa_without_loading.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/max_min_value_of.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/max_min_value_of.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/max_min_value_of.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/max_min_value_of.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,32 @@
+use strict;
+use Test::More;
+
+#----------------------------------------------------------------------
+# Test database failures
+#----------------------------------------------------------------------
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 2);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+
+Film->create({
+ title => "Bad Taste",
+ numexplodingsheep => 10,
+});
+
+Film->create({
+ title => "Evil Alien Conquerers",
+ numexplodingsheep => 2,
+});
+
+is( Film->maximum_value_of("numexplodingsheep"), 10 );
+is( Film->minimum_value_of("numexplodingsheep"), 2 );
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/max_min_value_of.t
___________________________________________________________________
Name: svn:mergeinfo
+
Added: DBIx-Class/0.08/branches/sybase/t/cdbi/mk_group_accessors.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/mk_group_accessors.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/mk_group_accessors.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,69 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => 'Class::Trigger and DBIx::ContextualFetch required' if $@;
+
+ eval "use DBD::SQLite";
+ plan skip_all => 'needs DBD::SQLite for testing' if $@;
+
+ plan 'no_plan';
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+ require Film;
+}
+
+sub Film::get_test {
+ my $self = shift;
+ my $key = shift;
+ $self->{get_test}++;
+ return $self->{$key};
+}
+
+sub Film::set_test {
+ my($self, $key, $val) = @_;
+ $self->{set_test}++;
+ return $self->{$key} = $val;
+}
+
+
+my $film = Film->create({ Title => "No Wolf McQuade" });
+
+# Test mk_group_accessors() with a list of fields.
+{
+ Film->mk_group_accessors(test => qw(foo bar));
+ $film->foo(42);
+ is $film->foo, 42;
+
+ $film->bar(23);
+ is $film->bar, 23;
+}
+
+
+# An explicit accessor passed to mk_group_accessors should
+# ignore accessor/mutator_name_for.
+sub Film::accessor_name_for {
+ my($class, $col) = @_;
+ return "hlaglagh" if $col eq "wibble";
+ return $col;
+}
+
+sub Film::mutator_name_for {
+ my($class, $col) = @_;
+ return "hlaglagh" if $col eq "wibble";
+ return $col;
+}
+
+
+# Test with a mix of fields and field specs
+{
+ Film->mk_group_accessors(test => ("baz", [wibble_thing => "wibble"]));
+ $film->baz(42);
+ is $film->baz, 42;
+
+ $film->wibble_thing(23);
+ is $film->wibble_thing, 23;
+}
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/mk_group_accessors.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/multi_column_set.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/multi_column_set.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/multi_column_set.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/multi_column_set.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,25 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 3);
+}
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(TEMP => qw[foo bar baz]);
+ Thing->columns(All => qw[some real stuff]);
+}
+
+my $thing = Thing->construct({ foo => 23, some => 42, baz => 99 });
+$thing->set( foo => "wibble", some => "woosh" );
+is $thing->foo, "wibble";
+is $thing->some, "woosh";
+is $thing->baz, 99;
+
+$thing->discard_changes;
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/multi_column_set.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/object_cache.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/object_cache.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/object_cache.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/object_cache.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,82 @@
+use strict;
+use Test::More;
+$| = 1;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ }
+
+ eval "use DBD::SQLite";
+ plan skip_all => 'needs DBD::SQLite for testing' if $@;
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+ use Film;
+}
+
+plan skip_all => "Object cache is turned off"
+ if Film->isa("DBIx::Class::CDBICompat::NoObjectIndex");
+
+plan tests => 5;
+
+
+ok +Film->create({
+ Title => 'This Is Spinal Tap',
+ Director => 'Rob Reiner',
+ Rating => 'R',
+});
+
+{
+ my $film1 = Film->retrieve( "This Is Spinal Tap" );
+ my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+ $film1->Director("Marty DiBergi");
+ is $film2->Director, "Marty DiBergi", 'retrieve returns the same object';
+
+ $film1->discard_changes;
+}
+
+{
+ Film->nocache(1);
+
+ my $film1 = Film->retrieve( "This Is Spinal Tap" );
+ my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+ $film1->Director("Marty DiBergi");
+ is $film2->Director, "Rob Reiner",
+ 'caching turned off';
+
+ $film1->discard_changes;
+}
+
+{
+ Film->nocache(0);
+
+ my $film1 = Film->retrieve( "This Is Spinal Tap" );
+ my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+ $film1->Director("Marty DiBergi");
+ is $film2->Director, "Marty DiBergi",
+ 'caching back on';
+
+ $film1->discard_changes;
+}
+
+
+{
+ Film->nocache(1);
+
+ local $Class::DBI::Weaken_Is_Available = 0;
+
+ my $film1 = Film->retrieve( "This Is Spinal Tap" );
+ my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+ $film1->Director("Marty DiBergi");
+ is $film2->Director, "Rob Reiner",
+ 'CDBI::Weaken_Is_Available turns off all caching';
+
+ $film1->discard_changes;
+}
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/object_cache.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/retrieve_from_sql_with_limit.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/retrieve_from_sql_with_limit.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/retrieve_from_sql_with_limit.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/retrieve_from_sql_with_limit.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,25 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 3);
+}
+
+INIT {
+ use lib 't/cdbi/testlib';
+ use Film;
+}
+
+for my $title ("Bad Taste", "Braindead", "Forgotten Silver") {
+ Film->insert({ Title => $title, Director => 'Peter Jackson' });
+}
+
+Film->insert({ Title => "Transformers", Director => "Michael Bay"});
+
+{
+ my @films = Film->retrieve_from_sql(qq[director = "Peter Jackson" LIMIT 2]);
+ is @films, 2, "retrieve_from_sql with LIMIT";
+ is( $_->director, "Peter Jackson" ) for @films;
+}
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/retrieve_from_sql_with_limit.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/set_to_undef.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/set_to_undef.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/set_to_undef.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/set_to_undef.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,32 @@
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
+ if $@;
+ plan skip_all => "DateTime required" unless eval { require DateTime };
+ plan tests => 2;
+}
+
+
+# Don't use Test::NoWarnings because of an unrelated DBD::SQLite warning.
+my @warnings;
+local $SIG{__WARN__} = sub {
+ push @warnings, @_;
+};
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(All => qw[thing_id this that date]);
+}
+
+my $thing = Thing->construct({ thing_id => 23, this => 42 });
+$thing->set( this => undef );
+is $thing->get( "this" ), undef, 'undef set';
+$thing->discard_changes;
+
+is @warnings, 0, 'no warnings';
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/set_to_undef.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/set_vs_DateTime.t (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-t/set_vs_DateTime.t)
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/cdbi/set_vs_DateTime.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/set_vs_DateTime.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,30 @@
+use strict;
+use Test::More;
+use Test::Exception;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
+ if $@;
+ plan skip_all => "DateTime required" unless eval { require DateTime };
+ plan tests => 1;
+}
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(All => qw[thing_id this that date]);
+}
+
+my $thing = Thing->construct({ thing_id => 23, date => "01-02-1994" });
+my $date = DateTime->now;
+lives_ok {
+ $thing->set( date => $date );
+ $thing->set( date => $date );
+};
+
+
+
+$thing->discard_changes;
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/set_vs_DateTime.t
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/sweet (from rev 4765, DBIx-Class/0.08/branches/sybase/t/cdbi-sweet-t)
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/sweet
___________________________________________________________________
Name: svn:mergeinfo
+
Copied: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib (from rev 4765, DBIx-Class/0.08/branches/sybase/t/testlib)
Property changes on: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib
___________________________________________________________________
Name: svn:mergeinfo
+
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Actor.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/testlib/Actor.pm 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Actor.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,8 +1,6 @@
package # hide from PAUSE
Actor;
-BEGIN { unshift @INC, './t/testlib'; }
-
use strict;
use warnings;
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/ActorAlias.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/testlib/ActorAlias.pm 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/ActorAlias.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,27 +1,25 @@
-package # hide from PAUSE
- ActorAlias;
-
-BEGIN { unshift @INC, './t/testlib'; }
-
-use strict;
-use warnings;
-
-use base 'DBIx::Class::Test::SQLite';
-
-__PACKAGE__->set_table( 'ActorAlias' );
-
-__PACKAGE__->columns( Primary => 'id' );
-__PACKAGE__->columns( All => qw/ actor alias / );
-__PACKAGE__->has_a( actor => 'Actor' );
-__PACKAGE__->has_a( alias => 'Actor' );
-
-sub create_sql {
- return qq{
- id INTEGER PRIMARY KEY,
- actor INTEGER,
- alias INTEGER
- }
-}
-
-1;
-
+package # hide from PAUSE
+ ActorAlias;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Test::SQLite';
+
+__PACKAGE__->set_table( 'ActorAlias' );
+
+__PACKAGE__->columns( Primary => 'id' );
+__PACKAGE__->columns( All => qw/ actor alias / );
+__PACKAGE__->has_a( actor => 'Actor' );
+__PACKAGE__->has_a( alias => 'Actor' );
+
+sub create_sql {
+ return qq{
+ id INTEGER PRIMARY KEY,
+ actor INTEGER,
+ alias INTEGER
+ }
+}
+
+1;
+
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Binary.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/testlib/Binary.pm 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Binary.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,8 +1,6 @@
package # hide from PAUSE
Binary;
-BEGIN { unshift @INC, './t/testlib'; }
-
use strict;
use base 'PgBase';
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Blurb.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/testlib/Blurb.pm 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Blurb.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,8 +1,6 @@
package # hide from PAUSE
Blurb;
-BEGIN { unshift @INC, './t/testlib'; }
-
use strict;
use base 'DBIx::Class::Test::SQLite';
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Director.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/testlib/Director.pm 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Director.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,8 +1,6 @@
package # hide from PAUSE
Director;
-BEGIN { unshift @INC, './t/testlib'; }
-
use strict;
use base 'DBIx::Class::Test::SQLite';
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Film.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/testlib/Film.pm 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Film.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,7 +1,6 @@
package # hide from PAUSE
Film;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'DBIx::Class::Test::SQLite';
use strict;
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Lazy.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/testlib/Lazy.pm 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Lazy.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,7 +1,6 @@
package # hide from PAUSE
Lazy;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'DBIx::Class::Test::SQLite';
use strict;
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Log.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/testlib/Log.pm 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Log.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,7 +1,6 @@
package # hide from PAUSE
Log;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'MyBase';
use strict;
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyBase.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/testlib/MyBase.pm 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyBase.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -8,7 +8,8 @@
use vars qw/$dbh/;
-my @connect = ("dbi:mysql:test", "", "");
+# temporary, might get switched to the new test framework someday
+my @connect = ("dbi:mysql:test", "", "", { PrintError => 0});
$dbh = DBI->connect(@connect) or die DBI->errstr;
my @table;
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyFilm.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/testlib/MyFilm.pm 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyFilm.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,7 +1,6 @@
package # hide from PAUSE
MyFilm;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'MyBase';
use MyStarLink;
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyFoo.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/testlib/MyFoo.pm 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyFoo.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,7 +1,6 @@
package # hide from PAUSE
MyFoo;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'MyBase';
use strict;
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyStar.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/testlib/MyStar.pm 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyStar.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,7 +1,6 @@
package # hide from PAUSE
MyStar;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'MyBase';
use strict;
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyStarLink.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/testlib/MyStarLink.pm 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyStarLink.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,7 +1,6 @@
package # hide from PAUSE
MyStarLink;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'MyBase';
use strict;
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyStarLinkMCPK.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/testlib/MyStarLinkMCPK.pm 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/MyStarLinkMCPK.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,7 +1,6 @@
package # hide from PAUSE
MyStarLinkMCPK;
-BEGIN { unshift @INC, './t/testlib'; }
use base 'MyBase';
use MyStar;
Modified: DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Order.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/testlib/Order.pm 2008-08-24 14:56:31 UTC (rev 4765)
+++ DBIx-Class/0.08/branches/sybase/t/cdbi/testlib/Order.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,8 +1,6 @@
package # hide from PAUSE
Order;
-BEGIN { unshift @INC, './t/testlib'; }
-
use strict;
use base 'DBIx::Class::Test::SQLite';
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBIC/DebugObj.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBIC/DebugObj.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBIC/DebugObj.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,50 @@
+package DBIC::DebugObj;
+
+use strict;
+use warnings;
+
+use Class::C3;
+
+use base qw/DBIx::Class::Storage::Statistics Exporter Class::Accessor::Fast/;
+
+__PACKAGE__->mk_accessors( qw/dbictest_sql_ref dbictest_bind_ref/ );
+
+
+=head2 new(PKG, SQL_REF, BIND_REF, ...)
+
+Creates a new instance that on subsequent queries will store
+the generated SQL to the scalar pointed to by SQL_REF and bind
+values to the array pointed to by BIND_REF.
+
+=cut
+
+sub new {
+ my $pkg = shift;
+ my $sql_ref = shift;
+ my $bind_ref = shift;
+
+ my $self = $pkg->SUPER::new(@_);
+
+ $self->debugfh(undef);
+
+ $self->dbictest_sql_ref($sql_ref);
+ $self->dbictest_bind_ref($bind_ref || []);
+
+ return $self;
+}
+
+sub query_start {
+ my $self = shift;
+
+ (${$self->dbictest_sql_ref}, @{$self->dbictest_bind_ref}) = @_;
+}
+
+sub query_end { }
+
+sub txn_start { }
+
+sub txn_commit { }
+
+sub txn_rollback { }
+
+1;
Property changes on: DBIx-Class/0.08/branches/sybase/t/lib/DBIC/DebugObj.pm
___________________________________________________________________
Name: svn:eol-style
+ native
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBIC/SqlMakerTest.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBIC/SqlMakerTest.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBIC/SqlMakerTest.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,248 @@
+package DBIC::SqlMakerTest;
+
+use strict;
+use warnings;
+
+use base qw/Test::Builder::Module Exporter/;
+
+our @EXPORT = qw/
+ &is_same_sql_bind
+ &is_same_sql
+ &is_same_bind
+ &eq_sql
+ &eq_bind
+ &eq_sql_bind
+/;
+
+
+{
+ package DBIC::SqlMakerTest::SQLATest;
+
+ # replacement for SQL::Abstract::Test if not available
+
+ use strict;
+ use warnings;
+
+ use base qw/Test::Builder::Module Exporter/;
+
+ use Scalar::Util qw(looks_like_number blessed reftype);
+ use Data::Dumper;
+ use Test::Builder;
+ use Test::Deep qw(eq_deeply);
+
+ our $tb = __PACKAGE__->builder;
+
+ sub is_same_sql_bind
+ {
+ my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
+
+ my $same_sql = eq_sql($sql1, $sql2);
+ my $same_bind = eq_bind($bind_ref1, $bind_ref2);
+
+ $tb->ok($same_sql && $same_bind, $msg);
+
+ if (!$same_sql) {
+ _sql_differ_diag($sql1, $sql2);
+ }
+ if (!$same_bind) {
+ _bind_differ_diag($bind_ref1, $bind_ref2);
+ }
+ }
+
+ sub is_same_sql
+ {
+ my ($sql1, $sql2, $msg) = @_;
+
+ my $same_sql = eq_sql($sql1, $sql2);
+
+ $tb->ok($same_sql, $msg);
+
+ if (!$same_sql) {
+ _sql_differ_diag($sql1, $sql2);
+ }
+ }
+
+ sub is_same_bind
+ {
+ my ($bind_ref1, $bind_ref2, $msg) = @_;
+
+ my $same_bind = eq_bind($bind_ref1, $bind_ref2);
+
+ $tb->ok($same_bind, $msg);
+
+ if (!$same_bind) {
+ _bind_differ_diag($bind_ref1, $bind_ref2);
+ }
+ }
+
+ sub _sql_differ_diag
+ {
+ my ($sql1, $sql2) = @_;
+
+ $tb->diag("SQL expressions differ\n"
+ . " got: $sql1\n"
+ . "expected: $sql2\n"
+ );
+ }
+
+ sub _bind_differ_diag
+ {
+ my ($bind_ref1, $bind_ref2) = @_;
+
+ $tb->diag("BIND values differ\n"
+ . " got: " . Dumper($bind_ref1)
+ . "expected: " . Dumper($bind_ref2)
+ );
+ }
+
+ sub eq_sql
+ {
+ my ($left, $right) = @_;
+
+ $left =~ s/\s+//g;
+ $right =~ s/\s+//g;
+
+ return $left eq $right;
+ }
+
+ sub eq_bind
+ {
+ my ($bind_ref1, $bind_ref2) = @_;
+
+ return eq_deeply($bind_ref1, $bind_ref2);
+ }
+
+ sub eq_sql_bind
+ {
+ my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
+
+ return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
+ }
+}
+
+eval "use SQL::Abstract::Test;";
+if ($@ eq '') {
+ # SQL::Abstract::Test available
+
+ *is_same_sql_bind = \&SQL::Abstract::Test::is_same_sql_bind;
+ *is_same_sql = \&SQL::Abstract::Test::is_same_sql;
+ *is_same_bind = \&SQL::Abstract::Test::is_same_bind;
+ *eq_sql = \&SQL::Abstract::Test::eq_sql;
+ *eq_bind = \&SQL::Abstract::Test::eq_bind;
+ *eq_sql_bind = \&SQL::Abstract::Test::eq_sql_bind;
+} else {
+ # old SQL::Abstract
+
+ *is_same_sql_bind = \&DBIC::SqlMakerTest::SQLATest::is_same_sql_bind;
+ *is_same_sql = \&DBIC::SqlMakerTest::SQLATest::is_same_sql;
+ *is_same_bind = \&DBIC::SqlMakerTest::SQLATest::is_same_bind;
+ *eq_sql = \&DBIC::SqlMakerTest::SQLATest::eq_sql;
+ *eq_bind = \&DBIC::SqlMakerTest::SQLATest::eq_bind;
+ *eq_sql_bind = \&DBIC::SqlMakerTest::SQLATest::eq_sql_bind;
+}
+
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+DBIC::SqlMakerTest - Helper package for testing sql_maker component of DBIC
+
+=head1 SYNOPSIS
+
+ use Test::More;
+ use DBIC::SqlMakerTest;
+
+ my ($sql, @bind) = $schema->storage->sql_maker->select(%args);
+ is_same_sql_bind(
+ $sql, \@bind,
+ $expected_sql, \@expected_bind,
+ 'foo bar works'
+ );
+
+=head1 DESCRIPTION
+
+Exports functions that can be used to compare generated SQL and bind values.
+
+If L<SQL::Abstract::Test> (packaged in L<SQL::Abstract> versions 1.50 and
+above) is available, then it is used to perform the comparisons (all functions
+are delegated to id). Otherwise uses simple string comparison for the SQL
+statements and simple L<Data::Dumper>-like recursive stringification for
+comparison of bind values.
+
+
+=head1 FUNCTIONS
+
+=head2 is_same_sql_bind
+
+ is_same_sql_bind(
+ $given_sql, \@given_bind,
+ $expected_sql, \@expected_bind,
+ $test_msg
+ );
+
+Compares given and expected pairs of C<($sql, \@bind)>, and calls
+L<Test::Builder/ok> on the result, with C<$test_msg> as message.
+
+=head2 is_same_sql
+
+ is_same_sql(
+ $given_sql,
+ $expected_sql,
+ $test_msg
+ );
+
+Compares given and expected SQL statement, and calls L<Test::Builder/ok> on the
+result, with C<$test_msg> as message.
+
+=head2 is_same_bind
+
+ is_same_bind(
+ \@given_bind,
+ \@expected_bind,
+ $test_msg
+ );
+
+Compares given and expected bind value lists, and calls L<Test::Builder/ok> on
+the result, with C<$test_msg> as message.
+
+=head2 eq_sql
+
+ my $is_same = eq_sql($given_sql, $expected_sql);
+
+Compares the two SQL statements. Returns true IFF they are equivalent.
+
+=head2 eq_bind
+
+ my $is_same = eq_sql(\@given_bind, \@expected_bind);
+
+Compares two lists of bind values. Returns true IFF their values are the same.
+
+=head2 eq_sql_bind
+
+ my $is_same = eq_sql_bind(
+ $given_sql, \@given_bind,
+ $expected_sql, \@expected_bind
+ );
+
+Compares the two SQL statements and the two lists of bind values. Returns true
+IFF they are equivalent and the bind values are the same.
+
+
+=head1 SEE ALSO
+
+L<SQL::Abstract::Test>, L<Test::More>, L<Test::Builder>.
+
+=head1 AUTHOR
+
+Norbert Buchmuller, <norbi at nix.hu>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2008 by Norbert Buchmuller.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
Property changes on: DBIx-Class/0.08/branches/sybase/t/lib/DBIC/SqlMakerTest.pm
___________________________________________________________________
Name: svn:eol-style
+ native
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/ResultSet/Foo.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/ResultSet/Foo.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/ResultSet/Foo.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,8 @@
+package DBICNSTest::RtBug41083::ResultSet::Foo;
+use strict;
+use warnings;
+use base 'DBICNSTest::RtBug41083::ResultSet';
+
+sub fooBar { 1; }
+
+1;
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/ResultSet.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/ResultSet.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/ResultSet.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,5 @@
+package DBICNSTest::RtBug41083::ResultSet;
+use strict;
+use warnings;
+use base 'DBIx::Class::ResultSet';
+1;
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/ResultSet_A/A.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/ResultSet_A/A.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/ResultSet_A/A.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,7 @@
+package DBICNSTest::RtBug41083::ResultSet_A::A;
+use strict;
+use warnings;
+use base 'DBICNSTest::RtBug41083::ResultSet';
+
+sub fooBar { 1; }
+1;
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema/Foo/Sub.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema/Foo/Sub.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema/Foo/Sub.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,5 @@
+package DBICNSTest::RtBug41083::Schema::Foo::Sub;
+use strict;
+use warnings;
+use base 'DBICNSTest::RtBug41083::Schema::Foo';
+1;
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema/Foo.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema/Foo.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema/Foo.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,8 @@
+package DBICNSTest::RtBug41083::Schema::Foo;
+use strict;
+use warnings;
+use base 'DBIx::Class';
+__PACKAGE__->load_components('Core');
+__PACKAGE__->table('foo');
+__PACKAGE__->add_columns('foo');
+1;
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema_A/A/Sub.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema_A/A/Sub.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema_A/A/Sub.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,5 @@
+package DBICNSTest::RtBug41083::Schema_A::A::Sub;
+use strict;
+use warnings;
+use base 'DBICNSTest::RtBug41083::Schema_A::A';
+1;
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema_A/A.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema_A/A.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICNSTest/RtBug41083/Schema_A/A.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,8 @@
+package DBICNSTest::RtBug41083::Schema_A::A;
+use strict;
+use warnings;
+use base 'DBIx::Class';
+__PACKAGE__->load_components('Core');
+__PACKAGE__->table('a');
+__PACKAGE__->add_columns('a');
+1;
Modified: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Artist.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Artist.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Artist.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -19,6 +19,15 @@
size => 100,
is_nullable => 1,
},
+ rank => {
+ data_type => 'integer',
+ default_value => 13,
+ },
+ charfield => {
+ data_type => 'char',
+ size => 10,
+ is_nullable => 1,
+ },
);
__PACKAGE__->set_primary_key('artistid');
@@ -44,12 +53,17 @@
{ cascade_copy => 0 } # this would *so* not make sense
);
+__PACKAGE__->has_many(
+ artist_to_artwork => 'DBICTest::Schema::Artwork_to_Artist' => 'artist_id'
+);
+__PACKAGE__->many_to_many('artworks', 'artist_to_artwork', 'artwork');
+
+
sub sqlt_deploy_hook {
my ($self, $sqlt_table) = @_;
-
if ($sqlt_table->schema->translator->producer_type =~ /SQLite$/ ) {
- $sqlt_table->add_index( name => 'artist_name', fields => ['name'] )
+ $sqlt_table->add_index( name => 'artist_name_hookidx', fields => ['name'] )
or die $sqlt_table->error;
}
}
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Artwork.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Artwork.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Artwork.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,19 @@
+package # hide from PAUSE
+ DBICTest::Schema::Artwork;
+
+use base qw/DBIx::Class::Core/;
+
+__PACKAGE__->table('cd_artwork');
+__PACKAGE__->add_columns(
+ 'cd_id' => {
+ data_type => 'integer',
+ },
+);
+__PACKAGE__->set_primary_key('cd_id');
+__PACKAGE__->belongs_to('cd', 'DBICTest::Schema::CD', 'cd_id');
+__PACKAGE__->has_many('images', 'DBICTest::Schema::Image', 'artwork_id');
+
+__PACKAGE__->has_many('artwork_to_artist', 'DBICTest::Schema::Artwork_to_Artist', 'artwork_cd_id');
+__PACKAGE__->many_to_many('artists', 'artwork_to_artist', 'artist');
+
+1;
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Artwork_to_Artist.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Artwork_to_Artist.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Artwork_to_Artist.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,21 @@
+package # hide from PAUSE
+ DBICTest::Schema::Artwork_to_Artist;
+
+use base qw/DBIx::Class::Core/;
+
+__PACKAGE__->table('artwork_to_artist');
+__PACKAGE__->add_columns(
+ 'artwork_cd_id' => {
+ data_type => 'integer',
+ is_foreign_key => 1,
+ },
+ 'artist_id' => {
+ data_type => 'integer',
+ is_foreign_key => 1,
+ },
+);
+__PACKAGE__->set_primary_key(qw/artwork_cd_id artist_id/);
+__PACKAGE__->belongs_to('artwork', 'DBICTest::Schema::Artwork', 'artwork_cd_id');
+__PACKAGE__->belongs_to('artist', 'DBICTest::Schema::Artist', 'artist_id');
+
+1;
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/BindType.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/BindType.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/BindType.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,29 @@
+package # hide from PAUSE
+ DBICTest::Schema::BindType;
+
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table('bindtype_test');
+
+__PACKAGE__->add_columns(
+ 'id' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'bytea' => {
+ data_type => 'bytea',
+ is_nullable => 1,
+ },
+ 'blob' => {
+ data_type => 'blob',
+ is_nullable => 1,
+ },
+ 'clob' => {
+ data_type => 'clob',
+ is_nullable => 1,
+ },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
Modified: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Bookmark.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Bookmark.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Bookmark.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -8,7 +8,6 @@
use warnings;
__PACKAGE__->table('bookmark');
-__PACKAGE__->add_columns(qw/id link/);
__PACKAGE__->add_columns(
'id' => {
data_type => 'integer',
Modified: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/BooksInLibrary.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/BooksInLibrary.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/BooksInLibrary.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -20,6 +20,10 @@
data_type => 'varchar',
size => '100',
},
+ 'price' => {
+ data_type => 'integer',
+ is_nullable => 1,
+ },
);
__PACKAGE__->set_primary_key('id');
Modified: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/CD.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/CD.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/CD.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -20,16 +20,26 @@
data_type => 'varchar',
size => 100,
},
+ 'genreid' => {
+ data_type => 'integer',
+ is_nullable => 1,
+ },
+ 'single_track' => {
+ data_type => 'integer',
+ is_nullable => 1,
+ is_foreign_key => 1,
+ }
);
__PACKAGE__->set_primary_key('cdid');
__PACKAGE__->add_unique_constraint([ qw/artist title/ ]);
__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist', undef, {
is_deferrable => 1,
- on_delete => undef,
- on_update => 'SET NULL',
});
+# in case this is a single-cd it promotes a track from another cd
+__PACKAGE__->belongs_to( single_track => 'DBICTest::Schema::Track' );
+
__PACKAGE__->has_many( tracks => 'DBICTest::Schema::Track' );
__PACKAGE__->has_many(
tags => 'DBICTest::Schema::Tag', undef,
@@ -43,10 +53,33 @@
liner_notes => 'DBICTest::Schema::LinerNotes', undef,
{ proxy => [ qw/notes/ ] },
);
+__PACKAGE__->might_have(artwork => 'DBICTest::Schema::Artwork', 'cd_id');
+
__PACKAGE__->many_to_many( producers => cd_to_producer => 'producer' );
__PACKAGE__->many_to_many(
producers_sorted => cd_to_producer => 'producer',
{ order_by => 'producer.name' },
);
+__PACKAGE__->belongs_to('genre', 'DBICTest::Schema::Genre',
+ { 'foreign.genreid' => 'self.genreid' },
+ {
+ join_type => 'left',
+ on_delete => 'SET NULL',
+ on_update => 'CASCADE',
+ },
+);
+
+#This second relationship was added to test the short-circuiting of pointless
+#queries provided by undef_on_null_fk. the relevant test in 66relationship.t
+__PACKAGE__->belongs_to('genre_inefficient', 'DBICTest::Schema::Genre',
+ { 'foreign.genreid' => 'self.genreid' },
+ {
+ join_type => 'left',
+ on_delete => 'SET NULL',
+ on_update => 'CASCADE',
+ undef_on_null_fk => 0,
+ },
+);
+
1;
Modified: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/CD_to_Producer.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/CD_to_Producer.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/CD_to_Producer.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -17,7 +17,8 @@
__PACKAGE__->belongs_to(
'producer', 'DBICTest::Schema::Producer',
- { 'foreign.producerid' => 'self.producer' }
+ { 'foreign.producerid' => 'self.producer' },
+ { on_delete => undef, on_update => undef },
);
1;
Modified: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Employee.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Employee.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Employee.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -23,6 +23,10 @@
data_type => 'integer',
is_nullable => 1,
},
+ group_id_3 => {
+ data_type => 'integer',
+ is_nullable => 1,
+ },
name => {
data_type => 'varchar',
size => 100,
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Encoded.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Encoded.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Encoded.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,39 @@
+package # hide from PAUSE
+ DBICTest::Schema::Encoded;
+
+use base 'DBIx::Class::Core';
+
+use strict;
+use warnings;
+
+__PACKAGE__->table('encoded');
+__PACKAGE__->add_columns(
+ 'id' => {
+ data_type => 'integer',
+ is_auto_increment => 1
+ },
+ 'encoded' => {
+ data_type => 'varchar',
+ size => 100,
+ is_nullable => 1,
+ },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+sub set_column {
+ my ($self, $col, $value) = @_;
+ if( $col eq 'encoded' ){
+ $value = reverse split '', $value;
+ }
+ $self->next::method($col, $value);
+}
+
+sub new {
+ my($self, $attr, @rest) = @_;
+ $attr->{encoded} = reverse split '', $attr->{encoded}
+ if defined $attr->{encoded};
+ return $self->next::method($attr, @rest);
+}
+
+1;
Modified: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Event.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Event.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Event.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -11,7 +11,10 @@
__PACKAGE__->add_columns(
id => { data_type => 'integer', is_auto_increment => 1 },
starts_at => { data_type => 'datetime', datetime_undef_if_invalid => 1 },
- created_on => { data_type => 'timestamp' }
+ created_on => { data_type => 'timestamp' },
+ varchar_date => { data_type => 'varchar', inflate_date => 1, size => 20, is_nullable => 1 },
+ varchar_datetime => { data_type => 'varchar', inflate_datetime => 1, size => 20, is_nullable => 1 },
+ skip_inflation => { data_type => 'datetime', inflate_datetime => 0, is_nullable => 1 },
);
__PACKAGE__->set_primary_key('id');
Modified: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/EventTZ.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/EventTZ.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/EventTZ.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -10,8 +10,8 @@
__PACKAGE__->add_columns(
id => { data_type => 'integer', is_auto_increment => 1 },
- starts_at => { data_type => 'datetime', extra => { timezone => "America/Chicago" } },
- created_on => { data_type => 'timestamp', extra => { timezone => "America/Chicago" } },
+ starts_at => { data_type => 'datetime', extra => { timezone => "America/Chicago", locale => 'de_DE' } },
+ created_on => { data_type => 'timestamp', extra => { timezone => "America/Chicago", floating_tz_ok => 1 } },
);
__PACKAGE__->set_primary_key('id');
Modified: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/ForceForeign.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/ForceForeign.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/ForceForeign.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -29,4 +29,13 @@
},
);
+# Normally this would appear as a FK constraint
+__PACKAGE__->belongs_to(
+ 'cd_3', 'DBICTest::Schema::CD', {
+ 'foreign.cdid' => 'self.cd',
+ }, {
+ is_foreign_key_constraint => 0,
+ },
+);
+
1;
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Genre.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Genre.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Genre.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,23 @@
+package DBICTest::Schema::Genre;
+
+use strict;
+
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table('genre');
+__PACKAGE__->add_columns(
+ genreid => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ name => {
+ data_type => 'varchar',
+ size => 100,
+ },
+);
+__PACKAGE__->set_primary_key('genreid');
+__PACKAGE__->add_unique_constraint ( genre_name => [qw/name/] );
+
+__PACKAGE__->has_many (cds => 'DBICTest::Schema::CD', 'genreid');
+
+1;
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Image.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Image.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Image.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,28 @@
+package # hide from PAUSE
+ DBICTest::Schema::Image;
+
+use base qw/DBIx::Class::Core/;
+
+__PACKAGE__->table('images');
+__PACKAGE__->add_columns(
+ 'id' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'artwork_id' => {
+ data_type => 'integer',
+ is_foreign_key => 1,
+ },
+ 'name' => {
+ data_type => 'varchar',
+ size => 100,
+ },
+ 'data' => {
+ data_type => 'blob',
+ is_nullable => 1,
+ },
+);
+__PACKAGE__->set_primary_key('id');
+__PACKAGE__->belongs_to('artwork', 'DBICTest::Schema::Artwork', 'artwork_id');
+
+1;
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/LyricVersion.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/LyricVersion.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/LyricVersion.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,24 @@
+package # hide from PAUSE
+ DBICTest::Schema::LyricVersion;
+
+use base qw/DBIx::Class::Core/;
+
+__PACKAGE__->table('lyric_versions');
+__PACKAGE__->add_columns(
+ 'id' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'lyric_id' => {
+ data_type => 'integer',
+ is_foreign_key => 1,
+ },
+ 'text' => {
+ data_type => 'varchar',
+ size => 100,
+ },
+);
+__PACKAGE__->set_primary_key('id');
+__PACKAGE__->belongs_to('lyric', 'DBICTest::Schema::Lyrics', 'lyric_id');
+
+1;
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Lyrics.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Lyrics.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Lyrics.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,21 @@
+package # hide from PAUSE
+ DBICTest::Schema::Lyrics;
+
+use base qw/DBIx::Class::Core/;
+
+__PACKAGE__->table('lyrics');
+__PACKAGE__->add_columns(
+ 'lyric_id' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'track_id' => {
+ data_type => 'integer',
+ is_foreign_key => 1,
+ },
+);
+__PACKAGE__->set_primary_key('lyric_id');
+__PACKAGE__->belongs_to('track', 'DBICTest::Schema::Track', 'track_id');
+__PACKAGE__->has_many('lyric_versions', 'DBICTest::Schema::LyricVersion', 'lyric_id');
+
+1;
Modified: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Producer.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Producer.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Producer.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -17,4 +17,8 @@
__PACKAGE__->set_primary_key('producerid');
__PACKAGE__->add_unique_constraint(prod_name => [ qw/name/ ]);
+__PACKAGE__->has_many(
+ producer_to_cd => 'DBICTest::Schema::CD_to_Producer' => 'producer'
+);
+__PACKAGE__->many_to_many('cds', 'producer_to_cd', 'cd');
1;
Modified: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Track.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Track.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Track.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -2,7 +2,7 @@
DBICTest::Schema::Track;
use base 'DBIx::Class::Core';
-__PACKAGE__->load_components(qw/InflateColumn::DateTime/);
+__PACKAGE__->load_components(qw/InflateColumn::DateTime Ordered/);
__PACKAGE__->table('track');
__PACKAGE__->add_columns(
@@ -32,7 +32,14 @@
__PACKAGE__->add_unique_constraint([ qw/cd position/ ]);
__PACKAGE__->add_unique_constraint([ qw/cd title/ ]);
+__PACKAGE__->position_column ('position');
+__PACKAGE__->grouping_column ('cd');
+
+
__PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD' );
__PACKAGE__->belongs_to( disc => 'DBICTest::Schema::CD' => 'cd');
+__PACKAGE__->might_have( cd_single => 'DBICTest::Schema::CD', 'single_track' );
+__PACKAGE__->might_have( lyrics => 'DBICTest::Schema::Lyrics', 'track_id' );
+
1;
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Year1999CDs.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Year1999CDs.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Year1999CDs.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,32 @@
+package # hide from PAUSE
+ DBICTest::Schema::Year1999CDs;
+## Used in 104view.t
+
+use base 'DBIx::Class::Core';
+use DBIx::Class::ResultSource::View;
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+
+__PACKAGE__->table('year1999cds');
+__PACKAGE__->result_source_instance->is_virtual(1);
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT cdid, artist, title FROM cd WHERE year ='1999'"
+);
+__PACKAGE__->add_columns(
+ 'cdid' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'artist' => {
+ data_type => 'integer',
+ },
+ 'title' => {
+ data_type => 'varchar',
+ size => 100,
+ },
+
+);
+__PACKAGE__->set_primary_key('cdid');
+__PACKAGE__->add_unique_constraint([ qw/artist title/ ]);
+
+1;
Added: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Year2000CDs.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Year2000CDs.pm (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema/Year2000CDs.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,31 @@
+package # hide from PAUSE
+ DBICTest::Schema::Year2000CDs;
+## Used in 104view.t
+
+use base 'DBIx::Class::Core';
+use DBIx::Class::ResultSource::View;
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+
+__PACKAGE__->table('year2000cds');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT cdid, artist, title FROM cd WHERE year ='2000'"
+);
+__PACKAGE__->add_columns(
+ 'cdid' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'artist' => {
+ data_type => 'integer',
+ },
+ 'title' => {
+ data_type => 'varchar',
+ size => 100,
+ },
+
+);
+__PACKAGE__->set_primary_key('cdid');
+__PACKAGE__->add_unique_constraint([ qw/artist title/ ]);
+
+1;
Modified: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest/Schema.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -8,17 +8,26 @@
__PACKAGE__->load_classes(qw/
Artist
SequenceTest
+ BindType
Employee
CD
FileColumn
+ Genre
Link
Bookmark
#dummy
Track
Tag
+ Year2000CDs
+ Year1999CDs
/,
{ 'DBICTest::Schema' => [qw/
LinerNotes
+ Artwork
+ Artwork_to_Artist
+ Image
+ Lyrics
+ LyricVersion
OneKey
#dummy
TwoKeys
@@ -34,10 +43,11 @@
'ArtistSubclass',
'Producer',
'CD_to_Producer',
+ 'Dummy', # this is a real result class we remove in the hook below
),
qw/SelfRefAlias TreeLike TwoKeyTreeLike Event EventTZ NoPrimaryKey/,
qw/Collection CollectionObject TypedObject Owners BooksInLibrary/,
- qw/ForceForeign/,
+ qw/ForceForeign Encoded/,
);
sub sqlt_deploy_hook {
Modified: DBIx-Class/0.08/branches/sybase/t/lib/DBICTest.pm
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/DBICTest.pm 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/lib/DBICTest.pm 2009-02-26 23:40:04 UTC (rev 5651)
@@ -51,12 +51,20 @@
}
sub _sqlite_dbfilename {
- return "t/var/DBIxClass.db";
+ return "t/var/DBIxClass.db";
}
+sub _sqlite_dbname {
+ my $self = shift;
+ my %args = @_;
+ return $self->_sqlite_dbfilename if $args{sqlite_use_file} or $ENV{"DBICTEST_SQLITE_USE_FILE"};
+ return ":memory:";
+}
+
sub _database {
my $self = shift;
- my $db_file = $self->_sqlite_dbfilename;
+ my %args = @_;
+ my $db_file = $self->_sqlite_dbname(%args);
unlink($db_file) if -e $db_file;
unlink($db_file . "-journal") if -e $db_file . "-journal";
@@ -76,10 +84,10 @@
my %args = @_;
my $schema;
-
+
if ($args{compose_connection}) {
$schema = DBICTest::Schema->compose_connection(
- 'DBICTest', $self->_database
+ 'DBICTest', $self->_database(%args)
);
} else {
$schema = DBICTest::Schema->compose_namespace('DBICTest');
@@ -88,7 +96,7 @@
$schema->storage_type($args{storage_type});
}
if ( !$args{no_connect} ) {
- $schema = $schema->connect($self->_database);
+ $schema = $schema->connect($self->_database(%args));
$schema->storage->on_connect_do(['PRAGMA synchronous = OFF'])
unless $self->has_custom_dsn;
}
@@ -124,7 +132,11 @@
my $sql;
{ local $/ = undef; $sql = <IN>; }
close IN;
- ($schema->storage->dbh->do($_) || print "Error on SQL: $_\n") for split(/;\n/, $sql);
+ for my $chunk ( split (/;\s*\n+/, $sql) ) {
+ if ( $chunk =~ / ^ (?! --\s* ) \S /xm ) { # there is some real sql in the chunk - a non-space at the start of the string which is not a comment
+ $schema->storage->dbh->do($chunk) or print "Error on SQL: $chunk\n";
+ }
+ }
}
return;
}
@@ -259,8 +271,8 @@
]);
$schema->populate('Event', [
- [ qw/id starts_at created_on/ ],
- [ 1, '2006-04-25 22:24:33', '2006-06-22 21:00:05'],
+ [ qw/id starts_at created_on varchar_date varchar_datetime skip_inflation/ ],
+ [ 1, '2006-04-25 22:24:33', '2006-06-22 21:00:05', '2006-07-23', '2006-05-22 19:05:07', '2006-04-21 18:04:06'],
]);
$schema->populate('Link', [
@@ -303,10 +315,10 @@
]);
$schema->populate('BooksInLibrary', [
- [ qw/id owner title source/ ],
- [ 1, 1, "Programming Perl", "Library" ],
- [ 2, 1, "Dynamical Systems", "Library" ],
- [ 3, 2, "Best Recipe Cookbook", "Library" ],
+ [ qw/id owner title source price/ ],
+ [ 1, 1, "Programming Perl", "Library", 23 ],
+ [ 2, 1, "Dynamical Systems", "Library", 37 ],
+ [ 3, 2, "Best Recipe Cookbook", "Library", 65 ],
]);
}
Modified: DBIx-Class/0.08/branches/sybase/t/lib/sqlite.sql
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/lib/sqlite.sql 2009-02-26 23:31:58 UTC (rev 5650)
+++ DBIx-Class/0.08/branches/sybase/t/lib/sqlite.sql 2009-02-26 23:40:04 UTC (rev 5651)
@@ -1,86 +1,85 @@
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Tue Aug 8 01:53:20 2006
+-- Created on Sun Feb 22 00:15:06 2009
--
+
+
BEGIN TRANSACTION;
--
--- Table: employee
+-- Table: artist
--
-CREATE TABLE employee (
- employee_id INTEGER PRIMARY KEY NOT NULL,
- position integer NOT NULL,
- group_id integer,
- group_id_2 integer,
- name varchar(100)
+CREATE TABLE artist (
+ artistid INTEGER PRIMARY KEY NOT NULL,
+ name varchar(100),
+ rank integer NOT NULL DEFAULT '13',
+ charfield char(10)
);
--
--- Table: serialized
+-- Table: artist_undirected_map
--
-CREATE TABLE serialized (
- id INTEGER PRIMARY KEY NOT NULL,
- serialized text NOT NULL
+CREATE TABLE artist_undirected_map (
+ id1 integer NOT NULL,
+ id2 integer NOT NULL,
+ PRIMARY KEY (id1, id2)
);
---
--- Table: liner_notes
---
-CREATE TABLE liner_notes (
- liner_id INTEGER PRIMARY KEY NOT NULL,
- notes varchar(100) NOT NULL
-);
+CREATE INDEX artist_undirected_map_idx_id1_ ON artist_undirected_map (id1);
+CREATE INDEX artist_undirected_map_idx_id2_ ON artist_undirected_map (id2);
+
--
--- Table: cd_to_producer
+-- Table: cd_artwork
--
-CREATE TABLE cd_to_producer (
- cd integer NOT NULL,
- producer integer NOT NULL,
- PRIMARY KEY (cd, producer)
+CREATE TABLE cd_artwork (
+ cd_id INTEGER PRIMARY KEY NOT NULL
);
+CREATE INDEX cd_artwork_idx_cd_id_cd_artwor ON cd_artwork (cd_id);
+
--
--- Table: artist
+-- Table: artwork_to_artist
--
-CREATE TABLE artist (
- artistid INTEGER PRIMARY KEY NOT NULL,
- name varchar(100)
+CREATE TABLE artwork_to_artist (
+ artwork_cd_id integer NOT NULL,
+ artist_id integer NOT NULL,
+ PRIMARY KEY (artwork_cd_id, artist_id)
);
+CREATE INDEX artwork_to_artist_idx_artist_id_artwork_to_arti ON artwork_to_artist (artist_id);
+
+CREATE INDEX artwork_to_artist_idx_artwork_cd_id_artwork_to_ ON artwork_to_artist (artwork_cd_id);
+
--
--- Table: twokeytreelike
+-- Table: bindtype_test
--
-CREATE TABLE twokeytreelike (
- id1 integer NOT NULL,
- id2 integer NOT NULL,
- parent1 integer NOT NULL,
- parent2 integer NOT NULL,
- name varchar(100) NOT NULL,
- PRIMARY KEY (id1, id2)
+CREATE TABLE bindtype_test (
+ id INTEGER PRIMARY KEY NOT NULL,
+ bytea blob,
+ blob blob,
+ clob clob
);
--
--- Table: fourkeys_to_twokeys
+-- Table: bookmark
--
-CREATE TABLE fourkeys_to_twokeys (
- f_foo integer NOT NULL,
- f_bar integer NOT NULL,
- f_hello integer NOT NULL,
- f_goodbye integer NOT NULL,
- t_artist integer NOT NULL,
- t_cd integer NOT NULL,
- autopilot character NOT NULL,
- PRIMARY KEY (f_foo, f_bar, f_hello, f_goodbye, t_artist, t_cd)
+CREATE TABLE bookmark (
+ id INTEGER PRIMARY KEY NOT NULL,
+ link integer NOT NULL
);
+CREATE INDEX bookmark_idx_link_bookmark ON bookmark (link);
+
--
--- Table: self_ref_alias
+-- Table: books
--
-CREATE TABLE self_ref_alias (
- self_ref integer NOT NULL,
- alias integer NOT NULL,
- PRIMARY KEY (self_ref, alias)
+CREATE TABLE books (
+ id INTEGER PRIMARY KEY NOT NULL,
+ source varchar(100) NOT NULL,
+ owner integer NOT NULL,
+ title varchar(100) NOT NULL,
+ price integer
);
--
@@ -90,43 +89,83 @@
cdid INTEGER PRIMARY KEY NOT NULL,
artist integer NOT NULL,
title varchar(100) NOT NULL,
- year varchar(100) NOT NULL
+ year varchar(100) NOT NULL,
+ genreid integer,
+ single_track integer
);
+CREATE INDEX cd_idx_artist_cd ON cd (artist);
+
+CREATE INDEX cd_idx_genreid_cd ON cd (genreid);
+
+CREATE INDEX cd_idx_single_track_cd ON cd (single_track);
+
+CREATE UNIQUE INDEX cd_artist_title_cd ON cd (artist, title);
+
--
--- Table: bookmark
+-- Table: cd_to_producer
--
-CREATE TABLE bookmark (
- id INTEGER PRIMARY KEY NOT NULL,
- link integer NOT NULL
+CREATE TABLE cd_to_producer (
+ cd integer NOT NULL,
+ producer integer NOT NULL,
+ PRIMARY KEY (cd, producer)
);
+CREATE INDEX cd_to_producer_idx_cd_cd_to_pr ON cd_to_producer (cd);
+
+CREATE INDEX cd_to_producer_idx_producer_cd ON cd_to_producer (producer);
+
--
--- Table: track
+-- Table: collection
--
-CREATE TABLE track (
- trackid INTEGER PRIMARY KEY NOT NULL,
- cd integer NOT NULL,
+CREATE TABLE collection (
+ collectionid INTEGER PRIMARY KEY NOT NULL,
+ name varchar(100) NOT NULL
+);
+
+--
+-- Table: collection_object
+--
+CREATE TABLE collection_object (
+ collection integer NOT NULL,
+ object integer NOT NULL,
+ PRIMARY KEY (collection, object)
+);
+
+CREATE INDEX collection_object_idx_collection_collection_obj ON collection_object (collection);
+
+CREATE INDEX collection_object_idx_object_c ON collection_object (object);
+
+--
+-- Table: employee
+--
+CREATE TABLE employee (
+ employee_id INTEGER PRIMARY KEY NOT NULL,
position integer NOT NULL,
- title varchar(100) NOT NULL,
- last_updated_on datetime NULL
+ group_id integer,
+ group_id_2 integer,
+ group_id_3 integer,
+ name varchar(100)
);
--
--- Table: self_ref
+-- Table: encoded
--
-CREATE TABLE self_ref (
+CREATE TABLE encoded (
id INTEGER PRIMARY KEY NOT NULL,
- name varchar(100) NOT NULL
+ encoded varchar(100)
);
--
--- Table: link
+-- Table: event
--
-CREATE TABLE link (
+CREATE TABLE event (
id INTEGER PRIMARY KEY NOT NULL,
- url varchar(100),
- title varchar(100)
+ starts_at datetime NOT NULL,
+ created_on timestamp NOT NULL,
+ varchar_date varchar(20),
+ varchar_datetime varchar(20),
+ skip_inflation datetime
);
--
@@ -134,46 +173,112 @@
--
CREATE TABLE file_columns (
id INTEGER PRIMARY KEY NOT NULL,
- file varchar(255)
+ file varchar(255) NOT NULL
);
--
--- Table: tags
+-- Table: forceforeign
--
-CREATE TABLE tags (
- tagid INTEGER PRIMARY KEY NOT NULL,
- cd integer NOT NULL,
- tag varchar(100) NOT NULL
+CREATE TABLE forceforeign (
+ artist INTEGER PRIMARY KEY NOT NULL,
+ cd integer NOT NULL
);
+CREATE INDEX forceforeign_idx_artist_forcef ON forceforeign (artist);
+
--
--- Table: treelike
+-- Table: fourkeys
--
-CREATE TABLE treelike (
- id INTEGER PRIMARY KEY NOT NULL,
- parent integer NULL,
+CREATE TABLE fourkeys (
+ foo integer NOT NULL,
+ bar integer NOT NULL,
+ hello integer NOT NULL,
+ goodbye integer NOT NULL,
+ sensors character NOT NULL,
+ PRIMARY KEY (foo, bar, hello, goodbye)
+);
+
+--
+-- Table: fourkeys_to_twokeys
+--
+CREATE TABLE fourkeys_to_twokeys (
+ f_foo integer NOT NULL,
+ f_bar integer NOT NULL,
+ f_hello integer NOT NULL,
+ f_goodbye integer NOT NULL,
+ t_artist integer NOT NULL,
+ t_cd integer NOT NULL,
+ autopilot character NOT NULL,
+ PRIMARY KEY (f_foo, f_bar, f_hello, f_goodbye, t_artist, t_cd)
+);
+
+CREATE INDEX fourkeys_to_twokeys_idx_f_foo_f_bar_f_hello_f_goodbye_ ON fourkeys_to_twokeys (f_foo, f_bar, f_hello, f_goodbye);
+
+CREATE INDEX fourkeys_to_twokeys_idx_t_artist_t_cd_fourkeys_to ON fourkeys_to_twokeys (t_artist, t_cd);
+
+--
+-- Table: genre
+--
+CREATE TABLE genre (
+ genreid INTEGER PRIMARY KEY NOT NULL,
name varchar(100) NOT NULL
);
+CREATE UNIQUE INDEX genre_name_genre ON genre (name);
+
--
--- Table: event
+-- Table: images
--
-CREATE TABLE event (
+CREATE TABLE images (
id INTEGER PRIMARY KEY NOT NULL,
- starts_at datetime NOT NULL,
- created_on timestamp NOT NULL
+ artwork_id integer NOT NULL,
+ name varchar(100) NOT NULL,
+ data blob
);
+CREATE INDEX images_idx_artwork_id_images ON images (artwork_id);
+
--
--- Table: twokeys
+-- Table: liner_notes
--
-CREATE TABLE twokeys (
- artist integer NOT NULL,
- cd integer NOT NULL,
- PRIMARY KEY (artist, cd)
+CREATE TABLE liner_notes (
+ liner_id INTEGER PRIMARY KEY NOT NULL,
+ notes varchar(100) NOT NULL
);
+CREATE INDEX liner_notes_idx_liner_id_liner ON liner_notes (liner_id);
+
--
+-- Table: link
+--
+CREATE TABLE link (
+ id INTEGER PRIMARY KEY NOT NULL,
+ url varchar(100),
+ title varchar(100)
+);
+
+--
+-- Table: lyric_versions
+--
+CREATE TABLE lyric_versions (
+ id INTEGER PRIMARY KEY NOT NULL,
+ lyric_id integer NOT NULL,
+ text varchar(100) NOT NULL
+);
+
+CREATE INDEX lyric_versions_idx_lyric_id_ly ON lyric_versions (lyric_id);
+
+--
+-- Table: lyrics
+--
+CREATE TABLE lyrics (
+ lyric_id INTEGER PRIMARY KEY NOT NULL,
+ track_id integer NOT NULL
+);
+
+CREATE INDEX lyrics_idx_track_id_lyrics ON lyrics (track_id);
+
+--
-- Table: noprimarykey
--
CREATE TABLE noprimarykey (
@@ -182,25 +287,23 @@
baz integer NOT NULL
);
+CREATE UNIQUE INDEX foo_bar_noprimarykey ON noprimarykey (foo, bar);
+
--
--- Table: fourkeys
+-- Table: onekey
--
-CREATE TABLE fourkeys (
- foo integer NOT NULL,
- bar integer NOT NULL,
- hello integer NOT NULL,
- goodbye integer NOT NULL,
- sensors character NOT NULL,
- PRIMARY KEY (foo, bar, hello, goodbye)
+CREATE TABLE onekey (
+ id INTEGER PRIMARY KEY NOT NULL,
+ artist integer NOT NULL,
+ cd integer NOT NULL
);
--
--- Table: artist_undirected_map
+-- Table: owners
--
-CREATE TABLE artist_undirected_map (
- id1 integer NOT NULL,
- id2 integer NOT NULL,
- PRIMARY KEY (id1, id2)
+CREATE TABLE owners (
+ ownerid INTEGER PRIMARY KEY NOT NULL,
+ name varchar(100) NOT NULL
);
--
@@ -211,63 +314,127 @@
name varchar(100) NOT NULL
);
+CREATE UNIQUE INDEX prod_name_producer ON producer (name);
+
--
--- Table: onekey
+-- Table: self_ref
--
-CREATE TABLE onekey (
+CREATE TABLE self_ref (
id INTEGER PRIMARY KEY NOT NULL,
- artist integer NOT NULL,
- cd integer NOT NULL
+ name varchar(100) NOT NULL
);
--
--- Table: typed_object
+-- Table: self_ref_alias
--
-CREATE TABLE typed_object (
- objectid INTEGER PRIMARY KEY NOT NULL,
- type VARCHAR(100) NOT NULL,
- value VARCHAR(100)
+CREATE TABLE self_ref_alias (
+ self_ref integer NOT NULL,
+ alias integer NOT NULL,
+ PRIMARY KEY (self_ref, alias)
);
+CREATE INDEX self_ref_alias_idx_alias_self_ ON self_ref_alias (alias);
+
+CREATE INDEX self_ref_alias_idx_self_ref_se ON self_ref_alias (self_ref);
+
--
--- Table: collection
+-- Table: sequence_test
--
-CREATE TABLE collection (
- collectionid INTEGER PRIMARY KEY NOT NULL,
- name VARCHAR(100)
+CREATE TABLE sequence_test (
+ pkid1 integer NOT NULL,
+ pkid2 integer NOT NULL,
+ nonpkid integer NOT NULL,
+ name varchar(100),
+ PRIMARY KEY (pkid1, pkid2)
);
--
--- Table: collection_object
+-- Table: serialized
--
-CREATE TABLE collection_object (
- collection INTEGER NOT NULL,
- object INTEGER NOT NULL
+CREATE TABLE serialized (
+ id INTEGER PRIMARY KEY NOT NULL,
+ serialized text NOT NULL
);
--
--- Table: owners
+-- Table: tags
--
-CREATE TABLE owners (
- ownerid INTEGER PRIMARY KEY NOT NULL,
- name varchar(100)
+CREATE TABLE tags (
+ tagid INTEGER PRIMARY KEY NOT NULL,
+ cd integer NOT NULL,
+ tag varchar(100) NOT NULL
);
+CREATE INDEX tags_idx_cd_tags ON tags (cd);
+
--
--- Table: books
+-- Table: track
--
-CREATE TABLE books (
+CREATE TABLE track (
+ trackid INTEGER PRIMARY KEY NOT NULL,
+ cd integer NOT NULL,
+ position integer NOT NULL,
+ title varchar(100) NOT NULL,
+ last_updated_on datetime
+);
+
+CREATE INDEX track_idx_cd_track ON track (cd);
+
+CREATE UNIQUE INDEX track_cd_position_track ON track (cd, position);
+
+CREATE UNIQUE INDEX track_cd_title_track ON track (cd, title);
+
+--
+-- Table: treelike
+--
+CREATE TABLE treelike (
id INTEGER PRIMARY KEY NOT NULL,
- owner INTEGER,
- source varchar(100),
- title varchar(100)
+ parent integer,
+ name varchar(100) NOT NULL
);
+CREATE INDEX treelike_idx_parent_treelike ON treelike (parent);
-CREATE UNIQUE INDEX tktlnameunique_twokeytreelike on twokeytreelike (name);
-CREATE UNIQUE INDEX cd_artist_title_cd on cd (artist, title);
-CREATE UNIQUE INDEX track_cd_position_track on track (cd, position);
-CREATE UNIQUE INDEX track_cd_title_track on track (cd, title);
-CREATE UNIQUE INDEX foo_bar_noprimarykey on noprimarykey (foo, bar);
-CREATE UNIQUE INDEX prod_name_producer on producer (name);
+--
+-- Table: twokeytreelike
+--
+CREATE TABLE twokeytreelike (
+ id1 integer NOT NULL,
+ id2 integer NOT NULL,
+ parent1 integer NOT NULL,
+ parent2 integer NOT NULL,
+ name varchar(100) NOT NULL,
+ PRIMARY KEY (id1, id2)
+);
+
+CREATE INDEX twokeytreelike_idx_parent1_parent2_twokeytre ON twokeytreelike (parent1, parent2);
+
+CREATE UNIQUE INDEX tktlnameunique_twokeytreelike ON twokeytreelike (name);
+
+--
+-- Table: twokeys
+--
+CREATE TABLE twokeys (
+ artist integer NOT NULL,
+ cd integer NOT NULL,
+ PRIMARY KEY (artist, cd)
+);
+
+CREATE INDEX twokeys_idx_artist_twokeys ON twokeys (artist);
+
+--
+-- Table: typed_object
+--
+CREATE TABLE typed_object (
+ objectid INTEGER PRIMARY KEY NOT NULL,
+ type varchar(100) NOT NULL,
+ value varchar(100) NOT NULL
+);
+
+--
+-- View: year2000cds
+--
+CREATE VIEW year2000cds AS
+ SELECT cdid, artist, title FROM cd WHERE year ='2000';
+
COMMIT;
Added: DBIx-Class/0.08/branches/sybase/t/ordered/cascade_delete.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/ordered/cascade_delete.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/ordered/cascade_delete.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,31 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+use POSIX qw(ceil);
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 1;
+
+{
+ my $artist = $schema->resultset ('Artist')->search ({}, { rows => 1})->single; # braindead sqlite
+ my $cd = $schema->resultset ('CD')->create ({
+ artist => $artist,
+ title => 'Get in order',
+ year => 2009,
+ tracks => [
+ { title => 'T1' },
+ { title => 'T2' },
+ { title => 'T3' },
+ ],
+ });
+
+ lives_ok (sub { $cd->delete}, "Cascade delete on ordered has_many doesn't bomb");
+}
+
+1;
Property changes on: DBIx-Class/0.08/branches/sybase/t/ordered/cascade_delete.t
___________________________________________________________________
Name: svn:mergeinfo
+
Added: DBIx-Class/0.08/branches/sybase/t/resultset/as_query.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/resultset/as_query.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/resultset/as_query.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,74 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings FATAL => 'all';
+
+use Data::Dumper;
+
+use Test::More;
+
+BEGIN {
+ eval "use SQL::Abstract 1.49";
+ plan $@
+ ? ( skip_all => "Needs SQLA 1.49+" )
+ : ( tests => 4 );
+}
+
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema();
+my $art_rs = $schema->resultset('Artist');
+my $cdrs = $schema->resultset('CD');
+
+{
+ my $arr = $art_rs->as_query;
+ my ($query, @bind) = @{$$arr};
+
+ is_same_sql_bind(
+ $query, \@bind,
+ "(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me)", [],
+ );
+}
+
+$art_rs = $art_rs->search({ name => 'Billy Joel' });
+
+{
+ my $arr = $art_rs->as_query;
+ my ($query, @bind) = @{$$arr};
+
+ is_same_sql_bind(
+ $query, \@bind,
+ "(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE ( name = ? ))",
+ [ [ name => 'Billy Joel' ] ],
+ );
+}
+
+$art_rs = $art_rs->search({ rank => 2 });
+
+{
+ my $arr = $art_rs->as_query;
+ my ($query, @bind) = @{$$arr};
+
+ is_same_sql_bind(
+ $query, \@bind,
+ "(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE ( ( ( rank = ? ) AND ( name = ? ) ) ) )",
+ [ [ rank => 2 ], [ name => 'Billy Joel' ] ],
+ );
+}
+
+my $rscol = $art_rs->get_column( 'charfield' );
+
+{
+ my $arr = $rscol->as_query;
+ my ($query, @bind) = @{$$arr};
+
+ is_same_sql_bind(
+ $query, \@bind,
+ "(SELECT me.charfield FROM artist me WHERE ( ( ( rank = ? ) AND ( name = ? ) ) ) )",
+ [ [ rank => 2 ], [ name => 'Billy Joel' ] ],
+ );
+}
+
+__END__
Added: DBIx-Class/0.08/branches/sybase/t/search/subquery.t
===================================================================
--- DBIx-Class/0.08/branches/sybase/t/search/subquery.t (rev 0)
+++ DBIx-Class/0.08/branches/sybase/t/search/subquery.t 2009-02-26 23:40:04 UTC (rev 5651)
@@ -0,0 +1,170 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings FATAL => 'all';
+
+use Data::Dumper;
+
+use Test::More;
+
+BEGIN {
+ eval "use SQL::Abstract 1.49";
+ plan $@
+ ? ( skip_all => "Needs SQLA 1.49+" )
+ : ( tests => 7 );
+}
+
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema();
+my $art_rs = $schema->resultset('Artist');
+my $cdrs = $schema->resultset('CD');
+
+{
+ my $cdrs2 = $cdrs->search({
+ artist_id => { 'in' => $art_rs->search({}, { rows => 1 })->get_column( 'id' )->as_query },
+ });
+
+ my $arr = $cdrs2->as_query;
+ my ($query, @bind) = @{$$arr};
+ is_same_sql_bind(
+ $query, \@bind,
+ "SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE artist_id IN ( SELECT id FROM artist me LIMIT 1 )",
+ [],
+ );
+}
+
+{
+ my $rs = $art_rs->search(
+ {},
+ {
+ 'select' => [
+ $cdrs->search({}, { rows => 1 })->get_column('id')->as_query,
+ ],
+ },
+ );
+
+ my $arr = $rs->as_query;
+ my ($query, @bind) = @{$$arr};
+ is_same_sql_bind(
+ $query, \@bind,
+ "SELECT (SELECT id FROM cd me LIMIT 1) FROM artist me",
+ [],
+ );
+}
+
+{
+ my $rs = $art_rs->search(
+ {},
+ {
+ '+select' => [
+ $cdrs->search({}, { rows => 1 })->get_column('id')->as_query,
+ ],
+ },
+ );
+
+ my $arr = $rs->as_query;
+ my ($query, @bind) = @{$$arr};
+ is_same_sql_bind(
+ $query, \@bind,
+ "SELECT me.artistid, me.name, me.rank, me.charfield, (SELECT id FROM cd me LIMIT 1) FROM artist me",
+ [],
+ );
+}
+
+# simple from
+{
+ my $rs = $cdrs->search(
+ {},
+ {
+ alias => 'cd2',
+ from => [
+ { cd2 => $cdrs->search({ id => { '>' => 20 } })->as_query },
+ ],
+ },
+ );
+
+ my $arr = $rs->as_query;
+ my ($query, @bind) = @{$$arr};
+ is_same_sql_bind(
+ $query, \@bind,
+ "SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE id > 20) cd2",
+ [],
+ );
+}
+
+# nested from
+{
+ my $art_rs2 = $schema->resultset('Artist')->search({},
+ {
+ from => [ { 'me' => 'artist' },
+ [ { 'cds' => $cdrs->search({},{ 'select' => [\'me.artist as cds_artist' ]})->as_query },
+ { 'me.artistid' => 'cds_artist' } ] ]
+ });
+
+ my $arr = $art_rs2->as_query;
+ my ($query, @bind) = @{$$arr};
+ is_same_sql_bind(
+ $query, \@bind,
+ "SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me JOIN (SELECT me.artist as cds_artist FROM cd me) cds ON me.artistid = cds_artist", []
+ );
+
+
+}
+
+# nested subquery in from
+{
+ my $rs = $cdrs->search(
+ {},
+ {
+ alias => 'cd2',
+ from => [
+ { cd2 => $cdrs->search(
+ { id => { '>' => 20 } },
+ {
+ alias => 'cd3',
+ from => [
+ { cd3 => $cdrs->search( { id => { '<' => 40 } } )->as_query }
+ ],
+ }, )->as_query },
+ ],
+ },
+ );
+
+ my $arr = $rs->as_query;
+ my ($query, @bind) = @{$$arr};
+ is_same_sql_bind(
+ $query, \@bind,
+ "SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track
+ FROM
+ (SELECT cd3.cdid,cd3.artist,cd3.title,cd3.year,cd3.genreid,cd3.single_track
+ FROM
+ (SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track
+ FROM cd me WHERE id < 40) cd3
+ WHERE id > 20) cd2",
+ [],
+ );
+
+}
+
+{
+ my $rs = $cdrs->search({
+ year => {
+ '=' => $cdrs->search(
+ { artistid => { '=' => \'me.artistid' } },
+ { alias => 'inner' }
+ )->get_column('year')->max_rs->as_query,
+ },
+ });
+ my $arr = $rs->as_query;
+ my ($query, @bind) = @{$$arr};
+ is_same_sql_bind(
+ $query, \@bind,
+ "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE year = (SELECT MAX(inner.year) FROM cd inner WHERE artistid = me.artistid)",
+ [],
+ );
+}
+
+__END__
More information about the Bast-commits
mailing list