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