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