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