[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Producer / ClassDBI.pm

package SQL::Translator::Producer::ClassDBI;

# -------------------------------------------------------------------
# $Id: ClassDBI.pm,v 1.35 2003-08-20 15:55:00 kycl4rk Exp $
# -------------------------------------------------------------------
# Copyright (C) 2003 Allen Day <allenday@ucla.edu>,
#                    Ying Zhang <zyolive@yahoo.com>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; version 2.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
# -------------------------------------------------------------------

use strict;
use vars qw[ $VERSION $DEBUG ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.35 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 1 unless defined $DEBUG;

use SQL::Translator::Schema::Constants;
use SQL::Translator::Utils qw(header_comment);
use Data::Dumper;

my %CDBI_auto_pkgs = (
    MySQL      => 'mysql',
    PostgreSQL => 'Pg',
    Oracle     => 'Oracle',
);

# -------------------------------------------------------------------
sub produce {
    my $t      = shift;
    my $create = undef;
    local $DEBUG = $t->debug;
    my $no_comments   = $t->no_comments;
    my $schema        = $t->schema;
    my $args          = $t->producer_args;
    my $db_user       = $args->{'db_user'} || '';
    my $db_pass       = $args->{'db_pass'} || '';
    my $main_pkg_name = $args->{'main_pkg_name'} ||
                        $t->format_package_name('DBI');
    my $header        = header_comment( __PACKAGE__, "# " );
    my $parser_type   = ( split /::/, $t->parser_type )[-1];
    my $from          = $CDBI_auto_pkgs{$parser_type} || '';
    my $dsn           = $args->{'dsn'} || sprintf( 'dbi:%s:_', 
        $CDBI_auto_pkgs{ $parser_type } 
        ? $CDBI_auto_pkgs{ $parser_type } : $parser_type 
    );
    my $sep           = '# ' . '-' x 67;

    #
    # Identify "link tables" (have only PK and FK fields).
    #
    my %linkable;
    my %linktable;
    foreach my $table ( $schema->get_tables ) {
        my $is_link = 1;
        foreach my $field ( $table->get_fields ) {
            unless ( $field->is_primary_key or $field->is_foreign_key ) {
                $is_link = 0;
                last;
            }
        }

        next unless $is_link;

        foreach my $left ( $table->get_fields ) {
            next unless $left->is_foreign_key;
            my $lfk = $left->foreign_key_reference or next;
            my $lr_table = $schema->get_table( $lfk->reference_table )
              or next;
            my $lr_field_name = ( $lfk->reference_fields )[0];
            my $lr_field      = $lr_table->get_field($lr_field_name);
            next unless $lr_field->is_primary_key;

            foreach my $right ( $table->get_fields ) {
                next if $left->name eq $right->name;

                my $rfk = $right->foreign_key_reference or next;
                my $rr_table = $schema->get_table( $rfk->reference_table )
                  or next;
                my $rr_field_name = ( $rfk->reference_fields )[0];
                my $rr_field      = $rr_table->get_field($rr_field_name);
                next unless $rr_field->is_primary_key;

                $linkable{ $lr_table->name }{ $rr_table->name } = $table;
                $linkable{ $rr_table->name }{ $lr_table->name } = $table;
                $linktable{ $table->name } = $table;
            }
        }
    }

    #
    # Iterate over all tables
    #
    my ( %packages, $order );
    for my $table ( $schema->get_tables ) {
        my $table_name = $table->name or next;

        my $table_pkg_name = $t->format_package_name($table_name);
        $packages{$table_pkg_name} = {
            order    => ++$order,
            pkg_name => $table_pkg_name,
            base     => $main_pkg_name,
            table    => $table_name,
        };

        #
        # Primary key may have a differenct accessor method name
        #
        if ( my $constraint = $table->primary_key ) {
            my $field = ( $constraint->fields )[0];
            $packages{ $table_pkg_name }{'_columns_primary'} = $field;

            if ( my $pk_xform = $t->format_pk_name ) {
                my $pk_name = $pk_xform->( $table_pkg_name, $field );

                $packages{$table_pkg_name}{'pk_accessor'} =
                  "#\n# Primary key accessor\n#\n"
                  . "sub $pk_name {\n    shift->$field\n}\n\n";
            }
        }

        my $is_data = 0;
        foreach my $field ( $table->get_fields ) {
            if ( !$field->is_foreign_key and !$field->is_primary_key ) {
                push @{ $packages{$table_pkg_name}{'_columns_essential'} },
                  $field->name;
                $is_data++;
            }
            elsif ( !$field->is_primary_key ) {
                push @{ $packages{$table_pkg_name}{'_columns_others'} },
                  $field->name;
            }
        }

        my %linked;
        if ($is_data) {
            foreach my $link ( keys %{ $linkable{$table_name} } ) {
                my $linkmethodname;

                if ( my $fk_xform = $t->format_fk_name ) {

                    # ADD CALLBACK FOR PLURALIZATION MANGLING HERE
                    $linkmethodname = $fk_xform->(
                        $linkable{ $table_name }{ $link }->name,
                        ( $schema->get_table( $link )->primary_key->fields )[0]
                      )
                      . 's';
                }
                else {
                    # ADD CALLBACK FOR PLURALIZATION MANGLING HERE
                    $linkmethodname =
                      $linkable{ $table_name }{ $link }->name . '_'
                      . ( $schema->get_table( $link )->primary_key->fields )[0]
                      . 's';
                }

                my @rk_fields = ();
                my @lk_fields = ();
                foreach my $field ( $linkable{$table_name}{$link}->get_fields )
                {
                    next unless $field->is_foreign_key;

                    next unless ( 
                        $field->foreign_key_reference->reference_table eq
                           $table_name
                        || 
                        $field->foreign_key_reference->reference_table eq $link 
                    );

                    push @lk_fields,
                      ( $field->foreign_key_reference->reference_fields )[0]
                      if $field->foreign_key_reference->reference_table eq
                      $link;

                    push @rk_fields, $field->name
                      if $field->foreign_key_reference->reference_table eq
                      $table_name;
                }

                #
                # If one possible traversal via link table.
                #
                if ( scalar(@rk_fields) == 1 and scalar(@lk_fields) == 1 ) {
                    foreach my $rk_field (@rk_fields) {
                        push @{ $packages{$table_pkg_name}{'has_many'}{$link} },
                          "sub "
                          . $linkmethodname
                          . " { my \$self = shift; "
                          . "return map \$_->"
                          . ( $schema->get_table($link)->primary_key->fields )
                          [0]
                          . ", \$self->"
                          . $linkable{$table_name}{$link}->name . "_"
                          . $rk_field
                          . " }\n\n";
                    }

                    #
                    # Else there is more than one way to traverse it.
                    # ack!  Let's treat these types of link tables as
                    # a many-to-one (easier)
                    #
                    # NOTE: we need to rethink the link method name,
                    # as the cardinality has shifted on us.
                    #
                }
                elsif ( scalar(@rk_fields) == 1 ) {
                    foreach my $rk_field (@rk_fields) {
                        #
                        # ADD CALLBACK FOR PLURALIZATION MANGLING HERE
                        #
                        push @{ $packages{$table_pkg_name}{'has_many'}{$link} },
                          "sub "
                          . $linkable{$table_name}{$link}->name
                          . "s { my \$self = shift; return \$self->"
                          . $linkable{$table_name}{$link}->name . "_"
                          . $rk_field
                          . "(\@_) }\n\n";
                    }
                }
                elsif ( scalar(@lk_fields) == 1 ) {
                    #
                    # These will be taken care of on the other end...
                    #
                }
                else {
                    #
                    # Many many many.  Need multiple iterations here,
                    # data structure revision to handle N FK sources.
                    # This code has not been tested and likely doesn't
                    # work here.
                    #
                    foreach my $rk_field (@rk_fields) {
                        # ADD CALLBACK FOR PLURALIZATION MANGLING HERE
                        push @{ $packages{$table_pkg_name}{'has_many'}{$link} },
                          "sub "
                          . $linkable{$table_name}{$link}->name . "_"
                          . $rk_field
                          . "s { my \$self = shift; return \$self->"
                          . $linkable{$table_name}{$link}->name . "_"
                          . $rk_field
                          . "(\@_) }\n\n";
                    }
                }
            }
        }

        #
        # Use foreign keys to set up "has_a/has_many" relationships.
        #
        foreach my $field ( $table->get_fields ) {
            if ( $field->is_foreign_key ) {
                my $table_name = $table->name;
                my $field_name = $field->name;
                my $fk_method  = $t->format_fk_name( $table_name, $field_name );
                my $fk         = $field->foreign_key_reference;
                my $ref_table  = $fk->reference_table;
                my $ref_pkg    = $t->format_package_name($ref_table);
                my $ref_field  = ( $fk->reference_fields )[0];

                push @{ $packages{$table_pkg_name}{'has_a'} },
                  "$table_pkg_name->has_a(\n"
                  . "    $field_name => '$ref_pkg'\n);\n\n"
                  . "sub $fk_method {\n"
                  . "    return shift->$field_name\n}\n\n";

                #
                # If this table "has a" to the other, then it follows 
                # that the other table "has many" of this one, right?
                #
                # No... there is the possibility of 1-1 cardinality
                #
                # if there weren't M-M relationships via the has_many
                # being set up here, create nice pluralized method alias
                # rather for user as alt. to ugly tablename_fieldname name
                #
                if ( !$packages{$ref_pkg}{'has_many'}{$table_name} ) {
                    #
                    # ADD CALLBACK FOR PLURALIZATION MANGLING HERE
                    #
                    push @{ $packages{$ref_pkg}{'has_many'}{$table_name} },
                        "sub ${table_name}s {\n    " .
                        "return shift->$table_name\_$field_name\n}\n\n";
                    # else ugly
                }
                else {
                }

                push @{ $packages{$ref_pkg}{'has_many'}{$table_name} },
                  "$ref_pkg->has_many(\n    '${table_name}_${field_name}', "
                  . "'$table_pkg_name' => '$field_name'\n);\n\n";

            }
        }
    }

    #
    # Now build up text of package.
    #
    my $base_pkg = sprintf( 'Class::DBI%s', $from ? "::$from" : '' );
    $create .= join ( "\n",
        "package $main_pkg_name;\n",
        $header,
        "use strict;",
        "use base '$base_pkg';\n",
        "$main_pkg_name->set_db('Main', '$dsn', '$db_user', '$db_pass');\n\n",
    );

    for my $pkg_name (
        sort { $packages{ $a }{'order'} <=> $packages{ $b }{'order'} }
        keys %packages
    ) {
        my $pkg = $packages{$pkg_name};

        $create .= join ( "\n",
            $sep,
            "package " . $pkg->{'pkg_name'} . ";",
            "use base '" . $pkg->{'base'} . "';",
            "use Class::DBI::Pager;\n\n",
        );

        #        if ( $from ) {
        #            $create .= 
        #                $pkg->{'pkg_name'}."->set_up_table('".$pkg->{'table'}."');\n\n";
        #        }
        #        else {
        #            my $table       = $schema->get_table( $pkg->{'table'} );
        #            my @field_names = map { $_->name } $table->get_fields;
        #
        #            $create .= join("\n",
        #                $pkg_name."->table('".$pkg->{'table'}."');\n",
        #                $pkg_name."->columns(All => qw/".
        #                join(' ', @field_names)."/);\n\n",
        #            );
        #        }

        #
        # The approach here is to do lazy loading on the expensive
        # columns (expensive defined as those columns which require
        # construction of a referenced object) fields which are
        # strictly data (ie, not references) are treated as essential
        # b/c they don't require much time to set up.
        #
        $create .= $pkg_name . "->table('" . $pkg->{'table'} . "');\n";

        #
        # Set up primary key field.
        #
        if ( $pkg->{'_columns_primary'} ) {
            $create .= $pkg_name
              . "->columns(Primary   => qw/"
              . $pkg->{'_columns_primary'} . "/);\n";
        }
        else {
            die "Class::DBI isn't going to like that you don't " .
              "have a primary key field for table " . $pkg->{'table'};
        }

        #
        # Set up non-FK fields to be populated at construction.
        #
        if ( $pkg->{'_columns_essential'} ) {
            $create .= $pkg_name
              . "->columns(Essential => qw/"
              . join ( ' ', @{ $pkg->{'_columns_essential'} } ) . "/);\n";
        }

        #
        # Set up FK fields for lazy loading on request.
        #
        if ( $pkg->{'_columns_others'} ) {
            $create .= $pkg_name
              . "->columns(Others    => qw/"
              . join ( ' ', @{ $pkg->{'_columns_others'} } ) . "/);\n";
        }

        $create .= "\n";

        if ( my $pk = $pkg->{'pk_accessor'} ) {
            $create .= $pk;
        }

        if ( my @has_a = @{ $pkg->{'has_a'} || [] } ) {
            $create .= $_ for @has_a;
        }

        foreach my $has_many_key ( keys %{ $pkg->{'has_many'} } ) {
            if ( my @has_many = @{ $pkg->{'has_many'}{$has_many_key} || [] } ) {
                $create .= $_ for @has_many;
            }
        }
    }

    $create .= "1;\n";

    return $create;
}

1;

# -------------------------------------------------------------------

=pod

=head1 NAME

SQL::Translator::Producer::ClassDBI - create Class::DBI classes from schema

=head1 SYNOPSIS

Use this producer as you would any other from SQL::Translator.  See
L<SQL::Translator> for details.

This package utilizes SQL::Translator's formatting methods
format_package_name(), format_pk_name(), format_fk_name(), and
format_table_name() as it creates classes, one per table in the schema
provided.  An additional base class is also created for database connectivity
configuration.  See L<Class::DBI> for details on how this works.

=head1 AUTHORS

Allen Day E<lt>allenday@ucla.eduE<gt>
Ying Zhang E<lt>zyolive@yahoo.comE<gt>,
Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
Commit	Line	Data
f42e7027	1	package SQL::Translator::Producer::ClassDBI;
	2
	3	# -------------------------------------------------------------------
41a7b982	4	# $Id: ClassDBI.pm,v 1.35 2003-08-20 15:55:00 kycl4rk Exp $
f42e7027	5	# -------------------------------------------------------------------
5f054727	6	# Copyright (C) 2003 Allen Day <allenday@ucla.edu>,
5f054727	7	# Ying Zhang <zyolive@yahoo.com>
f42e7027	8	#
	9	# This program is free software; you can redistribute it and/or
	10	# modify it under the terms of the GNU General Public License as
	11	# published by the Free Software Foundation; version 2.
	12	#
	13	# This program is distributed in the hope that it will be useful, but
	14	# WITHOUT ANY WARRANTY; without even the implied warranty of
	15	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	16	# General Public License for more details.
	17	#
	18	# You should have received a copy of the GNU General Public License
	19	# along with this program; if not, write to the Free Software
	20	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	21	# 02111-1307 USA
	22	# -------------------------------------------------------------------
	23
	24	use strict;
	25	use vars qw[ $VERSION $DEBUG ];
41a7b982	26	$VERSION = sprintf "%d.%02d", q$Revision: 1.35 $ =~ /(\d+)\.(\d+)/;
41a7b982	27	$DEBUG = 1 unless defined $DEBUG;
f42e7027	28
6c45056f	29	use SQL::Translator::Schema::Constants;
5ee19df8	30	use SQL::Translator::Utils qw(header_comment);
71046f4b	31	use Data::Dumper;
f42e7027	32
bf4629e7	33	my %CDBI_auto_pkgs = (
71046f4b	34	MySQL => 'mysql',
	35	PostgreSQL => 'Pg',
	36	Oracle => 'Oracle',
bf4629e7	37	);
	38
	39	# -------------------------------------------------------------------
f42e7027	40	sub produce {
41a7b982	41	my $t = shift;
	42	my $create = undef;
	43	local $DEBUG = $t->debug;
390292d3	44	my $no_comments = $t->no_comments;
	45	my $schema = $t->schema;
	46	my $args = $t->producer_args;
bf4629e7	47	my $db_user = $args->{'db_user'} \|\| '';
bf4629e7	48	my $db_pass = $args->{'db_pass'} \|\| '';
41a7b982	49	my $main_pkg_name = $args->{'main_pkg_name'} \|\|
	50	$t->format_package_name('DBI');
	51	my $header = header_comment( __PACKAGE__, "# " );
390292d3	52	my $parser_type = ( split /::/, $t->parser_type )[-1];
41a7b982	53	my $from = $CDBI_auto_pkgs{$parser_type} \|\| '';
	54	my $dsn = $args->{'dsn'} \|\| sprintf( 'dbi:%s:_',
	55	$CDBI_auto_pkgs{ $parser_type }
	56	? $CDBI_auto_pkgs{ $parser_type } : $parser_type
	57	);
71046f4b	58	my $sep = '# ' . '-' x 67;
fe77d758	59
	60	#
	61	# Identify "link tables" (have only PK and FK fields).
	62	#
	63	my %linkable;
	64	my %linktable;
	65	foreach my $table ( $schema->get_tables ) {
	66	my $is_link = 1;
	67	foreach my $field ( $table->get_fields ) {
	68	unless ( $field->is_primary_key or $field->is_foreign_key ) {
41a7b982	69	$is_link = 0;
fe77d758	70	last;
	71	}
	72	}
	73
	74	next unless $is_link;
41a7b982	75
fe77d758	76	foreach my $left ( $table->get_fields ) {
fe77d758	77	next unless $left->is_foreign_key;
41a7b982	78	my $lfk = $left->foreign_key_reference or next;
	79	my $lr_table = $schema->get_table( $lfk->reference_table )
	80	or next;
	81	my $lr_field_name = ( $lfk->reference_fields )[0];
fe77d758	82	my $lr_field = $lr_table->get_field($lr_field_name);
	83	next unless $lr_field->is_primary_key;
	84
	85	foreach my $right ( $table->get_fields ) {
	86	next if $left->name eq $right->name;
41a7b982	87
41a7b982	88	my $rfk = $right->foreign_key_reference or next;
fe77d758	89	my $rr_table = $schema->get_table( $rfk->reference_table )
41a7b982	90	or next;
41a7b982	91	my $rr_field_name = ( $rfk->reference_fields )[0];
fe77d758	92	my $rr_field = $rr_table->get_field($rr_field_name);
fe77d758	93	next unless $rr_field->is_primary_key;
41a7b982	94
c703e51d	95	$linkable{ $lr_table->name }{ $rr_table->name } = $table;
c703e51d	96	$linkable{ $rr_table->name }{ $lr_table->name } = $table;
fe77d758	97	$linktable{ $table->name } = $table;
	98	}
	99	}
	100	}
c703e51d	101
6c45056f	102	#
71046f4b	103	# Iterate over all tables
6c45056f	104	#
bf4629e7	105	my ( %packages, $order );
6c45056f	106	for my $table ( $schema->get_tables ) {
6c45056f	107	my $table_name = $table->name or next;
6c45056f	108
390292d3	109	my $table_pkg_name = $t->format_package_name($table_name);
41a7b982	110	$packages{$table_pkg_name} = {
	111	order => ++$order,
	112	pkg_name => $table_pkg_name,
	113	base => $main_pkg_name,
	114	table => $table_name,
bf4629e7	115	};
6c45056f	116
6c45056f	117	#
bf4629e7	118	# Primary key may have a differenct accessor method name
6c45056f	119	#
41a7b982	120	if ( my $constraint = $table->primary_key ) {
	121	my $field = ( $constraint->fields )[0];
	122	$packages{ $table_pkg_name }{'_columns_primary'} = $field;
d79af833	123
41a7b982	124	if ( my $pk_xform = $t->format_pk_name ) {
41a7b982	125	my $pk_name = $pk_xform->( $table_pkg_name, $field );
b789c790	126
41a7b982	127	$packages{$table_pkg_name}{'pk_accessor'} =
	128	"#\n# Primary key accessor\n#\n"
	129	. "sub $pk_name {\n shift->$field\n}\n\n";
bf4629e7	130	}
6c45056f	131	}
d79af833	132
	133	my $is_data = 0;
	134	foreach my $field ( $table->get_fields ) {
41a7b982	135	if ( !$field->is_foreign_key and !$field->is_primary_key ) {
	136	push @{ $packages{$table_pkg_name}{'_columns_essential'} },
	137	$field->name;
	138	$is_data++;
	139	}
	140	elsif ( !$field->is_primary_key ) {
	141	push @{ $packages{$table_pkg_name}{'_columns_others'} },
	142	$field->name;
	143	}
d79af833	144	}
d79af833	145
41a7b982	146	my %linked;
	147	if ($is_data) {
	148	foreach my $link ( keys %{ $linkable{$table_name} } ) {
	149	my $linkmethodname;
	150
	151	if ( my $fk_xform = $t->format_fk_name ) {
	152
	153	# ADD CALLBACK FOR PLURALIZATION MANGLING HERE
	154	$linkmethodname = $fk_xform->(
	155	$linkable{ $table_name }{ $link }->name,
	156	( $schema->get_table( $link )->primary_key->fields )[0]
	157	)
	158	. 's';
	159	}
	160	else {
	161	# ADD CALLBACK FOR PLURALIZATION MANGLING HERE
	162	$linkmethodname =
	163	$linkable{ $table_name }{ $link }->name . '_'
	164	. ( $schema->get_table( $link )->primary_key->fields )[0]
	165	. 's';
	166	}
	167
	168	my @rk_fields = ();
	169	my @lk_fields = ();
	170	foreach my $field ( $linkable{$table_name}{$link}->get_fields )
	171	{
	172	next unless $field->is_foreign_key;
	173
	174	next unless (
	175	$field->foreign_key_reference->reference_table eq
	176	$table_name
	177	\|\|
	178	$field->foreign_key_reference->reference_table eq $link
	179	);
	180
	181	push @lk_fields,
	182	( $field->foreign_key_reference->reference_fields )[0]
	183	if $field->foreign_key_reference->reference_table eq
	184	$link;
	185
	186	push @rk_fields, $field->name
	187	if $field->foreign_key_reference->reference_table eq
	188	$table_name;
	189	}
	190
	191	#
	192	# If one possible traversal via link table.
	193	#
	194	if ( scalar(@rk_fields) == 1 and scalar(@lk_fields) == 1 ) {
	195	foreach my $rk_field (@rk_fields) {
	196	push @{ $packages{$table_pkg_name}{'has_many'}{$link} },
	197	"sub "
	198	. $linkmethodname
	199	. " { my \$self = shift; "
	200	. "return map \$_->"
	201	. ( $schema->get_table($link)->primary_key->fields )
	202	[0]
	203	. ", \$self->"
	204	. $linkable{$table_name}{$link}->name . "_"
	205	. $rk_field
	206	. " }\n\n";
	207	}
	208
	209	#
210	# Else there is more than one way to traverse it.
211	# ack! Let's treat these types of link tables as
212	# a many-to-one (easier)
213	#
214	# NOTE: we need to rethink the link method name,
215	# as the cardinality has shifted on us.
216	#
217	}
218	elsif ( scalar(@rk_fields) == 1 ) {
219	foreach my $rk_field (@rk_fields) {
220	#
221	# ADD CALLBACK FOR PLURALIZATION MANGLING HERE
222	#
223	push @{ $packages{$table_pkg_name}{'has_many'}{$link} },
224	"sub "
225	. $linkable{$table_name}{$link}->name
226	. "s { my \$self = shift; return \$self->"
227	. $linkable{$table_name}{$link}->name . "_"
228	. $rk_field
229	. "(\@_) }\n\n";
230	}
231	}
232	elsif ( scalar(@lk_fields) == 1 ) {
233	#
234	# These will be taken care of on the other end...
235	#
236	}
237	else {
238	#
239	# Many many many. Need multiple iterations here,
240	# data structure revision to handle N FK sources.
241	# This code has not been tested and likely doesn't
242	# work here.
243	#
244	foreach my $rk_field (@rk_fields) {
245	# ADD CALLBACK FOR PLURALIZATION MANGLING HERE
246	push @{ $packages{$table_pkg_name}{'has_many'}{$link} },
247	"sub "
248	. $linkable{$table_name}{$link}->name . "_"
249	. $rk_field
250	. "s { my \$self = shift; return \$self->"
251	. $linkable{$table_name}{$link}->name . "_"
252	. $rk_field
253	. "(\@_) }\n\n";
254	}
255	}
256	}
257	}
d79af833	258
6c45056f	259	#
bf4629e7	260	# Use foreign keys to set up "has_a/has_many" relationships.
6c45056f	261	#
	262	foreach my $field ( $table->get_fields ) {
	263	if ( $field->is_foreign_key ) {
bf4629e7	264	my $table_name = $table->name;
6c45056f	265	my $field_name = $field->name;
41a7b982	266	my $fk_method = $t->format_fk_name( $table_name, $field_name );
6c45056f	267	my $fk = $field->foreign_key_reference;
6c45056f	268	my $ref_table = $fk->reference_table;
390292d3	269	my $ref_pkg = $t->format_package_name($ref_table);
41a7b982	270	my $ref_field = ( $fk->reference_fields )[0];
6c45056f	271
41a7b982	272	push @{ $packages{$table_pkg_name}{'has_a'} },
	273	"$table_pkg_name->has_a(\n"
	274	. " $field_name => '$ref_pkg'\n);\n\n"
	275	. "sub $fk_method {\n"
	276	. " return shift->$field_name\n}\n\n";
52fbac6a	277
bf4629e7	278	#
	279	# If this table "has a" to the other, then it follows
	280	# that the other table "has many" of this one, right?
	281	#
41a7b982	282	# No... there is the possibility of 1-1 cardinality
	283	#
	284	# if there weren't M-M relationships via the has_many
	285	# being set up here, create nice pluralized method alias
	286	# rather for user as alt. to ugly tablename_fieldname name
	287	#
	288	if ( !$packages{$ref_pkg}{'has_many'}{$table_name} ) {
	289	#
	290	# ADD CALLBACK FOR PLURALIZATION MANGLING HERE
	291	#
	292	push @{ $packages{$ref_pkg}{'has_many'}{$table_name} },
	293	"sub ${table_name}s {\n " .
	294	"return shift->$table_name\_$field_name\n}\n\n";
	295	# else ugly
	296	}
	297	else {
	298	}
	299
	300	push @{ $packages{$ref_pkg}{'has_many'}{$table_name} },
	301	"$ref_pkg->has_many(\n '${table_name}_${field_name}', "
	302	. "'$table_pkg_name' => '$field_name'\n);\n\n";
71046f4b	303
fe77d758	304	}
41a7b982	305	}
41a7b982	306	}
6c45056f	307
fe77d758	308	#
	309	# Now build up text of package.
	310	#
bf4629e7	311	my $base_pkg = sprintf( 'Class::DBI%s', $from ? "::$from" : '' );
41a7b982	312	$create .= join ( "\n",
	313	"package $main_pkg_name;\n",
	314	$header,
	315	"use strict;",
	316	"use base '$base_pkg';\n",
	317	"$main_pkg_name->set_db('Main', '$dsn', '$db_user', '$db_pass');\n\n",
	318	);
	319
	320	for my $pkg_name (
bf4629e7	321	sort { $packages{ $a }{'order'} <=> $packages{ $b }{'order'} }
	322	keys %packages
	323	) {
41a7b982	324	my $pkg = $packages{$pkg_name};
bf4629e7	325
41a7b982	326	$create .= join ( "\n",
bf4629e7	327	$sep,
41a7b982	328	"package " . $pkg->{'pkg_name'} . ";",
41a7b982	329	"use base '" . $pkg->{'base'} . "';",
bf4629e7	330	"use Class::DBI::Pager;\n\n",
41a7b982	331	);
	332
	333	# if ( $from ) {
	334	# $create .=
	335	# $pkg->{'pkg_name'}."->set_up_table('".$pkg->{'table'}."');\n\n";
	336	# }
	337	# else {
	338	# my $table = $schema->get_table( $pkg->{'table'} );
	339	# my @field_names = map { $_->name } $table->get_fields;
	340	#
	341	# $create .= join("\n",
	342	# $pkg_name."->table('".$pkg->{'table'}."');\n",
	343	# $pkg_name."->columns(All => qw/".
	344	# join(' ', @field_names)."/);\n\n",
	345	# );
	346	# }
b789c790	347
41a7b982	348	#
	349	# The approach here is to do lazy loading on the expensive
	350	# columns (expensive defined as those columns which require
	351	# construction of a referenced object) fields which are
	352	# strictly data (ie, not references) are treated as essential
	353	# b/c they don't require much time to set up.
	354	#
	355	$create .= $pkg_name . "->table('" . $pkg->{'table'} . "');\n";
b789c790	356
41a7b982	357	#
	358	# Set up primary key field.
	359	#
	360	if ( $pkg->{'_columns_primary'} ) {
	361	$create .= $pkg_name
	362	. "->columns(Primary => qw/"
	363	. $pkg->{'_columns_primary'} . "/);\n";
	364	}
	365	else {
	366	die "Class::DBI isn't going to like that you don't " .
	367	"have a primary key field for table " . $pkg->{'table'};
	368	}
71046f4b	369
41a7b982	370	#
	371	# Set up non-FK fields to be populated at construction.
	372	#
	373	if ( $pkg->{'_columns_essential'} ) {
	374	$create .= $pkg_name
	375	. "->columns(Essential => qw/"
	376	. join ( ' ', @{ $pkg->{'_columns_essential'} } ) . "/);\n";
	377	}
71046f4b	378
41a7b982	379	#
	380	# Set up FK fields for lazy loading on request.
	381	#
	382	if ( $pkg->{'_columns_others'} ) {
	383	$create .= $pkg_name
	384	. "->columns(Others => qw/"
	385	. join ( ' ', @{ $pkg->{'_columns_others'} } ) . "/);\n";
	386	}
71046f4b	387
41a7b982	388	$create .= "\n";
b789c790	389
bf4629e7	390	if ( my $pk = $pkg->{'pk_accessor'} ) {
	391	$create .= $pk;
	392	}
df602cfb	393
bf4629e7	394	if ( my @has_a = @{ $pkg->{'has_a'} \|\| [] } ) {
	395	$create .= $_ for @has_a;
	396	}
	397
41a7b982	398	foreach my $has_many_key ( keys %{ $pkg->{'has_many'} } ) {
	399	if ( my @has_many = @{ $pkg->{'has_many'}{$has_many_key} \|\| [] } ) {
	400	$create .= $_ for @has_many;
	401	}
	402	}
6c45056f	403	}
df602cfb	404
bf4629e7	405	$create .= "1;\n";
	406
	407	return $create;
f42e7027	408	}
	409
	410	1;
	411
bf4629e7	412	# -------------------------------------------------------------------
	413
	414	=pod
f42e7027	415
	416	=head1 NAME
	417
bf4629e7	418	SQL::Translator::Producer::ClassDBI - create Class::DBI classes from schema
f42e7027	419
	420	=head1 SYNOPSIS
	421
1eee27d3	422	Use this producer as you would any other from SQL::Translator. See
1eee27d3	423	L<SQL::Translator> for details.
f42e7027	424
1eee27d3	425	This package utilizes SQL::Translator's formatting methods
	426	format_package_name(), format_pk_name(), format_fk_name(), and
	427	format_table_name() as it creates classes, one per table in the schema
	428	provided. An additional base class is also created for database connectivity
	429	configuration. See L<Class::DBI> for details on how this works.
f42e7027	430
6c45056f	431	=head1 AUTHORS
f42e7027	432
6c45056f	433	Allen Day E<lt>allenday@ucla.eduE<gt>
5f054727	434	Ying Zhang E<lt>zyolive@yahoo.comE<gt>,
799df8f9	435	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.