lib/DBIx/Class/Schema/Loader/Generic.pm

   1 package DBIx::Class::Schema::Loader::Generic;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/DBIx::Class::Schema/;
   7
   8 use Carp;
   9 use Lingua::EN::Inflect;
  10
  11 require DBIx::Class::Core;
  12
  13 __PACKAGE__->mk_classdata('loader_data');
  14
  15 =head1 NAME
  16
  17 DBIx::Class::Schema::Loader::Generic - Generic DBIx::Class::Schema::Loader Implementation.
  18
  19 =head1 SYNOPSIS
  20
  21 See L<DBIx::Class::Schema::Loader>
  22
  23 =head1 DESCRIPTION
  24
  25 =head2 OPTIONS
  26
  27 Available constructor options are:
  28
  29 =head3 additional_base_classes
  30
  31 List of additional base classes your table classes will use.
  32
  33 =head3 left_base_classes
  34
  35 List of additional base classes, that need to be leftmost.
  36
  37 =head3 additional_classes
  38
  39 List of additional classes which your table classes will use.
  40
  41 =head3 constraint
  42
  43 Only load tables matching regex.
  44
  45 =head3 exclude
  46
  47 Exclude tables matching regex.
  48
  49 =head3 debug
  50
  51 Enable debug messages.
  52
  53 =head3 dsn
  54
  55 DBI Data Source Name.
  56
  57 =head3 namespace
  58
  59 Namespace under which your table classes will be initialized.
  60
  61 =head3 password
  62
  63 Password.
  64
  65 =head3 relationships
  66
  67 Try to automatically detect/setup has_a and has_many relationships.
  68
  69 =head3 inflect
  70
  71 An hashref, which contains exceptions to Lingua::EN::Inflect::PL().
  72 Useful for foreign language column names.
  73
  74 =head3 user
  75
  76 Username.
  77
  78 =head2 METHODS
  79
  80 =cut
  81
  82 =head3 new
  83
  84 Not intended to be called directly.  This is used internally by the
  85 C<new()> method in L<DBIx::Class::Schema::Loader>.
  86
  87 =cut
  88
  89 sub _load_from_connection {
  90     my ( $class, %args ) = @_;
  91     if ( $args{debug} ) {
  92         no strict 'refs';
  93         *{"$class\::debug_loader"} = sub { 1 };
  94     }
  95     my $additional = $args{additional_classes} || [];
  96     $additional = [$additional] unless ref $additional eq 'ARRAY';
  97     my $additional_base = $args{additional_base_classes} || [];
  98     $additional_base = [$additional_base]
  99       unless ref $additional_base eq 'ARRAY';
 100     my $left_base = $args{left_base_classes} || [];
 101     $left_base = [$left_base] unless ref $left_base eq 'ARRAY';
 102     $class->loader_data({
 103         _datasource =>
 104           [ $args{dsn}, $args{user}, $args{password}, $args{options} ],
 105         _namespace       => $args{namespace},
 106         _additional      => $additional,
 107         _additional_base => $additional_base,
 108         _left_base       => $left_base,
 109         _constraint      => $args{constraint} || '.*',
 110         _exclude         => $args{exclude},
 111         _relationships   => $args{relationships},
 112         _inflect         => $args{inflect},
 113         _db_schema       => $args{db_schema},
 114         _drop_db_schema  => $args{drop_db_schema},
 115         TABLE_CLASSES    => {},
 116         MONIKERS         => {},
 117     });
 118
 119     $class->connection(@{$class->loader_data->{_datasource}});
 120     warn qq/\### START DBIx::Class::Schema::Loader dump ###\n/ if $class->debug_loader;
 121     $class->_load_classes;
 122     $class->_relationships                            if $class->loader_data->{_relationships};
 123     warn qq/\### END DBIx::Class::Schema::Loader dump ###\n/ if $class->debug_loader;
 124     $class->storage->dbh->disconnect; # XXX this should be ->storage->disconnect later?
 125
 126     1;
 127 }
 128
 129 # The original table class name during Loader,
 130 sub _find_table_class {
 131     my ( $class, $table ) = @_;
 132     return $class->loader_data->{TABLE_CLASSES}->{$table};
 133 }
 134
 135 # Returns the moniker for a given table name,
 136 # for use in $conn->resultset($moniker)
 137
 138 =head3 moniker
 139
 140 Returns the moniker for a given literal table name.  Used
 141 as $schema->resultset($moniker), etc.
 142
 143 =cut
 144 sub moniker {
 145     my ( $class, $table ) = @_;
 146     return $class->loader_data->{MONIKERS}->{$table};
 147 }
 148
 149 =head3 debug_loader
 150
 151 Overload to enable Loader debug messages.
 152
 153 =cut
 154
 155 sub debug_loader { 0 }
 156
 157 =head3 tables
 158
 159 Returns a sorted list of tables.
 160
 161     my @tables = $loader->tables;
 162
 163 =cut
 164
 165 sub tables {
 166     my $class = shift;
 167     return sort keys %{ $class->loader_data->{MONIKERS} };
 168 }
 169
 170 # Overload in your driver class
 171 sub _db_classes { croak "ABSTRACT METHOD" }
 172
 173 # Setup has_a and has_many relationships
 174 sub _belongs_to_many {
 175     my ( $class, $table, $column, $other, $other_column ) = @_;
 176     my $table_class = $class->_find_table_class($table);
 177     my $other_class = $class->_find_table_class($other);
 178
 179     warn qq/\# Belongs_to relationship\n/ if $class->debug_loader;
 180
 181     if($other_column) {
 182         warn qq/$table_class->belongs_to( '$column' => '$other_class',/
 183           .  qq/ { "foreign.$other_column" => "self.$column" },/
 184           .  qq/ { accessor => 'filter' });\n\n/
 185           if $class->debug_loader;
 186         $table_class->belongs_to( $column => $other_class,
 187           { "foreign.$other_column" => "self.$column" },
 188           { accessor => 'filter' }
 189         );
 190     }
 191     else {
 192         warn qq/$table_class->belongs_to( '$column' => '$other_class' );\n\n/
 193           if $class->debug_loader;
 194         $table_class->belongs_to( $column => $other_class );
 195     }
 196
 197     my ($table_class_base) = $table_class =~ /.*::(.+)/;
 198     my $plural = Lingua::EN::Inflect::PL( lc $table_class_base );
 199     $plural = $class->loader_data->{_inflect}->{ lc $table_class_base }
 200       if $class->loader_data->{_inflect}
 201       and exists $class->loader_data->{_inflect}->{ lc $table_class_base };
 202
 203     warn qq/\# Has_many relationship\n/ if $class->debug_loader;
 204
 205     if($other_column) {
 206         warn qq/$other_class->has_many( '$plural' => '$table_class',/
 207           .  qq/ { "foreign.$column" => "self.$other_column" } );\n\n/
 208           if $class->debug_loader;
 209         $other_class->has_many( $plural => $table_class,
 210                                 { "foreign.$column" => "self.$other_column" }
 211                               );
 212     }
 213     else {
 214         warn qq/$other_class->has_many( '$plural' => '$table_class',/
 215           .  qq/'$other_column' );\n\n/
 216           if $class->debug_loader;
 217         $other_class->has_many( $plural => $table_class, $column );
 218     }
 219 }
 220
 221 # Load and setup classes
 222 sub _load_classes {
 223     my $class = shift;
 224
 225     my $namespace    = $class->loader_data->{_namespace};
 226
 227     my @tables          = $class->_tables();
 228     my @db_classes      = $class->_db_classes();
 229     my $additional      = join '', map "use $_;\n", @{ $class->loader_data->{_additional} };
 230     my $additional_base = join '', map "use base '$_';\n",
 231       @{ $class->loader_data->{_additional_base} };
 232     my $left_base  = join '', map "use base '$_';\n", @{ $class->loader_data->{_left_base} };
 233     my $constraint = $class->loader_data->{_constraint};
 234     my $exclude    = $class->loader_data->{_exclude};
 235
 236     foreach my $table (@tables) {
 237         next unless $table =~ /$constraint/;
 238         next if ( defined $exclude && $table =~ /$exclude/ );
 239
 240         my $table = lc $table;
 241         my $table_name_db_schema = $table;
 242         my $table_name_only = $table_name_db_schema;
 243         my ($db_schema, $tbl) = split /\./, $table;
 244         if($tbl) {
 245             $table_name_db_schema = $tbl if $class->loader_data->{_drop_db_schema};
 246             $table_name_only = $tbl;
 247         }
 248         else {
 249             undef $db_schema;
 250         }
 251
 252         my $table_subclass = $class->_table2subclass($db_schema, $table_name_only);
 253         my $table_class = $namespace . '::' . $table_subclass;
 254
 255         $class->inject_base( $table_class, 'DBIx::Class::Core' );
 256         $_->require for @db_classes;
 257         $class->inject_base( $table_class, $_ ) for @db_classes;
 258         warn qq/\# Initializing table "$table_name_db_schema" as "$table_class"\n/ if $class->debug_loader;
 259         $table_class->table(lc $table_name_db_schema);
 260
 261         my ( $cols, $pks ) = $class->_table_info($table_name_db_schema);
 262         carp("$table has no primary key") unless @$pks;
 263         $table_class->add_columns(@$cols);
 264         $table_class->set_primary_key(@$pks) if @$pks;
 265
 266         my $code = "package $table_class;\n$additional_base$additional$left_base";
 267         warn qq/$code/                        if $class->debug_loader;
 268         warn qq/$table_class->table('$table_name_db_schema');\n/ if $class->debug_loader;
 269         my $columns = join "', '", @$cols;
 270         warn qq/$table_class->add_columns('$columns')\n/ if $class->debug_loader;
 271         my $primaries = join "', '", @$pks;
 272         warn qq/$table_class->set_primary_key('$primaries')\n/ if $class->debug_loader && @$pks;
 273         eval $code;
 274         croak qq/Couldn't load additional classes "$@"/ if $@;
 275         unshift @{"$table_class\::ISA"}, $_ foreach ( @{ $class->loader_data->{_left_base} } );
 276
 277         $class->register_class($table_subclass, $table_class);
 278         $class->loader_data->{TABLE_CLASSES}->{$table_name_db_schema} = $table_class;
 279         $class->loader_data->{MONIKERS}->{$table_name_db_schema} = $table_subclass;
 280     }
 281 }
 282
 283 # Find and setup relationships
 284 sub _relationships {
 285     my $class = shift;
 286     my $dbh = $class->storage->dbh;
 287     foreach my $table ( $class->tables ) {
 288         my $quoter = $dbh->get_info(29) || q{"};
 289         if ( my $sth = $dbh->foreign_key_info( '', '', '', '', '', $table ) ) {
 290             for my $res ( @{ $sth->fetchall_arrayref( {} ) } ) {
 291                 my $column = $res->{FK_COLUMN_NAME};
 292                 my $other  = $res->{UK_TABLE_NAME};
 293                 my $other_column  = $res->{UK_COLUMN_NAME};
 294                 $column =~ s/$quoter//g;
 295                 $other =~ s/$quoter//g;
 296                 $other_column =~ s/$quoter//g;
 297                 eval { $class->_belongs_to_many( $table, $column, $other,
 298                   $other_column ) };
 299                 warn qq/\# belongs_to_many failed "$@"\n\n/
 300                   if $@ && $class->debug_loader;
 301             }
 302         }
 303     }
 304 }
 305
 306 # Make a subclass (dbix moniker) from a table
 307 sub _table2subclass {
 308     my ( $class, $db_schema, $table ) = @_;
 309
 310     my $table_subclass = join '', map ucfirst, split /[\W_]+/, $table;
 311
 312     if($db_schema && !$class->loader_data->{_drop_db_schema}) {
 313         $table_subclass = (ucfirst lc $db_schema) . '-' . $table_subclass;
 314     }
 315
 316     $table_subclass;
 317 }
 318
 319 # Overload in driver class
 320 sub _tables { croak "ABSTRACT METHOD" }
 321
 322 sub _table_info { croak "ABSTRACT METHOD" }
 323
 324 =head1 SEE ALSO
 325
 326 L<DBIx::Class::Schema::Loader>
 327
 328 =cut
 329
 330 1;