[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 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 _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} ],
        _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{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 {
    my ( $class, $table, $column, $other, $other_column ) = @_;
    my $table_class = $class->_find_table_class($table);
    my $other_class = $class->_find_table_class($other);

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

    if($other_column) {
        warn qq/$table_class->belongs_to( '$column' => '$other_class',/
          .  qq/ { "foreign.$other_column" => "self.$column" },/
          .  qq/ { accessor => 'filter' });\n\n/
          if $class->debug_loader;
        $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 $class->debug_loader;
        $table_class->belongs_to( $column => $other_class );
    }

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

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

    if($other_column) {
        warn qq/$other_class->has_many( '$plural' => '$table_class',/
          .  qq/ { "foreign.$column" => "self.$other_column" } );\n\n/
          if $class->debug_loader;
        $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 $class->debug_loader;
        $other_class->has_many( $plural => $table_class, $column );
    }
}

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

    my $namespace    = $class->loader_data->{_namespace};

    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 $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 $class->loader_data->{_drop_db_schema};
            $table_name_only = $tbl;
        }
        else {
            undef $db_schema;
        }

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

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

        my ( $cols, $pks ) = $class->_table_info($table_name_db_schema);
        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('$table_name_db_schema');\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_subclass, $table_class);
        $class->loader_data->{TABLE_CLASSES}->{$table_name_db_schema} = $table_class;
        $class->loader_data->{MONIKERS}->{$table_name_db_schema} = $table_subclass;
    }
}

# Find and setup relationships
sub _relationships {
    my $class = shift;
    my $dbh = $class->storage->dbh;
    foreach my $table ( $class->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 { $class->_belongs_to_many( $table, $column, $other,
                  $other_column ) };
                warn qq/\# belongs_to_many failed "$@"\n\n/
                  if $@ && $class->debug_loader;
            }
        }
    }
}

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

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

    if($db_schema && !$class->loader_data->{_drop_db_schema}) {
        $table_subclass = (ucfirst lc $db_schema) . '-' . $table_subclass;
    }

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