Commit | Line | Data |
37503827 |
1 | package SQL::Translator::Producer::Diagram; |
2 | |
3 | # ------------------------------------------------------------------- |
550022e5 |
4 | # $Id: Diagram.pm,v 1.2 2003-04-24 19:40:52 kycl4rk Exp $ |
37503827 |
5 | # ------------------------------------------------------------------- |
6 | # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org> |
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 GD; |
25 | use Data::Dumper; |
26 | use SQL::Translator::Utils qw(debug); |
27 | |
28 | use vars qw[ $VERSION $DEBUG ]; |
550022e5 |
29 | $VERSION = sprintf "%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/; |
37503827 |
30 | $DEBUG = 0 unless defined $DEBUG; |
31 | |
32 | use constant VALID_FONT_SIZE => { |
33 | small => 1, |
34 | medium => 1, |
35 | large => 1, |
36 | huge => 1, |
37 | }; |
38 | |
39 | use constant VALID_IMAGE_TYPE => { |
40 | png => 1, |
41 | jpeg => 1, |
42 | }; |
43 | |
44 | sub produce { |
45 | my ($t, $data) = @_; |
46 | my $args = $t->producer_args; |
47 | local $DEBUG = $t->debug; |
48 | debug("Data =\n", Dumper( $data )); |
49 | debug("Producer args =\n", Dumper( $args )); |
50 | |
51 | my $out_file = $args->{'out_file'} || ''; |
52 | my $image_type = $args->{'image_type'} || 'png'; |
53 | my $title = $args->{'title'} || $t->filename; |
54 | my $font_size = $args->{'font_size'} || 'medium'; |
55 | my $no_columns = $args->{'no_columns'}; |
56 | my $no_lines = $args->{'no_lines'}; |
57 | my $add_color = $args->{'add_color'}; |
58 | my $show_fk_only = $args->{'show_fk_only'}; |
59 | my $join_pk_only = $args->{'join_pk_only'}; |
60 | my $natural_join = $args->{'natural_join'} || $join_pk_only; |
61 | my $skip_fields = $args->{'skip_fields'}; |
62 | my %skip = map { $_, 1 } split ( /,/, $skip_fields ); |
63 | |
64 | die "Invalid image type '$image_type'" |
65 | unless VALID_IMAGE_TYPE ->{ $image_type }; |
66 | die "Invalid font size '$font_size'" |
67 | unless VALID_FONT_SIZE->{ $font_size }; |
68 | |
69 | # |
70 | # Layout the image. |
71 | # |
72 | my $font = |
73 | $font_size eq 'small' ? gdTinyFont : |
74 | $font_size eq 'medium' ? gdSmallFont : |
75 | $font_size eq 'large' ? gdLargeFont : gdGiantFont; |
76 | my $no_tables = scalar keys %$data; |
550022e5 |
77 | $no_columns = 0 unless $no_columns =~ /^\d+$/; |
37503827 |
78 | $no_columns ||= sprintf( "%.0f", sqrt( $no_tables ) + .5 ); |
79 | $no_columns ||= .5; |
80 | my $no_per_col = sprintf( "%.0f", $no_tables/$no_columns + .5 ); |
81 | |
82 | my @shapes; |
83 | my ( $max_x, $max_y ); # the furthest x and y used |
84 | my $orig_y = 40; # used to reset y for each column |
85 | my ( $x, $y ) = (30,$orig_y); # where to start |
86 | my $cur_col = 1; # the current column |
87 | my $no_this_col = 0; # number of tables in current column |
88 | my $this_col_x = $x; # current column's x |
89 | my $gutter = 30; # distance b/w columns |
90 | my %nj_registry; # for locations of fields for natural joins |
91 | my @fk_registry; # for locations of fields for foreign keys |
92 | my %table_x; # for max x of each table |
93 | my $field_no; # counter to give distinct no. to each field |
94 | my %legend; |
95 | |
96 | # |
97 | # If necessary, pre-process fields to find foreign keys. |
98 | # |
99 | if ( $show_fk_only && $natural_join ) { |
100 | my ( %common_keys, %pk ); |
101 | for my $table ( values %$data ) { |
102 | for my $index ( |
103 | @{ $table->{'indices'} || [] }, |
104 | @{ $table->{'constraints'} || [] }, |
105 | ) { |
106 | my @fields = @{ $index->{'fields'} || [] } or next; |
107 | if ( $index->{'type'} eq 'primary_key' ) { |
108 | $pk{ $_ } = 1 for @fields; |
109 | } |
110 | } |
111 | |
112 | for my $field ( values %{ $table->{'fields'} } ) { |
113 | push @{ $common_keys{ $field->{'name'} } }, |
114 | $table->{'table_name'}; |
115 | } |
116 | } |
117 | |
118 | for my $field ( keys %common_keys ) { |
119 | my @tables = @{ $common_keys{ $field } }; |
120 | next unless scalar @tables > 1; |
121 | for my $table ( @tables ) { |
122 | next if $join_pk_only and !defined $pk{ $field }; |
123 | $data->{ $table }{'fields'}{ $field }{'is_fk'} = 1; |
124 | } |
125 | } |
126 | } |
127 | else { |
128 | for my $table ( values %$data ) { |
129 | for my $field ( values %{ $table->{'fields'} } ) { |
130 | for my $constraint ( |
131 | grep { $_->{'type'} eq 'foreign_key' } |
132 | @{ $field->{'constraints'} } |
133 | ) { |
134 | my $ref_table = $constraint->{'reference_table'} or next; |
135 | my @ref_fields = @{$constraint->{'reference_fields'} || []}; |
136 | |
137 | unless ( @ref_fields ) { |
138 | for my $field ( |
139 | values %{ $data->{ $ref_table }{'fields'} } |
140 | ) { |
141 | for my $pk ( |
142 | grep { $_->{'type'} eq 'primary_key' } |
143 | @{ $field->{'constraints'} } |
144 | ) { |
145 | push @ref_fields, @{ $pk->{'fields'} }; |
146 | } |
147 | } |
148 | |
149 | $constraint->{'reference_fields'} = [ @ref_fields ]; |
150 | } |
151 | |
152 | for my $ref_field ( |
153 | @{ $constraint->{'reference_fields'} } |
154 | ) { |
155 | $data->{$ref_table}{'fields'}{$ref_field}{'is_fk'} = 1; |
156 | } |
157 | } |
158 | } |
159 | } |
160 | } |
161 | |
162 | |
163 | for my $table ( |
164 | map { $_->[1] } |
165 | sort { $a->[0] <=> $b->[0] } |
166 | map { [ $_->{'order'}, $_ ] } |
167 | values %$data |
168 | ) { |
169 | my $table_name = $table->{'table_name'}; |
170 | my $top = $y; |
171 | push @shapes, |
172 | [ 'string', $font, $this_col_x, $y, $table_name, 'black' ]; |
173 | |
174 | $y += $font->height + 2; |
175 | my $below_table_name = $y; |
176 | $y += 2; |
177 | my $this_max_x = |
178 | $this_col_x + ($font->width * length($table_name)); |
179 | |
180 | debug("Processing table '$table_name'"); |
181 | |
182 | my @fields = |
183 | map { $_->[1] } |
184 | sort { $a->[0] <=> $b->[0] } |
185 | map { [ $_->{'order'}, $_ ] } |
186 | values %{ $table->{'fields'} }; |
187 | |
188 | debug("Fields = ", join(', ', map { $_->{'name'} } @fields)); |
189 | |
190 | my ( %pk, %unique ); |
191 | for my $index ( |
192 | @{ $table->{'indices'} || [] }, |
193 | @{ $table->{'constraints'} || [] }, |
194 | ) { |
195 | my @fields = @{ $index->{'fields'} || [] } or next; |
196 | if ( $index->{'type'} eq 'primary_key' ) { |
197 | $pk{ $_ } = 1 for @fields; |
198 | } |
199 | elsif ( $index->{'type'} eq 'unique' ) { |
200 | $unique{ $_ } = 1 for @fields; |
201 | } |
202 | } |
203 | |
204 | debug("PK = ", join(', ', sort keys %pk)) if %pk; |
205 | debug("Unique = ", join(', ', sort keys %unique)) if %unique; |
206 | |
207 | my ( @fld_desc, $max_name ); |
208 | for my $f ( @fields ) { |
209 | my $name = $f->{'name'} or next; |
210 | my $is_pk = $pk{ $name }; |
211 | my $is_unique = $unique{ $name }; |
212 | |
213 | # |
214 | # Decide if we should skip this field. |
215 | # |
216 | if ( $show_fk_only ) { |
217 | if ( $natural_join ) { |
218 | next unless $is_pk || $f->{'is_fk'}; |
219 | } |
220 | else { |
221 | next unless $is_pk || $f->{'is_fk'} || |
222 | grep { $_->{'type'} eq 'foreign_key' } |
223 | @{ $f->{'constraints'} } |
224 | ; |
225 | } |
226 | } |
227 | |
228 | if ( $is_pk ) { |
229 | $name .= ' *'; |
230 | $legend{'Primary key'} = '*'; |
231 | } |
232 | elsif ( $is_unique ) { |
233 | $name .= ' [U]'; |
234 | $legend{'Unique constraint'} = '[U]'; |
235 | } |
236 | |
237 | my $size = @{ $f->{'size'} || [] } |
238 | ? '(' . join( ',', @{ $f->{'size'} } ) . ')' |
239 | : ''; |
240 | my $desc = join( ' ', map { $_ || () } $f->{'data_type'}, $size ); |
241 | |
242 | my $nlen = length $name; |
243 | $max_name = $nlen if $nlen > $max_name; |
244 | push @fld_desc, [ $name, $desc, $f->{'name'}, $is_pk ]; |
245 | } |
246 | |
247 | $max_name += 4; |
248 | for my $fld_desc ( @fld_desc ) { |
249 | my ( $name, $desc, $orig_name, $is_pk ) = @$fld_desc; |
250 | my $diff = $max_name - length $name; |
251 | $name .= ' ' x $diff; |
252 | $desc = $name . $desc; |
253 | |
254 | push @shapes, [ 'string', $font, $this_col_x, $y, $desc, 'black' ]; |
255 | $y += $font->height + 2; |
256 | my $length = $this_col_x + ( $font->width * length( $desc ) ); |
257 | $this_max_x = $length if $length > $this_max_x; |
258 | |
259 | my $constraints = $table->{'fields'}{ $orig_name }{'constraints'}; |
260 | |
261 | if ( $natural_join && !$skip{ $orig_name } ) { |
262 | push @{ $nj_registry{ $orig_name } }, $table_name; |
263 | } |
264 | elsif ( @{ $constraints || [] } ) { |
265 | for my $constraint ( @$constraints ) { |
266 | next unless $constraint->{'type'} eq 'foreign_key'; |
267 | for my $fk_field ( |
268 | @{ $constraint->{'reference_fields'} || [] } |
269 | ) { |
270 | my $fk_table = $constraint->{'reference_table'}; |
271 | next unless defined $data->{ $fk_table }; |
272 | push @fk_registry, [ |
273 | [ $table_name, $orig_name ], |
274 | [ $fk_table , $fk_field ], |
275 | ]; |
276 | } |
277 | } |
278 | } |
279 | |
280 | my $y_link = $y - $font->height/2; |
281 | $table->{'fields'}{ $orig_name }{'coords'} = { |
282 | left => [ $this_col_x - 6, $y_link ], |
283 | right => [ $length + 2 , $y_link ], |
284 | table => $table_name, |
285 | field_no => ++$field_no, |
286 | is_pk => $is_pk, |
287 | fld_name => $orig_name, |
288 | }; |
289 | } |
290 | |
291 | $this_max_x += 5; |
292 | $table_x{ $table_name } = $this_max_x + 5; |
293 | push @shapes, [ 'line', $this_col_x - 5, $below_table_name, |
294 | $this_max_x, $below_table_name, 'black' ]; |
295 | my @bounds = ( $this_col_x - 5, $top - 5, $this_max_x, $y + 5 ); |
296 | if ( $add_color ) { |
297 | unshift @shapes, [ |
298 | 'filledRectangle', |
299 | $bounds[0], $bounds[1], |
300 | $this_max_x, $below_table_name, |
301 | 'khaki' |
302 | ]; |
303 | unshift @shapes, [ 'filledRectangle', @bounds, 'white' ]; |
304 | } |
305 | push @shapes, [ 'rectangle', @bounds, 'black' ]; |
306 | $max_x = $this_max_x if $this_max_x > $max_x; |
307 | $y += 25; |
308 | |
309 | if ( ++$no_this_col == $no_per_col ) {# if we've filled up this column |
310 | $cur_col++; # up the column number |
311 | $no_this_col = 0; # reset the number of tables |
312 | $max_x += $gutter; # push the x over for next column |
313 | $this_col_x = $max_x; # remember the max x for this col |
314 | $max_y = $y if $y > $max_y; # note the max y |
315 | $y = $orig_y; # reset the y for next column |
316 | } |
317 | } |
318 | |
319 | # |
320 | # Connect the lines. |
321 | # |
322 | my %horz_taken; |
323 | my %done; |
324 | unless ( $no_lines ) { |
325 | my @position_bunches; |
326 | |
327 | if ( $natural_join ) { |
328 | for my $field_name ( keys %nj_registry ) { |
329 | my @positions; |
330 | my @table_names = |
331 | @{ $nj_registry{ $field_name } || [] } or next; |
332 | next if scalar @table_names == 1; |
333 | |
334 | for my $table_name ( @table_names ) { |
335 | push @positions, |
336 | $data->{$table_name}{'fields'}{ $field_name }{'coords'}; |
337 | } |
338 | |
339 | push @position_bunches, [ @positions ]; |
340 | } |
341 | } |
342 | else { |
343 | for my $pair ( @fk_registry ) { |
344 | push @position_bunches, [ |
345 | $data->{$pair->[0][0]}{'fields'}{ $pair->[0][1] }{'coords'}, |
346 | $data->{$pair->[1][0]}{'fields'}{ $pair->[1][1] }{'coords'}, |
347 | ]; |
348 | } |
349 | } |
350 | |
351 | my $is_directed = $natural_join ? 0 : 1; |
352 | |
353 | for my $bunch ( @position_bunches ) { |
354 | my @positions = @$bunch; |
355 | |
356 | for my $i ( 0 .. $#positions ) { |
357 | my $pos1 = $positions[ $i ]; |
358 | my ( $ax, $ay ) = @{ $pos1->{'left'} || [] } or next; |
359 | my ( $bx, $by ) = @{ $pos1->{'right'} || [] } or next; |
360 | my $table1 = $pos1->{'table'}; |
361 | my $fno1 = $pos1->{'field_no'}; |
362 | my $is_pk = $pos1->{'is_pk'}; |
363 | next if $join_pk_only and !$is_pk; |
364 | |
365 | for my $j ( 0 .. $#positions ) { |
366 | my $pos2 = $positions[ $j ]; |
367 | my ( $cx, $cy ) = @{ $pos2->{'left'} || [] } or next; |
368 | my ( $dx, $dy ) = @{ $pos2->{'right'} || [] } or next; |
369 | my $table2 = $pos2->{'table'}; |
370 | my $fno2 = $pos2->{'field_no'}; |
371 | next if $table1 eq $table2; |
372 | next if $done{ $fno1 }{ $fno2 }; |
373 | next if $fno1 == $fno2; |
374 | |
375 | my @distances = (); |
376 | push @distances, [ |
377 | abs ( $ax - $cx ) + abs ( $ay - $cy ), |
378 | [ $ax, $ay, $cx, $cy ], |
379 | [ 'left', 'left' ] |
380 | ]; |
381 | push @distances, [ |
382 | abs ( $ax - $dx ) + abs ( $ay - $dy ), |
383 | [ $ax, $ay, $dx, $dy ], |
384 | [ 'left', 'right' ], |
385 | ]; |
386 | push @distances, [ |
387 | abs ( $bx - $cx ) + abs ( $by - $cy ), |
388 | [ $bx, $by, $cx, $cy ], |
389 | [ 'right', 'left' ], |
390 | ]; |
391 | push @distances, [ |
392 | abs ( $bx - $dx ) + abs ( $by - $dy ), |
393 | [ $bx, $by, $dx, $dy ], |
394 | [ 'right', 'right' ], |
395 | ]; |
396 | @distances = sort { $a->[0] <=> $b->[0] } @distances; |
397 | my $shortest = $distances[0]; |
398 | my ( $x1, $y1, $x2, $y2 ) = @{ $shortest->[1] }; |
399 | my ( $side1, $side2 ) = @{ $shortest->[2] }; |
400 | my ( $start, $end ); |
401 | my $offset = 9; |
402 | my $col1_right = $table_x{ $table1 }; |
403 | my $col2_right = $table_x{ $table2 }; |
404 | |
405 | my $diff = 0; |
406 | if ( $x1 == $x2 ) { |
407 | while ( $horz_taken{ $x1 + $diff } ) { |
408 | $diff = $side1 eq 'left' ? $diff - 2 : $diff + 2; |
409 | } |
410 | $horz_taken{ $x1 + $diff } = 1; |
411 | } |
412 | |
413 | if ( $side1 eq 'left' ) { |
414 | $start = $x1 - $offset + $diff; |
415 | } |
416 | else { |
417 | $start = $col1_right + $diff; |
418 | } |
419 | |
420 | if ( $side2 eq 'left' ) { |
421 | $end = $x2 - $offset + $diff; |
422 | } |
423 | else { |
424 | $end = $col2_right + $diff; |
425 | } |
426 | |
427 | push @shapes, |
428 | [ 'line', $x1, $y1, $start, $y1, 'cadetblue' ]; |
429 | push @shapes, |
430 | [ 'line', $start, $y1, $end, $y2, 'cadetblue' ]; |
431 | push @shapes, |
432 | [ 'line', $end, $y2, $x2, $y2, 'cadetblue' ]; |
433 | |
434 | if ( $is_directed ) { |
435 | if ( |
436 | $side1 eq 'right' && $side2 eq 'left' |
437 | || |
438 | $side1 eq 'left' && $side2 eq 'left' |
439 | ) { |
440 | push @shapes, [ |
441 | 'line', $x2 - 3, $y2 - 3, $x2, $y2, 'cadetblue' |
442 | ]; |
443 | push @shapes, [ |
444 | 'line', $x2 - 3, $y2 + 3, $x2, $y2, 'cadetblue' |
445 | ]; |
446 | push @shapes, [ |
447 | 'line', $x2 - 3, $y2 - 3, $x2 - 3, $y2 +3, |
448 | 'cadetblue' |
449 | ]; |
450 | } |
451 | else { |
452 | push @shapes, [ |
453 | 'line', $x2 + 3, $y2 - 3, $x2, $y2, 'cadetblue' |
454 | ]; |
455 | push @shapes, [ |
456 | 'line', $x2 + 3, $y2 + 3, $x2, $y2, 'cadetblue' |
457 | ]; |
458 | push @shapes, [ |
459 | 'line', $x2 + 3, $y2 - 3, $x2 + 3, $y2 +3, |
460 | 'cadetblue' |
461 | ]; |
462 | } |
463 | } |
464 | |
465 | $done{ $fno1 }{ $fno2 } = 1; |
466 | $done{ $fno2 }{ $fno1 } = 1; |
467 | } |
468 | } |
469 | } |
470 | } |
471 | |
472 | # |
473 | # Add the title, legend and signature. |
474 | # |
475 | my $large_font = gdLargeFont; |
476 | my $title_len = $large_font->width * length $title; |
477 | push @shapes, [ |
478 | 'string', $large_font, $max_x/2 - $title_len/2, 10, $title, 'black' |
479 | ]; |
480 | |
481 | if ( %legend ) { |
482 | $max_y += 5; |
483 | push @shapes, [ |
484 | 'string', $font, $x, $max_y - $font->height - 4, 'Legend', 'black' |
485 | ]; |
486 | $max_y += $font->height + 4; |
487 | |
488 | my $longest; |
489 | for my $len ( map { length $_ } values %legend ) { |
490 | $longest = $len if $len > $longest; |
491 | } |
492 | $longest += 2; |
493 | |
494 | while ( my ( $key, $shape ) = each %legend ) { |
495 | my $space = $longest - length $shape; |
496 | push @shapes, [ |
497 | 'string', $font, $x, $max_y - $font->height - 4, |
498 | join( '', $shape, ' ' x $space, $key ), 'black' |
499 | ]; |
500 | |
501 | $max_y += $font->height + 4; |
502 | } |
503 | } |
504 | |
505 | my $sig = __PACKAGE__." $VERSION"; |
506 | my $sig_len = $font->width * length $sig; |
507 | push @shapes, [ |
508 | 'string', $font, $max_x - $sig_len, $max_y - $font->height - 4, |
509 | $sig, 'black' |
510 | ]; |
511 | |
512 | # |
513 | # Render the image. |
514 | # |
515 | my $gd = GD::Image->new( $max_x + 30, $max_y ); |
516 | unless ( $gd->can( $image_type ) ) { |
517 | die "GD can't create images of type '$image_type'\n"; |
518 | } |
519 | my %colors = map { $_->[0], $gd->colorAllocate( @{$_->[1]} ) } ( |
520 | [ white => [ 255, 255, 255 ] ], |
521 | [ beige => [ 245, 245, 220 ] ], |
522 | [ black => [ 0, 0, 0 ] ], |
523 | [ lightblue => [ 173, 216, 230 ] ], |
524 | [ cadetblue => [ 95, 158, 160 ] ], |
525 | [ lightgoldenrodyellow => [ 250, 250, 210 ] ], |
526 | [ khaki => [ 240, 230, 140 ] ], |
527 | [ red => [ 255, 0, 0 ] ], |
528 | ); |
529 | $gd->interlaced( 'true' ); |
530 | my $background_color = $add_color ? 'lightgoldenrodyellow' : 'white'; |
531 | $gd->fill( 0, 0, $colors{ $background_color } ); |
532 | for my $shape ( @shapes ) { |
533 | my $method = shift @$shape; |
534 | my $color = pop @$shape; |
535 | $gd->$method( @$shape, $colors{ $color } ); |
536 | } |
537 | |
538 | # |
539 | # Print the image. |
540 | # |
541 | if ( $out_file ) { |
542 | open my $fh, ">$out_file" or die "Can't write '$out_file': $!\n"; |
543 | print $fh $gd->$image_type; |
544 | close $fh; |
545 | } |
546 | else { |
550022e5 |
547 | return $gd->$image_type; |
37503827 |
548 | } |
549 | } |
550 | |
551 | 1; |
552 | |
553 | =pod |
554 | |
555 | =head1 NAME |
556 | |
557 | SQL::Translator::Producer::Diagram - ER diagram producer for SQL::Translator |
558 | |
559 | =head1 AUTHOR |
560 | |
561 | Ken Y. Clark E<lt>kclark@cpan.orgE<gt> |
562 | |
563 | =cut |