package DBIx::Class::Schema::Loader::Generic;
use strict;
-use base 'DBIx::Class::Componentised';
+use warnings;
+use base qw/Class::Accessor::Fast/;
+use Class::C3;
use Carp;
use Lingua::EN::Inflect;
use UNIVERSAL::require;
-use DBIx::Class::Storage::DBI;
-require DBIx::Class::Core;
-require DBIx::Class::Schema;
+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
=head1 DESCRIPTION
-=head2 OPTIONS
+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:
-=head3 additional_base_classes
+=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.
-=head3 left_base_classes
+=head2 left_base_classes
List of additional base classes, that need to be leftmost.
-=head3 additional_classes
+=head2 additional_classes
List of additional classes which your table classes will use.
-=head3 constraint
+=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.
-=head3 exclude
+=head2 exclude
Exclude tables matching regex.
-=head3 debug
+=head2 debug
Enable debug messages.
-=head3 dsn
+=head2 relationships
-DBI Data Source Name.
+Try to automatically detect/setup has_a and has_many relationships.
-=head3 namespace
+=head2 moniker_map
-Namespace under which your table classes will be initialized.
+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.
-=head3 password
+=head2 inflect_map
-Password.
+Just like L</moniker_map> above, but for inflecting (pluralizing)
+relationship names.
-=head3 relationships
+=head2 inflect
-Try to automatically detect/setup has_a and has_many relationships.
+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
-=head3 inflect
+DEPRECATED, use L</connect_info> instead.
+
+DBI Data Source Name.
-An hashref, which contains exceptions to Lingua::EN::Inflect::PL().
-Useful for foreign language column names.
+=head2 user
-=head3 user
+DEPRECATED, use L</connect_info> instead.
Username.
-=head2 METHODS
+=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
-=head3 new
+# 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';
+ }
+}
-Not intended to be called directly. This is used internally by the
-C<new()> method in L<DBIx::Class::Schema::Loader>.
+=head2 new
+
+Constructor for L<DBIx::Class::Schema::Loader::Generic>, used internally
+by L<DBIx::Class::Schema::Loader>.
=cut
sub new {
my ( $class, %args ) = @_;
- if ( $args{debug} ) {
- no strict 'refs';
- *{"$class\::debug"} = sub { 1 };
- }
- my $additional = $args{additional_classes} || [];
- $additional = [$additional] unless ref $additional eq 'ARRAY';
- my $additional_base = $args{additional_base_classes} || [];
- $additional_base = [$additional_base]
- unless ref $additional_base eq 'ARRAY';
- my $left_base = $args{left_base_classes} || [];
- $left_base = [$left_base] unless ref $left_base eq 'ARRAY';
- my $self = bless {
- _datasource =>
- [ $args{dsn}, $args{user}, $args{password}, $args{options} ],
- _namespace => $args{namespace},
- _additional => $additional,
- _additional_base => $additional_base,
- _left_base => $left_base,
- _constraint => $args{constraint} || '.*',
- _exclude => $args{exclude},
- _relationships => $args{relationships},
- _inflect => $args{inflect},
- _db_schema => $args{schema},
- _drop_db_schema => $args{dropschema},
- _schema_class => "$args{namespace}\::_schema",
- TABLE_CLASSES => {},
- MONIKERS => {},
- }, $class;
- warn qq/\### START DBIx::Class::Schema::Loader dump ###\n/ if $self->debug;
- $self->_load_classes;
- $self->_relationships if $self->{_relationships};
- warn qq/\### END DBIx::Class::Schema::Loader dump ###\n/ if $self->debug;
- $self->{_storage}->dbh->disconnect;
- $self;
-}
-# The original table class name during Loader,
-sub _find_table_class {
- my ( $self, $table ) = @_;
- return $self->{TABLE_CLASSES}->{$table};
-}
+ my $self = { %args };
-# Returns the moniker for a given table name,
-# for use in $conn->resultset($moniker)
-sub moniker {
- my ( $self, $table ) = @_;
- return $self->{MONIKERS}->{$table};
-}
+ bless $self => $class;
-sub connect {
- my $self = shift;
- return $self->{_schema_class}->connect(@_) if(@_);
- return $self->{_schema_class}->connect(@{$self->{_datasource}});
+ $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;
}
-=head3 debug
+=head2 load
-Overload to enable debug messages.
+Does the actual schema-construction work, used internally by
+L<DBIx::Class::Schema::Loader> right after object construction.
=cut
-sub debug { 0 }
+sub load {
+ my $self = shift;
-=head3 tables
+ $self->schema->connection(@{$self->connect_info});
-Returns a sorted list of tables.
+ warn qq/\### START DBIx::Class::Schema::Loader dump ###\n/
+ if $self->debug;
- my @tables = $loader->tables;
+ $self->_load_classes;
+ $self->_load_relationships if $self->relationships;
+ $self->_load_external;
-=cut
+ warn qq/\### END DBIx::Class::Schema::Loader dump ###\n/
+ if $self->debug;
+ $self->schema->storage->disconnect;
-sub tables {
+ $self;
+}
+
+sub _load_external {
my $self = shift;
- return sort keys %{ $self->{MONIKERS} };
+
+ 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" }
-# Setup has_a and has_many relationships
-sub _belongs_to_many {
- my ( $self, $table, $column, $other, $other_column ) = @_;
- my $table_class = $self->_find_table_class($table);
- my $other_class = $self->_find_table_class($other);
+# 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;
- if($other_column) {
- warn qq/$table_class->belongs_to( '$column' => '$other_class',/
- . qq/ { "foreign.$other_column" => "self.$column" },/
- . qq/ { accessor => 'filter' });\n\n/
- if $self->debug;
- $table_class->belongs_to( $column => $other_class,
- { "foreign.$other_column" => "self.$column" },
- { accessor => 'filter' }
- );
+ $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};
}
- else {
- warn qq/$table_class->belongs_to( '$column' => '$other_class' );\n\n/
- if $self->debug;
- $table_class->belongs_to( $column => $other_class );
+
+ my $rev_cond = { reverse %$cond };
+
+ for (keys %$rev_cond) {
+ $rev_cond->{"foreign.$_"} = "self.".$rev_cond->{$_};
+ delete $rev_cond->{$_};
}
- my ($table_class_base) = $table_class =~ /.*::(.+)/;
- my $plural = Lingua::EN::Inflect::PL( lc $table_class_base );
- $plural = $self->{_inflect}->{ lc $table_class_base }
- if $self->{_inflect}
- and exists $self->{_inflect}->{ lc $table_class_base };
+ 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;
- if($other_column) {
- warn qq/$other_class->has_many( '$plural' => '$table_class',/
- . qq/ { "foreign.$column" => "self.$other_column" } );\n\n/
- if $self->debug;
- $other_class->has_many( $plural => $table_class,
- { "foreign.$column" => "self.$other_column" }
- );
+ 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 $@;
}
- else {
- warn qq/$other_class->has_many( '$plural' => '$table_class',/
- . qq/'$other_column' );\n\n/
- if $self->debug;
- $other_class->has_many( $plural => $table_class, $column );
+}
+
+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 $namespace = $self->{_namespace};
- my $schema_class = $self->{_schema_class};
- $self->inject_base( $schema_class, 'DBIx::Class::Schema' );
- $self->{_storage} = $schema_class->storage(DBIx::Class::Storage::DBI->new());
- $schema_class->storage->connect_info($self->{_datasource});
-
- my @tables = $self->_tables();
- my @db_classes = $self->_db_classes();
- my $additional = join '', map "use $_;\n", @{ $self->{_additional} };
- my $additional_base = join '', map "use base '$_';\n",
- @{ $self->{_additional_base} };
- my $left_base = join '', map "use base '$_';\n", @{ $self->{_left_base} };
- my $constraint = $self->{_constraint};
- my $exclude = $self->{_exclude};
+ my $self = shift;
- foreach my $table (@tables) {
- next unless $table =~ /$constraint/;
- next if ( defined $exclude && $table =~ /$exclude/ );
+ my @db_classes = $self->_db_classes();
+ my $schema = $self->schema;
- my $table = lc $table;
- my $table_name_db_schema = $table;
- my $table_name_only = $table_name_db_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_name_db_schema = $tbl if $self->{_drop_db_schema};
- $table_name_only = $tbl;
+ $table = $self->drop_db_schema ? $tbl : $table;
}
- else {
- undef $db_schema;
+ 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;
- my $subclass = $self->_table2subclass($db_schema, $table_name_only);
- my $class = $namespace . '::' . $subclass;
+ foreach my $table (@tables) {
+ my $table_class = $self->classes->{$table};
+ my $table_moniker = $self->monikers->{$table};
- $self->inject_base( $class, 'DBIx::Class::Core' );
- $_->require for @db_classes;
- $self->inject_base( $class, $_ ) for @db_classes;
- warn qq/\# Initializing table "$table_name_db_schema" as "$class"\n/ if $self->debug;
- $class->table(lc $table_name_db_schema);
+ warn qq/\# Initializing table "$table" as "$table_class"\n/
+ if $self->debug;
+ $table_class->table($table);
- my ( $cols, $pks ) = $self->_table_info($table_name_db_schema);
+ my ( $cols, $pks ) = $self->_table_info($table);
carp("$table has no primary key") unless @$pks;
- $class->add_columns(@$cols);
- $class->set_primary_key(@$pks) if @$pks;
+ $table_class->add_columns(@$cols);
+ $table_class->set_primary_key(@$pks) if @$pks;
- my $code = "package $class;\n$additional_base$additional$left_base";
- warn qq/$code/ if $self->debug;
- warn qq/$class->table('$table_name_db_schema');\n/ if $self->debug;
+ warn qq/$table_class->table('$table');\n/ if $self->debug;
my $columns = join "', '", @$cols;
- warn qq/$class->add_columns('$columns')\n/ if $self->debug;
+ warn qq/$table_class->add_columns('$columns')\n/ if $self->debug;
my $primaries = join "', '", @$pks;
- warn qq/$class->set_primary_key('$primaries')\n/ if $self->debug && @$pks;
- eval $code;
- croak qq/Couldn't load additional classes "$@"/ if $@;
- unshift @{"$class\::ISA"}, $_ foreach ( @{ $self->{_left_base} } );
-
- $schema_class->register_class($subclass, $class);
- $self->{TABLE_CLASSES}->{$table_name_db_schema} = $class;
- $self->{MONIKERS}->{$table_name_db_schema} = $subclass;
+ 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 _relationships {
+sub _load_relationships {
my $self = shift;
- my $dbh = $self->{_storage}->dbh;
+
+ my $dbh = $self->schema->storage->dbh;
+ my $quoter = $dbh->get_info(29) || q{"};
foreach my $table ( $self->tables ) {
- my $quoter = $dbh->get_info(29) || q{"};
- if ( my $sth = $dbh->foreign_key_info( '', '', '', '', '', $table ) ) {
- for my $res ( @{ $sth->fetchall_arrayref( {} ) } ) {
- my $column = $res->{FK_COLUMN_NAME};
- my $other = $res->{UK_TABLE_NAME};
- my $other_column = $res->{UK_COLUMN_NAME};
- $column =~ s/$quoter//g;
- $other =~ s/$quoter//g;
- $other_column =~ s/$quoter//g;
- eval { $self->_belongs_to_many( $table, $column, $other,
- $other_column ) };
- warn qq/\# belongs_to_many failed "$@"\n\n/
- if $@ && $self->debug;
- }
+ 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 subclass (dbix moniker) from a table
-sub _table2subclass {
+# Make a moniker from a table
+sub _table2moniker {
my ( $self, $db_schema, $table ) = @_;
- my $subclass = join '', map ucfirst, split /[\W_]+/, $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($db_schema && !$self->{_drop_db_schema}) {
- $subclass = (ucfirst lc $db_schema) . '-' . $subclass;
+ if( ref $self->moniker_map eq 'HASH' ) {
+ $moniker = $self->moniker_map->{$table};
+ }
+ elsif( ref $self->moniker_map eq 'CODE' ) {
+ $moniker = $self->moniker_map->($table);
}
- $subclass;
+ $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 { croak "ABSTRACT METHOD" }
+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>
projects / dbsrgits/DBIx-Class-Schema-Loader.git / blobdiff