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