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     for (keys %$rev_cond) {
 227         $rev_cond->{"foreign.$_"} = "self.".$rev_cond->{$_};
 228         delete $rev_cond->{$_};
 229     }
 230
 231     my $cond_printable = _stringify_hash($cond)
 232         if $self->debug;
 233     my $rev_cond_printable = _stringify_hash($rev_cond)
 234         if $self->debug;
 235
 236     warn qq/\# Belongs_to relationship\n/ if $self->debug;
 237
 238     warn qq/$table_class->belongs_to( '$other_relname' => '$other_class',/
 239       .  qq/$cond_printable);\n\n/
 240       if $self->debug;
 241
 242     $table_class->belongs_to( $other_relname => $other_class, $cond);
 243
 244     warn qq/\# Has_many relationship\n/ if $self->debug;
 245
 246     warn qq/$other_class->has_many( '$table_relname' => '$table_class',/
 247       .  qq/$rev_cond_printable);\n\n/
 248       .  qq/);\n\n/
 249       if $self->debug;
 250
 251     $other_class->has_many( $table_relname => $table_class, $rev_cond);
 252 }
 253
 254 sub _use {
 255     my $self = shift;
 256     my $target = shift;
 257
 258     foreach (@_) {
 259         $_->require or croak ($_ . "->require: $@");
 260         eval "package $target; use $_;";
 261         croak "use $_: $@" if $@;
 262     }
 263 }
 264
 265 sub _inject {
 266     my $self = shift;
 267     my $target = shift;
 268     my $schema = $self->schema;
 269
 270     foreach (@_) {
 271         $_->require or croak ($_ . "->require: $@");
 272         $schema->inject_base($target, $_);
 273     }
 274 }
 275
 276 # Load and setup classes
 277 sub _load_classes {
 278     my $self = shift;
 279
 280     my @tables     = $self->_tables();
 281     my @db_classes = $self->_db_classes();
 282     my $schema     = $self->schema;
 283
 284     foreach my $table (@tables) {
 285         my $constraint = $self->constraint;
 286         my $exclude = $self->exclude;
 287
 288         next unless $table =~ /$constraint/;
 289         next if defined $exclude && $table =~ /$exclude/;
 290
 291         my ($db_schema, $tbl) = split /\./, $table;
 292         my $tablename = lc $table;
 293         if($tbl) {
 294             $tablename = $self->drop_db_schema ? $tbl : lc $table;
 295         }
 296         my $lc_tblname = lc $tablename;
 297
 298         my $table_moniker = $self->_table2moniker($db_schema, $tbl);
 299         my $table_class = $schema . q{::} . $table_moniker;
 300
 301         $self->_inject($table_class, 'DBIx::Class::Core');
 302         $self->_inject($table_class, @db_classes);
 303         $self->_inject($table_class, @{$self->additional_base_classes});
 304         $self->_use   ($table_class, @{$self->additional_classes});
 305         $self->_inject($table_class, @{$self->left_base_classes});
 306
 307         warn qq/\# Initializing table "$tablename" as "$table_class"\n/
 308             if $self->debug;
 309         $table_class->table($lc_tblname);
 310
 311         my ( $cols, $pks ) = $self->_table_info($table);
 312         carp("$table has no primary key") unless @$pks;
 313         $table_class->add_columns(@$cols);
 314         $table_class->set_primary_key(@$pks) if @$pks;
 315
 316         warn qq/$table_class->table('$tablename');\n/ if $self->debug;
 317         my $columns = join "', '", @$cols;
 318         warn qq/$table_class->add_columns('$columns')\n/ if $self->debug;
 319         my $primaries = join "', '", @$pks;
 320         warn qq/$table_class->set_primary_key('$primaries')\n/
 321             if $self->debug && @$pks;
 322
 323         $schema->register_class($table_moniker, $table_class);
 324         $self->classes->{$lc_tblname} = $table_class;
 325         $self->monikers->{$lc_tblname} = $table_moniker;
 326     }
 327 }
 328
 329 =head2 tables
 330
 331 Returns a sorted list of loaded tables, using the original database table
 332 names.  Actually generated from the keys of the C<monikers> hash below.
 333
 334   my @tables = $schema->loader->tables;
 335
 336 =cut
 337
 338 sub tables {
 339     my $self = shift;
 340
 341     return sort keys %{ $self->monikers };
 342 }
 343
 344 # Find and setup relationships
 345 sub _load_relationships {
 346     my $self = shift;
 347
 348     my $dbh = $self->schema->storage->dbh;
 349     my $quoter = $dbh->get_info(29) || q{"};
 350     foreach my $table ( $self->tables ) {
 351         my $rels = {};
 352         my $sth = $dbh->foreign_key_info( '',
 353             $self->db_schema, '', '', '', $table );
 354         next if !$sth;
 355         while(my $raw_rel = $sth->fetchrow_hashref) {
 356             my $uk_tbl  = lc $raw_rel->{UK_TABLE_NAME};
 357             my $uk_col  = lc $raw_rel->{UK_COLUMN_NAME};
 358             my $fk_col  = lc $raw_rel->{FK_COLUMN_NAME};
 359             my $relid   = lc $raw_rel->{UK_NAME};
 360             $uk_tbl =~ s/$quoter//g;
 361             $uk_col =~ s/$quoter//g;
 362             $fk_col =~ s/$quoter//g;
 363             $relid  =~ s/$quoter//g;
 364             $rels->{$relid}->{tbl} = $uk_tbl;
 365             $rels->{$relid}->{cols}->{$uk_col} = $fk_col;
 366         }
 367
 368         foreach my $relid (keys %$rels) {
 369             my $reltbl = $rels->{$relid}->{tbl};
 370             my $cond   = $rels->{$relid}->{cols};
 371             eval { $self->_make_cond_rel( $table, $reltbl, $cond ) };
 372               warn qq/\# belongs_to_many failed "$@"\n\n/
 373                 if $@ && $self->debug;
 374         }
 375     }
 376 }
 377
 378 # Make a moniker from a table
 379 sub _table2moniker {
 380     my ( $self, $db_schema, $table ) = @_;
 381
 382     my $db_schema_ns;
 383
 384     if($table) {
 385         $db_schema = ucfirst lc $db_schema;
 386         $db_schema_ns = $db_schema if(!$self->drop_db_schema);
 387     } else {
 388         $table = $db_schema;
 389     }
 390
 391     my $moniker = join '', map ucfirst, split /[\W_]+/, lc $table;
 392     $moniker = $db_schema_ns ? $db_schema_ns . $moniker : $moniker;
 393
 394     return $moniker;
 395 }
 396
 397 # Overload in driver class
 398 sub _tables { croak "ABSTRACT METHOD" }
 399
 400 sub _table_info { croak "ABSTRACT METHOD" }
 401
 402 =head2 monikers
 403
 404 Returns a hashref of loaded table-to-moniker mappings for the original
 405 database table names.
 406
 407   my $monikers = $schema->loader->monikers;
 408   my $foo_tbl_moniker = $monikers->{foo_tbl};
 409   # -or-
 410   my $foo_tbl_moniker = $schema->loader->monikers->{foo_tbl};
 411   # $foo_tbl_moniker would look like "FooTbl"
 412
 413 =head2 classes
 414
 415 Returns a hashref of table-to-classname mappings for the original database
 416 table names.  You probably shouldn't be using this for any normal or simple
 417 usage of your Schema.  The usual way to run queries on your tables is via
 418 C<$schema-E<gt>resultset('FooTbl')>, where C<FooTbl> is a moniker as
 419 returned by C<monikers> above.
 420
 421   my $classes = $schema->loader->classes;
 422   my $foo_tbl_class = $classes->{foo_tbl};
 423   # -or-
 424   my $foo_tbl_class = $schema->loader->classes->{foo_tbl};
 425   # $foo_tbl_class would look like "My::Schema::FooTbl",
 426   #   assuming the schema class is "My::Schema"
 427
 428 =head1 SEE ALSO
 429
 430 L<DBIx::Class::Schema::Loader>
 431
 432 =cut
 433
 434 1;