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         $self->_inject($table_class, 'DBIx::Class::Core');
 321         $self->_inject($table_class, @db_classes);
 322         $self->_inject($table_class, @{$self->additional_base_classes});
 323         $self->_use   ($table_class, @{$self->additional_classes});
 324         $self->_inject($table_class, @{$self->left_base_classes});
 325         $table_class->load_components(@{$self->components});
 326         $table_class->load_resultset_components(@{$self->resultset_components})
 327             if @{$self->resultset_components};
 328
 329         warn qq/\# Initializing table "$tablename" as "$table_class"\n/
 330             if $self->debug;
 331         $table_class->table($lc_tblname);
 332
 333         my ( $cols, $pks ) = $self->_table_info($table);
 334         carp("$table has no primary key") unless @$pks;
 335         $table_class->add_columns(@$cols);
 336         $table_class->set_primary_key(@$pks) if @$pks;
 337
 338         warn qq/$table_class->table('$tablename');\n/ if $self->debug;
 339         my $columns = join "', '", @$cols;
 340         warn qq/$table_class->add_columns('$columns')\n/ if $self->debug;
 341         my $primaries = join "', '", @$pks;
 342         warn qq/$table_class->set_primary_key('$primaries')\n/
 343             if $self->debug && @$pks;
 344
 345         $table_class->require;
 346         if($@ && $@ !~ /^Can't locate /) {
 347             croak "Failed to load external class definition"
 348                   . "for '$table_class': $@";
 349         }
 350
 351         warn qq/# Loaded external class definition for '$table_class'\n/
 352             if $self->debug;
 353
 354         $schema->register_class($table_moniker, $table_class);
 355         $self->classes->{$lc_tblname} = $table_class;
 356         $self->monikers->{$lc_tblname} = $table_moniker;
 357     }
 358 }
 359
 360 =head2 tables
 361
 362 Returns a sorted list of loaded tables, using the original database table
 363 names.  Actually generated from the keys of the C<monikers> hash below.
 364
 365   my @tables = $schema->loader->tables;
 366
 367 =cut
 368
 369 sub tables {
 370     my $self = shift;
 371
 372     return sort keys %{ $self->monikers };
 373 }
 374
 375 # Find and setup relationships
 376 sub _load_relationships {
 377     my $self = shift;
 378
 379     my $dbh = $self->schema->storage->dbh;
 380     my $quoter = $dbh->get_info(29) || q{"};
 381     foreach my $table ( $self->tables ) {
 382         my $rels = {};
 383         my $sth = $dbh->foreign_key_info( '',
 384             $self->db_schema, '', '', '', $table );
 385         next if !$sth;
 386         while(my $raw_rel = $sth->fetchrow_hashref) {
 387             my $uk_tbl  = lc $raw_rel->{UK_TABLE_NAME};
 388             my $uk_col  = lc $raw_rel->{UK_COLUMN_NAME};
 389             my $fk_col  = lc $raw_rel->{FK_COLUMN_NAME};
 390             my $relid   = lc $raw_rel->{UK_NAME};
 391             $uk_tbl =~ s/$quoter//g;
 392             $uk_col =~ s/$quoter//g;
 393             $fk_col =~ s/$quoter//g;
 394             $relid  =~ s/$quoter//g;
 395             $rels->{$relid}->{tbl} = $uk_tbl;
 396             $rels->{$relid}->{cols}->{$uk_col} = $fk_col;
 397         }
 398
 399         foreach my $relid (keys %$rels) {
 400             my $reltbl = $rels->{$relid}->{tbl};
 401             my $cond   = $rels->{$relid}->{cols};
 402             eval { $self->_make_cond_rel( $table, $reltbl, $cond ) };
 403               warn qq/\# belongs_to_many failed "$@"\n\n/
 404                 if $@ && $self->debug;
 405         }
 406     }
 407 }
 408
 409 # Make a moniker from a table
 410 sub _table2moniker {
 411     my ( $self, $db_schema, $table ) = @_;
 412
 413     my $db_schema_ns;
 414
 415     if($table) {
 416         $db_schema = ucfirst lc $db_schema;
 417         $db_schema_ns = $db_schema if(!$self->drop_db_schema);
 418     } else {
 419         $table = $db_schema;
 420     }
 421
 422     my $moniker = join '', map ucfirst, split /[\W_]+/, lc $table;
 423     $moniker = $db_schema_ns ? $db_schema_ns . $moniker : $moniker;
 424
 425     return $moniker;
 426 }
 427
 428 # Overload in driver class
 429 sub _tables { croak "ABSTRACT METHOD" }
 430
 431 sub _table_info { croak "ABSTRACT METHOD" }
 432
 433 =head2 monikers
 434
 435 Returns a hashref of loaded table-to-moniker mappings for the original
 436 database table names.
 437
 438   my $monikers = $schema->loader->monikers;
 439   my $foo_tbl_moniker = $monikers->{foo_tbl};
 440   # -or-
 441   my $foo_tbl_moniker = $schema->loader->monikers->{foo_tbl};
 442   # $foo_tbl_moniker would look like "FooTbl"
 443
 444 =head2 classes
 445
 446 Returns a hashref of table-to-classname mappings for the original database
 447 table names.  You probably shouldn't be using this for any normal or simple
 448 usage of your Schema.  The usual way to run queries on your tables is via
 449 C<$schema-E<gt>resultset('FooTbl')>, where C<FooTbl> is a moniker as
 450 returned by C<monikers> above.
 451
 452   my $classes = $schema->loader->classes;
 453   my $foo_tbl_class = $classes->{foo_tbl};
 454   # -or-
 455   my $foo_tbl_class = $schema->loader->classes->{foo_tbl};
 456   # $foo_tbl_class would look like "My::Schema::FooTbl",
 457   #   assuming the schema class is "My::Schema"
 458
 459 =head1 SEE ALSO
 460
 461 L<DBIx::Class::Schema::Loader>
 462
 463 =cut
 464
 465 1;