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

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