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
 225     warn qq/\### END DBIx::Class::Schema::Loader dump ###\n/
 226         if $self->debug;
 227     $self->schema->storage->disconnect;
 228
 229     $self;
 230 }
 231
 232 # Overload in your driver class
 233 sub _db_classes { croak "ABSTRACT METHOD" }
 234
 235 # Inflect a relationship name
 236 sub _inflect_relname {
 237     my ($self, $relname) = @_;
 238
 239     if( ref $self->{inflect_map} eq 'HASH' ) {
 240         return $self->inflect_map->{$relname}
 241             if exists $self->inflect_map->{$relname};
 242     }
 243     elsif( ref $self->{inflect_map} eq 'CODE' ) {
 244         my $inflected = $self->inflect_map->($relname);
 245         return $inflected if $inflected;
 246     }
 247
 248     return Lingua::EN::Inflect::PL($relname);
 249 }
 250
 251 # Set up a simple relation with just a local col and foreign table
 252 sub _make_simple_rel {
 253     my ($self, $table, $other, $col) = @_;
 254
 255     my $table_class = $self->classes->{$table};
 256     my $other_class = $self->classes->{$other};
 257     my $table_relname = $self->_inflect_relname(lc $table);
 258
 259     warn qq/\# Belongs_to relationship\n/ if $self->debug;
 260     warn qq/$table_class->belongs_to( '$col' => '$other_class' );\n\n/
 261       if $self->debug;
 262     $table_class->belongs_to( $col => $other_class );
 263
 264     warn qq/\# Has_many relationship\n/ if $self->debug;
 265     warn qq/$other_class->has_many( '$table_relname' => '$table_class',/
 266       .  qq/$col);\n\n/
 267       if $self->debug;
 268
 269     $other_class->has_many( $table_relname => $table_class, $col);
 270 }
 271
 272 # not a class method, just a helper for cond_rel XXX
 273 sub _stringify_hash {
 274     my $href = shift;
 275
 276     return '{ ' .
 277            join(q{, }, map("$_ => $href->{$_}", keys %$href))
 278            . ' }';
 279 }
 280
 281 # Set up a complex relation based on a hashref condition
 282 sub _make_cond_rel {
 283     my ( $self, $table, $other, $cond ) = @_;
 284
 285     my $table_class = $self->classes->{$table};
 286     my $other_class = $self->classes->{$other};
 287     my $table_relname = $self->_inflect_relname(lc $table);
 288     my $other_relname = lc $other;
 289
 290     # for single-column case, set the relname to the column name,
 291     # to make filter accessors work
 292     if(scalar keys %$cond == 1) {
 293         my ($col) = keys %$cond;
 294         $other_relname = $cond->{$col};
 295     }
 296
 297     my $rev_cond = { reverse %$cond };
 298
 299     for (keys %$rev_cond) {
 300         $rev_cond->{"foreign.$_"} = "self.".$rev_cond->{$_};
 301         delete $rev_cond->{$_};
 302     }
 303
 304     my $cond_printable = _stringify_hash($cond)
 305         if $self->debug;
 306     my $rev_cond_printable = _stringify_hash($rev_cond)
 307         if $self->debug;
 308
 309     warn qq/\# Belongs_to relationship\n/ if $self->debug;
 310
 311     warn qq/$table_class->belongs_to( '$other_relname' => '$other_class',/
 312       .  qq/$cond_printable);\n\n/
 313       if $self->debug;
 314
 315     $table_class->belongs_to( $other_relname => $other_class, $cond);
 316
 317     warn qq/\# Has_many relationship\n/ if $self->debug;
 318
 319     warn qq/$other_class->has_many( '$table_relname' => '$table_class',/
 320       .  qq/$rev_cond_printable);\n\n/
 321       .  qq/);\n\n/
 322       if $self->debug;
 323
 324     $other_class->has_many( $table_relname => $table_class, $rev_cond);
 325 }
 326
 327 sub _use {
 328     my $self = shift;
 329     my $target = shift;
 330
 331     foreach (@_) {
 332         $_->require or croak ($_ . "->require: $@");
 333         eval "package $target; use $_;";
 334         croak "use $_: $@" if $@;
 335     }
 336 }
 337
 338 sub _inject {
 339     my $self = shift;
 340     my $target = shift;
 341     my $schema = $self->schema;
 342
 343     foreach (@_) {
 344         $_->require or croak ($_ . "->require: $@");
 345         $schema->inject_base($target, $_);
 346     }
 347 }
 348
 349 # Load and setup classes
 350 sub _load_classes {
 351     my $self = shift;
 352
 353     my @tables     = $self->_tables();
 354     my @db_classes = $self->_db_classes();
 355     my $schema     = $self->schema;
 356
 357     foreach my $table (@tables) {
 358         my $constraint = $self->constraint;
 359         my $exclude = $self->exclude;
 360
 361         next unless $table =~ /$constraint/;
 362         next if defined $exclude && $table =~ /$exclude/;
 363
 364         my ($db_schema, $tbl) = split /\./, $table;
 365         my $tablename = lc $table;
 366         if($tbl) {
 367             $tablename = $self->drop_db_schema ? $tbl : lc $table;
 368         }
 369         my $lc_tblname = lc $tablename;
 370
 371         my $table_moniker = $self->_table2moniker($db_schema, $tbl);
 372         my $table_class = $schema . q{::} . $table_moniker;
 373
 374         { no strict 'refs';
 375           @{"${table_class}::ISA"} = qw/DBIx::Class/;
 376         }
 377         $self->_use   ($table_class, @{$self->additional_classes});
 378         $self->_inject($table_class, @{$self->additional_base_classes});
 379         $table_class->load_components(@{$self->components}, @db_classes, 'Core');
 380         $table_class->load_resultset_components(@{$self->resultset_components})
 381             if @{$self->resultset_components};
 382         $self->_inject($table_class, @{$self->left_base_classes});
 383
 384         warn qq/\# Initializing table "$tablename" as "$table_class"\n/
 385             if $self->debug;
 386         $table_class->table($lc_tblname);
 387
 388         my ( $cols, $pks ) = $self->_table_info($table);
 389         carp("$table has no primary key") unless @$pks;
 390         $table_class->add_columns(@$cols);
 391         $table_class->set_primary_key(@$pks) if @$pks;
 392
 393         warn qq/$table_class->table('$tablename');\n/ if $self->debug;
 394         my $columns = join "', '", @$cols;
 395         warn qq/$table_class->add_columns('$columns')\n/ if $self->debug;
 396         my $primaries = join "', '", @$pks;
 397         warn qq/$table_class->set_primary_key('$primaries')\n/
 398             if $self->debug && @$pks;
 399
 400         $table_class->require;
 401         if($@ && $@ !~ /^Can't locate /) {
 402             croak "Failed to load external class definition"
 403                   . "for '$table_class': $@";
 404         }
 405
 406         warn qq/# Loaded external class definition for '$table_class'\n/
 407             if $self->debug;
 408
 409         $schema->register_class($table_moniker, $table_class);
 410         $self->classes->{$lc_tblname} = $table_class;
 411         $self->monikers->{$lc_tblname} = $table_moniker;
 412     }
 413 }
 414
 415 =head2 tables
 416
 417 Returns a sorted list of loaded tables, using the original database table
 418 names.  Actually generated from the keys of the C<monikers> hash below.
 419
 420   my @tables = $schema->loader->tables;
 421
 422 =cut
 423
 424 sub tables {
 425     my $self = shift;
 426
 427     return sort keys %{ $self->monikers };
 428 }
 429
 430 # Find and setup relationships
 431 sub _load_relationships {
 432     my $self = shift;
 433
 434     my $dbh = $self->schema->storage->dbh;
 435     my $quoter = $dbh->get_info(29) || q{"};
 436     foreach my $table ( $self->tables ) {
 437         my $rels = {};
 438         my $sth = $dbh->foreign_key_info( '',
 439             $self->db_schema, '', '', '', $table );
 440         next if !$sth;
 441         while(my $raw_rel = $sth->fetchrow_hashref) {
 442             my $uk_tbl  = lc $raw_rel->{UK_TABLE_NAME};
 443             my $uk_col  = lc $raw_rel->{UK_COLUMN_NAME};
 444             my $fk_col  = lc $raw_rel->{FK_COLUMN_NAME};
 445             my $relid   = lc $raw_rel->{UK_NAME};
 446             $uk_tbl =~ s/$quoter//g;
 447             $uk_col =~ s/$quoter//g;
 448             $fk_col =~ s/$quoter//g;
 449             $relid  =~ s/$quoter//g;
 450             $rels->{$relid}->{tbl} = $uk_tbl;
 451             $rels->{$relid}->{cols}->{$uk_col} = $fk_col;
 452         }
 453
 454         foreach my $relid (keys %$rels) {
 455             my $reltbl = $rels->{$relid}->{tbl};
 456             my $cond   = $rels->{$relid}->{cols};
 457             eval { $self->_make_cond_rel( $table, $reltbl, $cond ) };
 458               warn qq/\# belongs_to_many failed "$@"\n\n/
 459                 if $@ && $self->debug;
 460         }
 461     }
 462 }
 463
 464 # Make a moniker from a table
 465 sub _table2moniker {
 466     my ( $self, $db_schema, $table ) = @_;
 467
 468     my $db_schema_ns;
 469
 470     if($table) {
 471         $db_schema = ucfirst lc $db_schema;
 472         $db_schema_ns = $db_schema if(!$self->drop_db_schema);
 473     } else {
 474         $table = $db_schema;
 475     }
 476
 477     my $moniker;
 478
 479     if( ref $self->moniker_map eq 'HASH' ) {
 480         $moniker = $self->moniker_map->{$table};
 481     }
 482     elsif( ref $self->moniker_map eq 'CODE' ) {
 483         $moniker = $self->moniker_map->($table);
 484     }
 485
 486     $moniker ||= join '', map ucfirst, split /[\W_]+/, lc $table;
 487
 488     $moniker = $db_schema_ns ? $db_schema_ns . $moniker : $moniker;
 489
 490     return $moniker;
 491 }
 492
 493 # Overload in driver class
 494 sub _tables { croak "ABSTRACT METHOD" }
 495
 496 sub _table_info { croak "ABSTRACT METHOD" }
 497
 498 =head2 monikers
 499
 500 Returns a hashref of loaded table-to-moniker mappings for the original
 501 database table names.
 502
 503   my $monikers = $schema->loader->monikers;
 504   my $foo_tbl_moniker = $monikers->{foo_tbl};
 505   # -or-
 506   my $foo_tbl_moniker = $schema->loader->monikers->{foo_tbl};
 507   # $foo_tbl_moniker would look like "FooTbl"
 508
 509 =head2 classes
 510
 511 Returns a hashref of table-to-classname mappings for the original database
 512 table names.  You probably shouldn't be using this for any normal or simple
 513 usage of your Schema.  The usual way to run queries on your tables is via
 514 C<$schema-E<gt>resultset('FooTbl')>, where C<FooTbl> is a moniker as
 515 returned by C<monikers> above.
 516
 517   my $classes = $schema->loader->classes;
 518   my $foo_tbl_class = $classes->{foo_tbl};
 519   # -or-
 520   my $foo_tbl_class = $schema->loader->classes->{foo_tbl};
 521   # $foo_tbl_class would look like "My::Schema::FooTbl",
 522   #   assuming the schema class is "My::Schema"
 523
 524 =head1 SEE ALSO
 525
 526 L<DBIx::Class::Schema::Loader>
 527
 528 =cut
 529
 530 1;