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