X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FProducer%2FDiagram.pm;h=30bcef16a7c0f78dc1673fbfc6ec7158566cdfb7;hb=752a0ffc868171987b517d88376181c3997bbba9;hp=ca1d1f66158b2639c78f3aba1e13fb22c568d3f4;hpb=da06ac74ada30aacf656943306679a28605ad5c8;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Producer/Diagram.pm b/lib/SQL/Translator/Producer/Diagram.pm index ca1d1f6..30bcef1 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 1440 2009-01-17 16:31:57Z jawnsy $ -# ------------------------------------------------------------------- -# 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 -# ------------------------------------------------------------------- - =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 => 'Diagram', + 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 = '1.99'; +our $DEBUG; +our $VERSION = '1.61'; $DEBUG = 0 unless defined $DEBUG; use constant VALID_FONT_SIZE => { @@ -62,26 +67,40 @@ sub produce { my $schema = $t->schema; my $args = $t->producer_args; local $DEBUG = $t->debug; - debug("Schema =\n", Dumper( $schema )); - debug("Producer args =\n", Dumper( $args )); + debug("Schema =\n", Dumper( $schema )) if $DEBUG; + debug("Producer args =\n", Dumper( $args )) if $DEBUG; 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 $gutter = $args->{'gutter'} || 30; # distance b/w columns - my $no_columns = $args->{'no_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'}||'' ) + ); + + 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 @tables = $schema->get_tables; my @table_names; if ( $natural_join ) { $schema->make_natural_joins( @@ -89,18 +108,18 @@ sub produce { skip_fields => $args->{'skip_fields'}, ); - my $g = $schema->as_graph_pm; + my $g = $schema->as_graph_pm; my $d = Graph::Traversal::DFS->new( $g, next_alphabetic => 1 ); $d->preorder; - @table_names = $d->dfs; + @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 }; @@ -108,18 +127,18 @@ sub produce { # Layout the image. # my $font - = $font_size eq 'small' ? gdTinyFont - : $font_size eq 'medium' ? gdSmallFont - : $font_size eq 'large' ? gdLargeFont + = $font_size eq 'small' ? gdTinyFont + : $font_size eq 'medium' ? gdSmallFont + : $font_size eq 'large' ? gdLargeFont : gdGiantFont; - my $no_tables = scalar @table_names; - $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 $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 @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 @@ -134,21 +153,30 @@ sub produce { my @imap_coords; # for making clickable image map my %legend; + 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, + 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'"); my @fields = $table->get_fields; - debug("Fields = ", join(', ', map { $_->name } @fields)); + debug("Fields = ", join(', ', map { $_->name } @fields)) if $DEBUG; my ( @fld_desc, $max_name, $max_desc ); for my $f ( @fields ) { @@ -187,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 ]; } @@ -212,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; } @@ -226,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, ]; @@ -251,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 } } @@ -294,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; @@ -308,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'}, ]; @@ -372,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; } @@ -386,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 ) { @@ -404,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' ]; } } @@ -441,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' ]; @@ -471,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' ]; @@ -507,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; } @@ -522,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; } @@ -533,12 +562,10 @@ sub produce { 1; -# ------------------------------------------------------------------- - =pod =head1 AUTHOR -Ken Y. Clark Ekclark@cpan.orgE. +Ken Youens-Clark Ekclark@cpan.orgE. =cut