X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FGeneric.pm;h=2fc043f6058f51ca81c446778c05508debd37f57;hb=c2849787d7804fcbe541c8063e240ceff0e5ff10;hp=01e0525dcf3daa89c6fd3071fb2148070272d338;hpb=38348090d25c45a95d32d640de77367a6a0284ea;p=dbsrgits%2FDBIx-Class-Schema-Loader.git diff --git a/lib/DBIx/Class/Schema/Loader/Generic.pm b/lib/DBIx/Class/Schema/Loader/Generic.pm index 01e0525..2fc043f 100644 --- a/lib/DBIx/Class/Schema/Loader/Generic.pm +++ b/lib/DBIx/Class/Schema/Loader/Generic.pm @@ -2,15 +2,37 @@ package DBIx::Class::Schema::Loader::Generic; use strict; use warnings; - -use base qw/DBIx::Class::Schema/; - +use base qw/Class::Accessor::Fast/; +use Class::C3; use Carp; use Lingua::EN::Inflect; - require DBIx::Class::Core; -__PACKAGE__->mk_classdata('loader_data'); +# 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 + dsn + user + password + options + exclude + constraint + additional_classes + additional_base_classes + left_base_classes + components + resultset_components + relationships + inflect + db_schema + drop_db_schema + debug + + classes + monikers + /); =head1 NAME @@ -22,291 +44,385 @@ See L =head1 DESCRIPTION -=head2 OPTIONS +This is the base class for the vendor-specific C +classes, and implements the common functionality between them. + +=head1 OPTIONS Available constructor options are: -=head3 additional_base_classes +=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. + +=head2 resultset_components + +List of additional resultset components to be loaded into your table +classes. A good example would be C. Component +C will be automatically added to the above +C list if this option is set. + +=head2 constraint Only load tables matching regex. -=head3 exclude +=head2 exclude Exclude tables matching regex. -=head3 debug +=head2 debug Enable debug messages. -=head3 dsn +=head2 dsn DBI Data Source Name. -=head3 password +=head2 password Password. -=head3 relationships +=head2 relationships Try to automatically detect/setup has_a and has_many relationships. -=head3 inflect +=head2 inflect An hashref, which contains exceptions to Lingua::EN::Inflect::PL(). Useful for foreign language column names. -=head3 user +=head2 user Username. -=head2 METHODS +=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'; + } +} + +=head2 new -Not intended to be called directly. This is used internally by the -C method in L. +Constructor for L, used internally +by L. =cut -sub _load_from_connection { +sub new { my ( $class, %args ) = @_; - if ( $args{debug} ) { - no strict 'refs'; - *{"$class\::debug_loader"} = 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'; - $class->loader_data({ - _datasource => - [ $args{dsn}, $args{user}, $args{password}, $args{options} ], - _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{db_schema} || '', - _drop_db_schema => $args{drop_db_schema}, - TABLE_CLASSES => {}, - MONIKERS => {}, - }); - - $class->connection(@{$class->loader_data->{_datasource}}); - warn qq/\### START DBIx::Class::Schema::Loader dump ###\n/ if $class->debug_loader; - $class->_load_classes; - $class->_relationships if $class->loader_data->{_relationships}; - warn qq/\### END DBIx::Class::Schema::Loader dump ###\n/ if $class->debug_loader; - $class->storage->dbh->disconnect; # XXX this should be ->storage->disconnect later? - - 1; -} -# The original table class name during Loader, -sub _find_table_class { - my ( $class, $table ) = @_; - return $class->loader_data->{TABLE_CLASSES}->{$table}; -} + my $self = { %args }; -# Returns the moniker for a given table name, -# for use in $conn->resultset($moniker) + bless $self => $class; -=head3 moniker + $self->{db_schema} ||= ''; + $self->{constraint} ||= '.*'; + $self->{inflect} ||= {}; + $self->_ensure_arrayref(qw/additional_classes + additional_base_classes + left_base_classes + components + resultset_components/); -Returns the moniker for a given literal table name. Used -as $schema->resultset($moniker), etc. + push(@{$self->{components}}, 'ResultSetManager') + if @{$self->{resultset_components}}; -=cut -sub moniker { - my ( $class, $table ) = @_; - return $class->loader_data->{MONIKERS}->{$table}; + $self->{monikers} = {}; + $self->{classes} = {}; + + $self; } -=head3 debug_loader +=head2 load -Overload to enable Loader debug messages. +Does the actual schema-construction work, used internally by +L right after object construction. =cut -sub debug_loader { 0 } +sub load { + my $self = shift; -=head3 tables + $self->schema->connection($self->dsn, $self->user, + $self->password, $self->options); -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; -=cut + warn qq/\### END DBIx::Class::Schema::Loader dump ###\n/ + if $self->debug; + $self->schema->storage->disconnect; -sub tables { - my $class = shift; - return sort keys %{ $class->loader_data->{MONIKERS} }; + $self; } # Overload in your driver class sub _db_classes { croak "ABSTRACT METHOD" } -# Setup has_a and has_many relationships -sub _belongs_to_many { - my ( $class, $table, $column, $other, $other_column ) = @_; - my $table_class = $class->_find_table_class($table); - my $other_class = $class->_find_table_class($other); - - warn qq/\# Belongs_to relationship\n/ if $class->debug_loader; - - if($other_column) { - warn qq/$table_class->belongs_to( '$column' => '$other_class',/ - . qq/ { "foreign.$other_column" => "self.$column" },/ - . qq/ { accessor => 'filter' });\n\n/ - if $class->debug_loader; - $table_class->belongs_to( $column => $other_class, - { "foreign.$other_column" => "self.$column" }, - { accessor => 'filter' } - ); +# Inflect a relationship name +# XXX (should pluralize, but currently also tends to de-pluralize plurals) +sub _inflect_relname { + my ($self, $relname) = @_; + + return $self->inflect->{$relname} if exists $self->inflect->{$relname}; + 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}; } - else { - warn qq/$table_class->belongs_to( '$column' => '$other_class' );\n\n/ - if $class->debug_loader; - $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 = $class->loader_data->{_inflect}->{ lc $table_class_base } - if $class->loader_data->{_inflect} - and exists $class->loader_data->{_inflect}->{ lc $table_class_base }; - - warn qq/\# Has_many relationship\n/ if $class->debug_loader; - - if($other_column) { - warn qq/$other_class->has_many( '$plural' => '$table_class',/ - . qq/ { "foreign.$column" => "self.$other_column" } );\n\n/ - if $class->debug_loader; - $other_class->has_many( $plural => $table_class, - { "foreign.$column" => "self.$other_column" } - ); + 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 $@; } - else { - warn qq/$other_class->has_many( '$plural' => '$table_class',/ - . qq/'$other_column' );\n\n/ - if $class->debug_loader; - $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 $class = shift; + my $self = shift; - my @tables = $class->_tables(); - my @db_classes = $class->_db_classes(); - my $additional = join '', map "use $_;\n", @{ $class->loader_data->{_additional} }; - my $additional_base = join '', map "use base '$_';\n", - @{ $class->loader_data->{_additional_base} }; - my $left_base = join '', map "use base '$_';\n", @{ $class->loader_data->{_left_base} }; - my $constraint = $class->loader_data->{_constraint}; - my $exclude = $class->loader_data->{_exclude}; + my @tables = $self->_tables(); + my @db_classes = $self->_db_classes(); + my $schema = $self->schema; foreach my $table (@tables) { + my $constraint = $self->constraint; + my $exclude = $self->exclude; + next unless $table =~ /$constraint/; - next if ( defined $exclude && $table =~ /$exclude/ ); + next if defined $exclude && $table =~ /$exclude/; my ($db_schema, $tbl) = split /\./, $table; my $tablename = lc $table; if($tbl) { - $tablename = $class->loader_data->{_drop_db_schema} ? $tbl : lc $table; + $tablename = $self->drop_db_schema ? $tbl : lc $table; } + my $lc_tblname = lc $tablename; + + my $table_moniker = $self->_table2moniker($db_schema, $tbl); + my $table_class = $schema . q{::} . $table_moniker; - my $table_subclass = $class->_table2subclass($db_schema, $tbl); - my $table_class = "$class\::$table_subclass"; + $self->_inject($table_class, 'DBIx::Class::Core'); + $self->_inject($table_class, @db_classes); + $self->_inject($table_class, @{$self->additional_base_classes}); + $self->_use ($table_class, @{$self->additional_classes}); + $self->_inject($table_class, @{$self->left_base_classes}); + $table_class->load_components(@{$self->components}); + $table_class->load_resultset_components(@{$self->resultset_components}) + if @{$self->resultset_components}; - $class->inject_base( $table_class, 'DBIx::Class::Core' ); - $_->require for @db_classes; - $class->inject_base( $table_class, $_ ) for @db_classes; - warn qq/\# Initializing table "$tablename" as "$table_class"\n/ if $class->debug_loader; - $table_class->table(lc $tablename); + warn qq/\# Initializing table "$tablename" as "$table_class"\n/ + if $self->debug; + $table_class->table($lc_tblname); - my ( $cols, $pks ) = $class->_table_info($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; - my $code = "package $table_class;\n$additional_base$additional$left_base"; - warn qq/$code/ if $class->debug_loader; - warn qq/$table_class->table('$tablename');\n/ if $class->debug_loader; + warn qq/$table_class->table('$tablename');\n/ if $self->debug; my $columns = join "', '", @$cols; - warn qq/$table_class->add_columns('$columns')\n/ if $class->debug_loader; + 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 $class->debug_loader && @$pks; - eval $code; - croak qq/Couldn't load additional classes "$@"/ if $@; - unshift @{"$table_class\::ISA"}, $_ foreach ( @{ $class->loader_data->{_left_base} } ); - - $class->register_class($table_subclass, $table_class); - $class->loader_data->{TABLE_CLASSES}->{lc $tablename} = $table_class; - $class->loader_data->{MONIKERS}->{lc $tablename} = $table_subclass; + warn qq/$table_class->set_primary_key('$primaries')\n/ + if $self->debug && @$pks; + + $table_class->require; + if($@ && $@ !~ /^Can't locate /) { + croak "Failed to load external class definition" + . "for '$table_class': $@"; + } + + warn qq/# Loaded external class definition for '$table_class'\n/ + if $self->debug; + + $schema->register_class($table_moniker, $table_class); + $self->classes->{$lc_tblname} = $table_class; + $self->monikers->{$lc_tblname} = $table_moniker; } } +=head2 tables + +Returns a sorted list of loaded tables, using the original database table +names. Actually generated from the keys of the C hash below. + + my @tables = $schema->loader->tables; + +=cut + +sub tables { + my $self = shift; + + return sort keys %{ $self->monikers }; +} + # Find and setup relationships -sub _relationships { - my $class = shift; - my $dbh = $class->storage->dbh; - foreach my $table ( $class->tables ) { - my $quoter = $dbh->get_info(29) || q{"}; - if ( my $sth = $dbh->foreign_key_info( '', $class->loader_data->{_db_schema}, '', '', '', $table ) ) { - for my $res ( @{ $sth->fetchall_arrayref( {} ) } ) { - my $column = lc $res->{FK_COLUMN_NAME}; - my $other = lc $res->{UK_TABLE_NAME}; - my $other_column = lc $res->{UK_COLUMN_NAME}; - $column =~ s/$quoter//g; - $other =~ s/$quoter//g; - $other_column =~ s/$quoter//g; - eval { $class->_belongs_to_many( $table, $column, $other, - $other_column ) }; - warn qq/\# belongs_to_many failed "$@"\n\n/ - if $@ && $class->debug_loader; - } +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 = lc $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 = lc $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 { - my ( $class, $db_schema, $table ) = @_; +# 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(!$class->loader_data->{_drop_db_schema}); + $db_schema_ns = $db_schema if(!$self->drop_db_schema); } else { $table = $db_schema; } - my $subclass = join '', map ucfirst, split /[\W_]+/, lc $table; - $subclass = $db_schema_ns ? "$db_schema_ns\::" . $subclass : $subclass; + my $moniker = join '', map ucfirst, split /[\W_]+/, lc $table; + $moniker = $db_schema_ns ? $db_schema_ns . $moniker : $moniker; - return $subclass; + return $moniker; } # Overload in driver class @@ -314,6 +430,32 @@ sub _tables { 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. + + 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. You probably shouldn't be using this for any normal or simple +usage of your Schema. The usual way to run queries on your tables is via +C<$schema-Eresultset('FooTbl')>, where C is a moniker as +returned by C above. + + my $classes = $schema->loader->classes; + my $foo_tbl_class = $classes->{foo_tbl}; + # -or- + my $foo_tbl_class = $schema->loader->classes->{foo_tbl}; + # $foo_tbl_class would look like "My::Schema::FooTbl", + # assuming the schema class is "My::Schema" + =head1 SEE ALSO L