File Coverage

blib/lib/SQL/Translator/Producer/Diagram.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


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