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