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

   1 package DBIx::Class::Schema::Loader::Generic;
   2
   3 use strict;
   4 use warnings;
   5 use base qw/Class::Accessor::Fast/;
   6 use Class::C3;
   7 use Carp;
   8 use Lingua::EN::Inflect;
   9 use UNIVERSAL::require;
  10 require DBIx::Class;
  11
  12 # The first group are all arguments which are may be defaulted within,
  13 # The last two (classes, monikers) are generated locally:
  14
  15 __PACKAGE__->mk_ro_accessors(qw/
  16                                 schema
  17                                 connect_info
  18                                 exclude
  19                                 constraint
  20                                 additional_classes
  21                                 additional_base_classes
  22                                 left_base_classes
  23                                 components
  24                                 resultset_components
  25                                 relationships
  26                                 inflect_map
  27                                 moniker_map
  28                                 db_schema
  29                                 drop_db_schema
  30                                 debug
  31
  32                                 classes
  33                                 monikers
  34                              /);
  35
  36 =head1 NAME
  37
  38 DBIx::Class::Schema::Loader::Generic - Generic DBIx::Class::Schema::Loader Implementation.
  39
  40 =head1 SYNOPSIS
  41
  42 See L<DBIx::Class::Schema::Loader>
  43
  44 =head1 DESCRIPTION
  45
  46 This is the base class for the vendor-specific C<DBIx::Class::Schema::*>
  47 classes, and implements the common functionality between them.
  48
  49 =head1 OPTIONS
  50
  51 Available constructor options are:
  52
  53 =head2 connect_info
  54
  55 Identical to the connect_info arguments to C<connect> and C<connection>
  56 that are mentioned in L<DBIx::Class::Schema>.
  57
  58 An arrayref of connection information.  For DBI-based Schemas,
  59 this takes the form:
  60
  61   connect_info => [ $dsn, $user, $pass, { AutoCommit => 1 } ],
  62
  63 =head2 additional_base_classes
  64
  65 List of additional base classes your table classes will use.
  66
  67 =head2 left_base_classes
  68
  69 List of additional base classes, that need to be leftmost.
  70
  71 =head2 additional_classes
  72
  73 List of additional classes which your table classes will use.
  74
  75 =head2 components
  76
  77 List of additional components to be loaded into your table classes.
  78 A good example would be C<ResultSetManager>.
  79
  80 =head2 resultset_components
  81
  82 List of additional resultset components to be loaded into your table
  83 classes.  A good example would be C<AlwaysRS>.  Component
  84 C<ResultSetManager> will be automatically added to the above
  85 C<components> list if this option is set.
  86
  87 =head2 constraint
  88
  89 Only load tables matching regex.
  90
  91 =head2 exclude
  92
  93 Exclude tables matching regex.
  94
  95 =head2 debug
  96
  97 Enable debug messages.
  98
  99 =head2 relationships
 100
 101 Try to automatically detect/setup has_a and has_many relationships.
 102
 103 =head2 moniker_map
 104
 105 Overrides the default tablename -> moniker translation.  Can be either
 106 a hashref of table => moniker names, or a coderef for a translator
 107 function taking a single scalar table name argument and returning
 108 a scalar moniker.  If the hash entry does not exist, or the function
 109 returns a false/undef value, the code falls back to default behavior
 110 for that table name.
 111
 112 =head2 inflect_map
 113
 114 Just like L</moniker_map> above, but for inflecting (pluralizing)
 115 relationship names.
 116
 117 =head2 inflect
 118
 119 Deprecated.  Equivalent to L</inflect_map>, but previously only took
 120 a hashref argument, not a coderef.  If you set C<inflect> to anything,
 121 that setting will be copied to L</inflect_map>.
 122
 123 =head2 dsn
 124
 125 DEPRECATED, use L</connect_info> instead.
 126
 127 DBI Data Source Name.
 128
 129 =head2 user
 130
 131 DEPRECATED, use L</connect_info> instead.
 132
 133 Username.
 134
 135 =head2 password
 136
 137 DEPRECATED, use L</connect_info> instead.
 138
 139 Password.
 140
 141 =head2 options
 142
 143 DEPRECATED, use L</connect_info> instead.
 144
 145 DBI connection options hashref, like:
 146
 147   { AutoCommit => 1 }
 148
 149 =head1 METHODS
 150
 151 =cut
 152
 153 # ensure that a peice of object data is a valid arrayref, creating
 154 # an empty one or encapsulating whatever's there.
 155 sub _ensure_arrayref {
 156     my $self = shift;
 157
 158     foreach (@_) {
 159         $self->{$_} ||= [];
 160         $self->{$_} = [ $self->{$_} ]
 161             unless ref $self->{$_} eq 'ARRAY';
 162     }
 163 }
 164
 165 =head2 new
 166
 167 Constructor for L<DBIx::Class::Schema::Loader::Generic>, used internally
 168 by L<DBIx::Class::Schema::Loader>.
 169
 170 =cut
 171
 172 sub new {
 173     my ( $class, %args ) = @_;
 174
 175     my $self = { %args };
 176
 177     bless $self => $class;
 178
 179     $self->{db_schema}  ||= '';
 180     $self->{constraint} ||= '.*';
 181     $self->_ensure_arrayref(qw/additional_classes
 182                                additional_base_classes
 183                                left_base_classes
 184                                components
 185                                resultset_components
 186                                connect_info/);
 187
 188     push(@{$self->{components}}, 'ResultSetManager')
 189         if @{$self->{resultset_components}};
 190
 191     $self->{monikers} = {};
 192     $self->{classes} = {};
 193
 194     # Support deprecated argument name
 195     $self->{inflect_map} ||= $self->{inflect};
 196
 197     # Support deprecated connect_info args, even mixed
 198     #  with a valid partially-filled connect_info
 199     $self->{connect_info}->[0] ||= $self->{dsn};
 200     $self->{connect_info}->[1] ||= $self->{user};
 201     $self->{connect_info}->[2] ||= $self->{password};
 202     $self->{connect_info}->[3] ||= $self->{options};
 203
 204     $self;
 205 }
 206
 207 =head2 load
 208
 209 Does the actual schema-construction work, used internally by
 210 L<DBIx::Class::Schema::Loader> right after object construction.
 211
 212 =cut
 213
 214 sub load {
 215     my $self = shift;
 216
 217     $self->schema->connection(@{$self->connect_info});
 218
 219     warn qq/\### START DBIx::Class::Schema::Loader dump ###\n/
 220         if $self->debug;
 221
 222     $self->_load_classes;
 223     $self->_load_relationships if $self->relationships;
 224     $self->_load_external;
 225
 226     warn qq/\### END DBIx::Class::Schema::Loader dump ###\n/
 227         if $self->debug;
 228     $self->schema->storage->disconnect;
 229
 230     $self;
 231 }
 232
 233 sub _load_external {
 234     my $self = shift;
 235
 236     foreach my $table_class (values %{$self->classes}) {
 237         $table_class->require;
 238         if($@ && $@ !~ /^Can't locate /) {
 239             croak "Failed to load external class definition"
 240                   . "for '$table_class': $@";
 241         }
 242         elsif(!$@) {
 243             warn qq/# Loaded external class definition for '$table_class'\n/
 244                 if $self->debug;
 245         }
 246     }
 247 }
 248
 249 # Overload in your driver class
 250 sub _db_classes { croak "ABSTRACT METHOD" }
 251
 252 # Inflect a relationship name
 253 sub _inflect_relname {
 254     my ($self, $relname) = @_;
 255
 256     if( ref $self->{inflect_map} eq 'HASH' ) {
 257         return $self->inflect_map->{$relname}
 258             if exists $self->inflect_map->{$relname};
 259     }
 260     elsif( ref $self->{inflect_map} eq 'CODE' ) {
 261         my $inflected = $self->inflect_map->($relname);
 262         return $inflected if $inflected;
 263     }
 264
 265     return Lingua::EN::Inflect::PL($relname);
 266 }
 267
 268 # Set up a simple relation with just a local col and foreign table
 269 sub _make_simple_rel {
 270     my ($self, $table, $other, $col) = @_;
 271
 272     my $table_class = $self->classes->{$table};
 273     my $other_class = $self->classes->{$other};
 274     my $table_relname = $self->_inflect_relname(lc $table);
 275
 276     warn qq/\# Belongs_to relationship\n/ if $self->debug;
 277     warn qq/$table_class->belongs_to( '$col' => '$other_class' );\n\n/
 278       if $self->debug;
 279     $table_class->belongs_to( $col => $other_class );
 280
 281     warn qq/\# Has_many relationship\n/ if $self->debug;
 282     warn qq/$other_class->has_many( '$table_relname' => '$table_class',/
 283       .  qq/$col);\n\n/
 284       if $self->debug;
 285
 286     $other_class->has_many( $table_relname => $table_class, $col);
 287 }
 288
 289 # not a class method, just a helper for cond_rel XXX
 290 sub _stringify_hash {
 291     my $href = shift;
 292
 293     return '{ ' .
 294            join(q{, }, map("$_ => $href->{$_}", keys %$href))
 295            . ' }';
 296 }
 297
 298 # Set up a complex relation based on a hashref condition
 299 sub _make_cond_rel {
 300     my ( $self, $table, $other, $cond ) = @_;
 301
 302     my $table_class = $self->classes->{$table};
 303     my $other_class = $self->classes->{$other};
 304     my $table_relname = $self->_inflect_relname(lc $table);
 305     my $other_relname = lc $other;
 306
 307     # for single-column case, set the relname to the column name,
 308     # to make filter accessors work
 309     if(scalar keys %$cond == 1) {
 310         my ($col) = keys %$cond;
 311         $other_relname = $cond->{$col};
 312     }
 313
 314     my $rev_cond = { reverse %$cond };
 315
 316     for (keys %$rev_cond) {
 317         $rev_cond->{"foreign.$_"} = "self.".$rev_cond->{$_};
 318         delete $rev_cond->{$_};
 319     }
 320
 321     my $cond_printable = _stringify_hash($cond)
 322         if $self->debug;
 323     my $rev_cond_printable = _stringify_hash($rev_cond)
 324         if $self->debug;
 325
 326     warn qq/\# Belongs_to relationship\n/ if $self->debug;
 327
 328     warn qq/$table_class->belongs_to( '$other_relname' => '$other_class',/
 329       .  qq/$cond_printable);\n\n/
 330       if $self->debug;
 331
 332     $table_class->belongs_to( $other_relname => $other_class, $cond);
 333
 334     warn qq/\# Has_many relationship\n/ if $self->debug;
 335
 336     warn qq/$other_class->has_many( '$table_relname' => '$table_class',/
 337       .  qq/$rev_cond_printable);\n\n/
 338       .  qq/);\n\n/
 339       if $self->debug;
 340
 341     $other_class->has_many( $table_relname => $table_class, $rev_cond);
 342 }
 343
 344 sub _use {
 345     my $self = shift;
 346     my $target = shift;
 347
 348     foreach (@_) {
 349         $_->require or croak ($_ . "->require: $@");
 350         eval "package $target; use $_;";
 351         croak "use $_: $@" if $@;
 352     }
 353 }
 354
 355 sub _inject {
 356     my $self = shift;
 357     my $target = shift;
 358     my $schema = $self->schema;
 359
 360     foreach (@_) {
 361         $_->require or croak ($_ . "->require: $@");
 362         $schema->inject_base($target, $_);
 363     }
 364 }
 365
 366 # Load and setup classes
 367 sub _load_classes {
 368     my $self = shift;
 369
 370     my @tables     = $self->_tables();
 371     my @db_classes = $self->_db_classes();
 372     my $schema     = $self->schema;
 373
 374     foreach my $table (@tables) {
 375         my $constraint = $self->constraint;
 376         my $exclude = $self->exclude;
 377
 378         next unless $table =~ /$constraint/;
 379         next if defined $exclude && $table =~ /$exclude/;
 380
 381         my ($db_schema, $tbl) = split /\./, $table;
 382         my $tablename = lc $table;
 383         if($tbl) {
 384             $tablename = $self->drop_db_schema ? $tbl : lc $table;
 385         }
 386         my $lc_tblname = lc $tablename;
 387
 388         my $table_moniker = $self->_table2moniker($db_schema, $tbl);
 389         my $table_class = $schema . q{::} . $table_moniker;
 390
 391         { no strict 'refs';
 392           @{"${table_class}::ISA"} = qw/DBIx::Class/;
 393         }
 394         $self->_use   ($table_class, @{$self->additional_classes});
 395         $self->_inject($table_class, @{$self->additional_base_classes});
 396         $table_class->load_components(@{$self->components}, @db_classes, 'Core');
 397         $table_class->load_resultset_components(@{$self->resultset_components})
 398             if @{$self->resultset_components};
 399         $self->_inject($table_class, @{$self->left_base_classes});
 400
 401         warn qq/\# Initializing table "$tablename" as "$table_class"\n/
 402             if $self->debug;
 403         $table_class->table($lc_tblname);
 404
 405         my ( $cols, $pks ) = $self->_table_info($table);
 406         carp("$table has no primary key") unless @$pks;
 407         $table_class->add_columns(@$cols);
 408         $table_class->set_primary_key(@$pks) if @$pks;
 409
 410         warn qq/$table_class->table('$tablename');\n/ if $self->debug;
 411         my $columns = join "', '", @$cols;
 412         warn qq/$table_class->add_columns('$columns')\n/ if $self->debug;
 413         my $primaries = join "', '", @$pks;
 414         warn qq/$table_class->set_primary_key('$primaries')\n/
 415             if $self->debug && @$pks;
 416
 417         $schema->register_class($table_moniker, $table_class);
 418         $self->classes->{$lc_tblname} = $table_class;
 419         $self->monikers->{$lc_tblname} = $table_moniker;
 420     }
 421 }
 422
 423 =head2 tables
 424
 425 Returns a sorted list of loaded tables, using the original database table
 426 names.  Actually generated from the keys of the C<monikers> hash below.
 427
 428   my @tables = $schema->loader->tables;
 429
 430 =cut
 431
 432 sub tables {
 433     my $self = shift;
 434
 435     return sort keys %{ $self->monikers };
 436 }
 437
 438 # Find and setup relationships
 439 sub _load_relationships {
 440     my $self = shift;
 441
 442     my $dbh = $self->schema->storage->dbh;
 443     my $quoter = $dbh->get_info(29) || q{"};
 444     foreach my $table ( $self->tables ) {
 445         my $rels = {};
 446         my $sth = $dbh->foreign_key_info( '',
 447             $self->db_schema, '', '', '', $table );
 448         next if !$sth;
 449         while(my $raw_rel = $sth->fetchrow_hashref) {
 450             my $uk_tbl  = lc $raw_rel->{UK_TABLE_NAME};
 451             my $uk_col  = lc $raw_rel->{UK_COLUMN_NAME};
 452             my $fk_col  = lc $raw_rel->{FK_COLUMN_NAME};
 453             my $relid   = lc $raw_rel->{UK_NAME};
 454             $uk_tbl =~ s/$quoter//g;
 455             $uk_col =~ s/$quoter//g;
 456             $fk_col =~ s/$quoter//g;
 457             $relid  =~ s/$quoter//g;
 458             $rels->{$relid}->{tbl} = $uk_tbl;
 459             $rels->{$relid}->{cols}->{$uk_col} = $fk_col;
 460         }
 461
 462         foreach my $relid (keys %$rels) {
 463             my $reltbl = $rels->{$relid}->{tbl};
 464             my $cond   = $rels->{$relid}->{cols};
 465             eval { $self->_make_cond_rel( $table, $reltbl, $cond ) };
 466               warn qq/\# belongs_to_many failed "$@"\n\n/
 467                 if $@ && $self->debug;
 468         }
 469     }
 470 }
 471
 472 # Make a moniker from a table
 473 sub _table2moniker {
 474     my ( $self, $db_schema, $table ) = @_;
 475
 476     my $db_schema_ns;
 477
 478     if($table) {
 479         $db_schema = ucfirst lc $db_schema;
 480         $db_schema_ns = $db_schema if(!$self->drop_db_schema);
 481     } else {
 482         $table = $db_schema;
 483     }
 484
 485     my $moniker;
 486
 487     if( ref $self->moniker_map eq 'HASH' ) {
 488         $moniker = $self->moniker_map->{$table};
 489     }
 490     elsif( ref $self->moniker_map eq 'CODE' ) {
 491         $moniker = $self->moniker_map->($table);
 492     }
 493
 494     $moniker ||= join '', map ucfirst, split /[\W_]+/, lc $table;
 495
 496     $moniker = $db_schema_ns ? $db_schema_ns . $moniker : $moniker;
 497
 498     return $moniker;
 499 }
 500
 501 # Overload in driver class
 502 sub _tables { croak "ABSTRACT METHOD" }
 503
 504 sub _table_info { croak "ABSTRACT METHOD" }
 505
 506 =head2 monikers
 507
 508 Returns a hashref of loaded table-to-moniker mappings for the original
 509 database table names.
 510
 511   my $monikers = $schema->loader->monikers;
 512   my $foo_tbl_moniker = $monikers->{foo_tbl};
 513   # -or-
 514   my $foo_tbl_moniker = $schema->loader->monikers->{foo_tbl};
 515   # $foo_tbl_moniker would look like "FooTbl"
 516
 517 =head2 classes
 518
 519 Returns a hashref of table-to-classname mappings for the original database
 520 table names.  You probably shouldn't be using this for any normal or simple
 521 usage of your Schema.  The usual way to run queries on your tables is via
 522 C<$schema-E<gt>resultset('FooTbl')>, where C<FooTbl> is a moniker as
 523 returned by C<monikers> above.
 524
 525   my $classes = $schema->loader->classes;
 526   my $foo_tbl_class = $classes->{foo_tbl};
 527   # -or-
 528   my $foo_tbl_class = $schema->loader->classes->{foo_tbl};
 529   # $foo_tbl_class would look like "My::Schema::FooTbl",
 530   #   assuming the schema class is "My::Schema"
 531
 532 =head1 SEE ALSO
 533
 534 L<DBIx::Class::Schema::Loader>
 535
 536 =cut
 537
 538 1;