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