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