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 password
  58
  59 Password.
  60
  61 =head3 relationships
  62
  63 Try to automatically detect/setup has_a and has_many relationships.
  64
  65 =head3 inflect
  66
  67 An hashref, which contains exceptions to Lingua::EN::Inflect::PL().
  68 Useful for foreign language column names.
  69
  70 =head3 user
  71
  72 Username.
  73
  74 =head2 METHODS
  75
  76 =cut
  77
  78 =head3 new
  79
  80 Not intended to be called directly.  This is used internally by the
  81 C<new()> method in L<DBIx::Class::Schema::Loader>.
  82
  83 =cut
  84
  85 sub _load_from_connection {
  86     my ( $class, %args ) = @_;
  87     if ( $args{debug} ) {
  88         no strict 'refs';
  89         *{"$class\::debug_loader"} = sub { 1 };
  90     }
  91     my $additional = $args{additional_classes} || [];
  92     $additional = [$additional] unless ref $additional eq 'ARRAY';
  93     my $additional_base = $args{additional_base_classes} || [];
  94     $additional_base = [$additional_base]
  95       unless ref $additional_base eq 'ARRAY';
  96     my $left_base = $args{left_base_classes} || [];
  97     $left_base = [$left_base] unless ref $left_base eq 'ARRAY';
  98     $class->loader_data({
  99         _datasource =>
 100           [ $args{dsn}, $args{user}, $args{password}, $args{options} ],
 101         _additional      => $additional,
 102         _additional_base => $additional_base,
 103         _left_base       => $left_base,
 104         _constraint      => $args{constraint} || '.*',
 105         _exclude         => $args{exclude},
 106         _relationships   => $args{relationships},
 107         _inflect         => $args{inflect},
 108         _db_schema       => $args{db_schema} || '',
 109         _drop_db_schema  => $args{drop_db_schema},
 110         TABLE_CLASSES    => {},
 111         MONIKERS         => {},
 112     });
 113
 114     $class->connection(@{$class->loader_data->{_datasource}});
 115     warn qq/\### START DBIx::Class::Schema::Loader dump ###\n/ if $class->debug_loader;
 116     $class->_load_classes;
 117     $class->_relationships                            if $class->loader_data->{_relationships};
 118     warn qq/\### END DBIx::Class::Schema::Loader dump ###\n/ if $class->debug_loader;
 119     $class->storage->dbh->disconnect; # XXX this should be ->storage->disconnect later?
 120
 121     1;
 122 }
 123
 124 # The original table class name during Loader,
 125 sub _find_table_class {
 126     my ( $class, $table ) = @_;
 127     return $class->loader_data->{TABLE_CLASSES}->{$table};
 128 }
 129
 130 # Returns the moniker for a given table name,
 131 # for use in $conn->resultset($moniker)
 132
 133 =head3 moniker
 134
 135 Returns the moniker for a given literal table name.  Used
 136 as $schema->resultset($moniker), etc.
 137
 138 =cut
 139 sub moniker {
 140     my ( $class, $table ) = @_;
 141     return $class->loader_data->{MONIKERS}->{$table};
 142 }
 143
 144 =head3 debug_loader
 145
 146 Overload to enable Loader debug messages.
 147
 148 =cut
 149
 150 sub debug_loader { 0 }
 151
 152 =head3 tables
 153
 154 Returns a sorted list of tables.
 155
 156     my @tables = $loader->tables;
 157
 158 =cut
 159
 160 sub tables {
 161     my $class = shift;
 162     return sort keys %{ $class->loader_data->{MONIKERS} };
 163 }
 164
 165 # Overload in your driver class
 166 sub _db_classes { croak "ABSTRACT METHOD" }
 167
 168 # Setup has_a and has_many relationships
 169 sub _belongs_to_many {
 170     use Data::Dumper;
 171
 172     my ( $class, $table, $other, $cond ) = @_;
 173     my $table_class = $class->_find_table_class($table);
 174     my $other_class = $class->_find_table_class($other);
 175
 176     my $table_relname = lc $table;
 177     my $other_relname = lc $other;
 178
 179     if(my $inflections = $class->loader_data->{_inflect}) {
 180         $table_relname = $inflections->{$table_relname}
 181           if exists $inflections->{$table_relname};
 182     }
 183     else {
 184         $table_relname = Lingua::EN::Inflect::PL($table_relname);
 185     }
 186
 187     # for single-column case, set the relname to the column name,
 188     # to make filter accessors work
 189     if(scalar keys %$cond == 1) {
 190         my ($col) = keys %$cond;
 191         $other_relname = $cond->{$col};
 192     }
 193
 194     my $rev_cond = { reverse %$cond };
 195
 196     warn qq/\# Belongs_to relationship\n/ if $class->debug_loader;
 197
 198     warn qq/$table_class->belongs_to( '$other_relname' => '$other_class',/
 199       .  Dumper($cond)
 200       .  qq/);\n\n/
 201       if $class->debug_loader;
 202
 203     $table_class->belongs_to( $other_relname => $other_class, $cond);
 204
 205     warn qq/\# Has_many relationship\n/ if $class->debug_loader;
 206
 207     warn qq/$other_class->has_many( '$table_relname' => '$table_class',/
 208       .  Dumper($rev_cond)
 209       .  qq/);\n\n/
 210       if $class->debug_loader;
 211
 212     $other_class->has_many( $table_relname => $table_class, $rev_cond);
 213 }
 214
 215 # Load and setup classes
 216 sub _load_classes {
 217     my $class = shift;
 218
 219     my @tables          = $class->_tables();
 220     my @db_classes      = $class->_db_classes();
 221     my $additional      = join '', map "use $_;\n", @{ $class->loader_data->{_additional} };
 222     my $additional_base = join '', map "use base '$_';\n",
 223       @{ $class->loader_data->{_additional_base} };
 224     my $left_base  = join '', map "use base '$_';\n", @{ $class->loader_data->{_left_base} };
 225     my $constraint = $class->loader_data->{_constraint};
 226     my $exclude    = $class->loader_data->{_exclude};
 227
 228     foreach my $table (@tables) {
 229         next unless $table =~ /$constraint/;
 230         next if ( defined $exclude && $table =~ /$exclude/ );
 231
 232         my ($db_schema, $tbl) = split /\./, $table;
 233         my $tablename = lc $table;
 234         if($tbl) {
 235             $tablename = $class->loader_data->{_drop_db_schema} ? $tbl : lc $table;
 236         }
 237
 238         my $table_moniker = $class->_table2moniker($db_schema, $tbl);
 239         my $table_class = "$class\::$table_moniker";
 240
 241         $class->inject_base( $table_class, 'DBIx::Class::Core' );
 242         $_->require for @db_classes;
 243         $class->inject_base( $table_class, $_ ) for @db_classes;
 244         warn qq/\# Initializing table "$tablename" as "$table_class"\n/ if $class->debug_loader;
 245         $table_class->table(lc $tablename);
 246
 247         my ( $cols, $pks ) = $class->_table_info($table);
 248         carp("$table has no primary key") unless @$pks;
 249         $table_class->add_columns(@$cols);
 250         $table_class->set_primary_key(@$pks) if @$pks;
 251
 252         my $code = "package $table_class;\n$additional_base$additional$left_base";
 253         warn qq/$code/                        if $class->debug_loader;
 254         warn qq/$table_class->table('$tablename');\n/ if $class->debug_loader;
 255         my $columns = join "', '", @$cols;
 256         warn qq/$table_class->add_columns('$columns')\n/ if $class->debug_loader;
 257         my $primaries = join "', '", @$pks;
 258         warn qq/$table_class->set_primary_key('$primaries')\n/ if $class->debug_loader && @$pks;
 259         eval $code;
 260         croak qq/Couldn't load additional classes "$@"/ if $@;
 261         unshift @{"$table_class\::ISA"}, $_ foreach ( @{ $class->loader_data->{_left_base} } );
 262
 263         $class->register_class($table_moniker, $table_class);
 264         $class->loader_data->{TABLE_CLASSES}->{lc $tablename} = $table_class;
 265         $class->loader_data->{MONIKERS}->{lc $tablename} = $table_moniker;
 266     }
 267 }
 268
 269 # Find and setup relationships
 270 sub _relationships {
 271     my $class = shift;
 272     my $dbh = $class->storage->dbh;
 273     my $quoter = $dbh->get_info(29) || q{"};
 274     foreach my $table ( $class->tables ) {
 275         my $rels = {};
 276         my $sth = $dbh->foreign_key_info( '',
 277             $class->loader_data->{_db_schema}, '', '', '', $table );
 278         next if !$sth;
 279         while(my $raw_rel = $sth->fetchrow_hashref) {
 280             my $uk_tbl  = lc $raw_rel->{UK_TABLE_NAME};
 281             my $uk_col  = lc $raw_rel->{UK_COLUMN_NAME};
 282             my $fk_col  = lc $raw_rel->{FK_COLUMN_NAME};
 283             $uk_tbl =~ s/$quoter//g;
 284             $uk_col =~ s/$quoter//g;
 285             $fk_col =~ s/$quoter//g;
 286             $rels->{$uk_tbl}->{$uk_col} = $fk_col;
 287         }
 288
 289         foreach my $reltbl (keys %$rels) {
 290             my $cond = $rels->{$reltbl};
 291             eval { $class->_belongs_to_many( $table, $reltbl, $cond ) };
 292               warn qq/\# belongs_to_many failed "$@"\n\n/
 293                 if $@ && $class->debug_loader;
 294         }
 295     }
 296 }
 297
 298 # Make a moniker from a table
 299 sub _table2moniker {
 300     my ( $class, $db_schema, $table ) = @_;
 301
 302     my $db_schema_ns;
 303
 304     if($table) {
 305         $db_schema = ucfirst lc $db_schema;
 306         $db_schema_ns = $db_schema if(!$class->loader_data->{_drop_db_schema});
 307     } else {
 308         $table = $db_schema;
 309     }
 310
 311     my $moniker = join '', map ucfirst, split /[\W_]+/, lc $table;
 312     $moniker = $db_schema_ns ? $db_schema_ns . $moniker : $moniker;
 313
 314     return $moniker;
 315 }
 316
 317 # Overload in driver class
 318 sub _tables { croak "ABSTRACT METHOD" }
 319
 320 sub _table_info { croak "ABSTRACT METHOD" }
 321
 322 =head1 SEE ALSO
 323
 324 L<DBIx::Class::Schema::Loader>
 325
 326 =cut
 327
 328 1;