Allow passing an arrayref to SQLT->filename
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Producer / GraphViz.pm
1 package SQL::Translator::Producer::GraphViz;
2
3 =pod
4
5 =head1 NAME
6
7 SQL::Translator::Producer::GraphViz - GraphViz producer for SQL::Translator
8
9 =head1 SYNOPSIS
10
11   use SQL::Translator;
12
13   my $trans = SQL::Translator->new(
14       from => 'MySQL',            # or your db of choice
15       to   => 'GraphViz',
16       producer_args => {
17           out_file         => 'schema.png',
18           bgcolor          => 'lightgoldenrodyellow',
19           show_constraints => 1,
20           show_datatypes   => 1,
21           show_sizes       => 1
22       }
23   ) or die SQL::Translator->error;
24
25   $trans->translate or die $trans->error;
26
27 =head1 DESCRIPTION
28
29 Creates a graph of a schema using the amazing graphviz
30 (see http://www.graphviz.org/) application (via
31 the L<GraphViz> module).  It's nifty--you should try it!
32
33 =head1 PRODUCER ARGS
34
35 All L<GraphViz> constructor attributes are accepted and passed
36 through to L<GraphViz/new>. The following defaults are assumed
37 for some attributes:
38
39   layout => 'dot',
40   overlap => 'false',
41
42   node => {
43     shape => 'record',
44     style => 'filled',
45     fillcolor => 'white',
46   },
47
48   # in inches
49   width => 8.5,
50   height => 11,
51
52 See the documentation of L<GraphViz/new> for more info on these
53 and other attributes.
54
55 In addition this producer accepts the following arguments:
56
57 =over 4
58
59 =item * skip_tables
60
61 An arrayref or a comma-separated list of table names that should be
62 skipped. Note that a skipped table node may still appear if another
63 table has foreign key constraints pointing to the skipped table. If
64 this happens no table field/index information will be included.
65
66 =item * skip_tables_like
67
68 An arrayref or a comma-separated list of regular expressions matching
69 table names that should be skipped.
70
71 =item * cluster
72
73 Clustering of tables allows you to group and box tables according to
74 function or domain or whatever criteria you choose.  The syntax for
75 clustering tables is:
76
77   cluster => 'cluster1=table1,table2;cluster2=table3,table4'
78
79 Or pass it as an arrayref like so:
80
81   cluster => [ 'cluster1=table1,table2', 'cluster2=table3,table4' ]
82
83 Or like so:
84
85   cluster => [
86     { name => 'cluster1', tables => [ 'table1', 'table2' ] },
87     { name => 'cluster2', tables => [ 'table3', 'table4' ] },
88   ]
89
90 =item * out_file
91
92 The name of the file where the resulting GraphViz output will be
93 written. Alternatively an open filehandle can be supplied. If
94 undefined (the default) - the result is returned as a string.
95
96 =item * output_type (DEFAULT: 'png')
97
98 This determines which
99 L<output method|GraphViz/as_canon,_as_text,_as_gif_etc._methods>
100 will be invoked to generate the graph: C<png> translates to
101 C<as_png>, C<ps> to C<as_ps> and so on.
102
103 =item * fontname
104
105 This sets the global font name (or full path to font file) for
106 node, edge, and graph labels
107
108 =item * fontsize
109
110 This sets the global font size for node and edge labels (note that
111 arbitrarily large sizes may be ignored due to page size or graph size
112 constraints)
113
114 =item * show_fields (DEFAULT: true)
115
116 If set to a true value, the names of the colums in a table will
117 be displayed in each table's node
118
119 =item * show_fk_only
120
121 If set to a true value, only columns which are foreign keys
122 will be displayed in each table's node
123
124 =item * show_datatypes
125
126 If set to a true value, the datatype of each column will be
127 displayed next to each column's name; this option will have no
128 effect if the value of C<show_fields> is set to false
129
130 =item * friendly_ints
131
132 If set to a true value, each integer type field will be displayed
133 as a tinyint, smallint, integer or bigint depending on the field's
134 associated size parameter. This only applies for the C<integer>
135 type (and not the C<int> type, which is always assumed to be a
136 32-bit integer); this option will have no effect if the value of
137 C<show_fields> is set to false
138
139 =item * friendly_ints_extended
140
141 If set to a true value, the friendly ints displayed will take into
142 account the non-standard types, 'tinyint' and 'mediumint' (which,
143 as far as I am aware, is only implemented in MySQL)
144
145 =item * show_sizes
146
147 If set to a true value, the size (in bytes) of each CHAR and
148 VARCHAR column will be displayed in parentheses next to the
149 column's name; this option will have no effect if the value of
150 C<show_fields> is set to false
151
152 =item * show_constraints
153
154 If set to a true value, a field's constraints (i.e., its
155 primary-key-ness, its foreign-key-ness and/or its uniqueness)
156 will appear as a comma-separated list in brackets next to the
157 field's name; this option will have no effect if the value of
158 C<show_fields> is set to false
159
160 =item * show_indexes
161
162 If set to a true value, each record will also show the indexes
163 set on each table. It describes the index types along with
164 which columns are included in the index.
165
166 =item * show_index_names (DEFAULT: true)
167
168 If C<show_indexes> is set to a true value, then the value of this
169 parameter determines whether or not to print names of indexes.
170 if C<show_index_names> is false, then a list of indexed columns
171 will appear below the field list. Otherwise, it will be a list
172 prefixed with the name of each index.
173
174 =item * natural_join
175
176 If set to a true value, L<SQL::Translator::Schema/make_natural_joins>
177 will be called before generating the graph.
178
179 =item * join_pk_only
180
181 The value of this option will be passed as the value of the
182 like-named argument to L<SQL::Translator::Schema/make_natural_joins>;
183 implies C<< natural_join => 1 >>
184
185 =item * skip_fields
186
187 The value of this option will be passed as the value of the
188 like-named argument to L<SQL::Translator::Schema/make_natural_joins>;
189 implies C<< natural_join => 1 >>
190
191 =back
192
193 =head2 DEPRECATED ARGS
194
195 =over 4
196
197 =item * node_shape
198
199 Deprecated, use node => { shape => ... } instead
200
201 =item * add_color
202
203 Deprecated, use bgcolor => 'lightgoldenrodyellow' instead
204
205 If set to a true value, the graphic will have a background
206 color of 'lightgoldenrodyellow'; otherwise the default
207 white background will be used
208
209 =item * nodeattrs
210
211 Deprecated, use node => { ... } instead
212
213 =item * edgeattrs
214
215 Deprecated, use edge => { ... } instead
216
217 =item * graphattrs
218
219 Deprecated, use graph => { ... } instead
220
221 =back
222
223 =cut
224
225 use warnings;
226 use strict;
227 use GraphViz;
228 use SQL::Translator::Schema::Constants;
229 use SQL::Translator::Utils qw(debug);
230 use Scalar::Util qw/openhandle/;
231
232 our $DEBUG;
233 our $VERSION = '1.59';
234 $DEBUG   = 0 unless defined $DEBUG;
235
236 sub produce {
237     my $t          = shift;
238     my $schema     = $t->schema;
239     my $args       = $t->producer_args;
240     local $DEBUG   = $t->debug;
241
242     # translate legacy {node|edge|graph}attrs to just {node|edge|graph}
243     for my $argtype (qw/node edge graph/) {
244         my $old_arg = $argtype . 'attrs';
245
246         my %arglist = (map
247           { %{ $_ || {} } }
248           ( delete $args->{$old_arg}, delete $args->{$argtype} )
249         );
250
251         $args->{$argtype} = \%arglist if keys %arglist;
252     }
253
254     # explode font settings
255     for (qw/fontsize fontname/) {
256         if (defined $args->{$_}) {
257             $args->{node}{$_} ||= $args->{$_};
258             $args->{edge}{$_} ||= $args->{$_};
259             $args->{graph}{$_} ||= $args->{$_};
260         }
261     }
262
263     # legacy add_color setting, trumped by bgcolor if set
264     $args->{bgcolor} ||= 'lightgoldenrodyellow' if $args->{add_color};
265
266     # legacy node_shape setting, defaults to 'record', trumped by {node}{shape}
267     $args->{node}{shape} ||= ( $args->{node_shape} || 'record' );
268
269     # maintain defaults
270     $args->{layout}          ||= 'dot';
271     $args->{output_type}     ||= 'png';
272     $args->{overlap}         ||= 'false';
273     $args->{node}{style}     ||= 'filled';
274     $args->{node}{fillcolor} ||= 'white';
275
276     $args->{show_fields}    = 1 if not exists $args->{show_fields};
277     $args->{show_index_names} = 1 if not exists $args->{show_index_names};
278     $args->{width}          = 8.5 if not defined $args->{width};
279     $args->{height}         = 11 if not defined $args->{height};
280     for ( $args->{height}, $args->{width} ) {
281         $_ = 0 unless $_ =~ /^\d+(?:.\d+)?$/;
282         $_ = 0 if $_ < 0;
283     }
284
285     # so split won't warn
286     $args->{$_} ||= '' for qw/skip_fields skip_tables skip_tables_like cluster/;
287
288     my %skip_fields = map { s/^\s+|\s+$//g; length $_ ? ($_, 1) : () }
289                         split ( /,/, $args->{skip_fields} );
290
291     my %skip_tables      = map { $_, 1 } (
292       ref $args->{skip_tables} eq 'ARRAY'
293         ? @{$args->{skip_tables}}
294         : split (/\s*,\s*/, $args->{skip_tables})
295       );
296
297     my @skip_tables_like = map { qr/$_/ } (
298       ref $args->{skip_tables_like} eq 'ARRAY'
299         ? @{$args->{skip_tables_like}}
300         : split (/\s*,\s*/, $args->{skip_tables_like})
301       );
302
303     # join_pk_only/skip_fields implies natural_join
304     $args->{natural_join} = 1
305       if ($args->{join_pk_only} or scalar keys %skip_fields);
306
307     # usually we do not want direction when using natural join
308     $args->{directed} = ($args->{natural_join} ? 0 : 1)
309       if not exists $args->{directed};
310
311     $schema->make_natural_joins(
312         join_pk_only => $args->{join_pk_only},
313         skip_fields  => $args->{skip_fields},
314     ) if $args->{natural_join};
315
316     my %cluster;
317     if ( defined $args->{'cluster'} ) {
318         my @clusters;
319         if ( ref $args->{'cluster'} eq 'ARRAY' ) {
320             @clusters = @{ $args->{'cluster'} };
321         }
322         else {
323             @clusters = split /\s*;\s*/, $args->{'cluster'};
324         }
325
326         for my $c ( @clusters ) {
327             my ( $cluster_name, @cluster_tables );
328             if ( ref $c eq 'HASH' ) {
329                 $cluster_name   = $c->{'name'} || $c->{'cluster_name'};
330                 @cluster_tables = @{ $c->{'tables'} || [] };
331             }
332             else {
333                 my ( $name, $tables ) = split /\s*=\s*/, $c;
334                 $cluster_name   = $name;
335                 @cluster_tables = split /\s*,\s*/, $tables;
336             }
337
338             for my $table ( @cluster_tables ) {
339                 $cluster{ $table } = $cluster_name;
340             }
341         }
342     }
343
344     #
345     # Create a blank GraphViz object and see if we can produce the output type.
346     #
347     my $gv = GraphViz->new( %$args )
348       or die sprintf ("Can't create GraphViz object: %s\n",
349         $@ || 'reason unknown'
350       );
351
352     my $output_method = "as_$args->{output_type}";
353
354     # the generators are AUTOLOADed so can't use ->can ($output_method)
355     eval { $gv->$output_method };
356     die "Invalid output type: '$args->{output_type}'" if $@;
357
358     #
359     # Process tables definitions, create nodes
360     #
361     my %nj_registry; # for locations of fields for natural joins
362     my @fk_registry; # for locations of fields for foreign keys
363
364     TABLE:
365     for my $table ( $schema->get_tables ) {
366
367         my $table_name = $table->name;
368         if ( @skip_tables_like or keys %skip_tables ) {
369           next TABLE if $skip_tables{ $table_name };
370           for my $regex ( @skip_tables_like ) {
371             next TABLE if $table_name =~ $regex;
372           }
373         }
374
375         my @fields     = $table->get_fields;
376         if ( $args->{show_fk_only} ) {
377             @fields = grep { $_->is_foreign_key } @fields;
378         }
379
380         my $field_str = '';
381         if ($args->{show_fields}) {
382             my @fmt_fields;
383             for my $field (@fields) {
384
385               my $field_info;
386               if ($args->{show_datatypes}) {
387
388                 my $field_type = $field->data_type;
389                 my $size = $field->size;
390
391                 if ( $args->{friendly_ints} && $size && (lc ($field_type) eq 'integer') ) {
392                   # Automatically translate to int2, int4, int8
393                   # Type (Bits)     Max. Signed/Unsigned  Length
394                   # tinyint* (8)    128                   3
395                   #                 255                   3
396                   # smallint (16)   32767                 5
397                   #                 65535                 5
398                   # mediumint* (24) 8388607               7
399                   #                 16777215              8
400                   # int (32)        2147483647            10
401                   #                 4294967295            11
402                   # bigint (64)     9223372036854775807   19
403                   #                 18446744073709551615  20
404                   #
405                   # * tinyint and mediumint are nonstandard extensions which are
406                   #   only available under MySQL (to my knowledge)
407                   if ($size <= 3 and $args->{friendly_ints_extended}) {
408                     $field_type = 'tinyint';
409                   }
410                   elsif ($size <= 5) {
411                     $field_type = 'smallint';
412                   }
413                   elsif ($size <= 8 and $args->{friendly_ints_extended}) {
414                     $field_type = 'mediumint';
415                   }
416                   elsif ($size <= 11) {
417                     $field_type = 'integer';
418                   }
419                   else {
420                     $field_type = 'bigint';
421                   }
422                 }
423
424                 $field_info = $field_type;
425                 if ($args->{show_sizes} && $size && ($field_type =~ /^ (?: NUMERIC | DECIMAL | (VAR)?CHAR2? ) $/ix ) ) {
426                   $field_info .= '(' . $size . ')';
427                 }
428               }
429
430               my $constraints;
431               if ($args->{show_constraints}) {
432                 my @constraints;
433                 push(@constraints, $field->is_auto_increment ? 'PA' : 'PK') if $field->is_primary_key;
434                 push(@constraints, 'FK') if $field->is_foreign_key;
435                 push(@constraints, 'U')  if $field->is_unique;
436                 push(@constraints, 'N')  if $field->is_nullable;
437
438                 $constraints = join (',', @constraints);
439               }
440
441               # construct the field line from all info gathered so far
442               push @fmt_fields, join (' ',
443                 '-',
444                 $field->name,
445                 $field_info || (),
446                 $constraints ? "[$constraints]" : (),
447               );
448             }
449
450             # join field lines with graphviz formatting
451             $field_str = join ('\l', @fmt_fields) . '\l';
452
453         }
454
455         my $index_str = '';
456         if ($args->{show_indexes}) {
457
458           my @fmt_indexes;
459           for my $index ($table->get_indices) {
460             next unless $index->is_valid;
461
462             push @fmt_indexes, join (' ',
463               '*',
464               $args->{show_index_names}
465                 ? $index->name . ':'
466                 : ()
467               ,
468               join (', ', $index->fields),
469               ($index->type eq 'UNIQUE') ? '[U]' : (),
470             );
471            }
472
473           # join index lines with graphviz formatting (if any indexes at all)
474           $index_str = join ('\l', @fmt_indexes) . '\l' if @fmt_indexes;
475         }
476
477         my $name_str = $table_name . '\n';
478
479         # escape spaces
480         for ($name_str, $field_str, $index_str) {
481           $_ =~ s/ /\\ /g;
482         }
483
484         my $node_args;
485
486         # only the 'record' type supports nice formatting
487         if ($args->{node}{shape} eq 'record') {
488
489             # the necessity to supply shape => 'record' is a graphviz bug
490             $node_args = {
491               shape => 'record',
492               label => sprintf ('{%s}',
493                 join ('|',
494                   $name_str,
495                   $field_str || (),
496                   $index_str || (),
497                 ),
498               ),
499             };
500         }
501         else {
502             my $sep = sprintf ('%s\n',
503               '-' x ( (length $table_name) + 2)
504             );
505
506             $node_args = {
507               label => join ($sep,
508                 $name_str,
509                 $field_str || (),
510                 $index_str || (),
511               ),
512             };
513         }
514
515         if (my $cluster_name = $cluster{$table_name} ) {
516           $node_args->{cluster} = $cluster_name;
517         }
518
519         $gv->add_node(qq["$table_name"], %$node_args);
520
521         debug("Processing table '$table_name'");
522
523         debug("Fields = ", join(', ', map { $_->name } @fields));
524
525         for my $f ( @fields ) {
526             my $name      = $f->name or next;
527             my $is_pk     = $f->is_primary_key;
528             my $is_unique = $f->is_unique;
529
530             #
531             # Decide if we should skip this field.
532             #
533             if ( $args->{natural_join} ) {
534                 next unless $is_pk || $f->is_foreign_key;
535             }
536
537             my $constraints = $f->{'constraints'};
538
539             if ( $args->{natural_join} && !$skip_fields{ $name } ) {
540                 push @{ $nj_registry{ $name } }, $table_name;
541             }
542         }
543
544         unless ( $args->{natural_join} ) {
545             for my $c ( $table->get_constraints ) {
546                 next unless $c->type eq FOREIGN_KEY;
547                 my $fk_table = $c->reference_table or next;
548
549                 for my $field_name ( $c->fields ) {
550                     for my $fk_field ( $c->reference_fields ) {
551                         next unless defined $schema->get_table( $fk_table );
552
553                         # a condition is optional if at least one fk is nullable
554                         push @fk_registry, [
555                             $table_name,
556                             $fk_table,
557                             scalar (grep { $_->is_nullable } ($c->fields))
558                         ];
559                     }
560                 }
561             }
562         }
563     }
564
565     #
566     # Process relationships, create edges
567     #
568     my (@table_bunches, %optional_constraints);
569     if ( $args->{natural_join} ) {
570         for my $field_name ( keys %nj_registry ) {
571             my @table_names = @{ $nj_registry{ $field_name } || [] } or next;
572             next if scalar @table_names == 1;
573             push @table_bunches, [ @table_names ];
574         }
575     }
576     else {
577         for my $i (0 .. $#fk_registry) {
578             my $fk = $fk_registry[$i];
579             push @table_bunches, [$fk->[0], $fk->[1]];
580             $optional_constraints{$i} = $fk->[2];
581         }
582     }
583
584     my %done;
585     for my $bi (0 .. $#table_bunches) {
586         my @tables = @{$table_bunches[$bi]};
587
588         for my $i ( 0 .. $#tables ) {
589             my $table1 = $tables[ $i ];
590             for my $j ( 1 .. $#tables ) {
591                 next if $i == $j;
592                 my $table2 = $tables[ $j ];
593                 next if $done{ $table1 }{ $table2 };
594                 debug("Adding edge '$table2' -> '$table1'");
595                 $gv->add_edge(
596                     qq["$table2"],
597                     qq["$table1"],
598                     arrowhead => $optional_constraints{$bi} ? 'empty' : 'normal',
599                 );
600                 $done{ $table1 }{ $table2 } = 1;
601             }
602         }
603     }
604
605     #
606     # Print the image
607     #
608     if ( my $out = $args->{out_file} ) {
609         if (openhandle ($out)) {
610             print $out $gv->$output_method;
611         }
612         else {
613             open my $fh, '>', $out or die "Can't write '$out': $!\n";
614             binmode $fh;
615             print $fh $gv->$output_method;
616             close $fh;
617         }
618     }
619     else {
620         return $gv->$output_method;
621     }
622 }
623
624 1;
625
626 =pod
627
628 =head1 AUTHOR
629
630 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>
631
632 Jonathan Yu E<lt>frequency@cpan.orgE<gt>
633
634 =head1 SEE ALSO
635
636 SQL::Translator, GraphViz
637
638 =cut