X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FProducer%2FDiagram.pm;h=08b6dd3e1e70920f8b1ab6903f4857763ce1b3cb;hb=0c04c5a2210135419771878dc7e341a1cba52cca;hp=c23633b5bdd4ecf6c1509dee1d04fd45d1c32820;hpb=9f61e9f29e7135f22c7de55b4ef8ca4725166a26;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Producer/Diagram.pm b/lib/SQL/Translator/Producer/Diagram.pm index c23633b..08b6dd3 100644 --- a/lib/SQL/Translator/Producer/Diagram.pm +++ b/lib/SQL/Translator/Producer/Diagram.pm @@ -1,25 +1,5 @@ package SQL::Translator::Producer::Diagram; -# ------------------------------------------------------------------- -# $Id: Diagram.pm,v 1.11 2004-03-04 14:39:15 dlc Exp $ -# ------------------------------------------------------------------- -# Copyright (C) 2002-4 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 -# ------------------------------------------------------------------- - =head1 NAME SQL::Translator::Producer::Diagram - ER diagram producer for SQL::Translator @@ -30,19 +10,44 @@ Use via SQL::Translator: use SQL::Translator; - my $t = SQL::Translator->new( producer => 'Diagram', '...' ); + my $t = SQL::Translator->new( + from => 'MySQL', + to => 'GraphViz', + producer_args => { + # All args are optional + out_file => 'schema.png',# if not provided will return from translate() + output_type => 'png', # is default or 'jpeg' + title => 'My Schema', # default is filename + font_size => 'medium', # is default or 'small,' 'large' + imap_file => '', # filename to write image map coords + imap_url => '', # base URL for image map + gutter => 30 # is default, px distance b/w cols + num_columns => 5, # the number of columns + no_lines => 1, # do not draw lines to show FKs + add_color => 1, # give it some color + show_fk_only => 1, # show only fields used in FKs + join_pk_only => 1, # use only primary keys to figure PKs + natural_join => 1, # intuit FKs if not defined + skip_fields => [...], # list* of field names to exclude + skip_tables => [...], # list* of table names to exclude + skip_tables_like => [...], # list* of regexen to exclude tables + } + ) or die SQL::Translator->error; $t->translate; +* "list" can be either an array-ref or a comma-separated string + =cut use strict; +use warnings; use GD; use Data::Dumper; use SQL::Translator::Schema::Constants; use SQL::Translator::Utils qw(debug); -use vars qw[ $VERSION $DEBUG ]; -$VERSION = sprintf "%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/; +our $DEBUG; +our $VERSION = '1.59'; $DEBUG = 0 unless defined $DEBUG; use constant VALID_FONT_SIZE => { @@ -66,52 +71,80 @@ sub produce { debug("Producer args =\n", Dumper( $args )); my $out_file = $args->{'out_file'} || ''; - my $output_type = $args->{'output_type'} || 'png'; + my $output_type = $args->{'output_type'} || 'png'; my $title = $args->{'title'} || $t->filename; my $font_size = $args->{'font_size'} || 'medium'; my $imap_file = $args->{'imap_file'} || ''; my $imap_url = $args->{'imap_url'} || ''; - my $no_columns = $args->{'no_columns'}; + my $gutter = $args->{'gutter'} || 30; # distance b/w columns + my $num_columns = $args->{'num_columns'} || $args->{'no_columns'} || ''; my $no_lines = $args->{'no_lines'}; my $add_color = $args->{'add_color'}; my $show_fk_only = $args->{'show_fk_only'}; my $join_pk_only = $args->{'join_pk_only'}; my $natural_join = $args->{'natural_join'} || $join_pk_only; - my $skip_fields = $args->{'skip_fields'}; - my %skip = map { s/^\s+|\s+$//g; $_,1 } split (/,/, $skip_fields); + my %skip_field = map { $_, 1 } ( + ref $args->{'skip_fields'} eq 'ARRAY' + ? @{ $args->{'skip_fields'} } + : split ( /\s*,\s*/, $args->{'skip_fields'}||'' ) + ); - $schema->make_natural_joins( - join_pk_only => $join_pk_only, - skip_fields => $args->{'skip_fields'}, - ) if $natural_join; + my %skip_table = 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'}||'' ) + ); + + my @table_names; + if ( $natural_join ) { + $schema->make_natural_joins( + join_pk_only => $join_pk_only, + skip_fields => $args->{'skip_fields'}, + ); + + my $g = $schema->as_graph_pm; + my $d = Graph::Traversal::DFS->new( $g, next_alphabetic => 1 ); + $d->preorder; + + @table_names = $d->dfs; + } + else { + @table_names = map { $_->name } $schema->get_tables; + } die "Invalid image type '$output_type'" - unless VALID_IMAGE_TYPE ->{ $output_type }; + unless VALID_IMAGE_TYPE->{ $output_type }; die "Invalid font size '$font_size'" unless VALID_FONT_SIZE->{ $font_size }; # # Layout the image. # - my $font = - $font_size eq 'small' ? gdTinyFont : - $font_size eq 'medium' ? gdSmallFont : - $font_size eq 'large' ? gdLargeFont : gdGiantFont; - my @tables = $schema->get_tables; - my $no_tables = scalar @tables; - $no_columns = 0 unless $no_columns =~ /^\d+$/; - $no_columns ||= sprintf( "%.0f", sqrt( $no_tables ) + .5 ); - $no_columns ||= .5; - my $no_per_col = sprintf( "%.0f", $no_tables/$no_columns + .5 ); - - my @shapes; + my $font + = $font_size eq 'small' ? gdTinyFont + : $font_size eq 'medium' ? gdSmallFont + : $font_size eq 'large' ? gdLargeFont + : gdGiantFont; + + my $num_tables = scalar @table_names; + $num_columns = 0 unless $num_columns =~ /^\d+$/; + $num_columns ||= sprintf( "%.0f", sqrt( $num_tables ) + .5 ); + $num_columns ||= .5; + my $no_per_col = sprintf( "%.0f", $num_tables/$num_columns + .5 ); + + my @shapes; my ( $max_x, $max_y ); # the furthest x and y used my $orig_y = 40; # used to reset y for each column my ( $x, $y ) = (30,$orig_y); # where to start my $cur_col = 1; # the current column my $no_this_col = 0; # number of tables in current column my $this_col_x = $x; # current column's x - my $gutter = 30; # distance b/w columns my %nj_registry; # for locations of fields for natural joins my @fk_registry; # for locations of fields for foreign keys my %table_x; # for max x of each table @@ -120,15 +153,24 @@ sub produce { my @imap_coords; # for making clickable image map my %legend; - for my $table ( @tables ) { - my $table_name = $table->name; - my $top = $y; - push @shapes, + TABLE: + for my $table_name ( @table_names ) { + my $table = $schema->get_table( $table_name ); + + if ( @skip_tables_like or keys %skip_table ) { + next TABLE if $skip_table{ $table_name }; + for my $regex ( @skip_tables_like ) { + next TABLE if $table_name =~ $regex; + } + } + + my $top = $y; + push @shapes, [ 'string', $font, $this_col_x, $y, $table_name, 'black' ]; $y += $font->height + 2; my $below_table_name = $y; $y += 2; - my $this_max_x = + my $this_max_x = $this_col_x + ($font->width * length($table_name)); debug("Processing table '$table_name'"); @@ -173,11 +215,11 @@ sub produce { my $desc = $f->data_type; $desc .= '('.$f->size.')' if $f->size && $f->data_type =~ /^(VAR)?CHAR2?$/i; - + my $nlen = length $name; my $dlen = length $desc; - $max_name = $nlen if $nlen > $max_name; - $max_desc = $dlen if $dlen > $max_desc; + $max_name = $nlen if $nlen > ($max_name||0); + $max_desc = $dlen if $dlen > ($max_desc||0); push @fld_desc, [ $name, $desc, $f->{'name'}, $is_pk, $attr ]; } @@ -198,7 +240,7 @@ sub produce { my $constraints = $table->{'fields'}{ $orig_name }{'constraints'}; - if ( $natural_join && !$skip{ $orig_name } ) { + if ( $natural_join && !$skip_field{ $orig_name } ) { push @{ $nj_registry{ $orig_name } }, $table_name; } @@ -212,7 +254,7 @@ sub produce { fld_name => $orig_name, }; - push @imap_coords, [ + push @imap_coords, [ $imap_url."#$table_name-$orig_name", $this_col_x, $y - $font->height, $length, $y_link, ]; @@ -237,34 +279,34 @@ sub produce { $this_max_x += 5; $table_x{ $table_name } = $this_max_x + 5; - push @shapes, [ 'line', $this_col_x - 5, $below_table_name, + push @shapes, [ 'line', $this_col_x - 5, $below_table_name, $this_max_x, $below_table_name, 'black' ]; my @bounds = ( $this_col_x - 5, $top - 5, $this_max_x, $y + 5 ); if ( $add_color ) { - unshift @shapes, [ - 'filledRectangle', + unshift @shapes, [ + 'filledRectangle', $bounds[0], $bounds[1], $this_max_x, $below_table_name, - 'khaki' + 'khaki' ]; unshift @shapes, [ 'filledRectangle', @bounds, 'white' ]; } - push @imap_coords, [ + push @imap_coords, [ $imap_url."#$table_name", $bounds[0], $bounds[1], $this_max_x, $below_table_name, ]; push @shapes, [ 'rectangle', @bounds, 'black' ]; - $max_x = $this_max_x if $this_max_x > $max_x; + $max_x = $this_max_x if $this_max_x > ($max_x||0); $y += 25; - + if ( ++$no_this_col == $no_per_col ) {# if we've filled up this column $cur_col++; # up the column number $no_this_col = 0; # reset the number of tables $max_x += $gutter; # push the x over for next column $this_col_x = $max_x; # remember the max x for this col - $max_y = $y if $y > $max_y; # note the max y + $max_y = $y if $y > ($max_y||0); # note the max y $y = $orig_y; # reset the y for next column } } @@ -280,7 +322,7 @@ sub produce { if ( $natural_join ) { for my $field_name ( keys %nj_registry ) { my @positions; - my @table_names = + my @table_names = @{ $nj_registry{ $field_name } || [] } or next; next if scalar @table_names == 1; @@ -294,7 +336,7 @@ sub produce { } else { for my $pair ( @fk_registry ) { - push @position_bunches, [ + push @position_bunches, [ $coords{$pair->[0][0]}{ $pair->[0][1] }{'coords'}, $coords{$pair->[1][0]}{ $pair->[1][1] }{'coords'}, ]; @@ -358,7 +400,7 @@ sub produce { my $diff = 0; if ( $x1 == $x2 ) { while ( $horz_taken{ $x1 + $diff } ) { - $diff = $side1 eq 'left' ? $diff - 2 : $diff + 2; + $diff = $side1 eq 'left' ? $diff - 2 : $diff + 2; } $horz_taken{ $x1 + $diff } = 1; } @@ -372,16 +414,16 @@ sub produce { if ( $side2 eq 'left' ) { $end = $x2 - $offset + $diff; - } + } else { $end = $col2_right + $diff; - } + } - push @shapes, + push @shapes, [ 'line', $x1, $y1, $start, $y1, 'cadetblue' ]; - push @shapes, + push @shapes, [ 'line', $start, $y1, $end, $y2, 'cadetblue' ]; - push @shapes, + push @shapes, [ 'line', $end, $y2, $x2, $y2, 'cadetblue' ]; if ( $is_directed ) { @@ -390,27 +432,27 @@ sub produce { || $side1 eq 'left' && $side2 eq 'left' ) { - push @shapes, [ - 'line', $x2 - 3, $y2 - 3, $x2, $y2, 'cadetblue' + push @shapes, [ + 'line', $x2 - 3, $y2 - 3, $x2, $y2, 'cadetblue' ]; - push @shapes, [ - 'line', $x2 - 3, $y2 + 3, $x2, $y2, 'cadetblue' + push @shapes, [ + 'line', $x2 - 3, $y2 + 3, $x2, $y2, 'cadetblue' ]; - push @shapes, [ - 'line', $x2 - 3, $y2 - 3, $x2 - 3, $y2 +3, - 'cadetblue' + push @shapes, [ + 'line', $x2 - 3, $y2 - 3, $x2 - 3, $y2 +3, + 'cadetblue' ]; } else { - push @shapes, [ - 'line', $x2 + 3, $y2 - 3, $x2, $y2, 'cadetblue' + push @shapes, [ + 'line', $x2 + 3, $y2 - 3, $x2, $y2, 'cadetblue' ]; - push @shapes, [ - 'line', $x2 + 3, $y2 + 3, $x2, $y2, 'cadetblue' + push @shapes, [ + 'line', $x2 + 3, $y2 + 3, $x2, $y2, 'cadetblue' ]; - push @shapes, [ - 'line', $x2 + 3, $y2 - 3, $x2 + 3, $y2 +3, - 'cadetblue' + push @shapes, [ + 'line', $x2 + 3, $y2 - 3, $x2 + 3, $y2 +3, + 'cadetblue' ]; } } @@ -427,27 +469,27 @@ sub produce { # my $large_font = gdLargeFont; my $title_len = $large_font->width * length $title; - push @shapes, [ - 'string', $large_font, $max_x/2 - $title_len/2, 10, $title, 'black' + push @shapes, [ + 'string', $large_font, $max_x/2 - $title_len/2, 10, $title, 'black' ]; if ( %legend ) { $max_y += 5; - push @shapes, [ + push @shapes, [ 'string', $font, $x, $max_y - $font->height - 4, 'Legend', 'black' ]; $max_y += $font->height + 4; my $longest; for my $len ( map { length $_ } values %legend ) { - $longest = $len if $len > $longest; + $longest = $len if $len > ($longest||0); } $longest += 2; while ( my ( $key, $shape ) = each %legend ) { my $space = $longest - length $shape; - push @shapes, [ - 'string', $font, $x, $max_y - $font->height - 4, + push @shapes, [ + 'string', $font, $x, $max_y - $font->height - 4, join( '', $shape, ' ' x $space, $key ), 'black' ]; @@ -457,8 +499,8 @@ sub produce { my $sig = 'Created by SQL::Translator ' . $t->version; my $sig_len = $font->width * length $sig; - push @shapes, [ - 'string', $font, $max_x - $sig_len, $max_y - $font->height - 4, + push @shapes, [ + 'string', $font, $max_x - $sig_len, $max_y - $font->height - 4, $sig, 'black' ]; @@ -493,13 +535,13 @@ sub produce { # debug("imap file = '$imap_file'"); if ( $imap_file && @imap_coords ) { - open my $fh, ">$imap_file" or die "Can't write '$imap_file': $!\n"; + open my $fh, '>', $imap_file or die "Can't write '$imap_file': $!\n"; print $fh qq[\n]. qq[\n]; for my $rec ( @imap_coords ) { my $href = shift @$rec; print $fh q[\n]; - } + } print $fh qq[]; close $fh; } @@ -508,7 +550,8 @@ sub produce { # Print the image. # if ( $out_file ) { - open my $fh, ">$out_file" or die "Can't write '$out_file': $!\n"; + open my $fh, '>', $out_file or die "Can't write '$out_file': $!\n"; + binmode $fh; print $fh $gd->$output_type; close $fh; } @@ -519,12 +562,10 @@ sub produce { 1; -# ------------------------------------------------------------------- - =pod =head1 AUTHOR -Ken Y. Clark Ekclark@cpan.orgE. +Ken Youens-Clark Ekclark@cpan.orgE. =cut