lib/SQL/Translator/Producer/GraphViz.pm

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