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

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

use strict;
use warnings;
our $DEBUG;
our $VERSION = '1.59';
$DEBUG = 1 unless defined $DEBUG;

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

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

sub produce {
    my $t             = shift;
    local $DEBUG      = $t->debug;
    my $no_comments   = $t->no_comments;
    my $schema        = $t->schema;
    my $args          = $t->producer_args;
    my @create;

    if ( my $fmt = $args->{'format_pkg_name'} ) {
        $t->format_package_name( $fmt );
    }

    if ( my $fmt = $args->{'format_fk_name'} ) {
        $t->format_fk_name( $fmt );
    }

    my $db_user       = $args->{'db_user'} || '';
    my $db_pass       = $args->{'db_password'} || '';
    my $main_pkg_name = $args->{'package_name'} ||
                        # $args->{'main_pkg_name'} || # keep this? undocumented
                        $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;
    for my $table ( $schema->get_tables ) {
        debug("PKG: Table = ", $table->name, "\n");
        my $is_link = 1;
        for 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 = join '::', $main_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_method  = join('::', $table_pkg_name,
                    $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];
#                my $fk_method  = join('::',
#                    $table_pkg_name, $t->format_fk_name( $ref_table )
#                );

                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 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" : '' );
    push @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} or next;
        next unless $pkg->{'pkg_name'};

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

                if ( $from ) {
                    push @create, join('',
                        $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;

                    push @create, join("\n",
                        $pkg_name."->table('".$pkg->{'table'}."');\n",
                        $pkg_name."->columns(All => qw/".
                        join(' ', @field_names)."/);\n\n",
                    );
                }

        push @create, "\n";

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

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

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

    push @create, "1;\n";

    return wantarray
        ? @create
        : join('', @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 uses 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 Youens-Clark E<lt>kclark@cpan.orgE<gt>.
Commit	Line	Data
f42e7027	1	package SQL::Translator::Producer::ClassDBI;
f42e7027	2
f42e7027	3	use strict;
f27f9229	4	use warnings;
0c04c5a2	5	our $DEBUG;
0c04c5a2	6	our $VERSION = '1.59';
41a7b982	7	$DEBUG = 1 unless defined $DEBUG;
f42e7027	8
6c45056f	9	use SQL::Translator::Schema::Constants;
73892176	10	use SQL::Translator::Utils qw(debug header_comment);
71046f4b	11	use Data::Dumper;
f42e7027	12
bf4629e7	13	my %CDBI_auto_pkgs = (
71046f4b	14	MySQL => 'mysql',
	15	PostgreSQL => 'Pg',
	16	Oracle => 'Oracle',
bf4629e7	17	);
bf4629e7	18
f42e7027	19	sub produce {
4d1e8cb4	20	my $t = shift;
4d1e8cb4	21	local $DEBUG = $t->debug;
390292d3	22	my $no_comments = $t->no_comments;
	23	my $schema = $t->schema;
	24	my $args = $t->producer_args;
4d1e8cb4	25	my @create;
4d1e8cb4	26
73892176	27	if ( my $fmt = $args->{'format_pkg_name'} ) {
	28	$t->format_package_name( $fmt );
	29	}
4d1e8cb4	30
73892176	31	if ( my $fmt = $args->{'format_fk_name'} ) {
	32	$t->format_fk_name( $fmt );
	33	}
4d1e8cb4	34
bf4629e7	35	my $db_user = $args->{'db_user'} \|\| '';
4330d04e	36	my $db_pass = $args->{'db_password'} \|\| '';
	37	my $main_pkg_name = $args->{'package_name'} \|\|
	38	# $args->{'main_pkg_name'} \|\| # keep this? undocumented
41a7b982	39	$t->format_package_name('DBI');
41a7b982	40	my $header = header_comment( __PACKAGE__, "# " );
390292d3	41	my $parser_type = ( split /::/, $t->parser_type )[-1];
41a7b982	42	my $from = $CDBI_auto_pkgs{$parser_type} \|\| '';
ea93df61	43	my $dsn = $args->{'dsn'} \|\| sprintf( 'dbi:%s:_',
	44	$CDBI_auto_pkgs{ $parser_type }
	45	? $CDBI_auto_pkgs{ $parser_type } : $parser_type
41a7b982	46	);
71046f4b	47	my $sep = '# ' . '-' x 67;
fe77d758	48
73892176	49
fe77d758	50	#
	51	# Identify "link tables" (have only PK and FK fields).
	52	#
	53	my %linkable;
	54	my %linktable;
73892176	55	for my $table ( $schema->get_tables ) {
73892176	56	debug("PKG: Table = ", $table->name, "\n");
fe77d758	57	my $is_link = 1;
73892176	58	for my $field ( $table->get_fields ) {
fe77d758	59	unless ( $field->is_primary_key or $field->is_foreign_key ) {
41a7b982	60	$is_link = 0;
fe77d758	61	last;
	62	}
	63	}
	64
	65	next unless $is_link;
41a7b982	66
fe77d758	67	foreach my $left ( $table->get_fields ) {
fe77d758	68	next unless $left->is_foreign_key;
41a7b982	69	my $lfk = $left->foreign_key_reference or next;
	70	my $lr_table = $schema->get_table( $lfk->reference_table )
	71	or next;
	72	my $lr_field_name = ( $lfk->reference_fields )[0];
fe77d758	73	my $lr_field = $lr_table->get_field($lr_field_name);
	74	next unless $lr_field->is_primary_key;
	75
	76	foreach my $right ( $table->get_fields ) {
	77	next if $left->name eq $right->name;
41a7b982	78
41a7b982	79	my $rfk = $right->foreign_key_reference or next;
fe77d758	80	my $rr_table = $schema->get_table( $rfk->reference_table )
41a7b982	81	or next;
41a7b982	82	my $rr_field_name = ( $rfk->reference_fields )[0];
fe77d758	83	my $rr_field = $rr_table->get_field($rr_field_name);
fe77d758	84	next unless $rr_field->is_primary_key;
41a7b982	85
c703e51d	86	$linkable{ $lr_table->name }{ $rr_table->name } = $table;
c703e51d	87	$linkable{ $rr_table->name }{ $lr_table->name } = $table;
fe77d758	88	$linktable{ $table->name } = $table;
	89	}
	90	}
	91	}
c703e51d	92
6c45056f	93	#
71046f4b	94	# Iterate over all tables
6c45056f	95	#
bf4629e7	96	my ( %packages, $order );
6c45056f	97	for my $table ( $schema->get_tables ) {
6c45056f	98	my $table_name = $table->name or next;
6c45056f	99
4330d04e	100	my $table_pkg_name = join '::', $main_pkg_name, $t->format_package_name($table_name);
73892176	101	$packages{ $table_pkg_name } = {
41a7b982	102	order => ++$order,
	103	pkg_name => $table_pkg_name,
	104	base => $main_pkg_name,
	105	table => $table_name,
bf4629e7	106	};
6c45056f	107
6c45056f	108	#
bf4629e7	109	# Primary key may have a differenct accessor method name
6c45056f	110	#
73892176	111	# if ( my $constraint = $table->primary_key ) {
	112	# my $field = ( $constraint->fields )[0];
	113	# $packages{ $table_pkg_name }{'_columns_primary'} = $field;
	114	#
	115	# if ( my $pk_xform = $t->format_pk_name ) {
	116	# my $pk_name = $pk_xform->( $table_pkg_name, $field );
	117	#
	118	# $packages{$table_pkg_name}{'pk_accessor'} =
	119	# "#\n# Primary key accessor\n#\n"
	120	# . "sub $pk_name {\n shift->$field\n}\n\n";
	121	# }
	122	# }
d79af833	123
	124	my $is_data = 0;
	125	foreach my $field ( $table->get_fields ) {
41a7b982	126	if ( !$field->is_foreign_key and !$field->is_primary_key ) {
	127	push @{ $packages{$table_pkg_name}{'_columns_essential'} },
	128	$field->name;
	129	$is_data++;
	130	}
	131	elsif ( !$field->is_primary_key ) {
	132	push @{ $packages{$table_pkg_name}{'_columns_others'} },
	133	$field->name;
	134	}
d79af833	135	}
d79af833	136
41a7b982	137	my %linked;
	138	if ($is_data) {
	139	foreach my $link ( keys %{ $linkable{$table_name} } ) {
	140	my $linkmethodname;
	141
	142	if ( my $fk_xform = $t->format_fk_name ) {
	143
	144	# ADD CALLBACK FOR PLURALIZATION MANGLING HERE
	145	$linkmethodname = $fk_xform->(
	146	$linkable{ $table_name }{ $link }->name,
	147	( $schema->get_table( $link )->primary_key->fields )[0]
	148	)
	149	. 's';
	150	}
	151	else {
	152	# ADD CALLBACK FOR PLURALIZATION MANGLING HERE
	153	$linkmethodname =
	154	$linkable{ $table_name }{ $link }->name . '_'
	155	. ( $schema->get_table( $link )->primary_key->fields )[0]
	156	. 's';
	157	}
	158
	159	my @rk_fields = ();
	160	my @lk_fields = ();
	161	foreach my $field ( $linkable{$table_name}{$link}->get_fields )
	162	{
	163	next unless $field->is_foreign_key;
	164
ea93df61	165	next unless (
41a7b982	166	$field->foreign_key_reference->reference_table eq
41a7b982	167	$table_name
ea93df61	168	\|\|
ea93df61	169	$field->foreign_key_reference->reference_table eq $link
41a7b982	170	);
	171
	172	push @lk_fields,
	173	( $field->foreign_key_reference->reference_fields )[0]
	174	if $field->foreign_key_reference->reference_table eq
	175	$link;
	176
	177	push @rk_fields, $field->name
	178	if $field->foreign_key_reference->reference_table eq
	179	$table_name;
	180	}
	181
	182	#
	183	# If one possible traversal via link table.
	184	#
	185	if ( scalar(@rk_fields) == 1 and scalar(@lk_fields) == 1 ) {
	186	foreach my $rk_field (@rk_fields) {
	187	push @{ $packages{$table_pkg_name}{'has_many'}{$link} },
	188	"sub "
	189	. $linkmethodname
	190	. " { my \$self = shift; "
	191	. "return map \$_->"
	192	. ( $schema->get_table($link)->primary_key->fields )
	193	[0]
	194	. ", \$self->"
	195	. $linkable{$table_name}{$link}->name . "_"
	196	. $rk_field
	197	. " }\n\n";
	198	}
	199
	200	#
	201	# Else there is more than one way to traverse it.
	202	# ack! Let's treat these types of link tables as
	203	# a many-to-one (easier)
	204	#
	205	# NOTE: we need to rethink the link method name,
	206	# as the cardinality has shifted on us.
	207	#
	208	}
	209	elsif ( scalar(@rk_fields) == 1 ) {
	210	foreach my $rk_field (@rk_fields) {
	211	#
	212	# ADD CALLBACK FOR PLURALIZATION MANGLING HERE
	213	#
	214	push @{ $packages{$table_pkg_name}{'has_many'}{$link} },
	215	"sub "
	216	. $linkable{$table_name}{$link}->name
	217	. "s { my \$self = shift; return \$self->"
	218	. $linkable{$table_name}{$link}->name . "_"
	219	. $rk_field
	220	. "(\@_) }\n\n";
	221	}
	222	}
	223	elsif ( scalar(@lk_fields) == 1 ) {
	224	#
	225	# These will be taken care of on the other end...
	226	#
	227	}
	228	else {
	229	#
	230	# Many many many. Need multiple iterations here,
	231	# data structure revision to handle N FK sources.
	232	# This code has not been tested and likely doesn't
	233	# work here.
234	#
235	foreach my $rk_field (@rk_fields) {
236	# ADD CALLBACK FOR PLURALIZATION MANGLING HERE
237	push @{ $packages{$table_pkg_name}{'has_many'}{$link} },
238	"sub "
239	. $linkable{$table_name}{$link}->name . "_"
240	. $rk_field
241	. "s { my \$self = shift; return \$self->"
242	. $linkable{$table_name}{$link}->name . "_"
243	. $rk_field
244	. "(\@_) }\n\n";
245	}
246	}
247	}
248	}
d79af833	249
6c45056f	250	#
bf4629e7	251	# Use foreign keys to set up "has_a/has_many" relationships.
6c45056f	252	#
	253	foreach my $field ( $table->get_fields ) {
	254	if ( $field->is_foreign_key ) {
bf4629e7	255	my $table_name = $table->name;
6c45056f	256	my $field_name = $field->name;
73892176	257	# my $fk_method = $t->format_fk_name( $table_name, $field_name );
ea93df61	258	my $fk_method = join('::', $table_pkg_name,
73892176	259	$t->format_fk_name( $table_name, $field_name )
73892176	260	);
6c45056f	261	my $fk = $field->foreign_key_reference;
6c45056f	262	my $ref_table = $fk->reference_table;
f7cde540	263	my $ref_pkg = $t->format_package_name($ref_table);
41a7b982	264	my $ref_field = ( $fk->reference_fields )[0];
73892176	265	# my $fk_method = join('::',
	266	# $table_pkg_name, $t->format_fk_name( $ref_table )
	267	# );
6c45056f	268
41a7b982	269	push @{ $packages{$table_pkg_name}{'has_a'} },
	270	"$table_pkg_name->has_a(\n"
	271	. " $field_name => '$ref_pkg'\n);\n\n"
	272	. "sub $fk_method {\n"
73892176	273	. " return shift->$field_name\n}\n\n"
73892176	274	;
52fbac6a	275
41a7b982	276	# if there weren't M-M relationships via the has_many
	277	# being set up here, create nice pluralized method alias
	278	# rather for user as alt. to ugly tablename_fieldname name
	279	#
73892176	280	# if ( !$packages{$ref_pkg}{'has_many'}{$table_name} ) {
	281	# #
	282	# # ADD CALLBACK FOR PLURALIZATION MANGLING HERE
	283	# #
	284	# push @{ $packages{$ref_pkg}{'has_many'}{$table_name} },
	285	# "sub ${table_name}s {\n " .
	286	# "return shift->$table_name\_$field_name\n}\n\n";
	287	# # else ugly
	288	# }
	289	# else {
	290	# }
41a7b982	291
	292	push @{ $packages{$ref_pkg}{'has_many'}{$table_name} },
	293	"$ref_pkg->has_many(\n '${table_name}_${field_name}', "
	294	. "'$table_pkg_name' => '$field_name'\n);\n\n";
71046f4b	295
fe77d758	296	}
41a7b982	297	}
41a7b982	298	}
6c45056f	299
fe77d758	300	#
	301	# Now build up text of package.
	302	#
bf4629e7	303	my $base_pkg = sprintf( 'Class::DBI%s', $from ? "::$from" : '' );
4d1e8cb4	304	push @create, join ( "\n",
41a7b982	305	"package $main_pkg_name;\n",
	306	$header,
	307	"use strict;",
	308	"use base '$base_pkg';\n",
	309	"$main_pkg_name->set_db('Main', '$dsn', '$db_user', '$db_pass');\n\n",
	310	);
	311
	312	for my $pkg_name (
bf4629e7	313	sort { $packages{ $a }{'order'} <=> $packages{ $b }{'order'} }
	314	keys %packages
	315	) {
8b183a02	316	my $pkg = $packages{$pkg_name} or next;
8b183a02	317	next unless $pkg->{'pkg_name'};
bf4629e7	318
4d1e8cb4	319	push @create, join ( "\n",
bf4629e7	320	$sep,
41a7b982	321	"package " . $pkg->{'pkg_name'} . ";",
41a7b982	322	"use base '" . $pkg->{'base'} . "';",
bf4629e7	323	"use Class::DBI::Pager;\n\n",
41a7b982	324	);
41a7b982	325
9c6eb8e3	326	if ( $from ) {
4d1e8cb4	327	push @create, join('',
	328	$pkg->{'pkg_name'},
	329	"->set_up_table('",
	330	$pkg->{'table'},
	331	"');\n\n"
	332	);
9c6eb8e3	333	}
	334	else {
	335	my $table = $schema->get_table( $pkg->{'table'} );
	336	my @field_names = map { $_->name } $table->get_fields;
ea93df61	337
4d1e8cb4	338	push @create, join("\n",
9c6eb8e3	339	$pkg_name."->table('".$pkg->{'table'}."');\n",
	340	$pkg_name."->columns(All => qw/".
	341	join(' ', @field_names)."/);\n\n",
	342	);
	343	}
b789c790	344
4d1e8cb4	345	push @create, "\n";
b789c790	346
bf4629e7	347	if ( my $pk = $pkg->{'pk_accessor'} ) {
4d1e8cb4	348	push @create, $pk;
bf4629e7	349	}
df602cfb	350
bf4629e7	351	if ( my @has_a = @{ $pkg->{'has_a'} \|\| [] } ) {
4d1e8cb4	352	push @create, $_ for @has_a;
bf4629e7	353	}
bf4629e7	354
41a7b982	355	foreach my $has_many_key ( keys %{ $pkg->{'has_many'} } ) {
41a7b982	356	if ( my @has_many = @{ $pkg->{'has_many'}{$has_many_key} \|\| [] } ) {
4d1e8cb4	357	push @create, $_ for @has_many;
41a7b982	358	}
41a7b982	359	}
6c45056f	360	}
df602cfb	361
4d1e8cb4	362	push @create, "1;\n";
bf4629e7	363
4d1e8cb4	364	return wantarray
	365	? @create
	366	: join('', @create);
f42e7027	367	}
	368
	369	1;
	370
bf4629e7	371	=pod
f42e7027	372
	373	=head1 NAME
	374
bf4629e7	375	SQL::Translator::Producer::ClassDBI - create Class::DBI classes from schema
f42e7027	376
	377	=head1 SYNOPSIS
	378
1eee27d3	379	Use this producer as you would any other from SQL::Translator. See
1eee27d3	380	L<SQL::Translator> for details.
f42e7027	381
4d1e8cb4	382	This package uses SQL::Translator's formatting methods
1eee27d3	383	format_package_name(), format_pk_name(), format_fk_name(), and
	384	format_table_name() as it creates classes, one per table in the schema
	385	provided. An additional base class is also created for database connectivity
	386	configuration. See L<Class::DBI> for details on how this works.
f42e7027	387
6c45056f	388	=head1 AUTHORS
f42e7027	389
7c2e6f47	390	Allen Day E<lt>allenday@ucla.eduE<gt>,
5f054727	391	Ying Zhang E<lt>zyolive@yahoo.comE<gt>,
4d1e8cb4	392	Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.