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

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

# -------------------------------------------------------------------
# $Id: ClassDBI.pm,v 1.34 2003-08-20 13:50:46 dlc 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.34 $ =~ /(\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 = $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 $pk_xform = $t->format_pk_name ) {
            if ( my $constraint = $table->primary_key ) {
                my $field          = ($constraint->fields)[0];
                my $pk_name        = $pk_xform->($table_pkg_name, $field);

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