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

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

use strict;
use warnings;

use base qw/DBIx::Class::Schema/;

use Carp;
use Lingua::EN::Inflect;

require DBIx::Class::Core;

__PACKAGE__->mk_classdata('loader_data');

=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 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 _load_from_connection {
    my ( $class, %args ) = @_;
    if ( $args{debug} ) {
        no strict 'refs';
        *{"$class\::debug_loader"} = 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';
    $class->loader_data({
        _datasource =>
          [ $args{dsn}, $args{user}, $args{password}, $args{options} ],
        _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{db_schema} || '',
        _drop_db_schema  => $args{drop_db_schema},
        TABLE_CLASSES    => {},
        MONIKERS         => {},
    });

    $class->connection(@{$class->loader_data->{_datasource}});
    warn qq/\### START DBIx::Class::Schema::Loader dump ###\n/ if $class->debug_loader;
    $class->_load_classes;
    $class->_relationships                            if $class->loader_data->{_relationships};
    warn qq/\### END DBIx::Class::Schema::Loader dump ###\n/ if $class->debug_loader;
    $class->storage->dbh->disconnect; # XXX this should be ->storage->disconnect later?

    1;
}

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

# Returns the moniker for a given table name,
# for use in $conn->resultset($moniker)

=head3 moniker

Returns the moniker for a given literal table name.  Used
as $schema->resultset($moniker), etc.

=cut
sub moniker {
    my ( $class, $table ) = @_;
    return $class->loader_data->{MONIKERS}->{$table};
}

=head3 debug_loader

Overload to enable Loader debug messages.

=cut

sub debug_loader { 0 }

=head3 tables

Returns a sorted list of tables.

    my @tables = $loader->tables;

=cut

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

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

# Setup has_a and has_many relationships
sub _belongs_to_many {
    use Data::Dumper;

    my ( $class, $table, $other, $cond ) = @_;
    my $table_class = $class->_find_table_class($table);
    my $other_class = $class->_find_table_class($other);

    my $table_relname = lc $table;
    my $other_relname = lc $other;

    if(my $inflections = $class->loader_data->{_inflect}) {
        $table_relname = $inflections->{$table_relname}
          if exists $inflections->{$table_relname};
    }
    else {
        $table_relname = Lingua::EN::Inflect::PL($table_relname);
    }

    # for single-column case, set the relname to the column name,
    # to make filter accessors work
    if(scalar keys %$cond == 1) {
        my ($col) = keys %$cond;
        $other_relname = $cond->{$col};
    }

    my $rev_cond = { reverse %$cond };

    warn qq/\# Belongs_to relationship\n/ if $class->debug_loader;

    warn qq/$table_class->belongs_to( '$other_relname' => '$other_class',/
      .  Dumper($cond)
      .  qq/);\n\n/
      if $class->debug_loader;

    $table_class->belongs_to( $other_relname => $other_class, $cond);

    warn qq/\# Has_many relationship\n/ if $class->debug_loader;

    warn qq/$other_class->has_many( '$table_relname' => '$table_class',/
      .  Dumper($rev_cond)
      .  qq/);\n\n/
      if $class->debug_loader;

    $other_class->has_many( $table_relname => $table_class, $rev_cond);
}

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

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

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

        my ($db_schema, $tbl) = split /\./, $table;
        my $tablename = lc $table;
        if($tbl) {
            $tablename = $class->loader_data->{_drop_db_schema} ? $tbl : lc $table;
        }

        my $table_moniker = $class->_table2moniker($db_schema, $tbl);
        my $table_class = "$class\::$table_moniker";

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

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

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

        $class->register_class($table_moniker, $table_class);
        $class->loader_data->{TABLE_CLASSES}->{lc $tablename} = $table_class;
        $class->loader_data->{MONIKERS}->{lc $tablename} = $table_moniker;
    }
}

# Find and setup relationships
sub _relationships {
    my $class = shift;
    my $dbh = $class->storage->dbh;
    my $quoter = $dbh->get_info(29) || q{"};
    foreach my $table ( $class->tables ) {
        my $rels = {};
        my $sth = $dbh->foreign_key_info( '',
            $class->loader_data->{_db_schema}, '', '', '', $table );
        next if !$sth;
        while(my $raw_rel = $sth->fetchrow_hashref) {
            my $uk_tbl  = lc $raw_rel->{UK_TABLE_NAME};
            my $uk_col  = lc $raw_rel->{UK_COLUMN_NAME};
            my $fk_col  = lc $raw_rel->{FK_COLUMN_NAME};
            $uk_tbl =~ s/$quoter//g;
            $uk_col =~ s/$quoter//g;
            $fk_col =~ s/$quoter//g;
            $rels->{$uk_tbl}->{$uk_col} = $fk_col;
        }

        foreach my $reltbl (keys %$rels) {
            my $cond = $rels->{$reltbl};
            eval { $class->_belongs_to_many( $table, $reltbl, $cond ) };
              warn qq/\# belongs_to_many failed "$@"\n\n/
                if $@ && $class->debug_loader;
        }
    }
}

# Make a moniker from a table
sub _table2moniker {
    my ( $class, $db_schema, $table ) = @_;

    my $db_schema_ns;

    if($table) {
        $db_schema = ucfirst lc $db_schema;
        $db_schema_ns = $db_schema if(!$class->loader_data->{_drop_db_schema});
    } else {
        $table = $db_schema;
    }

    my $moniker = join '', map ucfirst, split /[\W_]+/, lc $table;
    $moniker = $db_schema_ns ? $db_schema_ns . $moniker : $moniker;

    return $moniker;
}

# 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
a78e3fed	3	use strict;
a4a19f3c	4	use warnings;
	5
	6	use base qw/DBIx::Class::Schema/;
	7
a78e3fed	8	use Carp;
a78e3fed	9	use Lingua::EN::Inflect;
a4a19f3c	10
a78e3fed	11	require DBIx::Class::Core;
a4a19f3c	12
	13	__PACKAGE__->mk_classdata('loader_data');
	14
a78e3fed	15	=head1 NAME
a78e3fed	16
18fca96a	17	DBIx::Class::Schema::Loader::Generic - Generic DBIx::Class::Schema::Loader Implementation.
a78e3fed	18
	19	=head1 SYNOPSIS
	20
18fca96a	21	See L<DBIx::Class::Schema::Loader>
a78e3fed	22
	23	=head1 DESCRIPTION
	24
	25	=head2 OPTIONS
	26
	27	Available constructor options are:
	28
	29	=head3 additional_base_classes
	30
	31	List of additional base classes your table classes will use.
	32
	33	=head3 left_base_classes
	34
	35	List of additional base classes, that need to be leftmost.
	36
	37	=head3 additional_classes
	38
	39	List of additional classes which your table classes will use.
	40
	41	=head3 constraint
	42
	43	Only load tables matching regex.
	44
	45	=head3 exclude
	46
	47	Exclude tables matching regex.
	48
	49	=head3 debug
	50
	51	Enable debug messages.
	52
	53	=head3 dsn
	54
	55	DBI Data Source Name.
	56
a78e3fed	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
18fca96a	81	C<new()> method in L<DBIx::Class::Schema::Loader>.
a78e3fed	82
	83	=cut
	84
a4a19f3c	85	sub _load_from_connection {
a78e3fed	86	my ( $class, %args ) = @_;
	87	if ( $args{debug} ) {
	88	no strict 'refs';
a4a19f3c	89	*{"$class\::debug_loader"} = sub { 1 };
a78e3fed	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';
a4a19f3c	98	$class->loader_data({
a78e3fed	99	_datasource =>
a78e3fed	100	[ $args{dsn}, $args{user}, $args{password}, $args{options} ],
a78e3fed	101	_additional => $additional,
	102	_additional_base => $additional_base,
	103	_left_base => $left_base,
	104	_constraint => $args{constraint} \|\| '.*',
	105	_exclude => $args{exclude},
	106	_relationships => $args{relationships},
	107	_inflect => $args{inflect},
af96f52e	108	_db_schema => $args{db_schema} \|\| '',
a4a19f3c	109	_drop_db_schema => $args{drop_db_schema},
af6c2665	110	TABLE_CLASSES => {},
af6c2665	111	MONIKERS => {},
a4a19f3c	112	});
	113
	114	$class->connection(@{$class->loader_data->{_datasource}});
fbd83464	115	warn qq/\### START DBIx::Class::Schema::Loader dump ###\n/ if $class->debug_loader;
a4a19f3c	116	$class->_load_classes;
a4a19f3c	117	$class->_relationships if $class->loader_data->{_relationships};
fbd83464	118	warn qq/\### END DBIx::Class::Schema::Loader dump ###\n/ if $class->debug_loader;
a4a19f3c	119	$class->storage->dbh->disconnect; # XXX this should be ->storage->disconnect later?
	120
	121	1;
a78e3fed	122	}
a78e3fed	123
af6c2665	124	# The original table class name during Loader,
af6c2665	125	sub _find_table_class {
a4a19f3c	126	my ( $class, $table ) = @_;
a4a19f3c	127	return $class->loader_data->{TABLE_CLASSES}->{$table};
a78e3fed	128	}
a78e3fed	129
af6c2665	130	# Returns the moniker for a given table name,
af6c2665	131	# for use in $conn->resultset($moniker)
fbd83464	132
	133	=head3 moniker
	134
	135	Returns the moniker for a given literal table name. Used
	136	as $schema->resultset($moniker), etc.
	137
	138	=cut
af6c2665	139	sub moniker {
a4a19f3c	140	my ( $class, $table ) = @_;
a4a19f3c	141	return $class->loader_data->{MONIKERS}->{$table};
a78e3fed	142	}
a78e3fed	143
fbd83464	144	=head3 debug_loader
a78e3fed	145
fbd83464	146	Overload to enable Loader debug messages.
a78e3fed	147
	148	=cut
	149
fbd83464	150	sub debug_loader { 0 }
a78e3fed	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 {
a4a19f3c	161	my $class = shift;
a4a19f3c	162	return sort keys %{ $class->loader_data->{MONIKERS} };
a78e3fed	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 {
708c0939	170	use Data::Dumper;
	171
	172	my ( $class, $table, $other, $cond ) = @_;
a4a19f3c	173	my $table_class = $class->_find_table_class($table);
a4a19f3c	174	my $other_class = $class->_find_table_class($other);
a78e3fed	175
708c0939	176	my $table_relname = lc $table;
708c0939	177	my $other_relname = lc $other;
a78e3fed	178
708c0939	179	if(my $inflections = $class->loader_data->{_inflect}) {
	180	$table_relname = $inflections->{$table_relname}
	181	if exists $inflections->{$table_relname};
a78e3fed	182	}
a78e3fed	183	else {
708c0939	184	$table_relname = Lingua::EN::Inflect::PL($table_relname);
	185	}
	186
	187	# for single-column case, set the relname to the column name,
	188	# to make filter accessors work
	189	if(scalar keys %$cond == 1) {
	190	my ($col) = keys %$cond;
	191	$other_relname = $cond->{$col};
a78e3fed	192	}
a78e3fed	193
708c0939	194	my $rev_cond = { reverse %$cond };
	195
	196	warn qq/\# Belongs_to relationship\n/ if $class->debug_loader;
	197
	198	warn qq/$table_class->belongs_to( '$other_relname' => '$other_class',/
	199	. Dumper($cond)
	200	. qq/);\n\n/
	201	if $class->debug_loader;
	202
	203	$table_class->belongs_to( $other_relname => $other_class, $cond);
a78e3fed	204
fbd83464	205	warn qq/\# Has_many relationship\n/ if $class->debug_loader;
a78e3fed	206
708c0939	207	warn qq/$other_class->has_many( '$table_relname' => '$table_class',/
	208	. Dumper($rev_cond)
	209	. qq/);\n\n/
	210	if $class->debug_loader;
	211
	212	$other_class->has_many( $table_relname => $table_class, $rev_cond);
a78e3fed	213	}
	214
	215	# Load and setup classes
	216	sub _load_classes {
a4a19f3c	217	my $class = shift;
af6c2665	218
a4a19f3c	219	my @tables = $class->_tables();
	220	my @db_classes = $class->_db_classes();
	221	my $additional = join '', map "use $_;\n", @{ $class->loader_data->{_additional} };
a78e3fed	222	my $additional_base = join '', map "use base '$_';\n",
a4a19f3c	223	@{ $class->loader_data->{_additional_base} };
	224	my $left_base = join '', map "use base '$_';\n", @{ $class->loader_data->{_left_base} };
	225	my $constraint = $class->loader_data->{_constraint};
	226	my $exclude = $class->loader_data->{_exclude};
a78e3fed	227
a78e3fed	228	foreach my $table (@tables) {
	229	next unless $table =~ /$constraint/;
	230	next if ( defined $exclude && $table =~ /$exclude/ );
af6c2665	231
af6c2665	232	my ($db_schema, $tbl) = split /\./, $table;
af96f52e	233	my $tablename = lc $table;
a78e3fed	234	if($tbl) {
af96f52e	235	$tablename = $class->loader_data->{_drop_db_schema} ? $tbl : lc $table;
af6c2665	236	}
af6c2665	237
65644119	238	my $table_moniker = $class->_table2moniker($db_schema, $tbl);
65644119	239	my $table_class = "$class\::$table_moniker";
af6c2665	240
a4a19f3c	241	$class->inject_base( $table_class, 'DBIx::Class::Core' );
a78e3fed	242	$_->require for @db_classes;
a4a19f3c	243	$class->inject_base( $table_class, $_ ) for @db_classes;
af96f52e	244	warn qq/\# Initializing table "$tablename" as "$table_class"\n/ if $class->debug_loader;
af96f52e	245	$table_class->table(lc $tablename);
af6c2665	246
af96f52e	247	my ( $cols, $pks ) = $class->_table_info($table);
a78e3fed	248	carp("$table has no primary key") unless @$pks;
a4a19f3c	249	$table_class->add_columns(@$cols);
a4a19f3c	250	$table_class->set_primary_key(@$pks) if @$pks;
af6c2665	251
a4a19f3c	252	my $code = "package $table_class;\n$additional_base$additional$left_base";
fbd83464	253	warn qq/$code/ if $class->debug_loader;
af96f52e	254	warn qq/$table_class->table('$tablename');\n/ if $class->debug_loader;
a78e3fed	255	my $columns = join "', '", @$cols;
fbd83464	256	warn qq/$table_class->add_columns('$columns')\n/ if $class->debug_loader;
a78e3fed	257	my $primaries = join "', '", @$pks;
fbd83464	258	warn qq/$table_class->set_primary_key('$primaries')\n/ if $class->debug_loader && @$pks;
a78e3fed	259	eval $code;
a78e3fed	260	croak qq/Couldn't load additional classes "$@"/ if $@;
a4a19f3c	261	unshift @{"$table_class\::ISA"}, $_ foreach ( @{ $class->loader_data->{_left_base} } );
af6c2665	262
65644119	263	$class->register_class($table_moniker, $table_class);
af96f52e	264	$class->loader_data->{TABLE_CLASSES}->{lc $tablename} = $table_class;
65644119	265	$class->loader_data->{MONIKERS}->{lc $tablename} = $table_moniker;
a78e3fed	266	}
	267	}
	268
	269	# Find and setup relationships
	270	sub _relationships {
a4a19f3c	271	my $class = shift;
a4a19f3c	272	my $dbh = $class->storage->dbh;
708c0939	273	my $quoter = $dbh->get_info(29) \|\| q{"};
a4a19f3c	274	foreach my $table ( $class->tables ) {
708c0939	275	my $rels = {};
	276	my $sth = $dbh->foreign_key_info( '',
	277	$class->loader_data->{_db_schema}, '', '', '', $table );
	278	next if !$sth;
	279	while(my $raw_rel = $sth->fetchrow_hashref) {
	280	my $uk_tbl = lc $raw_rel->{UK_TABLE_NAME};
	281	my $uk_col = lc $raw_rel->{UK_COLUMN_NAME};
	282	my $fk_col = lc $raw_rel->{FK_COLUMN_NAME};
	283	$uk_tbl =~ s/$quoter//g;
	284	$uk_col =~ s/$quoter//g;
	285	$fk_col =~ s/$quoter//g;
	286	$rels->{$uk_tbl}->{$uk_col} = $fk_col;
	287	}
	288
	289	foreach my $reltbl (keys %$rels) {
	290	my $cond = $rels->{$reltbl};
	291	eval { $class->_belongs_to_many( $table, $reltbl, $cond ) };
	292	warn qq/\# belongs_to_many failed "$@"\n\n/
	293	if $@ && $class->debug_loader;
a78e3fed	294	}
	295	}
	296	}
	297
65644119	298	# Make a moniker from a table
65644119	299	sub _table2moniker {
a4a19f3c	300	my ( $class, $db_schema, $table ) = @_;
af6c2665	301
af96f52e	302	my $db_schema_ns;
af6c2665	303
af96f52e	304	if($table) {
af96f52e	305	$db_schema = ucfirst lc $db_schema;
65644119	306	$db_schema_ns = $db_schema if(!$class->loader_data->{_drop_db_schema});
af96f52e	307	} else {
af96f52e	308	$table = $db_schema;
a78e3fed	309	}
af6c2665	310
65644119	311	my $moniker = join '', map ucfirst, split /[\W_]+/, lc $table;
65644119	312	$moniker = $db_schema_ns ? $db_schema_ns . $moniker : $moniker;
af96f52e	313
65644119	314	return $moniker;
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;