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,
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
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
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
# 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
# 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');
-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?)
-...
+ ...
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
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 ...
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<DBIx::Class::Schema> 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<DBIx::Class::Schema::Loader::Generic> for more, and
-L<DBIx::Class::Schema::Loader::Writing> 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<DBIx::Class> 0.05 or later, and obsoletes
-L<DBIx::Class::Loader> for L<DBIx::Class> version 0.05 and later.
+See L<DBIx::Class::Schema::Loader::DBI::Writing> 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<DBIx::Class::Schema::Loader>.
+This module requires L<DBIx::Class> 0.06 or later, and obsoletes
+the older L<DBIx::Class::Loader>.
-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<DBIx::Class::Schema::Loader::Generic> 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<DBIx::Class::Schema::Loader::Base> 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<DBIx::Class::Schema>. 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<DBIx::Class::Schema>. 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<DBIx::Class::Schema::Loader>
+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<DBIx::Class::Schema::Loader::Base/dump_directory> for more
+details on the dumping mechanism.
+
+This can also be set at module import time via the import option
+C<dump_to_dir:/foo/bar> to L<DBIx::Class::Schema::Loader>, where
+C</foo/bar> 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<dump_directory> 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<DBIx::Class::Manual::ExampleSchema> 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</loader_options>.
+
+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<loader_options> on the class before C<connect> or
+C<connection> 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<Lingua::EN::Inflect> just like pre-0.03 versions of this
+module did.
+
+You can force these legacy inflections with the
+option C<legacy_default_inflections>, even after switch over
+to the preferred L</loader_options> 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<DBIx::Class::Schema::Loader::Generic> -based loader object
+the L<DBIx::Class::Schema::Loader::Base> -based loader object
that was used during construction. See the
-L<DBIx::Class::Schema::Loader::Generic> docs for more information
+L<DBIx::Class::Schema::Loader::Base> 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<loader>, you can get via the normal L<DBIx::Class::Schema>
+methods, and your code will be more robust and forward-thinking
+for doing so.
+
+If you're already using C<loader> 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<db_schema> 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<DBIx::Class::Schema> usage, manually-defined
+source classes and relationships have no problems crossing vendor schemas.
=head1 AUTHOR
=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
=head1 SEE ALSO
-L<DBIx::Class>
+L<DBIx::Class>, L<DBIx::Class::Manual::ExampleSchema>
=cut
--- /dev/null
+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<DBIx::Class::Schema::Loader>
+
+=head1 DESCRIPTION
+
+This is the base class for the storage-specific C<DBIx::Class::Schema::*>
+classes, and implements the common functionality between them.
+
+=head1 CONSTRUCTOR OPTIONS
+
+These constructor options are the base options for
+L<DBIx::Class::Schema::Loader/loader_opts>. 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<DBIx::Class> statement the loader
+decides to execute will be C<warn>-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<join '', map ucfirst, split /[\W_]+/, lc $table>,
+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</moniker_map> 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<Lingua::EN::Inflect::Number/to_PL>.
+
+=head2 inflect_singular
+
+As L</inflect_plural> above, but for singularizing relationship names.
+Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
+
+=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<ResultSetManager>.
+
+=head2 resultset_components
+
+List of additional resultset components to be loaded into your table
+classes. A good example would be C<AlwaysRS>. Component
+C<ResultSetManager> will be automatically added to the above
+C<components> list if this option is set.
+
+=head2 legacy_default_inflections
+
+Setting this option changes the default fallback for L</inflect_plural> to
+utilize L<Lingua::EN::Inflect/PL>, and L</inflect_singlular> 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<DBIx::Class::Schema> 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<dump_directory> 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<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
+recommended way to access this functionality.
+
+=head1 DEPRECATED CONSTRUCTOR OPTIONS
+
+=head2 inflect_map
+
+Equivalent to L</inflect_plural>.
+
+=head2 inflect
+
+Equivalent to L</inflect_plural>.
+
+=head2 connect_info, dsn, user, password, options
+
+You connect these schemas the same way you would any L<DBIx::Class::Schema>,
+which is by calling either C<connect> or C<connection> on a schema class
+or object. These options are only supported via the deprecated
+C<load_from_connection> interface, which will be removed in the future.
+
+=head1 METHODS
+
+None of these methods are intended for direct invocation by regular
+users of L<DBIx::Class::Schema::Loader>. Anything you can find here
+can also be found via standard L<DBIx::Class::Schema> 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<DBIx::Class::Schema::Loader::Base>, used internally
+by L<DBIx::Class::Schema::Loader>.
+
+=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</monikers>.
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::Loader>
+
+=cut
+
+1;
+++ /dev/null
-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<DBIx::Class::Schema::Loader>.
-
-=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<DBIx::Class::Schema::Loader>
-
-=cut
-
-1;
--- /dev/null
+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<DBIx::Class::Schema::Loader::Base>
+
+=head1 DESCRIPTION
+
+This is the base class for L<DBIx::Class::Schema::Loader::Base> classes for
+DBI-based storage backends, and implements the common functionality between them.
+
+See L<DBIx::Class::Schema::Loader::Base> for the available options.
+
+=head1 METHODS
+
+=head2 new
+
+Overlays L<DBIx::Class::Schema::Loader::Base/new> 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<DBIx::Class::Schema::Loader>
+
+=cut
+
+1;
--- /dev/null
+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<DBIx::Class::Schema::Loader::Base>.
+
+=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<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
+L<DBIx::Class::Schema::Loader::DBI>
+
+=cut
+
+1;
--- /dev/null
+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<DBIx::Class::Schema::Loader::Base>.
+
+=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<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
+L<DBIx::Class::Schema::Loader::DBI>
+
+=cut
+
+1;
--- /dev/null
+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<DBIx::Class::Schema::Loader::Base>.
+
+=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<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
+L<DBIx::Class::Schema::Loader::DBI>
+
+=cut
+
+1;
--- /dev/null
+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;
--- /dev/null
+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<DBIx::Class::Schema::Loader::Base>.
+
+=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<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
+L<DBIx::Class::Schema::Loader::DBI>
+
+=cut
+
+1;
+++ /dev/null
-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<DBIx::Class::Schema::Loader>
-
-=head1 DESCRIPTION
-
-This is the base class for the vendor-specific C<DBIx::Class::Schema::*>
-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<connect> and C<connection>
-that are mentioned in L<DBIx::Class::Schema>.
-
-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<ResultSetManager>.
-
-=head2 resultset_components
-
-List of additional resultset components to be loaded into your table
-classes. A good example would be C<AlwaysRS>. Component
-C<ResultSetManager> will be automatically added to the above
-C<components> 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</moniker_map> above, but for inflecting (pluralizing)
-relationship names.
-
-=head2 inflect
-
-Deprecated. Equivalent to L</inflect_map>, but previously only took
-a hashref argument, not a coderef. If you set C<inflect> to anything,
-that setting will be copied to L</inflect_map>.
-
-=head2 dsn
-
-DEPRECATED, use L</connect_info> instead.
-
-DBI Data Source Name.
-
-=head2 user
-
-DEPRECATED, use L</connect_info> instead.
-
-Username.
-
-=head2 password
-
-DEPRECATED, use L</connect_info> instead.
-
-Password.
-
-=head2 options
-
-DEPRECATED, use L</connect_info> 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<DBIx::Class::Schema::Loader::Generic>, used internally
-by L<DBIx::Class::Schema::Loader>.
-
-=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<DBIx::Class::Schema::Loader> 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-E<gt>resultset('FooTbl')>, where C<FooTbl> is a moniker as
-returned by C<monikers> 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<DBIx::Class::Schema::Loader>
-
-=cut
-
-1;
+++ /dev/null
-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<DBIx::Class::Schema::Loader>.
-
-=head1 METHODS
-
-=head2 new
-
-Overrides L<DBIx::Class::Schema::Loader::Generic>'s C<new()> to default the postgres
-schema to C<public> 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<DBIx::Class::Schema::Loader>
-
-=cut
-
-1;
--- /dev/null
+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<DBIx::Class::Schema::Loader>
+
+=head1 DESCRIPTION
+
+This class builds relationships for L<DBIx::Class::Schema::Loader>. 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<DBIx::Class::Schema::Loader::Base>.
+
+=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<gt>>.
+
+=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;
+++ /dev/null
-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<DBIx::Class::Schema::Loader>.
-
-=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<DBIx::Schema::Class::Loader>
-
-=cut
-
-1;
+++ /dev/null
-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
+++ /dev/null
-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<DBIx::Class::Schema::Loader>.
-
-=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<DBIx::Class::Schema::Loader>
-
-=cut
-
-1;
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';
}
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();
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();
eval { require Test::Kwalitee; Test::Kwalitee->import() };
-plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;
+plan( skip_all => 'Test::Kwalitee not installed' ) if $@;
user => $user,
password => $password,
db_schema => uc $user,
- drop_db_schema => 1,
);
if( !$dsn || !$user ) {
--- /dev/null
+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');
+
--- /dev/null
+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');
+
--- /dev/null
+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');
+
--- /dev/null
+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');
--- /dev/null
+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');
--- /dev/null
+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');
--- /dev/null
+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');
sub run_tests {
my $self = shift;
- plan tests => 54;
+ plan tests => 73;
$self->create();
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;
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");
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: {
}
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: {
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";
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};
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" );
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);
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) {
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}
},
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 = (
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}
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}
},
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 = (
$self->drop_tables;
- $self->{created} = 1;
-
my $dbh = $self->dbconnect(1);
# Silence annoying but harmless postgres "NOTICE: CREATE TABLE..."
# 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);
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/
loader_test8
loader_test7
loader_test9
+ loader_test17
+ loader_test16
+ loader_test20
+ loader_test19
+ loader_test18
+ loader_test22
+ loader_test21
/;
my @tables_advanced = qw/
$dbh->disconnect;
}
-sub DESTROY { shift->drop_tables; }
+sub DESTROY {
+ my $self = shift;
+ $self->drop_tables if $self->{_created};
+}
1;
--- /dev/null
+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;
projects / dbsrgits/DBIx-Class-Schema-Loader.git / commitdiff