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 for any normal or simple
 343 usage of your Schema.  The usual way to run queries on your tables is via
 344 C<$schema-E<gt>resultset('FooTbl')>, where C<FooTbl> is a moniker as
 345 returned by C<monikers> above.
 346
 347     my $classes = $schema->loader->classes;
 348     my $foo_tbl_class = $classes->{foo_tbl};
 349     # -or-
 350     my $foo_tbl_class = $schema->loader->classes->{foo_tbl};
 351     # $foo_tbl_class would look like "My::Schema::FooTbl",
 352     #   assuming the schema class is "My::Schema"
 353
 354 =cut
 355
 356 sub tables {
 357     my $self = shift;
 358
 359     return sort keys %{ $self->monikers };
 360 }
 361
 362 # Find and setup relationships
 363 sub _load_relationships {
 364     my $self = shift;
 365
 366     my $dbh = $self->schema->storage->dbh;
 367     my $quoter = $dbh->get_info(29) || q{"};
 368     foreach my $table ( $self->tables ) {
 369         my $rels = {};
 370         my $sth = $dbh->foreign_key_info( '',
 371             $self->db_schema, '', '', '', $table );
 372         next if !$sth;
 373         while(my $raw_rel = $sth->fetchrow_hashref) {
 374             my $uk_tbl  = lc $raw_rel->{UK_TABLE_NAME};
 375             my $uk_col  = lc $raw_rel->{UK_COLUMN_NAME};
 376             my $fk_col  = lc $raw_rel->{FK_COLUMN_NAME};
 377             my $relid   = lc $raw_rel->{UK_NAME};
 378             $uk_tbl =~ s/$quoter//g;
 379             $uk_col =~ s/$quoter//g;
 380             $fk_col =~ s/$quoter//g;
 381             $relid  =~ s/$quoter//g;
 382             $rels->{$relid}->{tbl} = $uk_tbl;
 383             $rels->{$relid}->{cols}->{$uk_col} = $fk_col;
 384         }
 385
 386         foreach my $relid (keys %$rels) {
 387             my $reltbl = $rels->{$relid}->{tbl};
 388             my $cond   = $rels->{$relid}->{cols};
 389             eval { $self->_make_cond_rel( $table, $reltbl, $cond ) };
 390               warn qq/\# belongs_to_many failed "$@"\n\n/
 391                 if $@ && $self->debug;
 392         }
 393     }
 394 }
 395
 396 # Make a moniker from a table
 397 sub _table2moniker {
 398     my ( $self, $db_schema, $table ) = @_;
 399
 400     my $db_schema_ns;
 401
 402     if($table) {
 403         $db_schema = ucfirst lc $db_schema;
 404         $db_schema_ns = $db_schema if(!$self->drop_db_schema);
 405     } else {
 406         $table = $db_schema;
 407     }
 408
 409     my $moniker = join '', map ucfirst, split /[\W_]+/, lc $table;
 410     $moniker = $db_schema_ns ? $db_schema_ns . $moniker : $moniker;
 411
 412     return $moniker;
 413 }
 414
 415 # Overload in driver class
 416 sub _tables { croak "ABSTRACT METHOD" }
 417
 418 sub _table_info { croak "ABSTRACT METHOD" }
 419
 420 =head1 SEE ALSO
 421
 422 L<DBIx::Class::Schema::Loader>
 423
 424 =cut
 425
 426 1;