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