1package SQL::Translator::Producer::ClassDBI;
2
3use strict;
4use warnings;
5our $DEBUG;
6our $VERSION = '1.62';
7$DEBUG = 1 unless defined $DEBUG;
8
9use SQL::Translator::Schema::Constants;
10use SQL::Translator::Utils qw(debug header_comment);
11use Data::Dumper;
12
13my %CDBI_auto_pkgs = (
14    MySQL      => 'mysql',
15    PostgreSQL => 'Pg',
16    Oracle     => 'Oracle',
17);
18
19sub produce {
20    my $t             = shift;
21    local $DEBUG      = $t->debug;
22    my $no_comments   = $t->no_comments;
23    my $schema        = $t->schema;
24    my $args          = $t->producer_args;
25    my @create;
26
27    if ( my $fmt = $args->{'format_pkg_name'} ) {
28        $t->format_package_name( $fmt );
29    }
30
31    if ( my $fmt = $args->{'format_fk_name'} ) {
32        $t->format_fk_name( $fmt );
33    }
34
35    my $db_user       = $args->{'db_user'} || '';
36    my $db_pass       = $args->{'db_password'} || '';
37    my $main_pkg_name = $args->{'package_name'} ||
38                        # $args->{'main_pkg_name'} || # keep this? undocumented
39                        $t->format_package_name('DBI');
40    my $header        = header_comment( __PACKAGE__, "# " );
41    my $parser_type   = ( split /::/, $t->parser_type )[-1];
42    my $from          = $CDBI_auto_pkgs{$parser_type} || '';
43    my $dsn           = $args->{'dsn'} || sprintf( 'dbi:%s:_',
44        $CDBI_auto_pkgs{ $parser_type }
45        ? $CDBI_auto_pkgs{ $parser_type } : $parser_type
46    );
47    my $sep           = '# ' . '-' x 67;
48
49
50    #
51    # Identify "link tables" (have only PK and FK fields).
52    #
53    my %linkable;
54    my %linktable;
55    for my $table ( $schema->get_tables ) {
56        debug("PKG: Table = ", $table->name, "\n");
57        my $is_link = 1;
58        for my $field ( $table->get_fields ) {
59            unless ( $field->is_primary_key or $field->is_foreign_key ) {
60                $is_link = 0;
61                last;
62            }
63        }
64
65        next unless $is_link;
66
67        foreach my $left ( $table->get_fields ) {
68            next unless $left->is_foreign_key;
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];
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;
78
79                my $rfk = $right->foreign_key_reference or next;
80                my $rr_table = $schema->get_table( $rfk->reference_table )
81                  or next;
82                my $rr_field_name = ( $rfk->reference_fields )[0];
83                my $rr_field      = $rr_table->get_field($rr_field_name);
84                next unless $rr_field->is_primary_key;
85
86                $linkable{ $lr_table->name }{ $rr_table->name } = $table;
87                $linkable{ $rr_table->name }{ $lr_table->name } = $table;
88                $linktable{ $table->name } = $table;
89            }
90        }
91    }
92
93    #
94    # Iterate over all tables
95    #
96    my ( %packages, $order );
97    for my $table ( $schema->get_tables ) {
98        my $table_name = $table->name or next;
99
100        my $table_pkg_name = join '::', $main_pkg_name, $t->format_package_name($table_name);
101        $packages{ $table_pkg_name } = {
102            order    => ++$order,
103            pkg_name => $table_pkg_name,
104            base     => $main_pkg_name,
105            table    => $table_name,
106        };
107
108        #
109        # Primary key may have a different accessor method name
110        #
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#        }
123
124        my $is_data = 0;
125        foreach my $field ( $table->get_fields ) {
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            }
135        }
136
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
165                    next unless (
166                        $field->foreign_key_reference->reference_table eq
167                           $table_name
168                        ||
169                        $field->foreign_key_reference->reference_table eq $link
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        }
249
250        #
251        # Use foreign keys to set up "has_a/has_many" relationships.
252        #
253        foreach my $field ( $table->get_fields ) {
254            if ( $field->is_foreign_key ) {
255                my $table_name = $table->name;
256                my $field_name = $field->name;
257#                my $fk_method  = $t->format_fk_name( $table_name, $field_name );
258                my $fk_method  = join('::', $table_pkg_name,
259                    $t->format_fk_name( $table_name, $field_name )
260                );
261                my $fk         = $field->foreign_key_reference;
262                my $ref_table  = $fk->reference_table;
263                my $ref_pkg    = $t->format_package_name($ref_table);
264                my $ref_field  = ( $fk->reference_fields )[0];
265#                my $fk_method  = join('::',
266#                    $table_pkg_name, $t->format_fk_name( $ref_table )
267#                );
268
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"
273                  . "    return shift->$field_name\n}\n\n"
274                ;
275
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                #
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#                }
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";
295
296            }
297        }
298    }
299
300    #
301    # Now build up text of package.
302    #
303    my $base_pkg = sprintf( 'Class::DBI%s', $from ? "::$from" : '' );
304    push @create, join ( "\n",
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 (
313        sort { $packages{ $a }{'order'} <=> $packages{ $b }{'order'} }
314        keys %packages
315    ) {
316        my $pkg = $packages{$pkg_name} or next;
317        next unless $pkg->{'pkg_name'};
318
319        push @create, join ( "\n",
320            $sep,
321            "package " . $pkg->{'pkg_name'} . ";",
322            "use base '" . $pkg->{'base'} . "';",
323            "use Class::DBI::Pager;\n\n",
324        );
325
326                if ( $from ) {
327                    push @create, join('',
328                        $pkg->{'pkg_name'},
329                        "->set_up_table('",
330                        $pkg->{'table'},
331                        "');\n\n"
332                    );
333                }
334                else {
335                    my $table       = $schema->get_table( $pkg->{'table'} );
336                    my @field_names = map { $_->name } $table->get_fields;
337
338                    push @create, join("\n",
339                        $pkg_name."->table('".$pkg->{'table'}."');\n",
340                        $pkg_name."->columns(All => qw/".
341                        join(' ', @field_names)."/);\n\n",
342                    );
343                }
344
345        push @create, "\n";
346
347        if ( my $pk = $pkg->{'pk_accessor'} ) {
348            push @create, $pk;
349        }
350
351        if ( my @has_a = @{ $pkg->{'has_a'} || [] } ) {
352            push @create, $_ for @has_a;
353        }
354
355        foreach my $has_many_key ( keys %{ $pkg->{'has_many'} } ) {
356            if ( my @has_many = @{ $pkg->{'has_many'}{$has_many_key} || [] } ) {
357                push @create, $_ for @has_many;
358            }
359        }
360    }
361
362    push @create, "1;\n";
363
364    return wantarray
365        ? @create
366        : join('', @create);
367}
368
3691;
370
371=pod
372
373=head1 NAME
374
375SQL::Translator::Producer::ClassDBI - create Class::DBI classes from schema
376
377=head1 SYNOPSIS
378
379Use this producer as you would any other from SQL::Translator.  See
380L<SQL::Translator> for details.
381
382This package uses SQL::Translator's formatting methods
383format_package_name(), format_pk_name(), format_fk_name(), and
384format_table_name() as it creates classes, one per table in the schema
385provided.  An additional base class is also created for database connectivity
386configuration.  See L<Class::DBI> for details on how this works.
387
388=head1 AUTHORS
389
390Allen Day E<lt>allenday@ucla.eduE<gt>,
391Ying Zhang E<lt>zyolive@yahoo.comE<gt>,
392Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
393