From: Brandon Black Date: Mon, 22 May 2006 21:28:48 +0000 (+0000) Subject: Merging branches/DBIx-Class-Schema-Loader-refactor back into trunk: X-Git-Tag: 0.03000~3 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=996be9ee6e82ec9928f801ecdc69c9e07d64339c;p=dbsrgits%2FDBIx-Class-Schema-Loader.git Merging branches/DBIx-Class-Schema-Loader-refactor back into trunk: ------------------------------------------------------------------------ r945 | castaway | 2006-02-21 06:34:44 -0600 (Tue, 21 Feb 2006) | 2 lines Create DBIC schema refactor branch for blblack ------------------------------------------------------------------------ r946 | blblack | 2006-02-21 06:53:22 -0600 (Tue, 21 Feb 2006) | 1 line reshuffling the modules ------------------------------------------------------------------------ r947 | blblack | 2006-02-21 07:17:33 -0600 (Tue, 21 Feb 2006) | 1 line the basics of a storage-type agnostic design ------------------------------------------------------------------------ r981 | blblack | 2006-02-27 18:20:59 -0600 (Mon, 27 Feb 2006) | 1 line change the default pluralization, and release 0.02999_01 ------------------------------------------------------------------------ r1020 | blblack | 2006-03-04 10:51:32 -0600 (Sat, 04 Mar 2006) | 1 line merged in relevant changes from trunk to this point, released 0.02999_02 ------------------------------------------------------------------------ r1043 | blblack | 2006-03-08 20:46:03 -0600 (Wed, 08 Mar 2006) | 1 line ->_setup for storage subclass operations at the end of ->new ------------------------------------------------------------------------ r1044 | blblack | 2006-03-08 20:47:20 -0600 (Wed, 08 Mar 2006) | 1 line copying out RelBuilder.pm ------------------------------------------------------------------------ r1045 | blblack | 2006-03-09 00:27:18 -0600 (Thu, 09 Mar 2006) | 1 line committing new interfaces work, not yet done, only Pg passes tests ------------------------------------------------------------------------ r1060 | blblack | 2006-03-11 11:29:12 -0600 (Sat, 11 Mar 2006) | 1 line sqlite and pg working with new rels interface and new DBI base code ------------------------------------------------------------------------ r1061 | blblack | 2006-03-11 12:32:02 -0600 (Sat, 11 Mar 2006) | 1 line mysql updates ------------------------------------------------------------------------ r1062 | blblack | 2006-03-11 13:28:16 -0600 (Sat, 11 Mar 2006) | 1 line RelBuilder made close to what it should be ------------------------------------------------------------------------ r1065 | blblack | 2006-03-11 17:41:15 -0600 (Sat, 11 Mar 2006) | 1 line Added EXAMPLE pod section from Kieren Diment ------------------------------------------------------------------------ r1066 | blblack | 2006-03-11 17:42:02 -0600 (Sat, 11 Mar 2006) | 1 line silence and test for the expected no-pk warning ------------------------------------------------------------------------ r1067 | blblack | 2006-03-11 17:47:44 -0600 (Sat, 11 Mar 2006) | 1 line db2 made to work again, DBI methods made more general in nature, drop_db_schema option removed, table/col names forced to lowercase everywhere for sanity sake ------------------------------------------------------------------------ r1069 | blblack | 2006-03-11 19:03:18 -0600 (Sat, 11 Mar 2006) | 1 line quoting/name_sep fixes, column order corrected, ->{_column_info_broken} flag ------------------------------------------------------------------------ r1070 | blblack | 2006-03-12 17:55:15 -0600 (Sun, 12 Mar 2006) | 1 line some improvements to _tables_list and _table_columns_info, and a new (failing) test for unique constraints ------------------------------------------------------------------------ r1071 | blblack | 2006-03-12 17:59:22 -0600 (Sun, 12 Mar 2006) | 1 line make tests more resilient against interrupt and restart ------------------------------------------------------------------------ r1072 | blblack | 2006-03-12 18:25:02 -0600 (Sun, 12 Mar 2006) | 1 line implemented unique constraint loading for Postgres ------------------------------------------------------------------------ r1073 | blblack | 2006-03-12 19:02:08 -0600 (Sun, 12 Mar 2006) | 1 line version bumped, Pg unique support improved, mysql unique support added, mysql pk support changed to use same (better) method as unique ------------------------------------------------------------------------ r1074 | blblack | 2006-03-12 22:55:07 -0600 (Sun, 12 Mar 2006) | 1 line added basic unique single-col unique support for sqlite and db2, clean out some vestigial test junk ------------------------------------------------------------------------ r1075 | blblack | 2006-03-12 23:13:07 -0600 (Sun, 12 Mar 2006) | 1 line added test for multi-col uniques, added db2 support for them (sqlite still missing it) ------------------------------------------------------------------------ r1076 | blblack | 2006-03-12 23:22:38 -0600 (Sun, 12 Mar 2006) | 1 line added multi-col unique support for sqlite ------------------------------------------------------------------------ r1080 | blblack | 2006-03-13 11:01:03 -0600 (Mon, 13 Mar 2006) | 1 line some test fixes ------------------------------------------------------------------------ r1081 | blblack | 2006-03-13 11:13:00 -0600 (Mon, 13 Mar 2006) | 1 line Build.PL updated to recommend DBD upgrades for any installed DBDs ------------------------------------------------------------------------ r1084 | blblack | 2006-03-13 18:46:44 -0600 (Mon, 13 Mar 2006) | 1 line forgotten Changes commit from _03 release ------------------------------------------------------------------------ r1093 | blblack | 2006-03-14 23:09:36 -0600 (Tue, 14 Mar 2006) | 1 line version bump, TEST_POD removed, ->disconnect removed ------------------------------------------------------------------------ r1100 | blblack | 2006-03-15 08:10:51 -0600 (Wed, 15 Mar 2006) | 1 line offload columns_info_for to the upgraded version in DBIx::Class 0.05999_04+ ------------------------------------------------------------------------ r1102 | blblack | 2006-03-15 23:38:13 -0600 (Wed, 15 Mar 2006) | 1 line completely hand over columns_info to Storage, speed up the multiple C3 reinits the way Schema does ------------------------------------------------------------------------ r1103 | blblack | 2006-03-15 23:49:36 -0600 (Wed, 15 Mar 2006) | 1 line remove unnecceary autogenerated dist files, update Changes ------------------------------------------------------------------------ r1104 | blblack | 2006-03-16 00:18:34 -0600 (Thu, 16 Mar 2006) | 1 line added test tables/data for multiple rels from one table to another, many:many, and many:many on same table ------------------------------------------------------------------------ r1110 | blblack | 2006-03-16 20:53:17 -0600 (Thu, 16 Mar 2006) | 1 line cleaned up the whole table/column name upper/lower/mixed case mess ------------------------------------------------------------------------ r1111 | blblack | 2006-03-16 21:51:40 -0600 (Thu, 16 Mar 2006) | 1 line Changes update for 0.02999_04 release ------------------------------------------------------------------------ r1114 | blblack | 2006-03-17 08:19:09 -0600 (Fri, 17 Mar 2006) | 1 line version bumped, now supports multiple rels between a single pair of tables ------------------------------------------------------------------------ r1115 | blblack | 2006-03-17 08:23:14 -0600 (Fri, 17 Mar 2006) | 1 line singularize rel names just like how we pluralize them, where appropriate ------------------------------------------------------------------------ r1116 | blblack | 2006-03-17 16:34:04 -0600 (Fri, 17 Mar 2006) | 1 line Build.PL recommends Class::Inspector (for ResultSetManager stuff), tests updated to not fail if it is not installed ------------------------------------------------------------------------ r1304 | blblack | 2006-03-22 00:36:48 -0600 (Wed, 22 Mar 2006) | 1 line more rel naming stuff ------------------------------------------------------------------------ r1332 | blblack | 2006-03-24 04:20:00 -0600 (Fri, 24 Mar 2006) | 1 line give appropriate warning when no tables ------------------------------------------------------------------------ r1333 | blblack | 2006-03-24 04:59:19 -0600 (Fri, 24 Mar 2006) | 1 line better constraint/exclude handling? ------------------------------------------------------------------------ r1368 | blblack | 2006-03-26 09:06:34 -0600 (Sun, 26 Mar 2006) | 1 line 0.02999_05 Changes and Build.PL updated to require DBIx::Class 0.06 ------------------------------------------------------------------------ r1607 | blblack | 2006-05-10 21:02:11 -0500 (Wed, 10 May 2006) | 1 line merged r1451 error msg fix from mst upwards ------------------------------------------------------------------------ r1645 | blblack | 2006-05-16 22:03:03 -0500 (Tue, 16 May 2006) | 1 line updated Makefile.PL (new M::B) ------------------------------------------------------------------------ r1646 | blblack | 2006-05-16 22:03:33 -0500 (Tue, 16 May 2006) | 1 line fixed mysql testing w/o InnoDB ------------------------------------------------------------------------ r1647 | blblack | 2006-05-16 22:42:35 -0500 (Tue, 16 May 2006) | 1 line correctly determine source class names in the rel code generator ------------------------------------------------------------------------ r1648 | blblack | 2006-05-16 22:52:45 -0500 (Tue, 16 May 2006) | 2 lines removed now-useless funcs in DB2.pm fixed pod typo in SQLite.pm ------------------------------------------------------------------------ r1653 | blblack | 2006-05-17 16:15:47 -0500 (Wed, 17 May 2006) | 4 lines version bump for 0.02999_06 backwards-compat fixed for all cases I could think of no longer requires schema class to have a connection (can connect cloned objects later and lazy load at that time) several smaller fixes ------------------------------------------------------------------------ r1665 | blblack | 2006-05-18 10:56:37 -0500 (Thu, 18 May 2006) | 1 line extensive documentation updates ------------------------------------------------------------------------ r1672 | blblack | 2006-05-18 11:11:39 -0500 (Thu, 18 May 2006) | 1 line Changes updates for 0.02999_06 release ------------------------------------------------------------------------ r1673 | blblack | 2006-05-18 11:31:56 -0500 (Thu, 18 May 2006) | 1 line removed dynamic Build.PL recommendation stuff ------------------------------------------------------------------------ r1674 | blblack | 2006-05-18 11:33:44 -0500 (Thu, 18 May 2006) | 4 lines Writing guide updated and moved Changes updated 0.02999_06 actually released from this commit ------------------------------------------------------------------------ r1687 | blblack | 2006-05-18 23:48:25 -0500 (Thu, 18 May 2006) | 2 lines more docs updates schema support fixes, including bugfix for RT #19164 ------------------------------------------------------------------------ r1688 | blblack | 2006-05-19 00:21:13 -0500 (Fri, 19 May 2006) | 1 line backwards compatibility improvements ------------------------------------------------------------------------ r1697 | blblack | 2006-05-19 14:55:40 -0500 (Fri, 19 May 2006) | 2 lines version bump to 0.02999_07 more fixes wrt backwards compat, runtime connections, cloning, etc ------------------------------------------------------------------------ r1705 | blblack | 2006-05-19 16:43:44 -0500 (Fri, 19 May 2006) | 2 lines more docs/TODO updates the beginnings of the new debug / dump_directory support ------------------------------------------------------------------------ r1729 | blblack | 2006-05-20 14:40:01 -0500 (Sat, 20 May 2006) | 2 lines new-style debug/dump hook made to work, used throughout version bumped to 0.02999_08 ------------------------------------------------------------------------ r1731 | blblack | 2006-05-20 17:29:05 -0500 (Sat, 20 May 2006) | 1 line further debug/dump improvements ------------------------------------------------------------------------ r1732 | blblack | 2006-05-20 17:36:23 -0500 (Sat, 20 May 2006) | 1 line Changes updated for 0.02999_08 ------------------------------------------------------------------------ r1736 | blblack | 2006-05-21 08:17:50 -0500 (Sun, 21 May 2006) | 2 lines docs updates uniq_info made non-fatal in the base DBI class ------------------------------------------------------------------------ r1740 | blblack | 2006-05-21 17:35:13 -0500 (Sun, 21 May 2006) | 2 lines new tests for various invocation methods (which highlist a current failure) ------------------------------------------------------------------------ r1741 | blblack | 2006-05-21 18:20:49 -0500 (Sun, 21 May 2006) | 1 line fixed bug with runtime connect/load of schema objects ------------------------------------------------------------------------ r1742 | blblack | 2006-05-21 18:27:29 -0500 (Sun, 21 May 2006) | 1 line one more new invocation test, and Changes updates for release of 0.02999_09 ------------------------------------------------------------------------ r1743 | blblack | 2006-05-21 23:25:29 -0500 (Sun, 21 May 2006) | 1 line added creation taglines to dump output files ------------------------------------------------------------------------ r1750 | blblack | 2006-05-22 11:29:56 -0500 (Mon, 22 May 2006) | 1 line improved dumping, TODO updates ------------------------------------------------------------------------ r1751 | blblack | 2006-05-22 11:31:35 -0500 (Mon, 22 May 2006) | 1 line version bump and typo fix ------------------------------------------------------------------------ r1752 | blblack | 2006-05-22 12:59:29 -0500 (Mon, 22 May 2006) | 1 line added new exportable package function 'make_schema_at' ------------------------------------------------------------------------ r1753 | blblack | 2006-05-22 13:17:17 -0500 (Mon, 22 May 2006) | 1 line TODO updated, a couple of small inconveniences fixed ------------------------------------------------------------------------ r1754 | blblack | 2006-05-22 13:46:43 -0500 (Mon, 22 May 2006) | 1 line added the last couple of missing debug outputs ------------------------------------------------------------------------ r1755 | blblack | 2006-05-22 13:58:59 -0500 (Mon, 22 May 2006) | 1 line new test added for make_schema_at, Changes updates, release of 0.02999_10 ------------------------------------------------------------------------ --- diff --git a/Build.PL b/Build.PL index 9fbe1aa..e3fb102 100644 --- a/Build.PL +++ b/Build.PL @@ -5,18 +5,28 @@ my %arguments = ( license => 'perl', module_name => 'DBIx::Class::Schema::Loader', requires => { - 'DBIx::Class' => 0.05006, - 'UNIVERSAL::require' => 0.10, - 'Lingua::EN::Inflect' => 0, - 'Text::Balanced' => 0, - 'Class::Accessor::Fast' => 0.22, - 'Class::Data::Accessor' => 0.02, - 'Class::C3' => 0.09, + 'Data::Dump' => 1.06, + 'UNIVERSAL::require' => 0.10, + 'Lingua::EN::Inflect' => 1.89, + 'Lingua::EN::Inflect::Number' => 1.1, + 'Text::Balanced' => 0, + 'Class::Accessor::Fast' => 0.22, + 'Class::Data::Accessor' => 0.02, + 'Class::C3' => 0.11, + 'DBIx::Class' => 0.06, + }, + recommends => { + 'Class::Inspector' => 0, + 'DBI' => 1.50, + 'DBD::SQLite' => 1.12, + 'DBD::mysql' => 3.0003, + 'DBD::Pg' => 1.49, + 'DBD::DB2' => 0.78, }, build_requires => { - 'Test::More' => 0.32, - 'DBI' => 1.40, - 'DBD::SQLite' => 1.11, + 'Test::More' => 0.32, + 'DBI' => 1.50, + 'DBD::SQLite' => 1.12, }, create_makefile_pl => 'passthrough', create_readme => 1, diff --git a/Changes b/Changes index 3899992..0efe84f 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,47 @@ Revision history for Perl extension DBIx::Class::Schema::Loader +0.02999_10 Mon May 22 18:58:20 UTC 2006 + - a few more small bugfixes + - more dump/debug improvements + - new exportable function "make_schema_at" + +0.02999_09 Sun May 21 23:26:58 UTC 2006 + - More docs improvements + - default uniq_info just warns and returns nothing now, + instead of dying. In theory, this allows unsupported + DBD drivers to potentially work with this module, if + the generic methods happen to work for that vendor. + - New tests for the various current and legacy/deprecated + methods of connecting a Schema::Loader class/object. + - Bugfix to the new runtime object connect/load code. + +0.02999_08 Sat May 20 22:36:45 UTC 2006 + - support for dumping to a directory for + conversion to manual DBIx::Class::Schema + - improved debugging output + - more documentation updates + - more backwards compatibility fixes + - runtime connection definitions (and cloning) work fine now. + - A couple of bugfixes related to db vendor "schemas", including + a fix for http://rt.cpan.org/Public/Bug/Display.html?id=19164 + +0.02999_06 Thu May 18 16:32:41 UTC 2006 + - backwards compat with all earlier versions + - no longer requires schema class to have a connection + - correctly determine source class names in the rel code generator + - fixed mysql testing w/o InnoDB + - Writing guide updated + - docs updated + - various trivial updates / fixes + +0.02999_05 Sun Mar 26 06:46:09 UTC 2006 + - bugfixes to constraint/exclude code + - friendly warnings if we don't find any tables + - inflect_map becomes inflect_plural and inflect_singular + - Singularize relationship names where appropriate + - Test updates + - Supports multiple rels between the same pair of tables + 0.02007 Wed Mar 22 06:03:53 UTC 2006 - Backported Class::C3::reinitialize changes from -refactor branch, resulting in significantly reduced load time @@ -7,6 +49,26 @@ Revision history for Perl extension DBIx::Class::Schema::Loader 0.02006 Fri Mar 17 04:55:55 UTC 2006 - Fix long-standing table/col-name case bugs +0.02999_04 Fri Mar 17 03:55:09 UTC 2006 + - Fixed case-sensitivity issues for table/col names + - Punt columns_info_for to ->storage + - Large loading speedup (get rid of redundant C3 reinits) + - Removed TEST_POD checks + - Removed unneccesary storage->disconnect + +0.02999_03 Mon Mar 13 15:01:11 UTC 2006 + - Added EXAMPLE section to pod [Kieren Diment] + - Invasive heavy changes to the DBI- and vendor-specific code + (expect some breakage in some cases until this settles down) + - Support for loading UNIQUE constraints + - Tests cleaned up a bit + - Relationship building seperated out into it's own file for + the changes that are coming, but still does basically what + it did before (this work is the next step). + +0.02999_02 Sat Mar 4 16:53:21 UTC 2006 + - Merged in relevant changes from trunk since the split + 0.02005 Mon Feb 27 23:53:17 UTC 2006 - Move the external file loading to after everything else loader does, in case people want to define, override, or @@ -15,6 +77,12 @@ Revision history for Perl extension DBIx::Class::Schema::Loader 0.02004 Mon Feb 27 23:53:17 UTC 2006 - Minor fix to debugging message for loading external files +0.02999_01 Sun Feb 28 00:24:00 UTC 2006 + - Shuffle the modules around + - Make ourselves theoretically storage_type-agnostic + - Remove the _db_classes stuff, bump PK::Auto to Base + - Change default inflections to Lingua::EN::Inflect::Number::to_PL() + 0.02003 Sun Feb 19 20:42:01 UTC 2006 - Deprecated arguments: dsn, user, password, options - New argument: connect_info diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index 9d68608..e6270f6 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -40,3 +40,9 @@ # Skip coverage output ^cover_db/ + +# Don't publish the TODO file +TODO + +# Don't try to add dist dirs to MANIFEST +^DBIx-Class-Schema-Loader diff --git a/Makefile.PL b/Makefile.PL index 51d31fd..192903a 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -17,15 +17,15 @@ # Save this 'cause CPAN will chdir all over the place. my $cwd = Cwd::cwd(); - my $makefile = File::Spec->rel2abs($0); - CPAN::Shell->install('Module::Build::Compat') - or die " *** Cannot install without Module::Build. Exiting ...\n"; + CPAN::Shell->install('Module::Build::Compat'); + CPAN::Shell->expand("Module", "Module::Build::Compat")->uptodate + or die "Couldn't install Module::Build, giving up.\n"; chdir $cwd or die "Cannot chdir() back to $cwd: $!"; } eval "use Module::Build::Compat 0.02; 1" or die $@; - use lib '_build/lib'; + Module::Build::Compat->run_build_pl(args => \@ARGV); require Module::Build; Module::Build::Compat->write_makefile(build_class => 'Module::Build'); diff --git a/TODO b/TODO index 8db718c..f17c732 100644 --- a/TODO +++ b/TODO @@ -1,14 +1,16 @@ -Reminders to myself or whoever else ever looks in here... +Fix up ResultSet Manager / Methods / etc stuff. May require some work in the +main DBIx::Class first. SQLite needs some heavy refactoring, the subroutines are becoming too complex to understand easily. -Relationship-building needs to be refactored into a seperate module to share with SQLT. +Refactor RelBuilder so that it doesn't require a live mostly-built +DBIx::Class::Schema, so that other modules (SQLT) can use it easier. And then +when/if we get there, break it out as a seperate distribution with a new name. Relationship stuff: - Fix multiple rels between same pair of tables If local column is UNIQUE or PK, use has_one() for relation? Re-scan relations/tables after initial relation setup to find ->many_to_many() relations to be set up? Check NULLability of columns involved in the relationship, which might suggest a more optimal non-default -join-type? While scanning for many-to-many, scan for implied rels as well? (if foo->belongs_to('bar') and baz->belongs_to('bar'), does that impliy foo->might_have('baz') and the reverse?) -... + ... diff --git a/lib/DBIx/Class/Schema/Loader.pm b/lib/DBIx/Class/Schema/Loader.pm index aa62e41..093ce5e 100644 --- a/lib/DBIx/Class/Schema/Loader.pm +++ b/lib/DBIx/Class/Schema/Loader.pm @@ -6,13 +6,17 @@ use base qw/DBIx::Class::Schema/; use base qw/Class::Data::Accessor/; use Carp; use UNIVERSAL::require; +use Class::C3; +use Data::Dump qw/ dump /; # Always remember to do all digits for the version even if they're 0 # i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports # brain damage and presumably various other packaging systems too -our $VERSION = '0.02007'; +our $VERSION = '0.02999_10'; +__PACKAGE__->mk_classaccessor('dump_to_dir'); __PACKAGE__->mk_classaccessor('loader'); +__PACKAGE__->mk_classaccessor('_loader_args'); =head1 NAME @@ -23,29 +27,10 @@ DBIx::Class::Schema::Loader - Dynamic definition of a DBIx::Class::Schema package My::Schema; use base qw/DBIx::Class::Schema::Loader/; - sub _monikerize { - my $name = shift; - $name = join '', map ucfirst, split /[\W_]+/, lc $name; - $name; - } - - __PACKAGE__->load_from_connection( - connect_info => [ "dbi:mysql:dbname", - "root", - "mypassword", - { AutoCommit => 1 }, - ], - additional_classes => [qw/DBIx::Class::Foo/], - additional_base_classes => [qw/My::Stuff/], - left_base_classes => [qw/DBIx::Class::Bar/], - components => [qw/ResultSetManager/], - resultset_components => [qw/AlwaysRS/], - constraint => '^foo.*', - relationships => 1, - options => { AutoCommit => 1 }, - inflect_map => { child => 'children' }, - moniker_map => \&_monikerize, - debug => 1, + __PACKAGE__->loader_options( + relationships => 1, + constraint => '^foo.*', + # debug => 1, ); # in seperate application code ... @@ -54,112 +39,349 @@ DBIx::Class::Schema::Loader - Dynamic definition of a DBIx::Class::Schema my $schema1 = My::Schema->connect( $dsn, $user, $password, $attrs); # -or- - my $schema1 = "My::Schema"; - # ^^ defaults to dsn/user/pass from load_from_connection() - - # Get a list of the original (database) names of the tables that - # were loaded - my @tables = $schema1->loader->tables; - - # Get a hashref of table_name => 'TableName' table-to-moniker - # mappings. - my $monikers = $schema1->loader->monikers; - - # Get a hashref of table_name => 'My::Schema::TableName' - # table-to-classname mappings. - my $classes = $schema1->loader->classes; - - # Use the schema as per normal for DBIx::Class::Schema - my $rs = $schema1->resultset($monikers->{foo_table})->search(...); - -=head1 DESCRIPTION - + my $schema1 = "My::Schema"; $schema1->connection(as above); +=head1 DESCRIPTION DBIx::Class::Schema::Loader automates the definition of a -DBIx::Class::Schema by scanning table schemas and setting up -columns and primary keys. +L by scanning database table definitions and +setting up the columns and primary keys. -DBIx::Class::Schema::Loader supports MySQL, Postgres, SQLite and DB2. See -L for more, and -L for notes on writing your own -db-specific subclass for an unsupported db. +DBIx::Class::Schema::Loader currently supports DBI for MySQL, +Postgres, SQLite and DB2. -This module requires L 0.05 or later, and obsoletes -L for L version 0.05 and later. +See L for notes on writing +your own vendor-specific subclass for an unsupported DBD driver. -While on the whole, the bare table definitions are fairly straightforward, -relationship creation is somewhat heuristic, especially in the choosing -of relationship types, join types, and relationship names. The relationships -generated by this module will probably never be as well-defined as -hand-generated ones. Because of this, over time a complex project will -probably wish to migrate off of L. +This module requires L 0.06 or later, and obsoletes +the older L. -It is designed more to get you up and running quickly against an existing -database, or to be effective for simple situations, rather than to be what -you use in the long term for a complex database/project. +This module is designed more to get you up and running quickly against +an existing database, or to be effective for simple situations, rather +than to be what you use in the long term for a complex database/project. That being said, transitioning your code from a Schema generated by this module to one that doesn't use this module should be straightforward and -painless, so don't shy away from it just for fears of the transition down -the road. +painless (as long as you're not using any methods that are now deprecated +in this document), so don't shy away from it just for fears of the +transition down the road. =head1 METHODS -=head2 load_from_connection +=head2 loader_options -Example in Synopsis above demonstrates the available arguments. For -detailed information on the arguments, see the -L documentation. +Example in Synopsis above demonstrates a few common arguments. For +detailed information on all of the arguments, most of which are +only useful in fairly complex scenarios, see the +L documentation. -=cut +This method is *required*, for backwards compatibility reasons. If +you do not wish to change any options, just call it with an empty +argument list during schema class initialization. -# XXX this is DBI-specific, as it peers into the dsn to determine -# the vendor class to use... -sub load_from_connection { - my ( $class, %args ) = @_; - - my $dsn; +=cut - if($args{connect_info} && $args{connect_info}->[0]) { - $dsn = $args{connect_info}->[0]; - } - elsif($args{dsn}) { - warn "dsn argument is deprecated, please use connect_info instead"; - $dsn = $args{dsn}; +sub loader_options { + my $self = shift; + + my %args; + if(ref $_[0] eq 'HASH') { + %args = %{$_[0]}; } else { - croak 'connect_info arrayref argument with valid ' - . 'first element is required'; + %args = @_; } - my ($driver) = $dsn =~ m/^dbi:(\w*?)(?:\((.*?)\))?:/i; - $driver = 'SQLite' if $driver eq 'SQLite2'; - my $impl = "DBIx::Class::Schema::Loader::" . $driver; + my $class = ref $self || $self; + $args{schema} = $self; + $args{schema_class} = $class; + $self->_loader_args(\%args); + $self->_invoke_loader if $self->storage && !$class->loader; + + $self; +} + +sub _invoke_loader { + my $self = shift; + my $class = ref $self || $self; + + $self->_loader_args->{dump_directory} ||= $self->dump_to_dir; + # XXX this only works for relative storage_type, like ::DBI ... + my $impl = "DBIx::Class::Schema::Loader" . $self->storage_type; $impl->require or - croak qq/Couldn't require loader class "$impl",/ . + croak qq/Could not load storage_type loader "$impl": / . qq/"$UNIVERSAL::require::ERROR"/; - $args{schema} = $class; - - $class->loader($impl->new(%args)); + # XXX in the future when we get rid of ->loader, the next two + # lines can be replaced by "$impl->new(%{$self->_loader_args})->load;" + $class->loader($impl->new(%{$self->_loader_args})); $class->loader->load; + + + $self; +} + +=head2 connection + +See L. Our local override here is to +hook in the main functionality of the loader, which occurs at the time +the connection is specified for a given schema class/object. + +=cut + +sub connection { + my $self = shift->next::method(@_); + + my $class = ref $self || $self; + $self->_invoke_loader if $self->_loader_args && !$class->loader; + + return $self; +} + +=head2 clone + +See L. Our local override here is to +make sure cloned schemas can still be loaded at runtime by +copying and altering a few things here. + +=cut + +sub clone { + my $self = shift; + + my $clone = $self->next::method(@_); + + $clone->_loader_args($self->_loader_args); + $clone->_loader_args->{schema} = $clone; + + $clone; +} + +=head2 dump_to_dir + +Argument: directory name. + +Calling this as a class method on either L +or any derived schema class will cause all affected schemas to dump +manual versions of themselves to the named directory when they are +loaded. In order to be effective, this must be set before defining a +connection on this schema class or any derived object (as the loading +happens at connection time, and only once per class). + +See L for more +details on the dumping mechanism. + +This can also be set at module import time via the import option +C to L, where +C is the target directory. + +Examples: + + # My::Schema isa DBIx::Class::Schema::Loader, and has connection info + # hardcoded in the class itself: + perl -MDBIx::Class::Schema::Loader=dump_to_dir:/foo/bar -MMy::Schema -e1 + + # Same, but no hard-coded connection, so we must provide one: + perl -MDBIx::Class::Schema::Loader=dump_to_dir:/foo/bar -MMy::Schema -e 'My::Schema->connection("dbi:Pg:dbname=foo", ...)' + + # Or as a class method, as long as you get it done *before* defining a + # connection on this schema class or any derived object: + use My::Schema; + My::Schema->dump_to_dir('/foo/bar'); + My::Schema->connection(........); + + # Or as a class method on the DBIx::Class::Schema::Loader itself, which affects all + # derived schemas + use My::Schema; + use My::OtherSchema; + DBIx::Class::Schema::Loader->dump_to_dir('/foo/bar'); + My::Schema->connection(.......); + My::OtherSchema->connection(.......); + + # Another alternative to the above: + use DBIx::Class::Schema::Loader qw| dump_to_dir:/foo/bar |; + use My::Schema; + use My::OtherSchema; + My::Schema->connection(.......); + My::OtherSchema->connection(.......); + +=cut + +sub import { + my $self = shift; + return if !@_; + foreach my $opt (@_) { + if($opt =~ m{^dump_to_dir:(.*)$}) { + $self->dump_to_dir($1) + } + elsif($opt eq 'make_schema_at') { + no strict 'refs'; + my $cpkg = (caller)[0]; + *{"${cpkg}::make_schema_at"} = \&make_schema_at; + } + } +} + +=head2 make_schema_at + +This simple function allows one to create a Loader-based schema +in-memory on the fly without any on-disk class files of any +kind. When used with the C option, you can +use this to generate a rought draft manual schema from a dsn +without the intermediate step of creating a physical Loader-based +schema class. + +This function can be exported/imported by the normal means, as +illustrated in these Examples: + + # Simple example... + use DBIx::Class::Schema::Loader qw/ make_schema_at /; + make_schema_at( + 'New::Schema::Name', + { relationships => 1, debug => 1 }, + [ 'dbi:Pg:dbname="foo"','postgres' ], + ); + + # Complex: dump loaded schema to disk, all from the commandline: + perl -MDBIx::Class::Schema::Loader=make_schema_at,dump_to_dir:./lib -e 'make_schema_at("New::Schema::Name", { relationships => 1 }, [ 'dbi:Pg:dbname="foo"','postgres' ])' + + # Same, but inside a script, and using a different way to specify the + # dump directory: + use DBIx::Class::Schema::Loader qw/ make_schema_at /; + make_schema_at( + 'New::Schema::Name', + { relationships => 1, debug => 1, dump_directory => './lib' }, + [ 'dbi:Pg:dbname="foo"','postgres' ], + ); + +=cut + +sub make_schema_at { + my ($target, $opts, $connect_info) = @_; + + my $opts_dumped = dump($opts); + my $cinfo_dumped = dump(@$connect_info); + eval qq| + package $target; + use base qw/DBIx::Class::Schema::Loader/; + __PACKAGE__->loader_options($opts_dumped); + __PACKAGE__->connection($cinfo_dumped); + |; +} + +=head1 EXAMPLE + +Using the example in L as a basis +replace the DB::Main with the following code: + + package DB::Main; + + use base qw/DBIx::Class::Schema::Loader/; + + __PACKAGE__->loader_options( + relationships => 1, + debug => 1, + ); + __PACKAGE__->connection('dbi:SQLite:example.db'); + + 1; + +and remove the Main directory tree (optional). Every thing else +should work the same + +=head1 DEPRECATED METHODS + +You don't need to read anything in this section unless you're upgrading +code that was written against pre-0.03 versions of this module. This +version is intended to be backwards-compatible with pre-0.03 code, but +will issue warnings about your usage of deprecated features/methods. + +=head2 load_from_connection + +This deprecated method is now roughly an alias for L. + +In the past it was a common idiom to invoke this method +after defining a connection on the schema class. That usage is now +deprecated. The correct way to do things from now forward is to +always do C on the class before C or +C is invoked on the class or any derived object. + +This method *will* dissappear in a future version. + +For now, using this method will invoke the legacy behavior for +backwards compatibility, and merely emit a warning about upgrading +your code. + +It also reverts the default inflection scheme to +use L just like pre-0.03 versions of this +module did. + +You can force these legacy inflections with the +option C, even after switch over +to the preferred L way of doing things. + +See the source of this method for more details. + +=cut + +sub load_from_connection { + my ($self, %args) = @_; + warn 'load_from_connection deprecated, please [re-]read the' + . ' [new] DBIx::Class::Schema::Loader documentation'; + + # Support the old connect_info / dsn / etc args... + $args{connect_info} = [ + delete $args{dsn}, + delete $args{user}, + delete $args{password}, + delete $args{options}, + ] if $args{dsn}; + + $self->connection(@{delete $args{connect_info}}) + if $args{connect_info}; + + $self->loader_options('legacy_default_inflections' => 1, %args); } =head2 loader This is an accessor in the generated Schema class for accessing -the L -based loader object +the L -based loader object that was used during construction. See the -L docs for more information +L docs for more information on the available loader methods there. -=head1 KNOWN BUGS +This accessor is deprecated. Do not use it. Anything you can +get from C, you can get via the normal L +methods, and your code will be more robust and forward-thinking +for doing so. + +If you're already using C in your code, make an effort +to get rid of it. If you think you've found a situation where it +is neccesary, let me know and we'll see what we can do to remedy +that situation. + +In some future version, this accessor *will* disappear. It was +apparently quite a design/API mistake to ever have exposed it to +user-land in the first place, all things considered. + +=head1 KNOWN ISSUES + +=head2 Multiple Database Schemas + +Currently the loader is limited to working within a single schema +(using the database vendors' definition of "schema"). If you +have a multi-schema database with inter-schema relationships (which +is easy to do in Postgres or DB2 for instance), you only get to +automatically load the tables of one schema, and any relationships +to tables in other schemas will be silently ignored. + +At some point in the future, an intelligent way around this might be +devised, probably by allowing the C option to be an +arrayref of schemas to load, or perhaps even offering schema +constraint/exclusion options just like the table ones. -Aside from relationship definitions being less than ideal in general, -this version is known not to handle the case of multiple relationships -between the same pair of tables. All of the relationship code will -be overhauled on the way to 0.03, at which time that bug will be -addressed. +In "normal" L usage, manually-defined +source classes and relationships have no problems crossing vendor schemas. =head1 AUTHOR @@ -172,7 +394,8 @@ Based upon the work of IKEBE Tomohiro =head1 THANK YOU Adam Anderson, Andy Grundman, Autrijus Tang, Dan Kubb, David Naughton, -Randal Schwartz, Simon Flack and all the others who've helped. +Randal Schwartz, Simon Flack, Matt S Trout, everyone on #dbix-class, and +all the others who've helped. =head1 LICENSE @@ -181,7 +404,7 @@ the same terms as Perl itself. =head1 SEE ALSO -L +L, L =cut diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm new file mode 100644 index 0000000..65109f4 --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/Base.pm @@ -0,0 +1,596 @@ +package DBIx::Class::Schema::Loader::Base; + +use strict; +use warnings; +use base qw/Class::Accessor::Fast/; +use Class::C3; +use Carp; +use UNIVERSAL::require; +use DBIx::Class::Schema::Loader::RelBuilder; +use Data::Dump qw/ dump /; +use POSIX qw//; +require DBIx::Class; + +__PACKAGE__->mk_ro_accessors(qw/ + schema + schema_class + + exclude + constraint + additional_classes + additional_base_classes + left_base_classes + components + resultset_components + relationships + moniker_map + inflect_singular + inflect_plural + debug + dump_directory + + legacy_default_inflections + + db_schema + _tables + classes + monikers + /); + +=head1 NAME + +DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation. + +=head1 SYNOPSIS + +See L + +=head1 DESCRIPTION + +This is the base class for the storage-specific C +classes, and implements the common functionality between them. + +=head1 CONSTRUCTOR OPTIONS + +These constructor options are the base options for +L. Available constructor options are: + +=head2 relationships + +Try to automatically detect/setup has_a and has_many relationships. + +=head2 debug + +If set to true, each constructive L statement the loader +decides to execute will be C-ed before execution. + +=head2 constraint + +Only load tables matching regex. Best specified as a qr// regex. + +=head2 exclude + +Exclude tables matching regex. Best specified as a qr// regex. + +=head2 moniker_map + +Overrides the default tablename -> moniker translation. Can be either +a hashref of table => moniker names, or a coderef for a translator +function taking a single scalar table name argument and returning +a scalar moniker. If the hash entry does not exist, or the function +returns a false value, the code falls back to default behavior +for that table name. + +The default behavior is: C, +which is to say: lowercase everything, split up the table name into chunks +anywhere a non-alpha-numeric character occurs, change the case of first letter +of each chunk to upper case, and put the chunks back together. Examples: + + Table Name | Moniker Name + --------------------------- + luser | Luser + luser_group | LuserGroup + luser-opts | LuserOpts + +=head2 inflect_plural + +Just like L above (can be hash/code-ref, falls back to default +if hash key does not exist or coderef returns false), but acts as a map +for pluralizing relationship names. The default behavior is to utilize +L. + +=head2 inflect_singular + +As L above, but for singularizing relationship names. +Default behavior is to utilize L. + +=head2 additional_base_classes + +List of additional base classes all of your table classes will use. + +=head2 left_base_classes + +List of additional base classes all of your table classes will use +that need to be leftmost. + +=head2 additional_classes + +List of additional classes which all of your table classes will use. + +=head2 components + +List of additional components to be loaded into all of your table +classes. A good example would be C. + +=head2 resultset_components + +List of additional resultset components to be loaded into your table +classes. A good example would be C. Component +C will be automatically added to the above +C list if this option is set. + +=head2 legacy_default_inflections + +Setting this option changes the default fallback for L to +utilize L, and L to a no-op. +Those choices produce substandard results, but might be neccesary to support +your existing code if you started developing on a version prior to 0.03 and +don't wish to go around updating all your relationship names to the new +defaults. + +=head2 dump_directory + +This option is designed to be a tool to help you transition from this +loader to a manually-defined schema when you decide it's time to do so. + +The value of this option is a perl libdir pathname. Within +that directory this module will create a baseline manual +L module set, based on what it creates at runtime +in memory. + +The created schema class will have the same classname as the one on +which you are setting this option (and the ResultSource classes will be +based on this name as well). Therefore it is wise to note that if you +point the C option of a schema class at the live libdir +where that class is currently located, it will overwrite itself with a +manual version of itself. This might be a really good or bad thing +depending on your situation and perspective. + +Normally you wouldn't hardcode this setting in your schema class, as it +is meant for one-time manual usage. + +See L for examples of the +recommended way to access this functionality. + +=head1 DEPRECATED CONSTRUCTOR OPTIONS + +=head2 inflect_map + +Equivalent to L. + +=head2 inflect + +Equivalent to L. + +=head2 connect_info, dsn, user, password, options + +You connect these schemas the same way you would any L, +which is by calling either C or C on a schema class +or object. These options are only supported via the deprecated +C interface, which will be removed in the future. + +=head1 METHODS + +None of these methods are intended for direct invocation by regular +users of L. Anything you can find here +can also be found via standard L methods somehow. + +=cut + +# ensure that a peice of object data is a valid arrayref, creating +# an empty one or encapsulating whatever's there. +sub _ensure_arrayref { + my $self = shift; + + foreach (@_) { + $self->{$_} ||= []; + $self->{$_} = [ $self->{$_} ] + unless ref $self->{$_} eq 'ARRAY'; + } +} + +=head2 new + +Constructor for L, used internally +by L. + +=cut + +sub new { + my ( $class, %args ) = @_; + + my $self = { %args }; + + bless $self => $class; + + $self->{db_schema} ||= ''; + $self->_ensure_arrayref(qw/additional_classes + additional_base_classes + left_base_classes + components + resultset_components + /); + + push(@{$self->{components}}, 'ResultSetManager') + if @{$self->{resultset_components}}; + + $self->{monikers} = {}; + $self->{classes} = {}; + + # Support deprecated arguments + for(qw/inflect_map inflect/) { + warn "Argument $_ is deprecated in favor of 'inflect_plural'" + if $self->{$_}; + } + $self->{inflect_plural} ||= $self->{inflect_map} || $self->{inflect}; + + $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} ); + $self->{schema} ||= $self->{schema_class}; + + $self; +} + +sub _load_external { + my $self = shift; + + foreach my $table_class (values %{$self->classes}) { + $table_class->require; + if($@ && $@ !~ /^Can't locate /) { + croak "Failed to load external class definition" + . " for '$table_class': $@"; + } + next if $@; # "Can't locate" error + + # If we make it to here, we loaded an external definition + warn qq/# Loaded external class definition for '$table_class'\n/ + if $self->debug; + + if($self->dump_directory) { + my $class_path = $table_class; + $class_path =~ s{::}{/}g; + my $filename = $INC{$class_path}; + croak 'Failed to locate actual external module file for ' + . "'$table_class'" + if !$filename; + open(my $fh, '<', $filename) + or croak "Failed to open $filename for reading: $!"; + $self->_raw_stmt($table_class, + q|# These lines loaded from user-supplied external file: | + ); + while(<$fh>) { + chomp; + $self->_raw_stmt($table_class, $_); + } + $self->_raw_stmt($table_class, + q|# End of lines loaded from user-supplied external file | + ); + close($fh) + or croak "Failed to close $filename: $!"; + } + } +} + +=head2 load + +Does the actual schema-construction work. + +=cut + +sub load { + my $self = shift; + + $self->_load_classes; + $self->_load_relationships if $self->relationships; + $self->_load_external; + $self->_dump_to_dir if $self->dump_directory; + + 1; +} + +sub _get_dump_filename { + my ($self, $class) = (@_); + + $class =~ s{::}{/}g; + return $self->dump_directory . q{/} . $class . q{.pm}; +} + +sub _ensure_dump_subdirs { + my ($self, $class) = (@_); + + my @name_parts = split(/::/, $class); + pop @name_parts; + my $dir = $self->dump_directory; + foreach (@name_parts) { + $dir .= q{/} . $_; + if(! -d $dir) { + mkdir($dir) or die "mkdir('$dir') failed: $!"; + } + } +} + +sub _dump_to_dir { + my ($self) = @_; + + my $target_dir = $self->dump_directory; + + die "Must specify target directory for dumping!" if ! $target_dir; + + warn "Dumping manual schema to $target_dir ...\n"; + + if(! -d $target_dir) { + mkdir($target_dir) or die "mkdir('$target_dir') failed: $!"; + } + + my $verstr = $DBIx::Class::Schema::Loader::VERSION; + my $datestr = POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime); + my $tagline = qq|# Created by DBIx::Class::Schema::Loader v$verstr @ $datestr|; + + my $schema_class = $self->schema_class; + $self->_ensure_dump_subdirs($schema_class); + + my $schema_fn = $self->_get_dump_filename($schema_class); + open(my $schema_fh, '>', $schema_fn) + or die "Cannot open $schema_fn for writing: $!"; + print $schema_fh qq|package $schema_class;\n\n$tagline\n\n|; + print $schema_fh qq|use strict;\nuse warnings;\n\n|; + print $schema_fh qq|use base 'DBIx::Class::Schema';\n\n|; + print $schema_fh qq|__PACKAGE__->load_classes;\n|; + print $schema_fh qq|\n1;\n\n|; + close($schema_fh) + or die "Cannot close $schema_fn: $!"; + + foreach my $src_class (sort keys %{$self->{_dump_storage}}) { + $self->_ensure_dump_subdirs($src_class); + my $src_fn = $self->_get_dump_filename($src_class); + open(my $src_fh, '>', $src_fn) + or die "Cannot open $src_fn for writing: $!"; + print $src_fh qq|package $src_class;\n\n$tagline\n\n|; + print $src_fh qq|use strict;\nuse warnings;\n\n|; + print $src_fh qq|use base 'DBIx::Class';\n\n|; + print $src_fh qq|$_\n| + for @{$self->{_dump_storage}->{$src_class}}; + print $src_fh qq|\n1;\n\n|; + close($src_fh) + or die "Cannot close $src_fn: $!"; + } + + warn "Schema dump completed.\n"; +} + +sub _use { + my $self = shift; + my $target = shift; + + foreach (@_) { + $_->require or croak ($_ . "->require: $@"); + $self->_raw_stmt($target, "use $_;"); + warn "$target: use $_" if $self->debug; + eval "package $target; use $_;"; + croak "use $_: $@" if $@; + } +} + +sub _inject { + my $self = shift; + my $target = shift; + my $schema_class = $self->schema_class; + + my $blist = join(q{ }, @_); + $self->_raw_stmt($target, "use base qw/ $blist /;") if @_; + warn "$target: use base qw/ $blist /" if $self->debug; + foreach (@_) { + $_->require or croak ($_ . "->require: $@"); + $schema_class->inject_base($target, $_); + } +} + +# Load and setup classes +sub _load_classes { + my $self = shift; + + my $schema = $self->schema; + my $schema_class = $self->schema_class; + + my $constraint = $self->constraint; + my $exclude = $self->exclude; + my @tables = sort $self->_tables_list; + + warn "No tables found in database, nothing to load" if !@tables; + + if(@tables) { + @tables = grep { /$constraint/ } @tables if $constraint; + @tables = grep { ! /$exclude/ } @tables if $exclude; + + warn "All tables excluded by constraint/exclude, nothing to load" + if !@tables; + } + + $self->{_tables} = \@tables; + + foreach my $table (@tables) { + my $table_moniker = $self->_table2moniker($table); + my $table_class = $schema_class . q{::} . $table_moniker; + + my $table_normalized = lc $table; + $self->classes->{$table} = $table_class; + $self->classes->{$table_normalized} = $table_class; + $self->monikers->{$table} = $table_moniker; + $self->monikers->{$table_normalized} = $table_moniker; + + no warnings 'redefine'; + local *Class::C3::reinitialize = sub { }; + use warnings; + + { no strict 'refs'; + @{"${table_class}::ISA"} = qw/DBIx::Class/; + } + $self->_use ($table_class, @{$self->additional_classes}); + $self->_inject($table_class, @{$self->additional_base_classes}); + + $self->_dbic_stmt($table_class, 'load_components', @{$self->components}, qw/PK::Auto Core/); + + $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components}) + if @{$self->resultset_components}; + $self->_inject($table_class, @{$self->left_base_classes}); + } + + Class::C3::reinitialize; + + foreach my $table (@tables) { + my $table_class = $self->classes->{$table}; + my $table_moniker = $self->monikers->{$table}; + + $self->_dbic_stmt($table_class,'table',$table); + + my $cols = $self->_table_columns($table); + $self->_dbic_stmt($table_class,'add_columns',@$cols); + + my $pks = $self->_table_pk_info($table) || []; + @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks) + : carp("$table has no primary key"); + + my $uniqs = $self->_table_uniq_info($table) || []; + $self->_dbic_stmt($table_class,'add_unique_constraint',@$_) for (@$uniqs); + + $schema_class->register_class($table_moniker, $table_class); + $schema->register_class($table_moniker, $table_class) if $schema ne $schema_class; + } +} + +=head2 tables + +Returns a sorted list of loaded tables, using the original database table +names. + +=cut + +sub tables { + my $self = shift; + + return @{$self->_tables}; +} + +# Make a moniker from a table +sub _table2moniker { + my ( $self, $table ) = @_; + + my $moniker; + + if( ref $self->moniker_map eq 'HASH' ) { + $moniker = $self->moniker_map->{$table}; + } + elsif( ref $self->moniker_map eq 'CODE' ) { + $moniker = $self->moniker_map->($table); + } + + $moniker ||= join '', map ucfirst, split /[\W_]+/, lc $table; + + return $moniker; +} + +sub _load_relationships { + my $self = shift; + + # Construct the fk_info RelBuilder wants to see, by + # translating table names to monikers in the _fk_info output + my %fk_info; + foreach my $table ($self->tables) { + my $tbl_fk_info = $self->_table_fk_info($table); + foreach my $fkdef (@$tbl_fk_info) { + $fkdef->{remote_source} = + $self->monikers->{delete $fkdef->{remote_table}}; + } + my $moniker = $self->monikers->{$table}; + $fk_info{$moniker} = $tbl_fk_info; + } + + my $relbuilder = DBIx::Class::Schema::Loader::RelBuilder->new( + $self->schema_class, \%fk_info, $self->inflect_plural, + $self->inflect_singular + ); + + my $rel_stmts = $relbuilder->generate_code; + foreach my $src_class (sort keys %$rel_stmts) { + my $src_stmts = $rel_stmts->{$src_class}; + foreach my $stmt (@$src_stmts) { + $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}}); + } + } +} + +# Overload these in driver class: + +# Returns an arrayref of column names +sub _table_columns { croak "ABSTRACT METHOD" } + +# Returns arrayref of pk col names +sub _table_pk_info { croak "ABSTRACT METHOD" } + +# Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ] +sub _table_uniq_info { croak "ABSTRACT METHOD" } + +# Returns an arrayref of foreign key constraints, each +# being a hashref with 3 keys: +# local_columns (arrayref), remote_columns (arrayref), remote_table +sub _table_fk_info { croak "ABSTRACT METHOD" } + +# Returns an array of lower case table names +sub _tables_list { croak "ABSTRACT METHOD" } + +# Execute a constructive DBIC class method, with debug/dump_to_dir hooks. +sub _dbic_stmt { + my $self = shift; + my $class = shift; + my $method = shift; + + if(!$self->debug && !$self->dump_directory) { + $class->$method(@_); + return; + } + + my $args = dump(@_); + $args = '(' . $args . ')' if @_ < 2; + my $stmt = $method . $args . q{;}; + + warn qq|$class\->$stmt\n| if $self->debug; + $class->$method(@_); + $self->_raw_stmt($class, '__PACKAGE__->' . $stmt); +} + +# Store a raw source line for a class (for dumping purposes) +sub _raw_stmt { + my ($self, $class, $stmt) = @_; + push(@{$self->{_dump_storage}->{$class}}, $stmt) if $self->dump_directory; +} + +=head2 monikers + +Returns a hashref of loaded table-to-moniker mappings. There will +be two entries for each table, the original name and the "normalized" +name, in the case that the two are different (such as databases +that like uppercase table names, or preserve your original mixed-case +definitions, or what-have-you). + +=head2 classes + +Returns a hashref of table-to-classname mappings. In some cases it will +contain multiple entries per table for the original and normalized table +names, as above in L. + +=head1 SEE ALSO + +L + +=cut + +1; diff --git a/lib/DBIx/Class/Schema/Loader/DB2.pm b/lib/DBIx/Class/Schema/Loader/DB2.pm deleted file mode 100644 index 967d135..0000000 --- a/lib/DBIx/Class/Schema/Loader/DB2.pm +++ /dev/null @@ -1,137 +0,0 @@ -package DBIx::Class::Schema::Loader::DB2; - -use strict; -use warnings; -use base 'DBIx::Class::Schema::Loader::Generic'; -use Class::C3; - -=head1 NAME - -DBIx::Class::Schema::Loader::DB2 - DBIx::Class::Schema::Loader DB2 Implementation. - -=head1 SYNOPSIS - - package My::Schema; - use base qw/DBIx::Class::Schema::Loader/; - - __PACKAGE__->load_from_connection( - dsn => "dbi:DB2:dbname", - user => "myuser", - password => "", - db_schema => "MYSCHEMA", - drop_schema => 1, - ); - - 1; - -=head1 DESCRIPTION - -See L. - -=cut - -sub _db_classes { - return qw/PK::Auto::DB2/; -} - -sub _tables_list { - my $self = shift; - my %args = @_; - my $db_schema = uc $self->db_schema; - my $dbh = $self->schema->storage->dbh; - my $quoter = $dbh->get_info(29) || q{"}; - - # this is split out to avoid version parsing errors... - my $is_dbd_db2_gte_114 = ( $DBD::DB2::VERSION >= 1.14 ); - my @tables = $is_dbd_db2_gte_114 ? - $dbh->tables( { TABLE_SCHEM => '%', TABLE_TYPE => 'TABLE,VIEW' } ) - : $dbh->tables; - # People who use table or schema names that aren't identifiers deserve - # what they get. Still, FIXME? - s/$quoter//g for @tables; - @tables = grep {!/^SYSIBM\./ and !/^SYSCAT\./ and !/^SYSSTAT\./} @tables; - @tables = grep {/^$db_schema\./} @tables if($db_schema); - return @tables; -} - -sub _table_info { - my ( $self, $table ) = @_; -# $|=1; -# print "_table_info($table)\n"; - my $db_schema = $self->db_schema; - - # FIXME: Horribly inefficient and just plain evil. (JMM) - my $dbh = $self->schema->storage->dbh; - $dbh->{RaiseError} = 1; - - my $sth = $dbh->prepare(<<'SQL') or die; -SELECT c.COLNAME -FROM SYSCAT.COLUMNS as c -WHERE c.TABSCHEMA = ? and c.TABNAME = ? -SQL - - $sth->execute($db_schema, $table) or die; - my @cols = map { lc } map { @$_ } @{$sth->fetchall_arrayref}; - - undef $sth; - - $sth = $dbh->prepare(<<'SQL') or die; -SELECT kcu.COLNAME -FROM SYSCAT.TABCONST as tc -JOIN SYSCAT.KEYCOLUSE as kcu ON tc.constname = kcu.constname -WHERE tc.TABSCHEMA = ? and tc.TABNAME = ? and tc.TYPE = 'P' -SQL - - $sth->execute($db_schema, $table) or die; - - my @pri = map { lc } map { @$_ } @{$sth->fetchall_arrayref}; - - return ( \@cols, \@pri ); -} - -# Find and setup relationships -sub _load_relationships { - my $self = shift; - - my $dbh = $self->schema->storage->dbh; - - my $sth = $dbh->prepare(<<'SQL') or die; -SELECT SR.COLCOUNT, SR.REFTBNAME, SR.PKCOLNAMES, SR.FKCOLNAMES -FROM SYSIBM.SYSRELS SR WHERE SR.TBNAME = ? -SQL - - my $db_schema = $self->db_schema; - foreach my $table ( $self->tables ) { - $table =~ s/^$db_schema\.//; - next if ! $sth->execute($table); - while(my $res = $sth->fetchrow_arrayref()) { - my ($colcount, $other, $other_column, $column) = @$res; - - my @self_cols = map { lc } split(' ',$column); - my @other_cols = map { lc } split(' ',$other_column); - if(@self_cols != $colcount || @other_cols != $colcount) { - die "Column count discrepancy while getting rel info"; - } - - my %cond; - for(my $i = 0; $i < @self_cols; $i++) { - $cond{$other_cols[$i]} = $self_cols[$i]; - } - - eval { $self->_make_cond_rel ($table, $other, \%cond); }; - warn qq/\# belongs_to_many failed "$@"\n\n/ - if $@ && $self->debug; - } - } - - $sth->finish; - $dbh->disconnect; -} - -=head1 SEE ALSO - -L - -=cut - -1; diff --git a/lib/DBIx/Class/Schema/Loader/DBI.pm b/lib/DBIx/Class/Schema/Loader/DBI.pm new file mode 100644 index 0000000..04cd305 --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBI.pm @@ -0,0 +1,160 @@ +package DBIx::Class::Schema::Loader::DBI; + +use strict; +use warnings; +use base qw/DBIx::Class::Schema::Loader::Base Class::Accessor::Fast/; +use Class::C3; +use Carp; +use UNIVERSAL::require; + +=head1 NAME + +DBIx::Class::Schema::Loader::DBI - DBIx::Class::Schema::Loader DBI Implementation. + +=head1 SYNOPSIS + +See L + +=head1 DESCRIPTION + +This is the base class for L classes for +DBI-based storage backends, and implements the common functionality between them. + +See L for the available options. + +=head1 METHODS + +=head2 new + +Overlays L to do some DBI-specific +things. + +=cut + +sub new { + my $self = shift->next::method(@_); + + # rebless to vendor-specific class if it exists and loads + my $dbh = $self->schema->storage->dbh; + my $driver = $dbh->{Driver}->{Name}; + my $subclass = 'DBIx::Class::Schema::Loader::DBI::' . $driver; + $subclass->require; + if($@ && $@ !~ /^Can't locate /) { + die "Failed to require $subclass: $@"; + } + elsif(!$@) { + bless $self, "DBIx::Class::Schema::Loader::DBI::${driver}"; + } + + # Set up the default quoting character and name seperators + $self->{_quoter} = $self->schema->storage->sql_maker->quote_char + || $dbh->get_info(29) + || q{"}; + + $self->{_namesep} = $self->schema->storage->sql_maker->name_sep + || $dbh->get_info(41) + || q{.}; + + # For our usage as regex matches, concatenating multiple quoter + # values works fine (e.g. s/\Q<>\E// if quoter was [ '<', '>' ]) + if( ref $self->{_quoter} eq 'ARRAY') { + $self->{_quoter} = join(q{}, @{$self->{_quoter}}); + } + + $self->_setup; + + $self; +} + +# Override this in vendor modules to do things at the end of ->new() +sub _setup { } + +# Returns an array of table names +sub _tables_list { + my $self = shift; + + my $dbh = $self->schema->storage->dbh; + my @tables = $dbh->tables(undef, $self->db_schema, '%', '%'); + s/\Q$self->{_quoter}\E//g for @tables; + s/^.*\Q$self->{_namesep}\E// for @tables; + + return @tables; +} + +# Returns an arrayref of column names +sub _table_columns { + my ($self, $table) = @_; + + my $dbh = $self->schema->storage->dbh; + + if($self->{db_schema}) { + $table = $self->{db_schema} . $self->{_namesep} . $table; + } + + my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0"); + $sth->execute; + return \@{$sth->{NAME_lc}}; +} + +# Returns arrayref of pk col names +sub _table_pk_info { + my ( $self, $table ) = @_; + + my $dbh = $self->schema->storage->dbh; + + my @primary = map { lc } $dbh->primary_key('', $self->db_schema, $table); + s/\Q$self->{_quoter}\E//g for @primary; + + return \@primary; +} + +# Override this for uniq info +sub _table_uniq_info { + warn "No UNIQUE information can be gathered for this vendor"; + return []; +} + +# Find relationships +sub _table_fk_info { + my ($self, $table) = @_; + + my $dbh = $self->schema->storage->dbh; + my $sth = $dbh->foreign_key_info( '', '', '', '', + $self->db_schema, $table ); + return [] if !$sth; + + my %rels; + + my $i = 1; # for unnamed rels, which hopefully have only 1 column ... + while(my $raw_rel = $sth->fetchrow_arrayref) { + my $uk_tbl = $raw_rel->[2]; + my $uk_col = lc $raw_rel->[3]; + my $fk_col = lc $raw_rel->[7]; + my $relid = ($raw_rel->[11] || ( "__dcsld__" . $i++ )); + $uk_tbl =~ s/\Q$self->{_quoter}\E//g; + $uk_col =~ s/\Q$self->{_quoter}\E//g; + $fk_col =~ s/\Q$self->{_quoter}\E//g; + $relid =~ s/\Q$self->{_quoter}\E//g; + $rels{$relid}->{tbl} = $uk_tbl; + $rels{$relid}->{cols}->{$uk_col} = $fk_col; + } + + my @rels; + foreach my $relid (keys %rels) { + push(@rels, { + remote_columns => [ keys %{$rels{$relid}->{cols}} ], + local_columns => [ values %{$rels{$relid}->{cols}} ], + remote_table => $rels{$relid}->{tbl}, + }); + } + + return \@rels; +} + +=head1 SEE ALSO + +L + +=cut + +1; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm b/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm new file mode 100644 index 0000000..5ec113f --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm @@ -0,0 +1,68 @@ +package DBIx::Class::Schema::Loader::DBI::DB2; + +use strict; +use warnings; +use base 'DBIx::Class::Schema::Loader::DBI'; +use Class::C3; + +=head1 NAME + +DBIx::Class::Schema::Loader::DBI::DB2 - DBIx::Class::Schema::Loader::DBI DB2 Implementation. + +=head1 SYNOPSIS + + package My::Schema; + use base qw/DBIx::Class::Schema::Loader/; + + __PACKAGE__->loader_options( + relationships => 1, + db_schema => "MYSCHEMA", + ); + + 1; + +=head1 DESCRIPTION + +See L. + +=cut + +sub _table_uniq_info { + my ($self, $table) = @_; + + my @uniqs; + + my $dbh = $self->schema->storage->dbh; + + my $sth = $dbh->prepare(<<'SQL') or die; +SELECT kcu.COLNAME, kcu.CONSTNAME, kcu.COLSEQ +FROM SYSCAT.TABCONST as tc +JOIN SYSCAT.KEYCOLUSE as kcu ON tc.CONSTNAME = kcu.CONSTNAME +WHERE tc.TABSCHEMA = ? and tc.TABNAME = ? and tc.TYPE = 'U' +SQL + + $sth->execute($self->db_schema, $table) or die; + + my %keydata; + while(my $row = $sth->fetchrow_arrayref) { + my ($col, $constname, $seq) = @$row; + push(@{$keydata{$constname}}, [ $seq, lc $col ]); + } + foreach my $keyname (keys %keydata) { + my @ordered_cols = map { $_->[1] } sort { $a->[0] <=> $b->[0] } + @{$keydata{$keyname}}; + push(@uniqs, [ $keyname => \@ordered_cols ]); + } + $sth->finish; + + return \@uniqs; +} + +=head1 SEE ALSO + +L, L, +L + +=cut + +1; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm b/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm new file mode 100644 index 0000000..dbc0470 --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm @@ -0,0 +1,77 @@ +package DBIx::Class::Schema::Loader::DBI::Pg; + +use strict; +use warnings; +use base 'DBIx::Class::Schema::Loader::DBI'; +use Class::C3; + +=head1 NAME + +DBIx::Class::Schema::Loader::DBI::Pg - DBIx::Class::Schema::Loader::DBI Postgres Implementation. + +=head1 SYNOPSIS + + package My::Schema; + use base qw/DBIx::Class::Schema::Loader/; + + __PACKAGE__->loader_options( + relationships => 1, + ); + + 1; + +=head1 DESCRIPTION + +See L. + +=cut + +sub _setup { + my $self = shift; + + $self->next::method(@_); + $self->{db_schema} ||= 'public'; +} + +sub _table_uniq_info { + my ($self, $table) = @_; + + my @uniqs; + my $dbh = $self->schema->storage->dbh; + + my $sth = $dbh->prepare_cached( + qq{SELECT conname,indexdef FROM pg_indexes JOIN pg_constraint } + . qq{ON (pg_indexes.indexname = pg_constraint.conname) } + . qq{WHERE schemaname=? and tablename=? and contype = 'u'} + ,{}, 1); + + $sth->execute($self->db_schema, $table); + while(my $constr = $sth->fetchrow_arrayref) { + my $constr_name = $constr->[0]; + my $constr_def = $constr->[1]; + my @cols; + if($constr_def =~ /\(\s*([^)]+)\)\s*$/) { + my $cols_text = $1; + $cols_text =~ s/\s+$//; + @cols = map { lc } split(/\s*,\s*/, $cols_text); + s/\Q$self->{_quoter}\E// for @cols; + } + if(!@cols) { + warn "Failed to parse unique constraint $constr_name on $table"; + } + else { + push(@uniqs, [ $constr_name => \@cols ]); + } + } + + return \@uniqs; +} + +=head1 SEE ALSO + +L, L, +L + +=cut + +1; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm new file mode 100644 index 0000000..603c672 --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm @@ -0,0 +1,160 @@ +package DBIx::Class::Schema::Loader::DBI::SQLite; + +use strict; +use warnings; +use base qw/DBIx::Class::Schema::Loader::DBI/; +use Class::C3; +use Text::Balanced qw( extract_bracketed ); + +=head1 NAME + +DBIx::Class::Schema::Loader::DBI::SQLite - DBIx::Class::Schema::Loader::DBI SQLite Implementation. + +=head1 SYNOPSIS + + package My::Schema; + use base qw/DBIx::Class::Schema::Loader/; + + __PACKAGE__->loader_optoins( relationships => 1 ); + + 1; + +=head1 DESCRIPTION + +See L. + +=cut + +# XXX this really needs a re-factor +sub _sqlite_parse_table { + my ($self, $table) = @_; + + my @rels; + my @uniqs; + + my $dbh = $self->schema->storage->dbh; + my $sth = $dbh->prepare(<<""); +SELECT sql FROM sqlite_master WHERE tbl_name = ? + + $sth->execute($table); + my ($sql) = $sth->fetchrow_array; + $sth->finish; + + # Cut "CREATE TABLE ( )" blabla... + $sql =~ /^[\w\s]+\((.*)\)$/si; + my $cols = $1; + + # strip single-line comments + $cols =~ s/\-\-.*\n/\n/g; + + # temporarily replace any commas inside parens, + # so we don't incorrectly split on them below + my $cols_no_bracketed_commas = $cols; + while ( my $extracted = + ( extract_bracketed( $cols, "()", "[^(]*" ) )[0] ) + { + my $replacement = $extracted; + $replacement =~ s/,/--comma--/g; + $replacement =~ s/^\(//; + $replacement =~ s/\)$//; + $cols_no_bracketed_commas =~ s/$extracted/$replacement/m; + } + + # Split column definitions + for my $col ( split /,/, $cols_no_bracketed_commas ) { + + # put the paren-bracketed commas back, to help + # find multi-col fks below + $col =~ s/\-\-comma\-\-/,/g; + + $col =~ s/^\s*FOREIGN\s+KEY\s*//i; + + # Strip punctuations around key and table names + $col =~ s/[\[\]'"]/ /g; + $col =~ s/^\s+//gs; + + # Grab reference + chomp $col; + + if($col =~ /^(.*)\s+UNIQUE/) { + my $colname = $1; + $colname =~ s/\s+.*$//; + push(@uniqs, [ "${colname}_unique" => [ lc $colname ] ]); + } + elsif($col =~/^\s*UNIQUE\s*\(\s*(.*)\)/) { + my $cols = $1; + $cols =~ s/\s+$//; + my @cols = map { lc } split(/\s*,\s*/, $cols); + my $name = join(q{_}, @cols) . '_unique'; + push(@uniqs, [ $name => \@cols ]); + } + + next if $col !~ /^(.*)\s+REFERENCES\s+(\w+) (?: \s* \( (.*) \) )? /ix; + + my ($cols, $f_table, $f_cols) = ($1, $2, $3); + + if($cols =~ /^\(/) { # Table-level + $cols =~ s/^\(\s*//; + $cols =~ s/\s*\)$//; + } + else { # Inline + $cols =~ s/\s+.*$//; + } + + my @cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$cols); + my $rcols; + if($f_cols) { + my @f_cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$f_cols); + die "Mismatched column count in rel for $table => $f_table" + if @cols != @f_cols; + $rcols = \@f_cols; + } + push(@rels, { + local_columns => \@cols, + remote_columns => $rcols, + remote_table => $f_table, + }); + } + + return { rels => \@rels, uniqs => \@uniqs }; +} + +sub _table_fk_info { + my ($self, $table) = @_; + + $self->{_sqlite_parse_data}->{$table} ||= + $self->_sqlite_parse_table($table); + + return $self->{_sqlite_parse_data}->{$table}->{rels}; +} + +sub _table_uniq_info { + my ($self, $table) = @_; + + $self->{_sqlite_parse_data}->{$table} ||= + $self->_sqlite_parse_table($table); + + return $self->{_sqlite_parse_data}->{$table}->{uniqs}; +} + +sub _tables_list { + my $self = shift; + my $dbh = $self->schema->storage->dbh; + my $sth = $dbh->prepare("SELECT * FROM sqlite_master"); + $sth->execute; + my @tables; + while ( my $row = $sth->fetchrow_hashref ) { + next unless lc( $row->{type} ) eq 'table'; + push @tables, $row->{tbl_name}; + } + return @tables; +} + +=head1 SEE ALSO + +L, L, +L + +=cut + +1; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Writing.pm b/lib/DBIx/Class/Schema/Loader/DBI/Writing.pm new file mode 100644 index 0000000..3ac5618 --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBI/Writing.pm @@ -0,0 +1,56 @@ +package DBIx::Class::Schema::Loader::DBI::Writing; +use strict; + +# Empty. POD only. + +1; + +=head1 NAME + +DBIx::Class::Schema::Loader::DBI::Writing - Loader subclass writing guide for DBI + +=head1 SYNOPSIS + + package DBIx::Class::Schema::Loader::DBI::Foo; + + # THIS IS JUST A TEMPLATE TO GET YOU STARTED. + + use strict; + use warnings; + use base 'DBIx::Class::Schema::Loader::DBI'; + use Class::C3; + + sub _table_uniq_info { + my ($self, $table) = @_; + + # ... get UNIQUE info for $table somehow + # and return a data structure that looks like this: + + return [ + [ 'keyname' => [ 'colname' ] ], + [ 'keyname2' => [ 'col1name', 'col2name' ] ], + [ 'keyname3' => [ 'colname' ] ], + ]; + + # Where the "keyname"'s are just unique identifiers, such as the + # name of the unique constraint, or the names of the columns involved + # concatenated if you wish. + } + + 1; + +=head1 DETAILS + +The only required method for new subclasses is C<_table_uniq_info>, +as I have not to date found any pseudo-standardized or DBD-agnostic +way for obtaining this information. + +The base DBI Loader contains generic methods that *should* work for +everything else in theory, although in practice some DBDs need to +override one or more of the other methods. The other methods one might +likely want to override are: C<_table_pk_info>, C<_table_fk_info>, and +C<_tables_list>. See the included DBD drivers for examples of these. + +=cut + +1; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/mysql.pm b/lib/DBIx/Class/Schema/Loader/DBI/mysql.pm new file mode 100644 index 0000000..b93669c --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBI/mysql.pm @@ -0,0 +1,115 @@ +package DBIx::Class::Schema::Loader::DBI::mysql; + +use strict; +use warnings; +use base 'DBIx::Class::Schema::Loader::DBI'; +use Class::C3; + +=head1 NAME + +DBIx::Class::Schema::Loader::DBI::mysql - DBIx::Class::Schema::Loader::DBI mysql Implementation. + +=head1 SYNOPSIS + + package My::Schema; + use base qw/DBIx::Class::Schema::Loader/; + + __PACKAGE__->load_from_connection( + relationships => 1, + ); + + 1; + +=head1 DESCRIPTION + +See L. + +=cut + +sub _table_fk_info { + my ($self, $table) = @_; + + my $dbh = $self->schema->storage->dbh; + + my $query = "SHOW CREATE TABLE ${table}"; + my $sth = $dbh->prepare($query) + or die("Cannot get table definition: $table"); + $sth->execute; + my $table_def = $sth->fetchrow_arrayref->[1] || ''; + $sth->finish; + + my (@reldata) = ($table_def =~ /CONSTRAINT `.*` FOREIGN KEY \(`(.*)`\) REFERENCES `(.*)` \(`(.*)`\)/ig); + + my @rels; + while (scalar @reldata > 0) { + my $cols = shift @reldata; + my $f_table = shift @reldata; + my $f_cols = shift @reldata; + + my @cols = map { s/\Q$self->{_quoter}\E//; lc $_ } split(/\s*,\s*/,$cols); + my @f_cols = map { s/\Q$self->{_quoter}\E//; lc $_ } split(/\s*,\s*/,$f_cols); + + push(@rels, { + local_columns => \@cols, + remote_columns => \@f_cols, + remote_table => $f_table + }); + } + + return \@rels; +} + +# primary and unique info comes from the same sql statement, +# so cache it here for both routines to use +sub _mysql_table_get_keys { + my ($self, $table) = @_; + + if(!exists($self->{_mysql_keys}->{$table})) { + my %keydata; + my $dbh = $self->schema->storage->dbh; + my $sth = $dbh->prepare("SHOW INDEX FROM $table"); + $sth->execute; + while(my $row = $sth->fetchrow_hashref) { + next if $row->{Non_unique}; + push(@{$keydata{$row->{Key_name}}}, + [ $row->{Seq_in_index}, lc $row->{Column_name} ] + ); + } + foreach my $keyname (keys %keydata) { + my @ordered_cols = map { $_->[1] } sort { $a->[0] <=> $b->[0] } + @{$keydata{$keyname}}; + $keydata{$keyname} = \@ordered_cols; + } + $self->{_mysql_keys}->{$table} = \%keydata; + } + + return $self->{_mysql_keys}->{$table}; +} + +sub _table_pk_info { + my ( $self, $table ) = @_; + + return $self->_mysql_table_get_keys($table)->{PRIMARY}; +} + +sub _table_uniq_info { + my ( $self, $table ) = @_; + + my @uniqs; + my $keydata = $self->_mysql_table_get_keys($table); + foreach my $keyname (%$keydata) { + next if $keyname eq 'PRIMARY'; + push(@uniqs, [ $keyname => $keydata->{$keyname} ]); + } + + return \@uniqs; +} + +=head1 SEE ALSO + +L, L, +L + +=cut + +1; diff --git a/lib/DBIx/Class/Schema/Loader/Generic.pm b/lib/DBIx/Class/Schema/Loader/Generic.pm deleted file mode 100644 index a2fbd21..0000000 --- a/lib/DBIx/Class/Schema/Loader/Generic.pm +++ /dev/null @@ -1,558 +0,0 @@ -package DBIx::Class::Schema::Loader::Generic; - -use strict; -use warnings; -use base qw/Class::Accessor::Fast/; -use Class::C3; -use Carp; -use Lingua::EN::Inflect; -use UNIVERSAL::require; -require DBIx::Class; - -# The first group are all arguments which are may be defaulted within, -# The last two (classes, monikers) are generated locally: - -__PACKAGE__->mk_ro_accessors(qw/ - schema - connect_info - exclude - constraint - additional_classes - additional_base_classes - left_base_classes - components - resultset_components - relationships - inflect_map - moniker_map - db_schema - drop_db_schema - debug - - _tables - classes - monikers - /); - -=head1 NAME - -DBIx::Class::Schema::Loader::Generic - Generic DBIx::Class::Schema::Loader Implementation. - -=head1 SYNOPSIS - -See L - -=head1 DESCRIPTION - -This is the base class for the vendor-specific C -classes, and implements the common functionality between them. - -=head1 OPTIONS - -Available constructor options are: - -=head2 connect_info - -Identical to the connect_info arguments to C and C -that are mentioned in L. - -An arrayref of connection information. For DBI-based Schemas, -this takes the form: - - connect_info => [ $dsn, $user, $pass, { AutoCommit => 1 } ], - -=head2 additional_base_classes - -List of additional base classes your table classes will use. - -=head2 left_base_classes - -List of additional base classes, that need to be leftmost. - -=head2 additional_classes - -List of additional classes which your table classes will use. - -=head2 components - -List of additional components to be loaded into your table classes. -A good example would be C. - -=head2 resultset_components - -List of additional resultset components to be loaded into your table -classes. A good example would be C. Component -C will be automatically added to the above -C list if this option is set. - -=head2 constraint - -Only load tables matching regex. - -=head2 exclude - -Exclude tables matching regex. - -=head2 debug - -Enable debug messages. - -=head2 relationships - -Try to automatically detect/setup has_a and has_many relationships. - -=head2 moniker_map - -Overrides the default tablename -> moniker translation. Can be either -a hashref of table => moniker names, or a coderef for a translator -function taking a single scalar table name argument and returning -a scalar moniker. If the hash entry does not exist, or the function -returns a false/undef value, the code falls back to default behavior -for that table name. - -=head2 inflect_map - -Just like L above, but for inflecting (pluralizing) -relationship names. - -=head2 inflect - -Deprecated. Equivalent to L, but previously only took -a hashref argument, not a coderef. If you set C to anything, -that setting will be copied to L. - -=head2 dsn - -DEPRECATED, use L instead. - -DBI Data Source Name. - -=head2 user - -DEPRECATED, use L instead. - -Username. - -=head2 password - -DEPRECATED, use L instead. - -Password. - -=head2 options - -DEPRECATED, use L instead. - -DBI connection options hashref, like: - - { AutoCommit => 1 } - -=head1 METHODS - -=cut - -# ensure that a peice of object data is a valid arrayref, creating -# an empty one or encapsulating whatever's there. -sub _ensure_arrayref { - my $self = shift; - - foreach (@_) { - $self->{$_} ||= []; - $self->{$_} = [ $self->{$_} ] - unless ref $self->{$_} eq 'ARRAY'; - } -} - -=head2 new - -Constructor for L, used internally -by L. - -=cut - -sub new { - my ( $class, %args ) = @_; - - my $self = { %args }; - - bless $self => $class; - - $self->{db_schema} ||= ''; - $self->{constraint} ||= '.*'; - $self->_ensure_arrayref(qw/additional_classes - additional_base_classes - left_base_classes - components - resultset_components - connect_info/); - - push(@{$self->{components}}, 'ResultSetManager') - if @{$self->{resultset_components}}; - - $self->{monikers} = {}; - $self->{classes} = {}; - - # Support deprecated argument name - $self->{inflect_map} ||= $self->{inflect}; - - # Support deprecated connect_info args, even mixed - # with a valid partially-filled connect_info - $self->{connect_info}->[0] ||= $self->{dsn}; - $self->{connect_info}->[1] ||= $self->{user}; - $self->{connect_info}->[2] ||= $self->{password}; - $self->{connect_info}->[3] ||= $self->{options}; - - $self; -} - -=head2 load - -Does the actual schema-construction work, used internally by -L right after object construction. - -=cut - -sub load { - my $self = shift; - - $self->schema->connection(@{$self->connect_info}); - - warn qq/\### START DBIx::Class::Schema::Loader dump ###\n/ - if $self->debug; - - $self->_load_classes; - $self->_load_relationships if $self->relationships; - $self->_load_external; - - warn qq/\### END DBIx::Class::Schema::Loader dump ###\n/ - if $self->debug; - $self->schema->storage->disconnect; - - $self; -} - -sub _load_external { - my $self = shift; - - foreach my $table_class (map { $self->classes->{$_} } $self->tables) { - $table_class->require; - if($@ && $@ !~ /^Can't locate /) { - croak "Failed to load external class definition" - . " for '$table_class': $@"; - } - elsif(!$@) { - warn qq/# Loaded external class definition for '$table_class'\n/ - if $self->debug; - } - } -} - -# Overload in your driver class -sub _db_classes { croak "ABSTRACT METHOD" } - -# Inflect a relationship name -sub _inflect_relname { - my ($self, $relname) = @_; - - if( ref $self->{inflect_map} eq 'HASH' ) { - return $self->inflect_map->{$relname} - if exists $self->inflect_map->{$relname}; - } - elsif( ref $self->{inflect_map} eq 'CODE' ) { - my $inflected = $self->inflect_map->($relname); - return $inflected if $inflected; - } - - return Lingua::EN::Inflect::PL($relname); -} - -# Set up a simple relation with just a local col and foreign table -sub _make_simple_rel { - my ($self, $table, $other, $col) = @_; - - my $table_class = $self->classes->{$table}; - my $other_class = $self->classes->{$other}; - my $table_relname = $self->_inflect_relname(lc $table); - - warn qq/\# Belongs_to relationship\n/ if $self->debug; - warn qq/$table_class->belongs_to( '$col' => '$other_class' );\n\n/ - if $self->debug; - $table_class->belongs_to( $col => $other_class ); - - warn qq/\# Has_many relationship\n/ if $self->debug; - warn qq/$other_class->has_many( '$table_relname' => '$table_class',/ - . qq/$col);\n\n/ - if $self->debug; - - $other_class->has_many( $table_relname => $table_class, $col); -} - -# not a class method, just a helper for cond_rel XXX -sub _stringify_hash { - my $href = shift; - - return '{ ' . - join(q{, }, map("$_ => $href->{$_}", keys %$href)) - . ' }'; -} - -# Set up a complex relation based on a hashref condition -sub _make_cond_rel { - my ( $self, $table, $other, $cond ) = @_; - - my $table_class = $self->classes->{$table}; - my $other_class = $self->classes->{$other}; - my $table_relname = $self->_inflect_relname(lc $table); - my $other_relname = lc $other; - - # for single-column case, set the relname to the column name, - # to make filter accessors work - if(scalar keys %$cond == 1) { - my ($col) = keys %$cond; - $other_relname = $cond->{$col}; - } - - my $rev_cond = { reverse %$cond }; - - for (keys %$rev_cond) { - $rev_cond->{"foreign.$_"} = "self.".$rev_cond->{$_}; - delete $rev_cond->{$_}; - } - - my $cond_printable = _stringify_hash($cond) - if $self->debug; - my $rev_cond_printable = _stringify_hash($rev_cond) - if $self->debug; - - warn qq/\# Belongs_to relationship\n/ if $self->debug; - - warn qq/$table_class->belongs_to( '$other_relname' => '$other_class',/ - . qq/$cond_printable);\n\n/ - if $self->debug; - - $table_class->belongs_to( $other_relname => $other_class, $cond); - - warn qq/\# Has_many relationship\n/ if $self->debug; - - warn qq/$other_class->has_many( '$table_relname' => '$table_class',/ - . qq/$rev_cond_printable);\n\n/ - . qq/);\n\n/ - if $self->debug; - - $other_class->has_many( $table_relname => $table_class, $rev_cond); -} - -sub _use { - my $self = shift; - my $target = shift; - - foreach (@_) { - $_->require or croak ($_ . "->require: $@"); - eval "package $target; use $_;"; - croak "use $_: $@" if $@; - } -} - -sub _inject { - my $self = shift; - my $target = shift; - my $schema = $self->schema; - - foreach (@_) { - $_->require or croak ($_ . "->require: $@"); - $schema->inject_base($target, $_); - } -} - -# Load and setup classes -sub _load_classes { - my $self = shift; - - my @db_classes = $self->_db_classes(); - my $schema = $self->schema; - - my $constraint = $self->constraint; - my $exclude = $self->exclude; - my @tables = sort grep - { /$constraint/ && (!$exclude || ! /$exclude/) } - $self->_tables_list; - - $self->{_tables} = \@tables; - - foreach my $table (@tables) { - my ($db_schema, $tbl) = split /\./, $table; - if($tbl) { - $table = $self->drop_db_schema ? $tbl : $table; - } - my $lc_table = lc $table; - - my $table_moniker = $self->_table2moniker($db_schema, $tbl); - my $table_class = $schema . q{::} . $table_moniker; - - $self->classes->{$lc_table} = $table_class; - $self->monikers->{$lc_table} = $table_moniker; - $self->classes->{$table} = $table_class; - $self->monikers->{$table} = $table_moniker; - - no warnings 'redefine'; - local *Class::C3::reinitialize = sub { }; - use warnings; - - { no strict 'refs'; - @{"${table_class}::ISA"} = qw/DBIx::Class/; - } - $self->_use ($table_class, @{$self->additional_classes}); - $self->_inject($table_class, @{$self->additional_base_classes}); - $table_class->load_components(@{$self->components}, @db_classes, 'Core'); - $table_class->load_resultset_components(@{$self->resultset_components}) - if @{$self->resultset_components}; - $self->_inject($table_class, @{$self->left_base_classes}); - } - - Class::C3::reinitialize; - - foreach my $table (@tables) { - my $table_class = $self->classes->{$table}; - my $table_moniker = $self->monikers->{$table}; - - warn qq/\# Initializing table "$table" as "$table_class"\n/ - if $self->debug; - $table_class->table($table); - - my ( $cols, $pks ) = $self->_table_info($table); - carp("$table has no primary key") unless @$pks; - $table_class->add_columns(@$cols); - $table_class->set_primary_key(@$pks) if @$pks; - - warn qq/$table_class->table('$table');\n/ if $self->debug; - my $columns = join "', '", @$cols; - warn qq/$table_class->add_columns('$columns')\n/ if $self->debug; - my $primaries = join "', '", @$pks; - warn qq/$table_class->set_primary_key('$primaries')\n/ - if $self->debug && @$pks; - - $schema->register_class($table_moniker, $table_class); - } -} - -=head2 tables - -Returns a sorted list of loaded tables, using the original database table -names. - - my @tables = $schema->loader->tables; - -=cut - -sub tables { - my $self = shift; - - return @{$self->_tables}; -} - -# Find and setup relationships -sub _load_relationships { - my $self = shift; - - my $dbh = $self->schema->storage->dbh; - my $quoter = $dbh->get_info(29) || q{"}; - foreach my $table ( $self->tables ) { - my $rels = {}; - my $sth = $dbh->foreign_key_info( '', - $self->db_schema, '', '', '', $table ); - next if !$sth; - while(my $raw_rel = $sth->fetchrow_hashref) { - my $uk_tbl = $raw_rel->{UK_TABLE_NAME}; - my $uk_col = lc $raw_rel->{UK_COLUMN_NAME}; - my $fk_col = lc $raw_rel->{FK_COLUMN_NAME}; - my $relid = $raw_rel->{UK_NAME}; - $uk_tbl =~ s/$quoter//g; - $uk_col =~ s/$quoter//g; - $fk_col =~ s/$quoter//g; - $relid =~ s/$quoter//g; - $rels->{$relid}->{tbl} = $uk_tbl; - $rels->{$relid}->{cols}->{$uk_col} = $fk_col; - } - - foreach my $relid (keys %$rels) { - my $reltbl = $rels->{$relid}->{tbl}; - my $cond = $rels->{$relid}->{cols}; - eval { $self->_make_cond_rel( $table, $reltbl, $cond ) }; - warn qq/\# belongs_to_many failed "$@"\n\n/ - if $@ && $self->debug; - } - } -} - -# Make a moniker from a table -sub _table2moniker { - my ( $self, $db_schema, $table ) = @_; - - my $db_schema_ns; - - if($table) { - $db_schema = ucfirst lc $db_schema; - $db_schema_ns = $db_schema if(!$self->drop_db_schema); - } else { - $table = $db_schema; - } - - my $moniker; - - if( ref $self->moniker_map eq 'HASH' ) { - $moniker = $self->moniker_map->{$table}; - } - elsif( ref $self->moniker_map eq 'CODE' ) { - $moniker = $self->moniker_map->($table); - } - - $moniker ||= join '', map ucfirst, split /[\W_]+/, lc $table; - - $moniker = $db_schema_ns ? $db_schema_ns . $moniker : $moniker; - - return $moniker; -} - -# Overload in driver class -sub _tables_list { croak "ABSTRACT METHOD" } - -sub _table_info { croak "ABSTRACT METHOD" } - -=head2 monikers - -Returns a hashref of loaded table-to-moniker mappings for the original -database table names. In cases where the database driver returns table -names as uppercase or mixed case, there will also be a duplicate entry -here in all lowercase. Best practice would be to use lower-case table -names when accessing this. - - my $monikers = $schema->loader->monikers; - my $foo_tbl_moniker = $monikers->{foo_tbl}; - # -or- - my $foo_tbl_moniker = $schema->loader->monikers->{foo_tbl}; - # $foo_tbl_moniker would look like "FooTbl" - -=head2 classes - -Returns a hashref of table-to-classname mappings for the original database -table names. Same lowercase stuff as above applies here. - -You probably shouldn't be using this for any normal or simple -usage of your Schema. The usual way to run queries on your tables is via -C<$schema-Eresultset('FooTbl')>, where C is a moniker as -returned by C above. - - my $classes = $schema->loader->classes; - my $foo_tbl_class = $classes->{foo_tbl}; - # -or- - my $foo_tbl_class = $schema->loader->classes->{foo_tbl}; - # $foo_tbl_class would look like "My::Schema::FooTbl", - # assuming the schema class is "My::Schema" - -=head1 SEE ALSO - -L - -=cut - -1; diff --git a/lib/DBIx/Class/Schema/Loader/Pg.pm b/lib/DBIx/Class/Schema/Loader/Pg.pm deleted file mode 100644 index e69ca38..0000000 --- a/lib/DBIx/Class/Schema/Loader/Pg.pm +++ /dev/null @@ -1,89 +0,0 @@ -package DBIx::Class::Schema::Loader::Pg; - -use strict; -use warnings; -use Class::C3; -use base 'DBIx::Class::Schema::Loader::Generic'; - -=head1 NAME - -DBIx::Class::Schema::Loader::Pg - DBIx::Class::Schema::Loader Postgres Implementation. - -=head1 SYNOPSIS - - package My::Schema; - use base qw/DBIx::Class::Schema::Loader/; - - __PACKAGE__->load_from_connection( - dsn => "dbi:Pg:dbname=dbname", - user => "postgres", - password => "", - ); - - 1; - -=head1 DESCRIPTION - -See L. - -=head1 METHODS - -=head2 new - -Overrides L's C to default the postgres -schema to C rather than blank. - -=cut - -sub new { - my ($class, %args) = @_; - - my $self = $class->next::method(%args); - $self->{db_schema} ||= 'public'; - - $self; -} - -sub _db_classes { - return qw/PK::Auto::Pg/; -} - -sub _tables_list { - my $self = shift; - my $dbh = $self->schema->storage->dbh; - my $quoter = $dbh->get_info(29) || q{"}; - - # This is split out to avoid version parsing errors... - my $is_dbd_pg_gte_131 = ( $DBD::Pg::VERSION >= 1.31 ); - my @tables = $is_dbd_pg_gte_131 - ? $dbh->tables( undef, $self->db_schema, "", - "table", { noprefix => 1, pg_noprefix => 1 } ) - : $dbh->tables; - - s/$quoter//g for @tables; - return @tables; -} - -sub _table_info { - my ( $self, $table ) = @_; - my $dbh = $self->schema->storage->dbh; - my $quoter = $dbh->get_info(29) || q{"}; - - my $sth = $dbh->column_info(undef, $self->db_schema, $table, undef); - my @cols = map { lc $_->[3] } @{ $sth->fetchall_arrayref }; - s/$quoter//g for @cols; - - my @primary = map { lc } $dbh->primary_key(undef, $self->db_schema, $table); - - s/$quoter//g for @primary; - - return ( \@cols, \@primary ); -} - -=head1 SEE ALSO - -L - -=cut - -1; diff --git a/lib/DBIx/Class/Schema/Loader/RelBuilder.pm b/lib/DBIx/Class/Schema/Loader/RelBuilder.pm new file mode 100644 index 0000000..10099e1 --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/RelBuilder.pm @@ -0,0 +1,217 @@ +package DBIx::Class::Schema::Loader::RelBuilder; + +use strict; +use warnings; +use Carp; +use Lingua::EN::Inflect (); +use Lingua::EN::Inflect::Number (); + +=head1 NAME + +DBIx::Class::Schema::Loader::RelBuilder - Builds relationships for DBIx::Class::Schema::Loader + +=head1 SYNOPSIS + +See L + +=head1 DESCRIPTION + +This class builds relationships for L. This +is module is not (yet) for external use. + +=head1 METHODS + +=head2 new + +Arguments: schema_class (scalar), fk_info (hashref), inflect_plural, inflect_singular + +C<$schema_class> should be a schema class name, where the source +classes have already been set up and registered. Column info, primary +key, and unique constraints will be drawn from this schema for all +of the existing source monikers. + +The fk_info hashref's contents should take the form: + + { + TableMoniker => [ + { + local_columns => [ 'col2', 'col3' ], + remote_columns => [ 'col5', 'col7' ], + remote_moniker => 'AnotherTableMoniker', + }, + # ... + ], + AnotherTableMoniker => [ + # ... + ], + # ... + } + +Options inflect_plural and inflect_singular are optional, and are better documented +in L. + +=head2 generate_code + +This method will return the generated relationships as a hashref per table moniker, +containing an arrayref of code strings which can be "eval"-ed in the context of +the source class, like: + + { + 'Some::Source::Class' => [ + "belongs_to( col1 => 'AnotherTableMoniker' )", + "has_many( anothers => 'AnotherTableMoniker', 'col15' )", + ], + 'Another::Source::Class' => [ + # ... + ], + # ... + } + +You might want to use this in building an on-disk source class file, by +adding each string to the appropriate source class file, +prefixed by C<__PACKAGE__-E>. + +=cut + +sub new { + my ( $class, $schema, $fk_info, $inflect_pl, $inflect_singular ) = @_; + + my $self = { + schema => $schema, + fk_info => $fk_info, + inflect_plural => $inflect_pl, + inflect_singular => $inflect_singular, + }; + + bless $self => $class; + + $self; +} + + +# pluralize a relationship name +sub _inflect_plural { + my ($self, $relname) = @_; + + if( ref $self->{inflect_plural} eq 'HASH' ) { + return $self->{inflect_plural}->{$relname} + if exists $self->{inflect_plural}->{$relname}; + } + elsif( ref $self->{inflect_plural} eq 'CODE' ) { + my $inflected = $self->{inflect_plural}->($relname); + return $inflected if $inflected; + } + + return $self->{legacy_default_inflections} + ? Lingua::EN::Inflect::PL($relname) + : Lingua::EN::Inflect::Number::to_PL($relname); +} + +# Singularize a relationship name +sub _inflect_singular { + my ($self, $relname) = @_; + + if( ref $self->{inflect_singular} eq 'HASH' ) { + return $self->{inflect_singular}->{$relname} + if exists $self->{inflect_singular}->{$relname}; + } + elsif( ref $self->{inflect_singular} eq 'CODE' ) { + my $inflected = $self->{inflect_singular}->($relname); + return $inflected if $inflected; + } + + return $self->{legacy_default_inflections} + ? $relname + : Lingua::EN::Inflect::Number::to_S($relname); +} + +sub generate_code { + my $self = shift; + + my $all_code = {}; + + foreach my $local_moniker (keys %{$self->{fk_info}}) { + my $local_table = $self->{schema}->source($local_moniker)->from; + my $local_class = $self->{schema}->class($local_moniker); + my $rels = $self->{fk_info}->{$local_moniker}; + + my %counters; + foreach my $rel (@$rels) { + next if !$rel->{remote_source}; + $counters{$rel->{remote_source}}++; + } + + foreach my $rel (@$rels) { + next if !$rel->{remote_source}; + my $local_cols = $rel->{local_columns}; + my $remote_cols = $rel->{remote_columns}; + my $remote_moniker = $rel->{remote_source}; + my $remote_obj = $self->{schema}->source($remote_moniker); + my $remote_class = $self->{schema}->class($remote_moniker); + my $remote_table = $remote_obj->from; + $remote_cols ||= [ $remote_obj->primary_columns ]; + + if($#$local_cols != $#$remote_cols) { + croak "Column count mismatch: $local_moniker (@$local_cols) " + . "$remote_moniker (@$remote_cols)"; + } + + my %cond; + foreach my $i (0 .. $#$local_cols) { + $cond{$remote_cols->[$i]} = $local_cols->[$i]; + } + + # If more than one rel between this pair of tables, use the + # local col name(s) as the relname in the foreign source, instead + # of the local table name. + my $local_relname; + if($counters{$remote_moniker} > 1) { + $local_relname = $self->_inflect_plural( + lc($local_table) . q{_} . join(q{_}, @$local_cols) + ); + } else { + $local_relname = $self->_inflect_plural(lc $local_table); + } + + # for single-column case, set the relname to the column name, + # to make filter accessors work + my $remote_relname; + if(scalar keys %cond == 1) { + my ($col) = keys %cond; + $remote_relname = $self->_inflect_singular($cond{$col}); + } + else { + $remote_relname = $self->_inflect_singular(lc $remote_table); + } + + my %rev_cond = reverse %cond; + + for (keys %rev_cond) { + $rev_cond{"foreign.$_"} = "self.".$rev_cond{$_}; + delete $rev_cond{$_}; + } + + push(@{$all_code->{$local_class}}, + { method => 'belongs_to', + args => [ $remote_relname, + $remote_moniker, + \%cond, + ], + } + ); + + push(@{$all_code->{$remote_class}}, + { method => 'has_many', + args => [ $local_relname, + $local_moniker, + \%rev_cond, + ], + } + ); + } + } + + return $all_code; +} + +1; diff --git a/lib/DBIx/Class/Schema/Loader/SQLite.pm b/lib/DBIx/Class/Schema/Loader/SQLite.pm deleted file mode 100644 index e3425ba..0000000 --- a/lib/DBIx/Class/Schema/Loader/SQLite.pm +++ /dev/null @@ -1,174 +0,0 @@ -package DBIx::Class::Schema::Loader::SQLite; - -use strict; -use warnings; -use base qw/DBIx::Class::Schema::Loader::Generic/; -use Class::C3; -use Text::Balanced qw( extract_bracketed ); - -=head1 NAME - -DBIx::Class::Schema::Loader::SQLite - DBIx::Class::Schema::Loader SQLite Implementation. - -=head1 SYNOPSIS - - package My::Schema; - use base qw/DBIx::Class::Schema::Loader/; - - __PACKAGE__->load_from_connection( - dsn => "dbi:SQLite:dbname=/path/to/dbfile", - ); - - 1; - -=head1 DESCRIPTION - -See L. - -=cut - -sub _db_classes { - return qw/PK::Auto::SQLite/; -} - -# XXX this really needs a re-factor -sub _load_relationships { - my $self = shift; - foreach my $table ( $self->tables ) { - - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(<<""); -SELECT sql FROM sqlite_master WHERE tbl_name = ? - - $sth->execute($table); - my ($sql) = $sth->fetchrow_array; - $sth->finish; - - # Cut "CREATE TABLE ( )" blabla... - $sql =~ /^[\w\s]+\((.*)\)$/si; - my $cols = $1; - - # strip single-line comments - $cols =~ s/\-\-.*\n/\n/g; - - # temporarily replace any commas inside parens, - # so we don't incorrectly split on them below - my $cols_no_bracketed_commas = $cols; - while ( my $extracted = - ( extract_bracketed( $cols, "()", "[^(]*" ) )[0] ) - { - my $replacement = $extracted; - $replacement =~ s/,/--comma--/g; - $replacement =~ s/^\(//; - $replacement =~ s/\)$//; - $cols_no_bracketed_commas =~ s/$extracted/$replacement/m; - } - - # Split column definitions - for my $col ( split /,/, $cols_no_bracketed_commas ) { - - # put the paren-bracketed commas back, to help - # find multi-col fks below - $col =~ s/\-\-comma\-\-/,/g; - - $col =~ s/^\s*FOREIGN\s+KEY\s*//i; - - # Strip punctuations around key and table names - $col =~ s/[\[\]'"]/ /g; - $col =~ s/^\s+//gs; - - # Grab reference - chomp $col; - next if $col !~ /^(.*)\s+REFERENCES\s+(\w+) (?: \s* \( (.*) \) )? /ix; - - my ($cols, $f_table, $f_cols) = ($1, $2, $3); - - if($cols =~ /^\(/) { # Table-level - $cols =~ s/^\(\s*//; - $cols =~ s/\s*\)$//; - } - else { # Inline - $cols =~ s/\s+.*$//; - } - - my $cond; - - if($f_cols) { - my @cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$cols); - my @f_cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$f_cols); - die "Mismatched column count in rel for $table => $f_table" - if @cols != @f_cols; - $cond = {}; - for(my $i = 0 ; $i < @cols; $i++) { - $cond->{$f_cols[$i]} = $cols[$i]; - } - eval { $self->_make_cond_rel( $table, $f_table, $cond ) }; - } - else { - eval { $self->_make_simple_rel( $table, $f_table, lc $cols ) }; - } - - warn qq/\# belongs_to_many failed "$@"\n\n/ - if $@ && $self->debug; - } - } -} - -sub _tables_list { - my $self = shift; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare("SELECT * FROM sqlite_master"); - $sth->execute; - my @tables; - while ( my $row = $sth->fetchrow_hashref ) { - next unless lc( $row->{type} ) eq 'table'; - push @tables, $row->{tbl_name}; - } - return @tables; -} - -sub _table_info { - my ( $self, $table ) = @_; - - # find all columns. - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare("PRAGMA table_info('$table')"); - $sth->execute(); - my @columns; - while ( my $row = $sth->fetchrow_hashref ) { - push @columns, lc $row->{name}; - } - $sth->finish; - - # find primary key. so complex ;-( - $sth = $dbh->prepare(<<'SQL'); -SELECT sql FROM sqlite_master WHERE tbl_name = ? -SQL - $sth->execute($table); - my ($sql) = $sth->fetchrow_array; - $sth->finish; - my ($primary) = $sql =~ m/ - (?:\(|\,) # either a ( to start the definition or a , for next - \s* # maybe some whitespace - (\w+) # the col name - [^,]* # anything but the end or a ',' for next column - PRIMARY\sKEY/sxi; - my @pks; - - if ($primary) { - @pks = (lc $primary); - } - else { - my ($pks) = $sql =~ m/PRIMARY\s+KEY\s*\(\s*([^)]+)\s*\)/i; - @pks = map { lc } split( m/\s*\,\s*/, $pks ) if $pks; - } - return ( \@columns, \@pks ); -} - -=head1 SEE ALSO - -L - -=cut - -1; diff --git a/lib/DBIx/Class/Schema/Loader/Writing.pm b/lib/DBIx/Class/Schema/Loader/Writing.pm deleted file mode 100644 index 77962af..0000000 --- a/lib/DBIx/Class/Schema/Loader/Writing.pm +++ /dev/null @@ -1,57 +0,0 @@ -package DBIx::Class::Schema::Loader::Writing; -use strict; - -# Empty. POD only. - -1; - -=head1 NAME - -DBIx::Class::Schema::Loader::Writing - Loader subclass writing guide - -=head1 SYNOPSIS - - package DBIx::Class::Schema::Loader::Foo; - - # THIS IS JUST A TEMPLATE TO GET YOU STARTED. - - use strict; - use warnings; - use base 'DBIx::Class::Schema::Loader::Generic'; - use Class::C3; - - sub _db_classes { - return qw/PK::Auto::Foo/; - # You may want to return more, or less, than this. - } - - sub _tables_list { - my $self = shift; - my $dbh = $self->schema->storage->dbh; - return $dbh->tables; # Your DBD may need something different - } - - sub _table_info { - my ( $self, $table ) = @_; - ... - return ( \@cols, \@primary ); - } - - sub _load_relationships { - my $self = shift; - ... - - # make a simple relationship, where $table($column) - # references the PK of $f_table: - $self->_make_simple_rel($table, $f_table, $column); - - # make a relationship with a complex condition-clause: - $self->_make_cond_rel($table, $f_table, - { foo => bar, baz => xaa } ); - - ... - } - - 1; - -=cut diff --git a/lib/DBIx/Class/Schema/Loader/mysql.pm b/lib/DBIx/Class/Schema/Loader/mysql.pm deleted file mode 100644 index 64f7500..0000000 --- a/lib/DBIx/Class/Schema/Loader/mysql.pm +++ /dev/null @@ -1,111 +0,0 @@ -package DBIx::Class::Schema::Loader::mysql; - -use strict; -use warnings; -use base 'DBIx::Class::Schema::Loader::Generic'; -use Class::C3; - -=head1 NAME - -DBIx::Class::Schema::Loader::mysql - DBIx::Schema::Class::Loader mysql Implementation. - -=head1 SYNOPSIS - - package My::Schema; - use base qw/DBIx::Class::Schema::Loader/; - - __PACKAGE__->load_from_connection( - dsn => "dbi:mysql:dbname", - user => "root", - password => "", - ); - - 1; - -=head1 DESCRIPTION - -See L. - -=cut - -sub _db_classes { - return qw/PK::Auto::MySQL/; -} - -sub _load_relationships { - my $self = shift; - my @tables = $self->tables; - my $dbh = $self->schema->storage->dbh; - - my $quoter = $dbh->get_info(29) || q{`}; - - foreach my $table (@tables) { - my $query = "SHOW CREATE TABLE ${table}"; - my $sth = $dbh->prepare($query) - or die("Cannot get table definition: $table"); - $sth->execute; - my $table_def = $sth->fetchrow_arrayref->[1] || ''; - - my (@reldata) = ($table_def =~ /CONSTRAINT `.*` FOREIGN KEY \(`(.*)`\) REFERENCES `(.*)` \(`(.*)`\)/ig); - - while (scalar @reldata > 0) { - my $cols = shift @reldata; - my $f_table = shift @reldata; - my $f_cols = shift @reldata; - - my @cols = map { s/$quoter//; lc $_ } split(/\s*,\s*/,$cols); - my @f_cols = map { s/$quoter//; lc $_ } split(/\s*,\s*/,$f_cols); - die "Mismatched column count in rel for $table => $f_table" - if @cols != @f_cols; - - my $cond = {}; - for(my $i = 0; $i < @cols; $i++) { - $cond->{$f_cols[$i]} = $cols[$i]; - } - - eval { $self->_make_cond_rel( $table, $f_table, $cond) }; - warn qq/\# belongs_to_many failed "$@"\n\n/ if $@ && $self->debug; - } - - $sth->finish; - } -} - -sub _tables_list { - my $self = shift; - my $dbh = $self->schema->storage->dbh; - my @tables; - my $quoter = $dbh->get_info(29) || q{`}; - foreach my $table ( $dbh->tables ) { - $table =~ s/$quoter//g; - push @tables, $1 - if $table =~ /\A(\w+)\z/; - } - return @tables; -} - -sub _table_info { - my ( $self, $table ) = @_; - my $dbh = $self->schema->storage->dbh; - - # MySQL 4.x doesn't support quoted tables - my $query = "DESCRIBE $table"; - my $sth = $dbh->prepare($query) or die("Cannot get table status: $table"); - $sth->execute; - my ( @cols, @pri ); - while ( my $hash = $sth->fetchrow_hashref ) { - my ($col) = $hash->{Field} =~ /(\w+)/; - push @cols, lc $col; - push @pri, lc $col if $hash->{Key} eq "PRI"; - } - - return ( \@cols, \@pri ); -} - -=head1 SEE ALSO - -L - -=cut - -1; diff --git a/t/01use.t b/t/01use.t index a998b0c..8ebdc27 100644 --- a/t/01use.t +++ b/t/01use.t @@ -1,10 +1,14 @@ use strict; -use Test::More tests => 5; +use Test::More tests => 9; BEGIN { use_ok 'DBIx::Class::Schema::Loader'; - use_ok 'DBIx::Class::Schema::Loader::SQLite'; - use_ok 'DBIx::Class::Schema::Loader::mysql'; - use_ok 'DBIx::Class::Schema::Loader::Pg'; - use_ok 'DBIx::Class::Schema::Loader::DB2'; + use_ok 'DBIx::Class::Schema::Loader::Base'; + use_ok 'DBIx::Class::Schema::Loader::DBI'; + use_ok 'DBIx::Class::Schema::Loader::RelBuilder'; + use_ok 'DBIx::Class::Schema::Loader::DBI::SQLite'; + use_ok 'DBIx::Class::Schema::Loader::DBI::mysql'; + use_ok 'DBIx::Class::Schema::Loader::DBI::Pg'; + use_ok 'DBIx::Class::Schema::Loader::DBI::DB2'; + use_ok 'DBIx::Class::Schema::Loader::DBI::Writing'; } diff --git a/t/02pod.t b/t/02pod.t index 1647794..ddc2905 100644 --- a/t/02pod.t +++ b/t/02pod.t @@ -2,6 +2,5 @@ use Test::More; eval "use Test::Pod 1.14"; plan skip_all => 'Test::Pod 1.14 required' if $@; -plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; all_pod_files_ok(); diff --git a/t/03podcoverage.t b/t/03podcoverage.t index d91be5e..83a42d0 100644 --- a/t/03podcoverage.t +++ b/t/03podcoverage.t @@ -2,6 +2,5 @@ use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@; -plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; all_pod_coverage_ok(); diff --git a/t/04kwalitee.t b/t/04kwalitee.t index 7576615..382e1bb 100644 --- a/t/04kwalitee.t +++ b/t/04kwalitee.t @@ -2,4 +2,4 @@ use Test::More; eval { require Test::Kwalitee; Test::Kwalitee->import() }; -plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@; +plan( skip_all => 'Test::Kwalitee not installed' ) if $@; diff --git a/t/13db2_common.t b/t/13db2_common.t index 149a0e9..b52fa68 100644 --- a/t/13db2_common.t +++ b/t/13db2_common.t @@ -13,7 +13,6 @@ my $tester = dbixcsl_common_tests->new( user => $user, password => $password, db_schema => uc $user, - drop_db_schema => 1, ); if( !$dsn || !$user ) { diff --git a/t/20invoke_deprecated_one.t b/t/20invoke_deprecated_one.t new file mode 100644 index 0000000..da20e61 --- /dev/null +++ b/t/20invoke_deprecated_one.t @@ -0,0 +1,29 @@ +use strict; +use Test::More tests => 4; +use lib qw(t/lib); +use make_dbictest_db; + +eval { require DBD::SQLite }; +my $class = $@ ? 'SQLite2' : 'SQLite'; + +package DBICTest::Schema; +use base qw/ DBIx::Class::Schema::Loader /; + +__PACKAGE__->connection("dbi:$class:dbname=./t/dbictest.db"); +__PACKAGE__->load_from_connection( relationships => 1 ); + +package main; + +my $schema_class = 'DBICTest::Schema'; +my $schema = $schema_class->clone; +isa_ok($schema, 'DBIx::Class::Schema'); + +my $foo_rs = $schema->resultset('Bar')->search({ barid => 3})->search_related('fooref'); +isa_ok($foo_rs, 'DBIx::Class::ResultSet'); + +my $foo_first = $foo_rs->first; +isa_ok($foo_first, 'DBICTest::Schema::Foo'); + +my $foo_first_text = $foo_first->footext; +is($foo_first_text, 'This is the text of the only Foo record associated with the Bar with barid 3'); + diff --git a/t/21invoke_deprecated_two.t b/t/21invoke_deprecated_two.t new file mode 100644 index 0000000..6b3be2b --- /dev/null +++ b/t/21invoke_deprecated_two.t @@ -0,0 +1,31 @@ +use strict; +use Test::More tests => 4; +use lib qw(t/lib); +use make_dbictest_db; + +eval { require DBD::SQLite }; +my $class = $@ ? 'SQLite2' : 'SQLite'; + +package DBICTest::Schema; +use base qw/ DBIx::Class::Schema::Loader /; + +__PACKAGE__->load_from_connection( + relationships => 1, + connect_info => [ "dbi:$class:dbname=./t/dbictest.db" ], +); + +package main; + +my $schema_class = 'DBICTest::Schema'; +my $schema = $schema_class->clone; +isa_ok($schema, 'DBIx::Class::Schema'); + +my $foo_rs = $schema->resultset('Bar')->search({ barid => 3})->search_related('fooref'); +isa_ok($foo_rs, 'DBIx::Class::ResultSet'); + +my $foo_first = $foo_rs->first; +isa_ok($foo_first, 'DBICTest::Schema::Foo'); + +my $foo_first_text = $foo_first->footext; +is($foo_first_text, 'This is the text of the only Foo record associated with the Bar with barid 3'); + diff --git a/t/22invoke_deprecated_three.t b/t/22invoke_deprecated_three.t new file mode 100644 index 0000000..47ab3ed --- /dev/null +++ b/t/22invoke_deprecated_three.t @@ -0,0 +1,31 @@ +use strict; +use Test::More tests => 4; +use lib qw(t/lib); +use make_dbictest_db; + +eval { require DBD::SQLite }; +my $class = $@ ? 'SQLite2' : 'SQLite'; + +package DBICTest::Schema; +use base qw/ DBIx::Class::Schema::Loader /; + +__PACKAGE__->load_from_connection( + relationships => 1, + dsn => "dbi:$class:dbname=./t/dbictest.db", +); + +package main; + +my $schema_class = 'DBICTest::Schema'; +my $schema = $schema_class->clone; +isa_ok($schema, 'DBIx::Class::Schema'); + +my $foo_rs = $schema->resultset('Bar')->search({ barid => 3})->search_related('fooref'); +isa_ok($foo_rs, 'DBIx::Class::ResultSet'); + +my $foo_first = $foo_rs->first; +isa_ok($foo_first, 'DBICTest::Schema::Foo'); + +my $foo_first_text = $foo_first->footext; +is($foo_first_text, 'This is the text of the only Foo record associated with the Bar with barid 3'); + diff --git a/t/23invoke_hardcode.t b/t/23invoke_hardcode.t new file mode 100644 index 0000000..b65190d --- /dev/null +++ b/t/23invoke_hardcode.t @@ -0,0 +1,28 @@ +use strict; +use Test::More tests => 4; +use lib qw(t/lib); +use make_dbictest_db; + +eval { require DBD::SQLite }; +my $class = $@ ? 'SQLite2' : 'SQLite'; + +package DBICTest::Schema; +use base qw/ DBIx::Class::Schema::Loader /; + +__PACKAGE__->loader_options( relationships => 1 ); +__PACKAGE__->connection("dbi:$class:dbname=./t/dbictest.db"); + +package main; + +my $schema_class = 'DBICTest::Schema'; +my $schema = $schema_class->clone; +isa_ok($schema, 'DBIx::Class::Schema'); + +my $foo_rs = $schema->resultset('Bar')->search({ barid => 3})->search_related('fooref'); +isa_ok($foo_rs, 'DBIx::Class::ResultSet'); + +my $foo_first = $foo_rs->first; +isa_ok($foo_first, 'DBICTest::Schema::Foo'); + +my $foo_first_text = $foo_first->footext; +is($foo_first_text, 'This is the text of the only Foo record associated with the Bar with barid 3'); diff --git a/t/24invoke_normal.t b/t/24invoke_normal.t new file mode 100644 index 0000000..087134e --- /dev/null +++ b/t/24invoke_normal.t @@ -0,0 +1,27 @@ +use strict; +use Test::More tests => 4; +use lib qw(t/lib); +use make_dbictest_db; + +eval { require DBD::SQLite }; +my $class = $@ ? 'SQLite2' : 'SQLite'; + +package DBICTest::Schema; +use base qw/ DBIx::Class::Schema::Loader /; + +__PACKAGE__->loader_options( relationships => 1 ); + +package main; + +my $schema_class = 'DBICTest::Schema'; +my $schema = $schema_class->connect("dbi:$class:dbname=./t/dbictest.db"); +isa_ok($schema, 'DBIx::Class::Schema'); + +my $foo_rs = $schema->resultset('Bar')->search({ barid => 3})->search_related('fooref'); +isa_ok($foo_rs, 'DBIx::Class::ResultSet'); + +my $foo_first = $foo_rs->next; +isa_ok($foo_first, 'DBICTest::Schema::Foo'); + +my $foo_first_text = $foo_first->footext; +is($foo_first_text, 'This is the text of the only Foo record associated with the Bar with barid 3'); diff --git a/t/25invoke_inverse.t b/t/25invoke_inverse.t new file mode 100644 index 0000000..0ca4209 --- /dev/null +++ b/t/25invoke_inverse.t @@ -0,0 +1,28 @@ +use strict; +use Test::More tests => 4; +use lib qw(t/lib); +use make_dbictest_db; + +eval { require DBD::SQLite }; +my $class = $@ ? 'SQLite2' : 'SQLite'; + +package DBICTest::Schema; +use base qw/ DBIx::Class::Schema::Loader /; + +__PACKAGE__->connection("dbi:$class:dbname=./t/dbictest.db"); +__PACKAGE__->loader_options( relationships => 1 ); + +package main; + +my $schema_class = 'DBICTest::Schema'; +my $schema = $schema_class->clone; +isa_ok($schema, 'DBIx::Class::Schema'); + +my $foo_rs = $schema->resultset('Bar')->search({ barid => 3})->search_related('fooref'); +isa_ok($foo_rs, 'DBIx::Class::ResultSet'); + +my $foo_first = $foo_rs->first; +isa_ok($foo_first, 'DBICTest::Schema::Foo'); + +my $foo_first_text = $foo_first->footext; +is($foo_first_text, 'This is the text of the only Foo record associated with the Bar with barid 3'); diff --git a/t/26invoke_classmeth.t b/t/26invoke_classmeth.t new file mode 100644 index 0000000..59f758c --- /dev/null +++ b/t/26invoke_classmeth.t @@ -0,0 +1,28 @@ +use strict; +use Test::More tests => 4; +use lib qw(t/lib); +use make_dbictest_db; + +eval { require DBD::SQLite }; +my $class = $@ ? 'SQLite2' : 'SQLite'; + +use DBIx::Class::Schema::Loader qw/ make_schema_at /; + +make_schema_at( + 'DBICTest::Schema', + { relationships => 1 }, + [ "dbi:$class:dbname=./t/dbictest.db" ], +); + +my $schema_class = 'DBICTest::Schema'; +my $schema = $schema_class->clone; +isa_ok($schema, 'DBIx::Class::Schema'); + +my $foo_rs = $schema->resultset('Bar')->search({ barid => 3})->search_related('fooref'); +isa_ok($foo_rs, 'DBIx::Class::ResultSet'); + +my $foo_first = $foo_rs->first; +isa_ok($foo_first, 'DBICTest::Schema::Foo'); + +my $foo_first_text = $foo_first->footext; +is($foo_first_text, 'This is the text of the only Foo record associated with the Bar with barid 3'); diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm index d1a66fd..2b3fd65 100644 --- a/t/lib/dbixcsl_common_tests.pm +++ b/t/lib/dbixcsl_common_tests.pm @@ -43,7 +43,7 @@ sub _monikerize { sub run_tests { my $self = shift; - plan tests => 54; + plan tests => 73; $self->create(); @@ -51,33 +51,55 @@ sub run_tests { my $debug = ($self->{verbose} > 1) ? 1 : 0; + my @connect_info = ( $self->{dsn}, $self->{user}, $self->{password} ); my %loader_opts = ( - connect_info => [ $self->{dsn}, $self->{user}, - $self->{password} ], - constraint => '^(?:\S+\.)?(?i:loader_test)[0-9]+$', + constraint => qr/^(?:\S+\.)?loader_test[0-9]+$/i, relationships => 1, additional_classes => 'TestAdditional', additional_base_classes => 'TestAdditionalBase', left_base_classes => [ qw/TestLeftBase/ ], components => [ qw/TestComponent/ ], - resultset_components => [ qw/TestRSComponent/ ], - inflect_map => { loader_test4 => 'loader_test4zes' }, + inflect_plural => { loader_test4 => 'loader_test4zes' }, + inflect_singular => { fkid => 'fkid_singular' }, moniker_map => \&_monikerize, debug => $debug, ); $loader_opts{db_schema} = $self->{db_schema} if $self->{db_schema}; - $loader_opts{drop_db_schema} = $self->{drop_db_schema} if $self->{drop_db_schema}; - - eval qq{ - package $schema_class; - use base qw/DBIx::Class::Schema::Loader/; + eval { require Class::Inspector }; + if($@) { + $self->{_no_rs_components} = 1; + } + else { + $loader_opts{resultset_components} = [ qw/TestRSComponent/ ]; + } - __PACKAGE__->load_from_connection(\%loader_opts); - }; - ok(!$@, "Loader initialization") or diag $@; + { + my @loader_warnings; + local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); }; + eval qq{ + package $schema_class; + use base qw/DBIx::Class::Schema::Loader/; + + __PACKAGE__->loader_options(\%loader_opts); + __PACKAGE__->connection(\@connect_info); + }; + ok(!$@, "Loader initialization") or diag $@; + if($self->{skip_rels}) { + is(scalar(@loader_warnings), 0) + or diag "Did not get the expected 0 warnings. Warnings are: " + . join('',@loader_warnings); + ok(1); + } + else { + is(scalar(@loader_warnings), 1) + or diag "Did not get the expected 1 warning. Warnings are: " + . join('',@loader_warnings); + like($loader_warnings[0], qr/loader_test9 has no primary key/i); + } + } - my $conn = $schema_class->connect($self->{dsn},$self->{user},$self->{password}); + my $conn = $schema_class->clone; my $monikers = $schema_class->loader->monikers; my $classes = $schema_class->loader->classes; @@ -89,8 +111,42 @@ sub run_tests { my $class2 = $classes->{loader_test2}; my $rsobj2 = $conn->resultset($moniker2); + my $moniker23 = $monikers->{LOADER_TEST23}; + my $class23 = $classes->{LOADER_TEST23}; + my $rsobj23 = $conn->resultset($moniker1); + + my $moniker24 = $monikers->{LoAdEr_test24}; + my $class24 = $classes->{LoAdEr_test24}; + my $rsobj24 = $conn->resultset($moniker2); + isa_ok( $rsobj1, "DBIx::Class::ResultSet" ); isa_ok( $rsobj2, "DBIx::Class::ResultSet" ); + isa_ok( $rsobj23, "DBIx::Class::ResultSet" ); + isa_ok( $rsobj24, "DBIx::Class::ResultSet" ); + + my %uniq1 = $class1->unique_constraints; + my $uniq1_test = 0; + foreach my $ucname (keys %uniq1) { + my $cols_arrayref = $uniq1{$ucname}; + if(@$cols_arrayref == 1 && $cols_arrayref->[0] eq 'dat') { + $uniq1_test = 1; + last; + } + } + ok($uniq1_test) or diag "Unique constraints not working"; + + my %uniq2 = $class2->unique_constraints; + my $uniq2_test = 0; + foreach my $ucname (keys %uniq2) { + my $cols_arrayref = $uniq2{$ucname}; + if(@$cols_arrayref == 2 + && $cols_arrayref->[0] eq 'dat' + && $cols_arrayref->[1] eq 'dat2') { + $uniq2_test = 2; + last; + } + } + ok($uniq2_test) or diag "Multi-col unique constraints not working"; is($moniker2, 'LoaderTest2X', "moniker_map testing"); @@ -102,7 +158,6 @@ sub run_tests { can_ok( $class1, 'test_additional_base_override' ) or $skip_tabo = 1; can_ok( $class1, 'test_additional_base_additional' ) or $skip_taba = 1; can_ok( $class1, 'dbix_class_testcomponent' ) or $skip_tcomp = 1; - can_ok( $rsobj1, 'dbix_class_testrscomponent' ) or $skip_trscomp = 1; can_ok( $class1, 'loader_test1_classmeth' ) or $skip_cmeth = 1; TODO: { @@ -136,9 +191,14 @@ sub run_tests { } SKIP: { - skip "Pre-requisite test failed", 1 if $skip_trscomp; - is( $rsobj1->dbix_class_testrscomponent, - 'dbix_class_testrscomponent works' ); + skip "These two tests need Class::Inspector installed", 2 + if $self->{_no_rs_components}; + can_ok($rsobj1, 'dbix_class_testrscomponent') or $skip_trscomp = 1; + SKIP: { + skip "Pre-requisite test failed", 1 if $skip_trscomp; + is( $rsobj1->dbix_class_testrscomponent, + 'dbix_class_testrscomponent works' ); + } } SKIP: { @@ -161,7 +221,7 @@ sub run_tests { my $saved_id; eval { my $new_obj1 = $rsobj1->create({ dat => 'newthing' }); - $saved_id = $new_obj1->id; + $saved_id = $new_obj1->id; }; ok(!$@) or diag "Died during create new record using a PK::Auto key: $@"; ok($saved_id) or diag "Failed to get PK::Auto-generated id"; @@ -174,7 +234,7 @@ sub run_tests { is( $obj2->id, 2 ); SKIP: { - skip $self->{skip_rels}, 29 if $self->{skip_rels}; + skip $self->{skip_rels}, 42 if $self->{skip_rels}; my $moniker3 = $monikers->{loader_test3}; my $class3 = $classes->{loader_test3}; @@ -204,6 +264,34 @@ sub run_tests { my $class9 = $classes->{loader_test9}; my $rsobj9 = $conn->resultset($moniker9); + my $moniker16 = $monikers->{loader_test16}; + my $class16 = $classes->{loader_test16}; + my $rsobj16 = $conn->resultset($moniker16); + + my $moniker17 = $monikers->{loader_test17}; + my $class17 = $classes->{loader_test17}; + my $rsobj17 = $conn->resultset($moniker17); + + my $moniker18 = $monikers->{loader_test18}; + my $class18 = $classes->{loader_test18}; + my $rsobj18 = $conn->resultset($moniker18); + + my $moniker19 = $monikers->{loader_test19}; + my $class19 = $classes->{loader_test19}; + my $rsobj19 = $conn->resultset($moniker19); + + my $moniker20 = $monikers->{loader_test20}; + my $class20 = $classes->{loader_test20}; + my $rsobj20 = $conn->resultset($moniker20); + + my $moniker21 = $monikers->{loader_test21}; + my $class21 = $classes->{loader_test21}; + my $rsobj21 = $conn->resultset($moniker21); + + my $moniker22 = $monikers->{loader_test22}; + my $class22 = $classes->{loader_test22}; + my $rsobj22 = $conn->resultset($moniker22); + isa_ok( $rsobj3, "DBIx::Class::ResultSet" ); isa_ok( $rsobj4, "DBIx::Class::ResultSet" ); isa_ok( $rsobj5, "DBIx::Class::ResultSet" ); @@ -211,18 +299,25 @@ sub run_tests { isa_ok( $rsobj7, "DBIx::Class::ResultSet" ); isa_ok( $rsobj8, "DBIx::Class::ResultSet" ); isa_ok( $rsobj9, "DBIx::Class::ResultSet" ); + isa_ok( $rsobj16, "DBIx::Class::ResultSet" ); + isa_ok( $rsobj17, "DBIx::Class::ResultSet" ); + isa_ok( $rsobj18, "DBIx::Class::ResultSet" ); + isa_ok( $rsobj19, "DBIx::Class::ResultSet" ); + isa_ok( $rsobj20, "DBIx::Class::ResultSet" ); + isa_ok( $rsobj21, "DBIx::Class::ResultSet" ); + isa_ok( $rsobj22, "DBIx::Class::ResultSet" ); # basic rel test my $obj4 = $rsobj4->find(123); - isa_ok( $obj4->fkid, $class3); + isa_ok( $obj4->fkid_singular, $class3); my $obj3 = $rsobj3->find(1); my $rs_rel4 = $obj3->search_related('loader_test4zes'); isa_ok( $rs_rel4->first, $class4); - # fk def in comments should not be parsed + # find on multi-col pk my $obj5 = $rsobj5->find( id1 => 1, id2 => 1 ); - is( ref( $obj5->id2 ), '' ); + is( $obj5->id2, 1 ); # mulit-col fk def my $obj6 = $rsobj6->find(1); @@ -233,6 +328,26 @@ sub run_tests { my $obj8 = $rsobj8->find(1); isa_ok( $obj8->loader_test7, $class7); + # test double-fk 17 ->-> 16 + my $obj17 = $rsobj17->find(33); + + my $rs_rel16_one = $obj17->loader16_one; + isa_ok($rs_rel16_one, $class16); + is($rs_rel16_one->dat, 'y16'); + + my $rs_rel16_two = $obj17->loader16_two; + isa_ok($rs_rel16_two, $class16); + is($rs_rel16_two->dat, 'z16'); + + my $obj16 = $rsobj16->find(2); + my $rs_rel17 = $obj16->search_related('loader_test17_loader16_ones'); + isa_ok($rs_rel17->first, $class17); + is($rs_rel17->first->id, 3); + + # XXX test m:m 18 <- 20 -> 19 + + # XXX test double-fk m:m 21 <- 22 -> 21 + # from Chisel's tests... SKIP: { if($self->{vendor} =~ /sqlite/i) { @@ -343,11 +458,13 @@ sub dbconnect { sub create { my $self = shift; + $self->{_created} = 1; + my @statements = ( qq{ CREATE TABLE loader_test1 ( id $self->{auto_inc_pk}, - dat VARCHAR(32) + dat VARCHAR(32) NOT NULL UNIQUE ) $self->{innodb} }, @@ -358,14 +475,30 @@ sub create { qq{ CREATE TABLE loader_test2 ( id $self->{auto_inc_pk}, - dat VARCHAR(32) + dat VARCHAR(32) NOT NULL, + dat2 VARCHAR(32) NOT NULL, + UNIQUE (dat, dat2) + ) $self->{innodb} + }, + + q{ INSERT INTO loader_test2 (dat, dat2) VALUES('aaa', 'zzz') }, + q{ INSERT INTO loader_test2 (dat, dat2) VALUES('bbb', 'yyy') }, + q{ INSERT INTO loader_test2 (dat, dat2) VALUES('ccc', 'xxx') }, + q{ INSERT INTO loader_test2 (dat, dat2) VALUES('ddd', 'www') }, + + qq{ + CREATE TABLE LOADER_TEST23 ( + ID INTEGER NOT NULL PRIMARY KEY, + DAT VARCHAR(32) NOT NULL UNIQUE ) $self->{innodb} }, - q{ INSERT INTO loader_test2 (dat) VALUES('aaa') }, - q{ INSERT INTO loader_test2 (dat) VALUES('bbb') }, - q{ INSERT INTO loader_test2 (dat) VALUES('ccc') }, - q{ INSERT INTO loader_test2 (dat) VALUES('ddd') }, + qq{ + CREATE TABLE LoAdEr_test24 ( + iD INTEGER NOT NULL PRIMARY KEY, + DaT VARCHAR(32) NOT NULL UNIQUE + ) $self->{innodb} + }, ); my @statements_reltests = ( @@ -398,7 +531,7 @@ sub create { qq{ CREATE TABLE loader_test5 ( id1 INTEGER NOT NULL, - id2 INTEGER NOT NULL, -- , id2 INTEGER REFERENCES loader_test1, + iD2 INTEGER NOT NULL, dat VARCHAR(8), PRIMARY KEY (id1,id2) ) $self->{innodb} @@ -409,11 +542,11 @@ sub create { qq{ CREATE TABLE loader_test6 ( id INTEGER NOT NULL PRIMARY KEY, - id2 INTEGER, + Id2 INTEGER, loader_test2 INTEGER, dat VARCHAR(8), FOREIGN KEY (loader_test2) REFERENCES loader_test2 (id), - FOREIGN KEY (id, id2 ) REFERENCES loader_test5 (id1,id2) + FOREIGN KEY (id, Id2 ) REFERENCES loader_test5 (id1,iD2) ) $self->{innodb} }, @@ -447,6 +580,92 @@ sub create { loader_test9 VARCHAR(8) NOT NULL ) $self->{innodb} }, + + qq{ + CREATE TABLE loader_test16 ( + id INTEGER NOT NULL PRIMARY KEY, + dat VARCHAR(8) + ) $self->{innodb} + }, + + qq{ INSERT INTO loader_test16 (id,dat) VALUES (2,'x16') }, + qq{ INSERT INTO loader_test16 (id,dat) VALUES (4,'y16') }, + qq{ INSERT INTO loader_test16 (id,dat) VALUES (6,'z16') }, + + qq{ + CREATE TABLE loader_test17 ( + id INTEGER NOT NULL PRIMARY KEY, + loader16_one INTEGER, + loader16_two INTEGER, + FOREIGN KEY (loader16_one) REFERENCES loader_test16 (id), + FOREIGN KEY (loader16_two) REFERENCES loader_test16 (id) + ) $self->{innodb} + }, + + qq{ INSERT INTO loader_test17 (id, loader16_one, loader16_two) VALUES (3, 2, 4) }, + qq{ INSERT INTO loader_test17 (id, loader16_one, loader16_two) VALUES (33, 4, 6) }, + + qq{ + CREATE TABLE loader_test18 ( + id INTEGER NOT NULL PRIMARY KEY, + dat VARCHAR(8) + ) $self->{innodb} + }, + + qq{ INSERT INTO loader_test18 (id,dat) VALUES (1,'x18') }, + qq{ INSERT INTO loader_test18 (id,dat) VALUES (2,'y18') }, + qq{ INSERT INTO loader_test18 (id,dat) VALUES (3,'z18') }, + + qq{ + CREATE TABLE loader_test19 ( + id INTEGER NOT NULL PRIMARY KEY, + dat VARCHAR(8) + ) $self->{innodb} + }, + + qq{ INSERT INTO loader_test19 (id,dat) VALUES (4,'x19') }, + qq{ INSERT INTO loader_test19 (id,dat) VALUES (5,'y19') }, + qq{ INSERT INTO loader_test19 (id,dat) VALUES (6,'z19') }, + + qq{ + CREATE TABLE loader_test20 ( + parent INTEGER NOT NULL, + child INTEGER NOT NULL, + PRIMARY KEY (parent, child), + FOREIGN KEY (parent) REFERENCES loader_test18 (id), + FOREIGN KEY (child) REFERENCES loader_test19 (id) + ) $self->{innodb} + }, + + q{ INSERT INTO loader_test20 (parent, child) VALUES (1,4) }, + q{ INSERT INTO loader_test20 (parent, child) VALUES (2,5) }, + q{ INSERT INTO loader_test20 (parent, child) VALUES (3,6) }, + + qq{ + CREATE TABLE loader_test21 ( + id INTEGER NOT NULL PRIMARY KEY, + dat VARCHAR(8) + ) $self->{innodb} + }, + + q{ INSERT INTO loader_test21 (id,dat) VALUES (7,'a21')}, + q{ INSERT INTO loader_test21 (id,dat) VALUES (11,'b21')}, + q{ INSERT INTO loader_test21 (id,dat) VALUES (13,'c21')}, + q{ INSERT INTO loader_test21 (id,dat) VALUES (17,'d21')}, + + qq{ + CREATE TABLE loader_test22 ( + parent INTEGER NOT NULL, + child INTEGER NOT NULL, + PRIMARY KEY (parent, child), + FOREIGN KEY (parent) REFERENCES loader_test21 (id), + FOREIGN KEY (child) REFERENCES loader_test21 (id) + ) $self->{innodb} + }, + + q{ INSERT INTO loader_test22 (parent, child) VALUES (7,11)}, + q{ INSERT INTO loader_test22 (parent, child) VALUES (11,13)}, + q{ INSERT INTO loader_test22 (parent, child) VALUES (13,17)}, ); my @statements_advanced = ( @@ -519,8 +738,6 @@ sub create { $self->drop_tables; - $self->{created} = 1; - my $dbh = $self->dbconnect(1); # Silence annoying but harmless postgres "NOTICE: CREATE TABLE..." @@ -534,9 +751,6 @@ sub create { # hack for now, since DB2 doesn't like inline comments, and we need # to test one for mysql, which works on everyone else... # this all needs to be refactored anyways. - if($self->{vendor} =~ /DB2/i) { - @statements_reltests = map { s/--.*\n//; $_ } @statements_reltests; - } $dbh->do($_) for (@statements_reltests); unless($self->{vendor} =~ /sqlite/i) { $dbh->do($_) for (@statements_advanced); @@ -554,11 +768,11 @@ sub create { sub drop_tables { my $self = shift; - return unless $self->{created}; - my @tables = qw/ loader_test1 loader_test2 + LOADER_TEST23 + LoAdEr_test24 /; my @tables_reltests = qw/ @@ -569,6 +783,13 @@ sub drop_tables { loader_test8 loader_test7 loader_test9 + loader_test17 + loader_test16 + loader_test20 + loader_test19 + loader_test18 + loader_test22 + loader_test21 /; my @tables_advanced = qw/ @@ -616,6 +837,9 @@ sub drop_tables { $dbh->disconnect; } -sub DESTROY { shift->drop_tables; } +sub DESTROY { + my $self = shift; + $self->drop_tables if $self->{_created}; +} 1; diff --git a/t/lib/make_dbictest_db.pm b/t/lib/make_dbictest_db.pm new file mode 100644 index 0000000..a796ba9 --- /dev/null +++ b/t/lib/make_dbictest_db.pm @@ -0,0 +1,37 @@ +package make_dbictest_db; + +use strict; +use warnings; +use DBI; + +eval { require DBD::SQLite }; +my $class = $@ ? 'SQLite2' : 'SQLite'; + +my $fn = './t/dbictest.db'; + +unlink($fn); + +my $dbh = DBI->connect("dbi:$class:dbname=./t/dbictest.db"); + +$dbh->do($_) for ( + q|CREATE TABLE foo ( + fooid INTEGER PRIMARY KEY, + footext TEXT + )|, + q|CREATE TABLE bar ( + barid INTEGER PRIMARY KEY, + fooref INTEGER REFERENCES foo(fooid) + )|, + q|INSERT INTO foo VALUES (1,'Foo text for number 1')|, + q|INSERT INTO foo VALUES (2,'This is the text of the only Foo record associated with the Bar with barid 3')|, + q|INSERT INTO foo VALUES (3,'Foo text for number 3')|, + q|INSERT INTO foo VALUES (4,'Foo text for number 4')|, + q|INSERT INTO bar VALUES (1,4)|, + q|INSERT INTO bar VALUES (2,3)|, + q|INSERT INTO bar VALUES (3,2)|, + q|INSERT INTO bar VALUES (4,1)|, +); + +END { unlink($fn); } + +1;