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

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