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