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.59';
 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         $args->{$argtype} = {
 249           map { %{ $_ || {} } }
 250           ( delete $args->{$old_arg}, $args->{$argtype} )
 251         };
 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     #
 346     # Create a blank GraphViz object and see if we can produce the output type.
 347     #
 348     my $gv = GraphViz->new( %$args )
 349       or die sprintf ("Can't create GraphViz object: %s\n",
 350         $@ || 'reason unknown'
 351       );
 352
 353     my $output_method = "as_$args->{output_type}";
 354
 355     # the generators are AUTOLOADed so can't use ->can ($output_method)
 356     eval { $gv->$output_method };
 357     die "Invalid output type: '$args->{output_type}'" if $@;
 358
 359     #
 360     # Process tables definitions, create nodes
 361     #
 362     my %nj_registry; # for locations of fields for natural joins
 363     my @fk_registry; # for locations of fields for foreign keys
 364
 365     TABLE:
 366     for my $table ( $schema->get_tables ) {
 367
 368         my $table_name = $table->name;
 369         if ( @skip_tables_like or keys %skip_tables ) {
 370           next TABLE if $skip_tables{ $table_name };
 371           for my $regex ( @skip_tables_like ) {
 372             next TABLE if $table_name =~ $regex;
 373           }
 374         }
 375
 376         my @fields     = $table->get_fields;
 377         if ( $args->{show_fk_only} ) {
 378             @fields = grep { $_->is_foreign_key } @fields;
 379         }
 380
 381         my $field_str = '';
 382         if ($args->{show_fields}) {
 383             my @fmt_fields;
 384             for my $field (@fields) {
 385
 386               my $field_info;
 387               if ($args->{show_datatypes}) {
 388
 389                 my $field_type = $field->data_type;
 390                 my $size = $field->size;
 391
 392                 if ( $args->{friendly_ints} && $size && (lc ($field_type) eq 'integer') ) {
 393                   # Automatically translate to int2, int4, int8
 394                   # Type (Bits)     Max. Signed/Unsigned  Length
 395                   # tinyint* (8)    128                   3
 396                   #                 255                   3
 397                   # smallint (16)   32767                 5
 398                   #                 65535                 5
 399                   # mediumint* (24) 8388607               7
 400                   #                 16777215              8
 401                   # int (32)        2147483647            10
 402                   #                 4294967295            11
 403                   # bigint (64)     9223372036854775807   19
 404                   #                 18446744073709551615  20
 405                   #
 406                   # * tinyint and mediumint are nonstandard extensions which are
 407                   #   only available under MySQL (to my knowledge)
 408                   if ($size <= 3 and $args->{friendly_ints_extended}) {
 409                     $field_type = 'tinyint';
 410                   }
 411                   elsif ($size <= 5) {
 412                     $field_type = 'smallint';
 413                   }
 414                   elsif ($size <= 8 and $args->{friendly_ints_extended}) {
 415                     $field_type = 'mediumint';
 416                   }
 417                   elsif ($size <= 11) {
 418                     $field_type = 'integer';
 419                   }
 420                   else {
 421                     $field_type = 'bigint';
 422                   }
 423                 }
 424
 425                 $field_info = $field_type;
 426                 if ($args->{show_sizes} && $size && ($field_type =~ /^ (?: NUMERIC | DECIMAL | (VAR)?CHAR2? ) $/ix ) ) {
 427                   $field_info .= '(' . $size . ')';
 428                 }
 429               }
 430
 431               my $constraints;
 432               if ($args->{show_constraints}) {
 433                 my @constraints;
 434                 push(@constraints, 'PK') if $field->is_primary_key;
 435                 push(@constraints, 'FK') if $field->is_foreign_key;
 436                 push(@constraints, 'U')  if $field->is_unique;
 437                 push(@constraints, 'N')  if $field->is_nullable;
 438
 439                 $constraints = join (',', @constraints);
 440               }
 441
 442               # construct the field line from all info gathered so far
 443               push @fmt_fields, join (' ',
 444                 '-',
 445                 $field->name,
 446                 $field_info || (),
 447                 $constraints ? "[$constraints]" : (),
 448               );
 449             }
 450
 451             # join field lines with graphviz formatting
 452             $field_str = join ('\l', @fmt_fields) . '\l';
 453
 454         }
 455
 456         my $index_str = '';
 457         if ($args->{show_indexes}) {
 458
 459           my @fmt_indexes;
 460           for my $index ($table->get_indices) {
 461             next unless $index->is_valid;
 462
 463             push @fmt_indexes, join (' ',
 464               '*',
 465               $args->{show_index_names}
 466                 ? $index->name . ':'
 467                 : ()
 468               ,
 469               join (', ', $index->fields),
 470               ($index->type eq 'UNIQUE') ? '[U]' : (),
 471             );
 472            }
 473
 474           # join index lines with graphviz formatting (if any indexes at all)
 475           $index_str = join ('\l', @fmt_indexes) . '\l' if @fmt_indexes;
 476         }
 477
 478         my $name_str = $table_name . '\n';
 479
 480         # escape spaces
 481         for ($name_str, $field_str, $index_str) {
 482           $_ =~ s/ /\\ /g;
 483         }
 484
 485         my $node_args;
 486
 487         # only the 'record' type supports nice formatting
 488         if ($args->{node}{shape} eq 'record') {
 489
 490             # the necessity to supply shape => 'record' is a graphviz bug
 491             $node_args = {
 492               shape => 'record',
 493               label => sprintf ('{%s}',
 494                 join ('|',
 495                   $name_str,
 496                   $field_str || (),
 497                   $index_str || (),
 498                 ),
 499               ),
 500             };
 501         }
 502         else {
 503             my $sep = sprintf ('%s\n',
 504               '-' x ( (length $table_name) + 2)
 505             );
 506
 507             $node_args = {
 508               label => join ($sep,
 509                 $name_str,
 510                 $field_str || (),
 511                 $index_str || (),
 512               ),
 513             };
 514         }
 515
 516         if (my $cluster_name = $cluster{$table_name} ) {
 517           $node_args->{cluster} = $cluster_name;
 518         }
 519
 520         $gv->add_node ($table_name, %$node_args);
 521
 522         debug("Processing table '$table_name'");
 523
 524         debug("Fields = ", join(', ', map { $_->name } @fields));
 525
 526         for my $f ( @fields ) {
 527             my $name      = $f->name or next;
 528             my $is_pk     = $f->is_primary_key;
 529             my $is_unique = $f->is_unique;
 530
 531             #
 532             # Decide if we should skip this field.
 533             #
 534             if ( $args->{natural_join} ) {
 535                 next unless $is_pk || $f->is_foreign_key;
 536             }
 537
 538             my $constraints = $f->{'constraints'};
 539
 540             if ( $args->{natural_join} && !$skip_fields{ $name } ) {
 541                 push @{ $nj_registry{ $name } }, $table_name;
 542             }
 543         }
 544
 545         unless ( $args->{natural_join} ) {
 546             for my $c ( $table->get_constraints ) {
 547                 next unless $c->type eq FOREIGN_KEY;
 548                 my $fk_table = $c->reference_table or next;
 549
 550                 for my $field_name ( $c->fields ) {
 551                     for my $fk_field ( $c->reference_fields ) {
 552                         next unless defined $schema->get_table( $fk_table );
 553
 554                         # a condition is optional if at least one fk is nullable
 555                         push @fk_registry, [
 556                             $table_name,
 557                             $fk_table,
 558                             scalar (grep { $_->is_nullable } ($c->fields))
 559                         ];
 560                     }
 561                 }
 562             }
 563         }
 564     }
 565
 566     #
 567     # Process relationships, create edges
 568     #
 569     my (@table_bunches, %optional_constraints);
 570     if ( $args->{natural_join} ) {
 571         for my $field_name ( keys %nj_registry ) {
 572             my @table_names = @{ $nj_registry{ $field_name } || [] } or next;
 573             next if scalar @table_names == 1;
 574             push @table_bunches, [ @table_names ];
 575         }
 576     }
 577     else {
 578         for my $i (0 .. $#fk_registry) {
 579             my $fk = $fk_registry[$i];
 580             push @table_bunches, [$fk->[0], $fk->[1]];
 581             $optional_constraints{$i} = $fk->[2];
 582         }
 583     }
 584
 585     my %done;
 586     for my $bi (0 .. $#table_bunches) {
 587         my @tables = @{$table_bunches[$bi]};
 588
 589         for my $i ( 0 .. $#tables ) {
 590             my $table1 = $tables[ $i ];
 591             for my $j ( 1 .. $#tables ) {
 592                 next if $i == $j;
 593                 my $table2 = $tables[ $j ];
 594                 next if $done{ $table1 }{ $table2 };
 595                 $gv->add_edge(
 596                     $table2,
 597                     $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 # -------------------------------------------------------------------
 627
 628 =pod
 629
 630 =head1 AUTHOR
 631
 632 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>
 633
 634 Jonathan Yu E<lt>frequency@cpan.orgE<gt>
 635
 636 =head1 SEE ALSO
 637
 638 SQL::Translator, GraphViz
 639
 640 =cut