X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FProducer%2FDiagram.pm;h=c23633b5bdd4ecf6c1509dee1d04fd45d1c32820;hb=afff8ac67f4291a68dcb72ab19508dcfd500ea0a;hp=c3da38db62bc0f3fb7db3c439c0e8f1f5e3f6cd8;hpb=761fa6211becef3a2b10c0f0daf28c7c9cd63842;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Producer/Diagram.pm b/lib/SQL/Translator/Producer/Diagram.pm index c3da38d..c23633b 100644 --- a/lib/SQL/Translator/Producer/Diagram.pm +++ b/lib/SQL/Translator/Producer/Diagram.pm @@ -1,9 +1,9 @@ package SQL::Translator::Producer::Diagram; # ------------------------------------------------------------------- -# $Id: Diagram.pm,v 1.3 2003-06-09 04:40:50 kycl4rk Exp $ +# $Id: Diagram.pm,v 1.11 2004-03-04 14:39:15 dlc Exp $ # ------------------------------------------------------------------- -# Copyright (C) 2003 Ken Y. Clark +# 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 @@ -20,6 +20,21 @@ package SQL::Translator::Producer::Diagram; # 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( producer => 'Diagram', '...' ); + $t->translate; + +=cut + use strict; use GD; use Data::Dumper; @@ -27,7 +42,7 @@ use SQL::Translator::Schema::Constants; use SQL::Translator::Utils qw(debug); use vars qw[ $VERSION $DEBUG ]; -$VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/; +$VERSION = sprintf "%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/; $DEBUG = 0 unless defined $DEBUG; use constant VALID_FONT_SIZE => { @@ -50,10 +65,12 @@ sub produce { debug("Schema =\n", Dumper( $schema )); 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 $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 $no_columns = $args->{'no_columns'}; my $no_lines = $args->{'no_lines'}; my $add_color = $args->{'add_color'}; @@ -68,8 +85,8 @@ sub produce { skip_fields => $args->{'skip_fields'}, ) if $natural_join; - die "Invalid image type '$image_type'" - unless VALID_IMAGE_TYPE ->{ $image_type }; + die "Invalid image type '$output_type'" + unless VALID_IMAGE_TYPE ->{ $output_type }; die "Invalid font size '$font_size'" unless VALID_FONT_SIZE->{ $font_size }; @@ -100,6 +117,7 @@ sub produce { 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; for my $table ( @tables ) { @@ -107,7 +125,6 @@ sub produce { 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; @@ -119,11 +136,13 @@ sub produce { my @fields = $table->get_fields; debug("Fields = ", join(', ', map { $_->name } @fields)); - 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 = $f->is_primary_key; + my @attr; + # # Decide if we should skip this field. # @@ -132,28 +151,45 @@ sub produce { } if ( $is_pk ) { - $name .= ' *'; - $legend{'Primary key'} = '*'; + push @attr, 'PK'; + $legend{'Primary key'} = '[PK]'; } - elsif ( $f->is_unique ) { - $name .= ' [U]'; + + if ( $f->is_unique ) { + push @attr, 'U'; $legend{'Unique constraint'} = '[U]'; } + 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; + $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; - push @fld_desc, [ $name, $desc, $f->{'name'}, $is_pk ]; + $max_desc = $dlen if $dlen > $max_desc; + 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; @@ -175,6 +211,11 @@ 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 ) { @@ -186,8 +227,8 @@ sub produce { for my $fk_field ( $c->reference_fields ) { next unless defined $schema->get_table( $fk_table ); push @fk_registry, [ - [ $table_name, $field_name ], [ $fk_table , $fk_field ], + [ $table_name, $field_name ], ]; } } @@ -208,6 +249,12 @@ sub produce { ]; 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; $y += 25; @@ -408,7 +455,7 @@ 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, @@ -419,8 +466,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 ] ], @@ -442,28 +489,42 @@ 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; + print $fh $gd->$output_type; close $fh; } else { - return $gd->$image_type; + return $gd->$output_type; } } 1; -=pod - -=head1 NAME +# ------------------------------------------------------------------- -SQL::Translator::Producer::Diagram - ER diagram producer for SQL::Translator +=pod =head1 AUTHOR -Ken Y. Clark Ekclark@cpan.orgE +Ken Y. Clark Ekclark@cpan.orgE. =cut