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=a62404a27d93bc6216ab8be4d6aad8b2fc07b23e;hpb=3750382793554f1fa7e9f3f49510e25cea65a6df;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Producer/Diagram.pm b/lib/SQL/Translator/Producer/Diagram.pm index a62404a..30bcef1 100644 --- a/lib/SQL/Translator/Producer/Diagram.pm +++ b/lib/SQL/Translator/Producer/Diagram.pm @@ -1,32 +1,53 @@ package SQL::Translator::Producer::Diagram; -# ------------------------------------------------------------------- -# $Id: Diagram.pm,v 1.1 2003-04-24 16:36:49 kycl4rk Exp $ -# ------------------------------------------------------------------- -# Copyright (C) 2003 Ken Y. Clark -# -# 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 + +=head1 SYNOPSIS + +Use via SQL::Translator: + + use SQL::Translator; + + 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 = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/; +our $DEBUG; +our $VERSION = '1.61'; $DEBUG = 0 unless defined $DEBUG; use constant VALID_FONT_SIZE => { @@ -42,213 +63,175 @@ use constant VALID_IMAGE_TYPE => { }; sub produce { - my ($t, $data) = @_; + my $t = shift; + my $schema = $t->schema; my $args = $t->producer_args; local $DEBUG = $t->debug; - debug("Data =\n", Dumper( $data )); - debug("Producer args =\n", Dumper( $args )); - - my $out_file = $args->{'out_file'} || ''; - my $image_type = $args->{'image_type'} || 'png'; - my $title = $args->{'title'} || $t->filename; - my $font_size = $args->{'font_size'} || 'medium'; - my $no_columns = $args->{'no_columns'}; + 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 $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 $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 { $_, 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'}||'' ) + ); - die "Invalid image type '$image_type'" - unless VALID_IMAGE_TYPE ->{ $image_type }; + 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 }; 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 $no_tables = scalar keys %$data; - $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 my $field_no; # counter to give distinct no. to each field + my %coords; # holds fields coordinates + my @imap_coords; # for making clickable image map my %legend; - # - # If necessary, pre-process fields to find foreign keys. - # - if ( $show_fk_only && $natural_join ) { - my ( %common_keys, %pk ); - for my $table ( values %$data ) { - for my $index ( - @{ $table->{'indices'} || [] }, - @{ $table->{'constraints'} || [] }, - ) { - my @fields = @{ $index->{'fields'} || [] } or next; - if ( $index->{'type'} eq 'primary_key' ) { - $pk{ $_ } = 1 for @fields; - } - } - - for my $field ( values %{ $table->{'fields'} } ) { - push @{ $common_keys{ $field->{'name'} } }, - $table->{'table_name'}; - } - } + TABLE: + for my $table_name ( @table_names ) { + my $table = $schema->get_table( $table_name ); - for my $field ( keys %common_keys ) { - my @tables = @{ $common_keys{ $field } }; - next unless scalar @tables > 1; - for my $table ( @tables ) { - next if $join_pk_only and !defined $pk{ $field }; - $data->{ $table }{'fields'}{ $field }{'is_fk'} = 1; + 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; } } - } - else { - for my $table ( values %$data ) { - for my $field ( values %{ $table->{'fields'} } ) { - for my $constraint ( - grep { $_->{'type'} eq 'foreign_key' } - @{ $field->{'constraints'} } - ) { - my $ref_table = $constraint->{'reference_table'} or next; - my @ref_fields = @{$constraint->{'reference_fields'} || []}; - - unless ( @ref_fields ) { - for my $field ( - values %{ $data->{ $ref_table }{'fields'} } - ) { - for my $pk ( - grep { $_->{'type'} eq 'primary_key' } - @{ $field->{'constraints'} } - ) { - push @ref_fields, @{ $pk->{'fields'} }; - } - } - - $constraint->{'reference_fields'} = [ @ref_fields ]; - } - for my $ref_field ( - @{ $constraint->{'reference_fields'} } - ) { - $data->{$ref_table}{'fields'}{$ref_field}{'is_fk'} = 1; - } - } - } - } - } - - - for my $table ( - map { $_->[1] } - sort { $a->[0] <=> $b->[0] } - map { [ $_->{'order'}, $_ ] } - values %$data - ) { - my $table_name = $table->{'table_name'}; - my $top = $y; - push @shapes, + 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'"); - my @fields = - map { $_->[1] } - sort { $a->[0] <=> $b->[0] } - map { [ $_->{'order'}, $_ ] } - values %{ $table->{'fields'} }; - - debug("Fields = ", join(', ', map { $_->{'name'} } @fields)); - - my ( %pk, %unique ); - for my $index ( - @{ $table->{'indices'} || [] }, - @{ $table->{'constraints'} || [] }, - ) { - my @fields = @{ $index->{'fields'} || [] } or next; - if ( $index->{'type'} eq 'primary_key' ) { - $pk{ $_ } = 1 for @fields; - } - elsif ( $index->{'type'} eq 'unique' ) { - $unique{ $_ } = 1 for @fields; - } - } - - debug("PK = ", join(', ', sort keys %pk)) if %pk; - debug("Unique = ", join(', ', sort keys %unique)) if %unique; + my @fields = $table->get_fields; + debug("Fields = ", join(', ', map { $_->name } @fields)) if $DEBUG; - my ( @fld_desc, $max_name ); + my ( @fld_desc, $max_name, $max_desc ); for my $f ( @fields ) { - my $name = $f->{'name'} or next; - my $is_pk = $pk{ $name }; - my $is_unique = $unique{ $name }; + my $name = $f->name or next; + my $is_pk = $f->is_primary_key; + + my @attr; # # Decide if we should skip this field. # if ( $show_fk_only ) { - if ( $natural_join ) { - next unless $is_pk || $f->{'is_fk'}; - } - else { - next unless $is_pk || $f->{'is_fk'} || - grep { $_->{'type'} eq 'foreign_key' } - @{ $f->{'constraints'} } - ; - } + next unless $is_pk || $f->is_foreign_key; } if ( $is_pk ) { - $name .= ' *'; - $legend{'Primary key'} = '*'; + push @attr, 'PK'; + $legend{'Primary key'} = '[PK]'; } - elsif ( $is_unique ) { - $name .= ' [U]'; + + if ( $f->is_unique ) { + push @attr, 'U'; $legend{'Unique constraint'} = '[U]'; } - my $size = @{ $f->{'size'} || [] } - ? '(' . join( ',', @{ $f->{'size'} } ) . ')' - : ''; - my $desc = join( ' ', map { $_ || () } $f->{'data_type'}, $size ); - + if ( $f->is_foreign_key ) { + push @attr, 'FK'; + $legend{'Foreign Key'} = '[FK]'; + } + + my $attr = ''; + if ( @attr ) { + $attr .= '[' . join(', ', @attr) . ']'; + } + + my $desc = $f->data_type; + $desc .= '('.$f->size.')' if $f->size && + $f->data_type =~ /^(VAR)?CHAR2?$/i; + my $nlen = length $name; - $max_name = $nlen if $nlen > $max_name; - push @fld_desc, [ $name, $desc, $f->{'name'}, $is_pk ]; + my $dlen = length $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 ]; } - $max_name += 4; + $max_name += 2; + $max_desc += 2; for my $fld_desc ( @fld_desc ) { - my ( $name, $desc, $orig_name, $is_pk ) = @$fld_desc; - my $diff = $max_name - length $name; - $name .= ' ' x $diff; - $desc = $name . $desc; + my ( $name, $desc, $orig_name, $is_pk, $attr ) = @$fld_desc; + my $diff1 = $max_name - length $name; + my $diff2 = $max_desc - length $desc; + $name .= ' ' x $diff1; + $desc .= ' ' x $diff2; + $desc = $name . $desc . $attr; push @shapes, [ 'string', $font, $this_col_x, $y, $desc, 'black' ]; $y += $font->height + 2; @@ -257,27 +240,12 @@ 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; } - elsif ( @{ $constraints || [] } ) { - for my $constraint ( @$constraints ) { - next unless $constraint->{'type'} eq 'foreign_key'; - for my $fk_field ( - @{ $constraint->{'reference_fields'} || [] } - ) { - my $fk_table = $constraint->{'reference_table'}; - next unless defined $data->{ $fk_table }; - push @fk_registry, [ - [ $table_name, $orig_name ], - [ $fk_table , $fk_field ], - ]; - } - } - } my $y_link = $y - $font->height/2; - $table->{'fields'}{ $orig_name }{'coords'} = { + $coords{ $table_name }{ $orig_name }{'coords'} = { left => [ $this_col_x - 6, $y_link ], right => [ $length + 2 , $y_link ], table => $table_name, @@ -285,32 +253,60 @@ sub produce { is_pk => $is_pk, fld_name => $orig_name, }; + + push @imap_coords, [ + $imap_url."#$table_name-$orig_name", + $this_col_x, $y - $font->height, $length, $y_link, + ]; + } + + unless ( $natural_join ) { + for my $c ( $table->get_constraints ) { + next unless $c->type eq FOREIGN_KEY; + my $fk_table = $c->reference_table or next; + + for my $field_name ( $c->fields ) { + for my $fk_field ( $c->reference_fields ) { + next unless defined $schema->get_table( $fk_table ); + push @fk_registry, [ + [ $fk_table , $fk_field ], + [ $table_name, $field_name ], + ]; + } + } + } } $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, [ + $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 } } @@ -326,13 +322,13 @@ 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; for my $table_name ( @table_names ) { push @positions, - $data->{$table_name}{'fields'}{ $field_name }{'coords'}; + $coords{ $table_name }{ $field_name }{'coords'}; } push @position_bunches, [ @positions ]; @@ -340,9 +336,9 @@ sub produce { } else { for my $pair ( @fk_registry ) { - push @position_bunches, [ - $data->{$pair->[0][0]}{'fields'}{ $pair->[0][1] }{'coords'}, - $data->{$pair->[1][0]}{'fields'}{ $pair->[1][1] }{'coords'}, + push @position_bunches, [ + $coords{$pair->[0][0]}{ $pair->[0][1] }{'coords'}, + $coords{$pair->[1][0]}{ $pair->[1][1] }{'coords'}, ]; } } @@ -404,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; } @@ -418,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 ) { @@ -436,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' ]; } } @@ -473,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' ]; @@ -501,10 +497,10 @@ sub produce { } } - my $sig = __PACKAGE__." $VERSION"; + 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' ]; @@ -512,8 +508,8 @@ sub produce { # Render the image. # my $gd = GD::Image->new( $max_x + 30, $max_y ); - unless ( $gd->can( $image_type ) ) { - die "GD can't create images of type '$image_type'\n"; + unless ( $gd->can( $output_type ) ) { + die "GD can't create images of type '$output_type'\n"; } my %colors = map { $_->[0], $gd->colorAllocate( @{$_->[1]} ) } ( [ white => [ 255, 255, 255 ] ], @@ -535,15 +531,32 @@ sub produce { } # + # Make image map. + # + debug("imap file = '$imap_file'"); + if ( $imap_file && @imap_coords ) { + 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; + } + + # # Print the image. # if ( $out_file ) { - open my $fh, ">$out_file" or die "Can't write '$out_file': $!\n"; - print $fh $gd->$image_type; + open my $fh, '>', $out_file or die "Can't write '$out_file': $!\n"; + binmode $fh; + print $fh $gd->$output_type; close $fh; } else { - print $gd->$image_type; + return $gd->$output_type; } } @@ -551,12 +564,8 @@ sub produce { =pod -=head1 NAME - -SQL::Translator::Producer::Diagram - ER diagram producer for SQL::Translator - =head1 AUTHOR -Ken Y. Clark Ekclark@cpan.orgE +Ken Youens-Clark Ekclark@cpan.orgE. =cut