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

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