lib/DBIx/Class/Schema/Loader/Generic.pm

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