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