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

   1 package DBIx::Class::Schema::Loader::Generic;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/DBIx::Class::Schema/;
   7
   8 use Carp;
   9 use Lingua::EN::Inflect;
  10
  11 require DBIx::Class::Core;
  12
  13 __PACKAGE__->mk_classdata('loader_data');
  14
  15 # XXX convert all usage of $class/$self->debug to ->debug_loader
  16
  17 =head1 NAME
  18
  19 DBIx::Class::Schema::Loader::Generic - Generic DBIx::Class::Schema::Loader Implementation.
  20
  21 =head1 SYNOPSIS
  22
  23 See L<DBIx::Class::Schema::Loader>
  24
  25 =head1 DESCRIPTION
  26
  27 =head2 OPTIONS
  28
  29 Available constructor options are:
  30
  31 =head3 additional_base_classes
  32
  33 List of additional base classes your table classes will use.
  34
  35 =head3 left_base_classes
  36
  37 List of additional base classes, that need to be leftmost.
  38
  39 =head3 additional_classes
  40
  41 List of additional classes which your table classes will use.
  42
  43 =head3 constraint
  44
  45 Only load tables matching regex.
  46
  47 =head3 exclude
  48
  49 Exclude tables matching regex.
  50
  51 =head3 debug
  52
  53 Enable debug messages.
  54
  55 =head3 dsn
  56
  57 DBI Data Source Name.
  58
  59 =head3 namespace
  60
  61 Namespace under which your table classes will be initialized.
  62
  63 =head3 password
  64
  65 Password.
  66
  67 =head3 relationships
  68
  69 Try to automatically detect/setup has_a and has_many relationships.
  70
  71 =head3 inflect
  72
  73 An hashref, which contains exceptions to Lingua::EN::Inflect::PL().
  74 Useful for foreign language column names.
  75
  76 =head3 user
  77
  78 Username.
  79
  80 =head2 METHODS
  81
  82 =cut
  83
  84 =head3 new
  85
  86 Not intended to be called directly.  This is used internally by the
  87 C<new()> method in L<DBIx::Class::Schema::Loader>.
  88
  89 =cut
  90
  91 sub _load_from_connection {
  92     my ( $class, %args ) = @_;
  93     if ( $args{debug} ) {
  94         no strict 'refs';
  95         *{"$class\::debug_loader"} = sub { 1 };
  96     }
  97     my $additional = $args{additional_classes} || [];
  98     $additional = [$additional] unless ref $additional eq 'ARRAY';
  99     my $additional_base = $args{additional_base_classes} || [];
 100     $additional_base = [$additional_base]
 101       unless ref $additional_base eq 'ARRAY';
 102     my $left_base = $args{left_base_classes} || [];
 103     $left_base = [$left_base] unless ref $left_base eq 'ARRAY';
 104     $class->loader_data({
 105         _datasource =>
 106           [ $args{dsn}, $args{user}, $args{password}, $args{options} ],
 107         _namespace       => $args{namespace} || $class,
 108         _additional      => $additional,
 109         _additional_base => $additional_base,
 110         _left_base       => $left_base,
 111         _constraint      => $args{constraint} || '.*',
 112         _exclude         => $args{exclude},
 113         _relationships   => $args{relationships},
 114         _inflect         => $args{inflect},
 115         _db_schema       => $args{db_schema},
 116         _drop_db_schema  => $args{drop_db_schema},
 117         TABLE_CLASSES    => {},
 118         MONIKERS         => {},
 119     });
 120
 121     $class->connection(@{$class->loader_data->{_datasource}});
 122     warn qq/\### START DBIx::Class::Schema::Loader dump ###\n/ if $class->debug;
 123     $class->_load_classes;
 124     $class->_relationships                            if $class->loader_data->{_relationships};
 125     warn qq/\### END DBIx::Class::Schema::Loader dump ###\n/ if $class->debug;
 126     $class->storage->dbh->disconnect; # XXX this should be ->storage->disconnect later?
 127
 128     1;
 129 }
 130
 131 # The original table class name during Loader,
 132 sub _find_table_class {
 133     my ( $class, $table ) = @_;
 134     return $class->loader_data->{TABLE_CLASSES}->{$table};
 135 }
 136
 137 # Returns the moniker for a given table name,
 138 # for use in $conn->resultset($moniker)
 139 sub moniker {
 140     my ( $class, $table ) = @_;
 141     return $class->loader_data->{MONIKERS}->{$table};
 142 }
 143
 144 =head3 debug
 145
 146 Overload to enable debug messages.
 147
 148 =cut
 149
 150 sub debug { 0 }
 151
 152 =head3 tables
 153
 154 Returns a sorted list of tables.
 155
 156     my @tables = $loader->tables;
 157
 158 =cut
 159
 160 sub tables {
 161     my $class = shift;
 162     return sort keys %{ $class->loader_data->{MONIKERS} };
 163 }
 164
 165 # Overload in your driver class
 166 sub _db_classes { croak "ABSTRACT METHOD" }
 167
 168 # Setup has_a and has_many relationships
 169 sub _belongs_to_many {
 170     my ( $class, $table, $column, $other, $other_column ) = @_;
 171     my $table_class = $class->_find_table_class($table);
 172     my $other_class = $class->_find_table_class($other);
 173
 174     warn qq/\# Belongs_to relationship\n/ if $class->debug;
 175
 176     if($other_column) {
 177         warn qq/$table_class->belongs_to( '$column' => '$other_class',/
 178           .  qq/ { "foreign.$other_column" => "self.$column" },/
 179           .  qq/ { accessor => 'filter' });\n\n/
 180           if $class->debug;
 181         $table_class->belongs_to( $column => $other_class,
 182           { "foreign.$other_column" => "self.$column" },
 183           { accessor => 'filter' }
 184         );
 185     }
 186     else {
 187         warn qq/$table_class->belongs_to( '$column' => '$other_class' );\n\n/
 188           if $class->debug;
 189         $table_class->belongs_to( $column => $other_class );
 190     }
 191
 192     my ($table_class_base) = $table_class =~ /.*::(.+)/;
 193     my $plural = Lingua::EN::Inflect::PL( lc $table_class_base );
 194     $plural = $class->loader_data->{_inflect}->{ lc $table_class_base }
 195       if $class->loader_data->{_inflect}
 196       and exists $class->loader_data->{_inflect}->{ lc $table_class_base };
 197
 198     warn qq/\# Has_many relationship\n/ if $class->debug;
 199
 200     if($other_column) {
 201         warn qq/$other_class->has_many( '$plural' => '$table_class',/
 202           .  qq/ { "foreign.$column" => "self.$other_column" } );\n\n/
 203           if $class->debug;
 204         $other_class->has_many( $plural => $table_class,
 205                                 { "foreign.$column" => "self.$other_column" }
 206                               );
 207     }
 208     else {
 209         warn qq/$other_class->has_many( '$plural' => '$table_class',/
 210           .  qq/'$other_column' );\n\n/
 211           if $class->debug;
 212         $other_class->has_many( $plural => $table_class, $column );
 213     }
 214 }
 215
 216 # Load and setup classes
 217 sub _load_classes {
 218     my $class = shift;
 219
 220     my $namespace    = $class->loader_data->{_namespace};
 221
 222     my @tables          = $class->_tables();
 223     my @db_classes      = $class->_db_classes();
 224     my $additional      = join '', map "use $_;\n", @{ $class->loader_data->{_additional} };
 225     my $additional_base = join '', map "use base '$_';\n",
 226       @{ $class->loader_data->{_additional_base} };
 227     my $left_base  = join '', map "use base '$_';\n", @{ $class->loader_data->{_left_base} };
 228     my $constraint = $class->loader_data->{_constraint};
 229     my $exclude    = $class->loader_data->{_exclude};
 230
 231     foreach my $table (@tables) {
 232         next unless $table =~ /$constraint/;
 233         next if ( defined $exclude && $table =~ /$exclude/ );
 234
 235         my $table = lc $table;
 236         my $table_name_db_schema = $table;
 237         my $table_name_only = $table_name_db_schema;
 238         my ($db_schema, $tbl) = split /\./, $table;
 239         if($tbl) {
 240             $table_name_db_schema = $tbl if $class->loader_data->{_drop_db_schema};
 241             $table_name_only = $tbl;
 242         }
 243         else {
 244             undef $db_schema;
 245         }
 246
 247         my $table_subclass = $class->_table2subclass($db_schema, $table_name_only);
 248         my $table_class = $namespace . '::' . $table_subclass;
 249
 250         $class->inject_base( $table_class, 'DBIx::Class::Core' );
 251         $_->require for @db_classes;
 252         $class->inject_base( $table_class, $_ ) for @db_classes;
 253         warn qq/\# Initializing table "$table_name_db_schema" as "$table_class"\n/ if $class->debug;
 254         $table_class->table(lc $table_name_db_schema);
 255
 256         my ( $cols, $pks ) = $class->_table_info($table_name_db_schema);
 257         carp("$table has no primary key") unless @$pks;
 258         $table_class->add_columns(@$cols);
 259         $table_class->set_primary_key(@$pks) if @$pks;
 260
 261         my $code = "package $table_class;\n$additional_base$additional$left_base";
 262         warn qq/$code/                        if $class->debug;
 263         warn qq/$table_class->table('$table_name_db_schema');\n/ if $class->debug;
 264         my $columns = join "', '", @$cols;
 265         warn qq/$table_class->add_columns('$columns')\n/ if $class->debug;
 266         my $primaries = join "', '", @$pks;
 267         warn qq/$table_class->set_primary_key('$primaries')\n/ if $class->debug && @$pks;
 268         eval $code;
 269         croak qq/Couldn't load additional classes "$@"/ if $@;
 270         unshift @{"$table_class\::ISA"}, $_ foreach ( @{ $class->loader_data->{_left_base} } );
 271
 272         $class->register_class($table_subclass, $table_class);
 273         $class->loader_data->{TABLE_CLASSES}->{$table_name_db_schema} = $table_class;
 274         $class->loader_data->{MONIKERS}->{$table_name_db_schema} = $table_subclass;
 275     }
 276 }
 277
 278 # Find and setup relationships
 279 sub _relationships {
 280     my $class = shift;
 281     my $dbh = $class->storage->dbh;
 282     foreach my $table ( $class->tables ) {
 283         my $quoter = $dbh->get_info(29) || q{"};
 284         if ( my $sth = $dbh->foreign_key_info( '', '', '', '', '', $table ) ) {
 285             for my $res ( @{ $sth->fetchall_arrayref( {} ) } ) {
 286                 my $column = $res->{FK_COLUMN_NAME};
 287                 my $other  = $res->{UK_TABLE_NAME};
 288                 my $other_column  = $res->{UK_COLUMN_NAME};
 289                 $column =~ s/$quoter//g;
 290                 $other =~ s/$quoter//g;
 291                 $other_column =~ s/$quoter//g;
 292                 eval { $class->_belongs_to_many( $table, $column, $other,
 293                   $other_column ) };
 294                 warn qq/\# belongs_to_many failed "$@"\n\n/
 295                   if $@ && $class->debug;
 296             }
 297         }
 298     }
 299 }
 300
 301 # Make a subclass (dbix moniker) from a table
 302 sub _table2subclass {
 303     my ( $class, $db_schema, $table ) = @_;
 304
 305     my $table_subclass = join '', map ucfirst, split /[\W_]+/, $table;
 306
 307     if($db_schema && !$class->loader_data->{_drop_db_schema}) {
 308         $table_subclass = (ucfirst lc $db_schema) . '-' . $table_subclass;
 309     }
 310
 311     $table_subclass;
 312 }
 313
 314 # Overload in driver class
 315 sub _tables { croak "ABSTRACT METHOD" }
 316
 317 sub _table_info { croak "ABSTRACT METHOD" }
 318
 319 =head1 SEE ALSO
 320
 321 L<DBIx::Class::Schema::Loader>
 322
 323 =cut
 324
 325 1;