X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FProducer%2FGraphViz.pm;h=f17a9d320996ef07598b84fe23272392b82703a6;hb=ac7adbab6451299d70b5ecc59c6bb7f8a6f9473b;hp=42ba5d03a00d058e73d5171d4d2bc4ad8927c853;hpb=d4f84dd192edc7a64a0b1a9923f1bafc0bc5ef9d;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Producer/GraphViz.pm b/lib/SQL/Translator/Producer/GraphViz.pm index 42ba5d0..f17a9d3 100644 --- a/lib/SQL/Translator/Producer/GraphViz.pm +++ b/lib/SQL/Translator/Producer/GraphViz.pm @@ -1,25 +1,5 @@ package SQL::Translator::Producer::GraphViz; -# ------------------------------------------------------------------- -# $Id: GraphViz.pm 1451 2009-02-10 11:48:37Z ribasushi $ -# ------------------------------------------------------------------- -# Copyright (C) 2002-2009 SQLFairy Authors -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License as -# published by the Free Software Foundation; version 2. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -# 02111-1307 USA -# ------------------------------------------------------------------- - =pod =head1 NAME @@ -30,15 +10,15 @@ SQL::Translator::Producer::GraphViz - GraphViz producer for SQL::Translator use SQL::Translator; - my $trans = new SQL::Translator( + my $trans = SQL::Translator->new( from => 'MySQL', # or your db of choice - to => 'GraphViz', + to => 'GraphViz', producer_args => { - out_file => 'schema.png', - add_color => 1, + out_file => 'schema.png', + bgcolor => 'lightgoldenrodyellow', show_constraints => 1, - show_datatypes => 1, - show_sizes => 1 + show_datatypes => 1, + show_sizes => 1 } ) or die SQL::Translator->error; @@ -48,412 +28,452 @@ SQL::Translator::Producer::GraphViz - GraphViz producer for SQL::Translator Creates a graph of a schema using the amazing graphviz (see http://www.graphviz.org/) application (via -the GraphViz module). It's nifty--you should try it! +the L module). It's nifty--you should try it! =head1 PRODUCER ARGS -=over 4 +All L constructor attributes are accepted and passed +through to L. The following defaults are assumed +for some attributes: -=item * out_file + layout => 'dot', + overlap => 'false', -The name of the file where the resulting GraphViz output will be -written. Alternatively an open filehandle can be supplied. If -undefined (the default) - the result is returned as a string. + node => { + shape => 'record', + style => 'filled', + fillcolor => 'white', + }, -=item * layout (DEFAULT: 'dot') + # in inches + width => 8.5, + height => 11, -determines which layout algorithm GraphViz will use; possible -values are 'dot' (the default GraphViz layout for directed graph -layouts), 'neato' (for undirected graph layouts - spring model) -or 'twopi' (for undirected graph layouts - circular) +See the documentation of L for more info on these +and other attributes. -=item * node_shape (DEFAULT: 'record') +In addition this producer accepts the following arguments: -sets the node shape of each table in the graph; this can be -one of 'record', 'plaintext', 'ellipse', 'circle', 'egg', -'triangle', 'box', 'diamond', 'trapezium', 'parallelogram', -'house', 'hexagon', or 'octagon' +=over 4 -=item * output_type (DEFAULT: 'png') +=item * skip_tables -sets the file type of the output graphic; possible values are -'ps', 'hpgl', 'pcl', 'mif', 'pic', 'gd', 'gd2', 'gif', 'jpeg', -'png', 'wbmp', 'cmap', 'ismap', 'imap', 'vrml', 'vtx', 'mp', -'fig', 'svg', 'canon', 'plain' or 'text' (see GraphViz for -details on each of these) +An arrayref or a comma-separated list of table names that should be +skipped. Note that a skipped table node may still appear if another +table has foreign key constraints pointing to the skipped table. If +this happens no table field/index information will be included. -=item * width (DEFAULT: 8.5) +=item * skip_tables_like -width (in inches) of the output graphic +An arrayref or a comma-separated list of regular expressions matching +table names that should be skipped. -=item * height (DEFAULT: 11) +=item * cluster -height (in inches) of the output grahic +Clustering of tables allows you to group and box tables according to +function or domain or whatever criteria you choose. The syntax for +clustering tables is: -=item * fontsize + cluster => 'cluster1=table1,table2;cluster2=table3,table4' -custom font size for node and edge labels (note that arbitrarily large -sizes may be ignored due to page size or graph size constraints) +Or pass it as an arrayref like so: -=item * fontname + cluster => [ 'cluster1=table1,table2', 'cluster2=table3,table4' ] -custom font name (or full path to font file) for node, edge, and graph -labels +Or like so: -=item * nodeattrs + cluster => [ + { name => 'cluster1', tables => [ 'table1', 'table2' ] }, + { name => 'cluster2', tables => [ 'table3', 'table4' ] }, + ] -reference to a hash of node attribute names and their values; these -may override general fontname or fontsize parameter +=item * out_file -=item * edgeattrs +The name of the file where the resulting GraphViz output will be +written. Alternatively an open filehandle can be supplied. If +undefined (the default) - the result is returned as a string. + +=item * output_type (DEFAULT: 'png') -reference to a hash of edge attribute names and their values; these -may override general fontname or fontsize parameter +This determines which +L +will be invoked to generate the graph: C translates to +C, C to C and so on. -=item * graphattrs +=item * fontname + +This sets the global font name (or full path to font file) for +node, edge, and graph labels + +=item * fontsize -reference to a hash of graph attribute names and their values; these -may override the general fontname parameter +This sets the global font size for node and edge labels (note that +arbitrarily large sizes may be ignored due to page size or graph size +constraints) =item * show_fields (DEFAULT: true) -if set to a true value, the names of the colums in a table will +If set to a true value, the names of the columns in a table will be displayed in each table's node =item * show_fk_only -if set to a true value, only columns which are foreign keys +If set to a true value, only columns which are foreign keys will be displayed in each table's node =item * show_datatypes -if set to a true value, the datatype of each column will be +If set to a true value, the datatype of each column will be displayed next to each column's name; this option will have no -effect if the value of show_fields is set to false +effect if the value of C is set to false + +=item * friendly_ints + +If set to a true value, each integer type field will be displayed +as a tinyint, smallint, integer or bigint depending on the field's +associated size parameter. This only applies for the C +type (and not the C type, which is always assumed to be a +32-bit integer); this option will have no effect if the value of +C is set to false + +=item * friendly_ints_extended + +If set to a true value, the friendly ints displayed will take into +account the non-standard types, 'tinyint' and 'mediumint' (which, +as far as I am aware, is only implemented in MySQL) =item * show_sizes -if set to a true value, the size (in bytes) of each CHAR and +If set to a true value, the size (in bytes) of each CHAR and VARCHAR column will be displayed in parentheses next to the column's name; this option will have no effect if the value of -show_fields is set to false +C is set to false =item * show_constraints -if set to a true value, a field's constraints (i.e., its +If set to a true value, a field's constraints (i.e., its primary-key-ness, its foreign-key-ness and/or its uniqueness) will appear as a comma-separated list in brackets next to the field's name; this option will have no effect if the value of -show_fields is set to false +C is set to false -=item * add_color +=item * show_indexes + +If set to a true value, each record will also show the indexes +set on each table. It describes the index types along with +which columns are included in the index. -if set to a true value, the graphic will have a background -color of 'lightgoldenrodyellow'; otherwise the background -color will be white +=item * show_index_names (DEFAULT: true) + +If C is set to a true value, then the value of this +parameter determines whether or not to print names of indexes. +if C is false, then a list of indexed columns +will appear below the field list. Otherwise, it will be a list +prefixed with the name of each index. =item * natural_join -if set to a true value, the make_natural_join method of -SQL::Translator::Schema will be called before generating the -graph; a true value for join_pk_only (see below) implies a -true value for this option +If set to a true value, L +will be called before generating the graph. =item * join_pk_only -the value of this option will be passed as the value of the -like-named argument in the make_natural_join method (see -natural_join above) of SQL::Translator::Schema, if either the -value of this option or the natural_join option is set to true +The value of this option will be passed as the value of the +like-named argument to L; +implies C<< natural_join => 1 >> =item * skip_fields -the value of this option will be passed as the value of the -like-named argument in the make_natural_join method (see -natural_join above) of SQL::Translator::Schema, if either -the natural_join or join_pk_only options has a true value +The value of this option will be passed as the value of the +like-named argument to L; +implies C<< natural_join => 1 >> -=item * show_indexes +=back -if set to a true value, each record will also show the indexes -set on each table. it describes the index types along with -which columns are included in the index. this option requires -that show_fields is a true value as well +=head2 DEPRECATED ARGS -=item * show_index_names +=over 4 -if show_indexes is set to a true value, then the value of this -parameter determines whether or not to print names of indexes. -if show_index_names is false, then a list of indexed columns -will appear below the field list. otherwise, it will be a list -prefixed with the name of each index. it defaults to true. +=item * node_shape -=item * friendly_ints +Deprecated, use node => { shape => ... } instead -if set to a true value, each integer type field will be displayed -as a smallint, integer or bigint depending on the field's -associated size parameter. this only applies for the 'integer' -type (and not the lowercase 'int' type, which is assumed to be a -32-bit integer). +=item * add_color -=item * friendly_ints_extended +Deprecated, use bgcolor => 'lightgoldenrodyellow' instead -if set to a true value, the friendly ints displayed will take into -account the non-standard types, 'tinyint' and 'mediumint' (which, -as far as I am aware, is only implemented in MySQL) +If set to a true value, the graphic will have a background +color of 'lightgoldenrodyellow'; otherwise the default +white background will be used + +=item * nodeattrs + +Deprecated, use node => { ... } instead + +=item * edgeattrs + +Deprecated, use edge => { ... } instead + +=item * graphattrs + +Deprecated, use graph => { ... } instead =back =cut +use warnings; use strict; use GraphViz; use SQL::Translator::Schema::Constants; use SQL::Translator::Utils qw(debug); use Scalar::Util qw/openhandle/; -use vars qw[ $VERSION $DEBUG ]; -$VERSION = sprintf "%d.%02d", q$Revision: 1451 $ =~ /(\d+)\.(\d+)/; +our $DEBUG; +our $VERSION = '1.59'; $DEBUG = 0 unless defined $DEBUG; -use constant VALID_LAYOUT => { - dot => 1, - neato => 1, - twopi => 1, -}; - -use constant VALID_NODE_SHAPE => { - record => 1, - plaintext => 1, - ellipse => 1, - circle => 1, - egg => 1, - triangle => 1, - box => 1, - diamond => 1, - trapezium => 1, - parallelogram => 1, - house => 1, - hexagon => 1, - octagon => 1, -}; - sub produce { my $t = shift; my $schema = $t->schema; my $args = $t->producer_args; local $DEBUG = $t->debug; - my $out_file = $args->{'out_file'} || ''; - my $layout = $args->{'layout'} || 'dot'; - my $node_shape = $args->{'node_shape'} || 'record'; - my $output_type = $args->{'output_type'} || 'png'; - my $width = defined $args->{'width'} - ? $args->{'width'} : 8.5; - my $height = defined $args->{'height'} - ? $args->{'height'} : 11; - my $fontsize = $args->{'fontsize'}; - my $fontname = $args->{'fontname'}; - my $edgeattrs = $args->{'edgeattrs'} || {}; - my $graphattrs = $args->{'graphattrs'} || {}; - my $nodeattrs = $args->{'nodeattrs'} || {}; - my $show_fields = defined $args->{'show_fields'} - ? $args->{'show_fields'} : 1; - my $add_color = $args->{'add_color'}; - my $natural_join = $args->{'natural_join'}; - my $show_fk_only = $args->{'show_fk_only'}; - my $show_datatypes = $args->{'show_datatypes'}; - my $show_sizes = $args->{'show_sizes'}; - my $show_indexes = $args->{'show_indexes'}; - my $show_index_names = defined $args->{'show_index_names'} ? $args->{'show_index_names'} : 1; - my $friendly_ints = $args->{'friendly_ints'}; - my $friendly_ints_ex = $args->{'friendly_ints_extended'}; - my $show_constraints = $args->{'show_constraints'}; - my $join_pk_only = $args->{'join_pk_only'}; - my $skip_fields = $args->{'skip_fields'} || ''; - my %skip = map { s/^\s+|\s+$//g; length $_ ? ($_, 1) : () } - split ( /,/, $skip_fields ); - $natural_join ||= $join_pk_only; - - $schema->make_natural_joins( - join_pk_only => $join_pk_only, - skip_fields => $args->{'skip_fields'}, - ) if $natural_join; + # translate legacy {node|edge|graph}attrs to just {node|edge|graph} + for my $argtype (qw/node edge graph/) { + my $old_arg = $argtype . 'attrs'; - die "Invalid layout '$layout'" unless VALID_LAYOUT->{ $layout }; - die "Invalid node shape'$node_shape'" - unless VALID_NODE_SHAPE->{ $node_shape }; + my %arglist = (map + { %{ $_ || {} } } + ( delete $args->{$old_arg}, delete $args->{$argtype} ) + ); - for ( $height, $width ) { - $_ = 0 unless $_ =~ /^\d+(.\d)?$/; - $_ = 0 if $_ < 0; + $args->{$argtype} = \%arglist if keys %arglist; } - my %args = ( - directed => $natural_join ? 0 : 1, - layout => $layout, - no_overlap => 1, - bgcolor => $add_color ? 'lightgoldenrodyellow' : 'white', - node => { - shape => $node_shape, - style => 'filled', - fillcolor => 'white', - }, - ); - $args{'width'} = $width if $width; - $args{'height'} = $height if $height; - # set fontsize for edge and node labels if specified - if ($fontsize) { - $args{'node'}->{'fontsize'} = $fontsize; - $args{'edge'} = {} unless $args{'edge'}; - $args{'edge'}->{'fontsize'} = $fontsize; - } - # set the font name globally for node, edge, and graph labels if - # specified (use node, edge, or graph attributes for individual - # font specification) - if ($fontname) { - $args{'node'}->{'fontname'} = $fontname; - $args{'edge'} = {} unless $args{'edge'}; - $args{'edge'}->{'fontname'} = $fontname; - $args{'graph'} = {} unless $args{'graph'}; - $args{'graph'}->{'fontname'} = $fontname; - } - # set additional node, edge, and graph attributes; these may - # possibly override ones set before - while (my ($key,$val) = each %$nodeattrs) { - $args{'node'}->{$key} = $val; + # explode font settings + for (qw/fontsize fontname/) { + if (defined $args->{$_}) { + $args->{node}{$_} ||= $args->{$_}; + $args->{edge}{$_} ||= $args->{$_}; + $args->{graph}{$_} ||= $args->{$_}; + } } - $args{'edge'} = {} if %$edgeattrs && !$args{'edge'}; - while (my ($key,$val) = each %$edgeattrs) { - $args{'edge'}->{$key} = $val; + + # legacy add_color setting, trumped by bgcolor if set + $args->{bgcolor} ||= 'lightgoldenrodyellow' if $args->{add_color}; + + # legacy node_shape setting, defaults to 'record', trumped by {node}{shape} + $args->{node}{shape} ||= ( $args->{node_shape} || 'record' ); + + # maintain defaults + $args->{layout} ||= 'dot'; + $args->{output_type} ||= 'png'; + $args->{overlap} ||= 'false'; + $args->{node}{style} ||= 'filled'; + $args->{node}{fillcolor} ||= 'white'; + + $args->{show_fields} = 1 if not exists $args->{show_fields}; + $args->{show_index_names} = 1 if not exists $args->{show_index_names}; + $args->{width} = 8.5 if not defined $args->{width}; + $args->{height} = 11 if not defined $args->{height}; + for ( $args->{height}, $args->{width} ) { + $_ = 0 unless $_ =~ /^\d+(?:.\d+)?$/; + $_ = 0 if $_ < 0; } - $args{'graph'} = {} if %$edgeattrs && !$args{'graph'}; - while (my ($key,$val) = each %$graphattrs) { - $args{'graph'}->{$key} = $val; + + # so split won't warn + $args->{$_} ||= '' for qw/skip_fields skip_tables skip_tables_like cluster/; + + my %skip_fields = map { s/^\s+|\s+$//g; length $_ ? ($_, 1) : () } + split ( /,/, $args->{skip_fields} ); + + my %skip_tables = map { $_, 1 } ( + ref $args->{skip_tables} eq 'ARRAY' + ? @{$args->{skip_tables}} + : split (/\s*,\s*/, $args->{skip_tables}) + ); + + my @skip_tables_like = map { qr/$_/ } ( + ref $args->{skip_tables_like} eq 'ARRAY' + ? @{$args->{skip_tables_like}} + : split (/\s*,\s*/, $args->{skip_tables_like}) + ); + + # join_pk_only/skip_fields implies natural_join + $args->{natural_join} = 1 + if ($args->{join_pk_only} or scalar keys %skip_fields); + + # usually we do not want direction when using natural join + $args->{directed} = ($args->{natural_join} ? 0 : 1) + if not exists $args->{directed}; + + $schema->make_natural_joins( + join_pk_only => $args->{join_pk_only}, + skip_fields => $args->{skip_fields}, + ) if $args->{natural_join}; + + my %cluster; + if ( defined $args->{'cluster'} ) { + my @clusters; + if ( ref $args->{'cluster'} eq 'ARRAY' ) { + @clusters = @{ $args->{'cluster'} }; + } + else { + @clusters = split /\s*;\s*/, $args->{'cluster'}; + } + + for my $c ( @clusters ) { + my ( $cluster_name, @cluster_tables ); + if ( ref $c eq 'HASH' ) { + $cluster_name = $c->{'name'} || $c->{'cluster_name'}; + @cluster_tables = @{ $c->{'tables'} || [] }; + } + else { + my ( $name, $tables ) = split /\s*=\s*/, $c; + $cluster_name = $name; + @cluster_tables = split /\s*,\s*/, $tables; + } + + for my $table ( @cluster_tables ) { + $cluster{ $table } = $cluster_name; + } + } } # # Create a blank GraphViz object and see if we can produce the output type. # - my $gv = GraphViz->new( %args ) or die "Can't create GraphViz object\n"; - my $output_method = "as_$output_type"; + my $gv = GraphViz->new( %$args ) + or die sprintf ("Can't create GraphViz object: %s\n", + $@ || 'reason unknown' + ); - # the generators are AUTOLOADed so can't use ->can ($output_method) - eval { $gv->$output_method }; - die "Invalid output type: '$output_type'" if $@; + my $output_method = "as_$args->{output_type}"; + # the generators are AUTOLOADed so can't use ->can ($output_method) + eval { $gv->$output_method }; + die "Invalid output type: '$args->{output_type}'" if $@; + # + # Process tables definitions, create nodes + # my %nj_registry; # for locations of fields for natural joins my @fk_registry; # for locations of fields for foreign keys + TABLE: for my $table ( $schema->get_tables ) { + + my $table_name = $table->name; + if ( @skip_tables_like or keys %skip_tables ) { + next TABLE if $skip_tables{ $table_name }; + for my $regex ( @skip_tables_like ) { + next TABLE if $table_name =~ $regex; + } + } + my @fields = $table->get_fields; - if ( $show_fk_only ) { + if ( $args->{show_fk_only} ) { @fields = grep { $_->is_foreign_key } @fields; } my $field_str = ''; - if ($show_fields) { - - my @fmt_fields; - foreach my $field (@fields) { - - my $field_type; - if ($show_datatypes) { - - $field_type = $field->data_type; - - # For the integer type, transform into different types based on - # requested size, if a size is given. - if ($field->size and $friendly_ints and (lc $field_type) eq 'integer') { - # Automatically translate to int2, int4, int8 - # Type (Bits) Max. Signed/Unsigned Length - # tinyint* (8) 128 3 - # 255 3 - # smallint (16) 32767 5 - # 65535 5 - # mediumint* (24) 8388607 7 - # 16777215 8 - # int (32) 2147483647 10 - # 4294967295 11 - # bigint (64) 9223372036854775807 19 - # 18446744073709551615 20 - # - # * tinyint and mediumint are nonstandard extensions which are - # only available under MySQL (to my knowledge) + if ($args->{show_fields}) { + my @fmt_fields; + for my $field (@fields) { + + my $field_info; + if ($args->{show_datatypes}) { + + my $field_type = $field->data_type; my $size = $field->size; - if ($size <= 3 and $friendly_ints_ex) { - $field_type = 'tinyint', - } - elsif ($size <= 5) { - $field_type = 'smallint'; - } - elsif ($size <= 8 and $friendly_ints_ex) { - $field_type = 'mediumint'; - } - elsif ($size <= 11) { - $field_type = 'integer'; + + if ( $args->{friendly_ints} && $size && (lc ($field_type) eq 'integer') ) { + # Automatically translate to int2, int4, int8 + # Type (Bits) Max. Signed/Unsigned Length + # tinyint* (8) 128 3 + # 255 3 + # smallint (16) 32767 5 + # 65535 5 + # mediumint* (24) 8388607 7 + # 16777215 8 + # int (32) 2147483647 10 + # 4294967295 11 + # bigint (64) 9223372036854775807 19 + # 18446744073709551615 20 + # + # * tinyint and mediumint are nonstandard extensions which are + # only available under MySQL (to my knowledge) + if ($size <= 3 and $args->{friendly_ints_extended}) { + $field_type = 'tinyint'; + } + elsif ($size <= 5) { + $field_type = 'smallint'; + } + elsif ($size <= 8 and $args->{friendly_ints_extended}) { + $field_type = 'mediumint'; + } + elsif ($size <= 11) { + $field_type = 'integer'; + } + else { + $field_type = 'bigint'; + } } - else { - $field_type = 'bigint'; + + $field_info = $field_type; + if ($args->{show_sizes} && $size && ($field_type =~ /^ (?: NUMERIC | DECIMAL | (VAR)?CHAR2? ) $/ix ) ) { + $field_info .= '(' . $size . ')'; } } - if ( - $show_sizes - and - $field->size - and - ($field_type =~ /^(var)?char2?$/ or $field_type eq 'numeric' or $field_type eq 'decimal') - ) { - $field_type .= '(' . $field->size . ')'; - } - } + my $constraints; + if ($args->{show_constraints}) { + my @constraints; + push(@constraints, $field->is_auto_increment ? 'PA' : 'PK') if $field->is_primary_key; + push(@constraints, 'FK') if $field->is_foreign_key; + push(@constraints, 'U') if $field->is_unique; + push(@constraints, 'N') if $field->is_nullable; - my $constraints; - if ($show_constraints) { - my @constraints; - push(@constraints, 'PK') if $field->is_primary_key; - push(@constraints, 'FK') if $field->is_foreign_key; - push(@constraints, 'U') if $field->is_unique; + $constraints = join (',', @constraints); + } - $constraints = join (',', @constraints); + # construct the field line from all info gathered so far + push @fmt_fields, join (' ', + '-', + $field->name, + $field_info || (), + $constraints ? "[$constraints]" : (), + ); } - # construct the field line from all info gathered so far - push @fmt_fields, join (' ', - '-', - $field->name, - $field_type || (), - $constraints ? "[$constraints]" : (), - ); - - } + # join field lines with graphviz formatting + $field_str = join ('\l', @fmt_fields) . '\l'; - # join field lines with graphviz formatting - $field_str = join ('\l', @fmt_fields) . '\l'; } my $index_str = ''; - if ($show_indexes) { + if ($args->{show_indexes}) { my @fmt_indexes; - foreach my $index ($table->get_indices) { + for my $index ($table->get_indices) { next unless $index->is_valid; push @fmt_indexes, join (' ', '*', - $show_index_names ? $index->name . ':' : (), + $args->{show_index_names} + ? $index->name . ':' + : () + , join (', ', $index->fields), ($index->type eq 'UNIQUE') ? '[U]' : (), ); - } + } # join index lines with graphviz formatting (if any indexes at all) $index_str = join ('\l', @fmt_indexes) . '\l' if @fmt_indexes; } - my $table_name = $table->name; my $name_str = $table_name . '\n'; # escape spaces @@ -461,12 +481,13 @@ sub produce { $_ =~ s/ /\\ /g; } + my $node_args; # only the 'record' type supports nice formatting - if ($node_shape eq 'record') { + if ($args->{node}{shape} eq 'record') { - # the necessity to supply shape => 'record' is a graphviz bug - $gv->add_node( $table_name, + # the necessity to supply shape => 'record' is a graphviz bug + $node_args = { shape => 'record', label => sprintf ('{%s}', join ('|', @@ -475,22 +496,27 @@ sub produce { $index_str || (), ), ), - ); + }; } else { my $sep = sprintf ('%s\n', - '-' x ( (length $table_name) + 2) + '-' x ( (length $table_name) + 2) ); - $gv->add_node( $table_name, - label => join ($sep, - $name_str, - $field_str || (), - $index_str || (), - ), - ); + $node_args = { + label => join ($sep, + $name_str, + $field_str || (), + $index_str || (), + ), + }; } + if (my $cluster_name = $cluster{$table_name} ) { + $node_args->{cluster} = $cluster_name; + } + + $gv->add_node(qq["$table_name"], %$node_args); debug("Processing table '$table_name'"); @@ -504,18 +530,18 @@ sub produce { # # Decide if we should skip this field. # - if ( $natural_join ) { + if ( $args->{natural_join} ) { next unless $is_pk || $f->is_foreign_key; } my $constraints = $f->{'constraints'}; - if ( $natural_join && !$skip{ $name } ) { + if ( $args->{natural_join} && !$skip_fields{ $name } ) { push @{ $nj_registry{ $name } }, $table_name; } } - unless ( $natural_join ) { + unless ( $args->{natural_join} ) { for my $c ( $table->get_constraints ) { next unless $c->type eq FOREIGN_KEY; my $fk_table = $c->reference_table or next; @@ -523,7 +549,13 @@ sub produce { for my $field_name ( $c->fields ) { for my $fk_field ( $c->reference_fields ) { next unless defined $schema->get_table( $fk_table ); - push @fk_registry, [ $table_name, $fk_table ]; + + # a condition is optional if at least one fk is nullable + push @fk_registry, [ + $table_name, + $fk_table, + scalar (grep { $_->is_nullable } ($c->fields)) + ]; } } } @@ -531,10 +563,10 @@ sub produce { } # - # Make the connections. + # Process relationships, create edges # - my @table_bunches; - if ( $natural_join ) { + my (@table_bunches, %optional_constraints); + if ( $args->{natural_join} ) { for my $field_name ( keys %nj_registry ) { my @table_names = @{ $nj_registry{ $field_name } || [] } or next; next if scalar @table_names == 1; @@ -542,56 +574,60 @@ sub produce { } } else { - @table_bunches = @fk_registry; + for my $i (0 .. $#fk_registry) { + my $fk = $fk_registry[$i]; + push @table_bunches, [$fk->[0], $fk->[1]]; + $optional_constraints{$i} = $fk->[2]; + } } my %done; - for my $bunch ( @table_bunches ) { - my @tables = @$bunch; + for my $bi (0 .. $#table_bunches) { + my @tables = @{$table_bunches[$bi]}; for my $i ( 0 .. $#tables ) { my $table1 = $tables[ $i ]; - for my $j ( 0 .. $#tables ) { + for my $j ( 1 .. $#tables ) { next if $i == $j; my $table2 = $tables[ $j ]; next if $done{ $table1 }{ $table2 }; - $gv->add_edge( $table2, $table1 ); + debug("Adding edge '$table2' -> '$table1'"); + $gv->add_edge( + qq["$table2"], + qq["$table1"], + arrowhead => $optional_constraints{$bi} ? 'empty' : 'normal', + ); $done{ $table1 }{ $table2 } = 1; - $done{ $table2 }{ $table1 } = 1; } } } # - # Print the image. + # Print the image # - if ( $out_file ) { - if (openhandle ($out_file)) { - print $out_file $gv->$output_method; - } - else { - open my $fh, ">$out_file" or die "Can't write '$out_file': $!\n"; - binmode $fh; - print $fh $gv->$output_method; - close $fh; - } + if ( my $out = $args->{out_file} ) { + if (openhandle ($out)) { + print $out $gv->$output_method; + } + else { + open my $fh, '>', $out or die "Can't write '$out': $!\n"; + binmode $fh; + print $fh $gv->$output_method; + close $fh; + } } else { - return $gv->$output_method; + return $gv->$output_method; } } 1; -# ------------------------------------------------------------------- - =pod =head1 AUTHOR -Ken Y. Clark Ekclark@cpan.orgE - -=head2 CONTRIBUTORS +Ken Youens-Clark Ekclark@cpan.orgE Jonathan Yu Efrequency@cpan.orgE