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 columns 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)) if $DEBUG;
 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