[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / Generic.pm

package DBIx::Class::Schema::Loader::Generic;

use strict;
use base 'DBIx::Class::Componentised';
use Carp;
use Lingua::EN::Inflect;
use UNIVERSAL::require;
use DBIx::Class::Storage::DBI;
require DBIx::Class::Core;
require DBIx::Class::Schema;

=head1 NAME

DBIx::Class::Schema::Loader::Generic - Generic DBIx::Class::Schema::Loader Implementation.

=head1 SYNOPSIS

See L<DBIx::Class::Schema::Loader>

=head1 DESCRIPTION

=head2 OPTIONS

Available constructor options are:

=head3 additional_base_classes

List of additional base classes your table classes will use.

=head3 left_base_classes

List of additional base classes, that need to be leftmost.

=head3 additional_classes

List of additional classes which your table classes will use.

=head3 constraint

Only load tables matching regex.

=head3 exclude

Exclude tables matching regex.

=head3 debug

Enable debug messages.

=head3 dsn

DBI Data Source Name.

=head3 namespace

Namespace under which your table classes will be initialized.

=head3 password

Password.

=head3 relationships

Try to automatically detect/setup has_a and has_many relationships.

=head3 inflect

An hashref, which contains exceptions to Lingua::EN::Inflect::PL().
Useful for foreign language column names.

=head3 user

Username.

=head2 METHODS

=cut

=head3 new

Not intended to be called directly.  This is used internally by the
C<new()> method in L<DBIx::Class::Schema::Loader>.

=cut

sub new {
    my ( $class, %args ) = @_;
    if ( $args{debug} ) {
        no strict 'refs';
        *{"$class\::debug"} = sub { 1 };
    }
    my $additional = $args{additional_classes} || [];
    $additional = [$additional] unless ref $additional eq 'ARRAY';
    my $additional_base = $args{additional_base_classes} || [];
    $additional_base = [$additional_base]
      unless ref $additional_base eq 'ARRAY';
    my $left_base = $args{left_base_classes} || [];
    $left_base = [$left_base] unless ref $left_base eq 'ARRAY';
    my $self = bless {
        _datasource =>
          [ $args{dsn}, $args{user}, $args{password}, $args{options} ],
        _namespace       => $args{namespace},
        _additional      => $additional,
        _additional_base => $additional_base,
        _left_base       => $left_base,
        _constraint      => $args{constraint} || '.*',
        _exclude         => $args{exclude},
        _relationships   => $args{relationships},
        _inflect         => $args{inflect},
        _db_schema       => $args{schema},
        _drop_db_schema  => $args{dropschema},
        _schema_class    => "$args{namespace}\::_schema",
        TABLE_CLASSES    => {},
        MONIKERS         => {},
    }, $class;
    warn qq/\### START DBIx::Class::Schema::Loader dump ###\n/ if $self->debug;
    $self->_load_classes;
    $self->_relationships                            if $self->{_relationships};
    warn qq/\### END DBIx::Class::Schema::Loader dump ###\n/ if $self->debug;
    $self->{_storage}->dbh->disconnect;
    $self;
}

# The original table class name during Loader,
sub _find_table_class {
    my ( $self, $table ) = @_;
    return $self->{TABLE_CLASSES}->{$table};
}

# Returns the moniker for a given table name,
# for use in $conn->resultset($moniker)
sub moniker {
    my ( $self, $table ) = @_;
    return $self->{MONIKERS}->{$table};
}

sub connect {
    my $self = shift;
    return $self->{_schema_class}->connect(@_) if(@_);
    return $self->{_schema_class}->connect(@{$self->{_datasource}});
}

=head3 debug

Overload to enable debug messages.

=cut

sub debug { 0 }

=head3 tables

Returns a sorted list of tables.

    my @tables = $loader->tables;

=cut

sub tables {
    my $self = shift;
    return sort keys %{ $self->{MONIKERS} };
}

# Overload in your driver class
sub _db_classes { croak "ABSTRACT METHOD" }

# Setup has_a and has_many relationships
sub _belongs_to_many {
    my ( $self, $table, $column, $other, $other_column ) = @_;
    my $table_class = $self->_find_table_class($table);
    my $other_class = $self->_find_table_class($other);

    warn qq/\# Belongs_to relationship\n/ if $self->debug;

    if($other_column) {
        warn qq/$table_class->belongs_to( '$column' => '$other_class',/
          .  qq/ { "foreign.$other_column" => "self.$column" },/
          .  qq/ { accessor => 'filter' });\n\n/
          if $self->debug;
        $table_class->belongs_to( $column => $other_class, 
          { "foreign.$other_column" => "self.$column" },
          { accessor => 'filter' }
        );
    }
    else {
        warn qq/$table_class->belongs_to( '$column' => '$other_class' );\n\n/
          if $self->debug;
        $table_class->belongs_to( $column => $other_class );
    }

    my ($table_class_base) = $table_class =~ /.*::(.+)/;
    my $plural = Lingua::EN::Inflect::PL( lc $table_class_base );
    $plural = $self->{_inflect}->{ lc $table_class_base }
      if $self->{_inflect}
      and exists $self->{_inflect}->{ lc $table_class_base };

    warn qq/\# Has_many relationship\n/ if $self->debug;

    if($other_column) {
        warn qq/$other_class->has_many( '$plural' => '$table_class',/
          .  qq/ { "foreign.$column" => "self.$other_column" } );\n\n/
          if $self->debug;
        $other_class->has_many( $plural => $table_class,
                                { "foreign.$column" => "self.$other_column" }
                              );
    }
    else {
        warn qq/$other_class->has_many( '$plural' => '$table_class',/
          .  qq/'$other_column' );\n\n/
          if $self->debug;
        $other_class->has_many( $plural => $table_class, $column );
    }
}

# Load and setup classes
sub _load_classes {
    my $self            = shift;

    my $namespace      = $self->{_namespace};
    my $schema_class   = $self->{_schema_class};
    $self->inject_base( $schema_class, 'DBIx::Class::Schema' );
    $self->{_storage} = $schema_class->storage(DBIx::Class::Storage::DBI->new());
    $schema_class->storage->connect_info($self->{_datasource});

    my @tables          = $self->_tables();
    my @db_classes      = $self->_db_classes();
    my $additional      = join '', map "use $_;\n", @{ $self->{_additional} };
    my $additional_base = join '', map "use base '$_';\n",
      @{ $self->{_additional_base} };
    my $left_base  = join '', map "use base '$_';\n", @{ $self->{_left_base} };
    my $constraint = $self->{_constraint};
    my $exclude    = $self->{_exclude};

    foreach my $table (@tables) {
        next unless $table =~ /$constraint/;
        next if ( defined $exclude && $table =~ /$exclude/ );

        my $table = lc $table;
        my $table_name_db_schema = $table;
        my $table_name_only = $table_name_db_schema;
        my ($db_schema, $tbl) = split /\./, $table;
        if($tbl) {
            $table_name_db_schema = $tbl if $self->{_drop_db_schema};
            $table_name_only = $tbl;
        }
        else {
            undef $db_schema;
        }

        my $subclass = $self->_table2subclass($db_schema, $table_name_only);
        my $class = $namespace . '::' . $subclass;

        $self->inject_base( $class, 'DBIx::Class::Core' );
        $_->require for @db_classes;
        $self->inject_base( $class, $_ ) for @db_classes;
        warn qq/\# Initializing table "$table_name_db_schema" as "$class"\n/ if $self->debug;
        $class->table(lc $table_name_db_schema);

        my ( $cols, $pks ) = $self->_table_info($table_name_db_schema);
        carp("$table has no primary key") unless @$pks;
        $class->add_columns(@$cols);
        $class->set_primary_key(@$pks) if @$pks;

        my $code = "package $class;\n$additional_base$additional$left_base";
        warn qq/$code/                        if $self->debug;
        warn qq/$class->table('$table_name_db_schema');\n/ if $self->debug;
        my $columns = join "', '", @$cols;
        warn qq/$class->add_columns('$columns')\n/ if $self->debug;
        my $primaries = join "', '", @$pks;
        warn qq/$class->set_primary_key('$primaries')\n/ if $self->debug && @$pks;
        eval $code;
        croak qq/Couldn't load additional classes "$@"/ if $@;
        unshift @{"$class\::ISA"}, $_ foreach ( @{ $self->{_left_base} } );

        $schema_class->register_class($subclass, $class);
        $self->{TABLE_CLASSES}->{$table_name_db_schema} = $class;
        $self->{MONIKERS}->{$table_name_db_schema} = $subclass;
    }
}

# Find and setup relationships
sub _relationships {
    my $self = shift;
    my $dbh = $self->{_storage}->dbh;
    foreach my $table ( $self->tables ) {
        my $quoter = $dbh->get_info(29) || q{"};
        if ( my $sth = $dbh->foreign_key_info( '', '', '', '', '', $table ) ) {
            for my $res ( @{ $sth->fetchall_arrayref( {} ) } ) {
                my $column = $res->{FK_COLUMN_NAME};
                my $other  = $res->{UK_TABLE_NAME};
                my $other_column  = $res->{UK_COLUMN_NAME};
                $column =~ s/$quoter//g;
                $other =~ s/$quoter//g;
                $other_column =~ s/$quoter//g;
                eval { $self->_belongs_to_many( $table, $column, $other,
                  $other_column ) };
                warn qq/\# belongs_to_many failed "$@"\n\n/
                  if $@ && $self->debug;
            }
        }
    }
}

# Make a subclass (dbix moniker) from a table
sub _table2subclass {
    my ( $self, $db_schema, $table ) = @_;

    my $subclass = join '', map ucfirst, split /[\W_]+/, $table;

    if($db_schema && !$self->{_drop_db_schema}) {
        $subclass = (ucfirst lc $db_schema) . '-' . $subclass;
    }

    $subclass;
}

# Overload in driver class
sub _tables { croak "ABSTRACT METHOD" }

sub _table_info { croak "ABSTRACT METHOD" }

=head1 SEE ALSO

L<DBIx::Class::Schema::Loader>

=cut

1;
Commit	Line	Data
18fca96a	1	package DBIx::Class::Schema::Loader::Generic;
a78e3fed	2
	3	use strict;
	4	use base 'DBIx::Class::Componentised';
	5	use Carp;
	6	use Lingua::EN::Inflect;
	7	use UNIVERSAL::require;
af6c2665	8	use DBIx::Class::Storage::DBI;
a78e3fed	9	require DBIx::Class::Core;
af6c2665	10	require DBIx::Class::Schema;
a78e3fed	11
	12	=head1 NAME
	13
18fca96a	14	DBIx::Class::Schema::Loader::Generic - Generic DBIx::Class::Schema::Loader Implementation.
a78e3fed	15
	16	=head1 SYNOPSIS
	17
18fca96a	18	See L<DBIx::Class::Schema::Loader>
a78e3fed	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
18fca96a	82	C<new()> method in L<DBIx::Class::Schema::Loader>.
a78e3fed	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},
af6c2665	110	_db_schema => $args{schema},
	111	_drop_db_schema => $args{dropschema},
	112	_schema_class => "$args{namespace}\::_schema",
	113	TABLE_CLASSES => {},
	114	MONIKERS => {},
a78e3fed	115	}, $class;
18fca96a	116	warn qq/\### START DBIx::Class::Schema::Loader dump ###\n/ if $self->debug;
a78e3fed	117	$self->_load_classes;
a78e3fed	118	$self->_relationships if $self->{_relationships};
18fca96a	119	warn qq/\### END DBIx::Class::Schema::Loader dump ###\n/ if $self->debug;
af6c2665	120	$self->{_storage}->dbh->disconnect;
a78e3fed	121	$self;
	122	}
	123
af6c2665	124	# The original table class name during Loader,
af6c2665	125	sub _find_table_class {
a78e3fed	126	my ( $self, $table ) = @_;
af6c2665	127	return $self->{TABLE_CLASSES}->{$table};
a78e3fed	128	}
a78e3fed	129
af6c2665	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	}
a78e3fed	136
af6c2665	137	sub connect {
a78e3fed	138	my $self = shift;
af6c2665	139	return $self->{_schema_class}->connect(@_) if(@_);
af6c2665	140	return $self->{_schema_class}->connect(@{$self->{_datasource}});
a78e3fed	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;
af6c2665	161	return sort keys %{ $self->{MONIKERS} };
a78e3fed	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 ) = @_;
af6c2665	170	my $table_class = $self->_find_table_class($table);
af6c2665	171	my $other_class = $self->_find_table_class($other);
a78e3fed	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;
af6c2665	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();
a78e3fed	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
a78e3fed	234	foreach my $table (@tables) {
	235	next unless $table =~ /$constraint/;
	236	next if ( defined $exclude && $table =~ /$exclude/ );
af6c2665	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;
a78e3fed	242	if($tbl) {
af6c2665	243	$table_name_db_schema = $tbl if $self->{_drop_db_schema};
af6c2665	244	$table_name_only = $tbl;
a78e3fed	245	}
af6c2665	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' );
a78e3fed	254	$_->require for @db_classes;
a78e3fed	255	$self->inject_base( $class, $_ ) for @db_classes;
af6c2665	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);
a78e3fed	260	carp("$table has no primary key") unless @$pks;
	261	$class->add_columns(@$cols);
	262	$class->set_primary_key(@$pks) if @$pks;
af6c2665	263
a78e3fed	264	my $code = "package $class;\n$additional_base$additional$left_base";
a78e3fed	265	warn qq/$code/ if $self->debug;
af6c2665	266	warn qq/$class->table('$table_name_db_schema');\n/ if $self->debug;
a78e3fed	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} } );
af6c2665	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;
a78e3fed	278	}
	279	}
	280
	281	# Find and setup relationships
	282	sub _relationships {
	283	my $self = shift;
af6c2665	284	my $dbh = $self->{_storage}->dbh;
a78e3fed	285	foreach my $table ( $self->tables ) {
a78e3fed	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
af6c2665	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;
a78e3fed	312	}
af6c2665	313
af6c2665	314	$subclass;
a78e3fed	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
18fca96a	324	L<DBIx::Class::Schema::Loader>
a78e3fed	325
	326	=cut
	327
	328	1;