#!/usr/bin/perl
-# $Id: auto-dia.pl,v 1.7 2003-04-02 01:45:45 kycl4rk Exp $
+# $Id: auto-dia.pl,v 1.8 2003-04-03 19:29:08 kycl4rk Exp $
=head1 NAME
Options:
- -o|--output Output file name (default STDOUT)
- -i|--image Output image type (default PNG)
- -t|--title Title to give schema
- -c|--cols Number of columns
- -n|--no-lines Don't draw lines
- -f|--font-size "small," "medium," "large," or "huge"
- (default "medium")
- --color Add colors
-
- --natural-join Perform natural joins
- --natural-join-pk-only Perform natural joins from primary keys only
- -s|--skip Fields to skip in natural joins
+ -o|--output Output file name (default STDOUT)
+ -i|--image Output image type ("png" or "jpeg," default "png")
+ -t|--title Title to give schema
+ -c|--cols Number of columns
+ -n|--no-lines Don't draw lines
+ -f|--font-size Font size ("small," "medium," "large," or "huge,"
+ default "medium")
+ --color Add colors
+ --show-fk-only Only show fields that act as primary
+ or foreign keys
+
+ --natural-join Perform natural joins
+ --natural-join-pk Perform natural joins from primary keys only
+ -s|--skip Fields to skip in natural joins
+ --debug Print debugging information
=head1 DESCRIPTION
include it in the "skip" option, and all fields called "name" will be
excluded from natural joins. A more efficient method, however, might
be to simply deduce the foriegn keys from primary keys to other fields
-named the same in other tables. Use the "natural-join-pk-only" option
+named the same in other tables. Use the "natural-join-pk" option
to acheive this.
=cut
use strict;
+use Data::Dumper;
use Getopt::Long;
use GD;
use Pod::Usage;
use SQL::Translator;
-my $VERSION = (qw$Revision: 1.7 $)[-1];
+my $VERSION = (qw$Revision: 1.8 $)[-1];
use constant VALID_FONT_SIZE => {
small => 1,
huge => 1,
};
+use constant VALID_IMAGE_TYPE => {
+ png => 1,
+ jpeg => 1,
+};
+
#
# Get arguments.
#
my (
$out_file, $image_type, $db_driver, $title, $no_columns,
- $no_lines, $font_size, $add_color,
+ $no_lines, $font_size, $add_color, $debug, $show_fk_only,
$natural_join, $join_pk_only, $skip_fields
);
GetOptions(
- 'd|db=s' => \$db_driver,
- 'o|output:s' => \$out_file,
- 'i|image:s' => \$image_type,
- 't|title:s' => \$title,
- 'c|columns:i' => \$no_columns,
- 'n|no-lines' => \$no_lines,
- 'f|font-size:s' => \$font_size,
- 'color' => \$add_color,
- 'natural-join' => \$natural_join,
- 'natural-join-pk-only' => \$join_pk_only,
- 's|skip:s' => \$skip_fields,
+ 'd|db=s' => \$db_driver,
+ 'o|output:s' => \$out_file,
+ 'i|image:s' => \$image_type,
+ 't|title:s' => \$title,
+ 'c|columns:i' => \$no_columns,
+ 'n|no-lines' => \$no_lines,
+ 'f|font-size:s' => \$font_size,
+ 'color' => \$add_color,
+ 'show-fk-only' => \$show_fk_only,
+ 'natural-join' => \$natural_join,
+ 'natural-join-pk' => \$join_pk_only,
+ 's|skip:s' => \$skip_fields,
+ 'debug' => \$debug,
) or die pod2usage;
my $file = shift @ARGV or pod2usage( -message => 'No input file' );
pod2usage( -message => "No db driver specified" ) unless $db_driver;
-$image_type = $image_type ? lc $image_type : 'png';
$title ||= $file;
+$image_type = 'png' unless VALID_IMAGE_TYPE ->{ $image_type };
$font_size = 'medium' unless VALID_FONT_SIZE->{ $font_size };
my %skip = map { $_, 1 } split ( /,/, $skip_fields );
$natural_join ||= $join_pk_only;
#
# Parse file.
#
+warn "Parsing file '$file' with driver '$db_driver'\n" if $debug;
my $t = SQL::Translator->new( parser => $db_driver, producer => 'Raw' );
my $data = $t->translate( $file ) or die $t->error;
+warn "Data =\n", Dumper( $data ), "\n" if $debug;
#
# Layout the image.
$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 ( $max_x, $max_y ); # the furthest x and y used
my $orig_y = 40; # used to reset y for each column
-my ( $x, $y ) = (20, $orig_y); # where to start
+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 $field_no; # counter to give distinct no. to each field
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'};
+ }
+ }
+
+ 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;
+ }
+ }
+}
+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;
+ 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] }
$y += 2;
my $this_max_x = $this_col_x + ($font->width * length($table_name));
+ warn "Processing table '$table_name'\n" if $debug;
+
my @fields =
map { $_->[1] }
sort { $a->[0] <=> $b->[0] }
map { [ $_->{'order'}, $_ ] }
values %{ $table->{'fields'} };
+ warn "Fields = ", join(', ', map { $_->{'name'} } @fields), "\n" if $debug;
+
my ( %pk, %unique );
- for my $index ( @{ $table->{'indices'} || [] } ) {
+ for my $index (
+ @{ $table->{'indices'} || [] },
+ @{ $table->{'constraints'} || [] },
+ ) {
my @fields = @{ $index->{'fields'} || [] } or next;
if ( $index->{'type'} eq 'primary_key' ) {
$pk{ $_ } = 1 for @fields;
}
}
+ warn "Primary keys = ", join(', ', sort keys %pk), "\n" if $debug;
+ warn "Unique = ", join(', ', sort keys %unique), "\n" if $debug;
+
my ( @fld_desc, $max_name );
for my $f ( @fields ) {
my $name = $f->{'name'} or next;
my $is_pk = $pk{ $name };
my $is_unique = $unique{ $name };
+
+ #
+ # 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'} }
+ ;
+ }
+ }
+
if ( $is_pk ) {
$name .= ' *';
$legend{'Primary key'} = '*';
for my $fk_field (
@{ $constraint->{'reference_fields'} || [] }
) {
+ my $fk_table = $constraint->{'reference_table'};
+ next unless defined $data->{ $fk_table };
push @fk_registry, [
- [ $constraint->{'reference_table'}, $fk_field ],
[ $table_name, $orig_name ],
+ [ $fk_table , $fk_field ],
];
}
}
}
- my $y_link = $y - $font->height * .75;
+ my $y_link = $y - $font->height/2;
$table->{'fields'}{ $orig_name }{'coords'} = {
- left => [ $this_col_x - 2, $y_link ],
- right => [ $length, $y_link ],
+ left => [ $this_col_x - 6, $y_link ],
+ right => [ $length + 2 , $y_link ],
table => $table_name,
field_no => ++$field_no,
is_pk => $is_pk,
+ fld_name => $orig_name,
};
}
}
else {
for my $pair ( @fk_registry ) {
- my $c1 =
- $data->{ $pair->[0][0] }{'fields'}{ $pair->[0][1] }{'coords'};
- my $c2 =
- $data->{ $pair->[1][0] }{'fields'}{ $pair->[1][1] }{'coords'};
- next unless %{ $c1 || {} } && %{ $c1 || {} };
- push @position_bunches, [ $c1, $c2 ];
+ push @position_bunches, [
+ $data->{ $pair->[0][0] }{'fields'}{ $pair->[0][1] }{'coords'},
+ $data->{ $pair->[1][0] }{'fields'}{ $pair->[1][1] }{'coords'},
+ ];
}
}
+ my $is_directed = $natural_join ? 0 : 1;
+
for my $bunch ( @position_bunches ) {
my @positions = @$bunch;
for my $i ( 0 .. $#positions ) {
my $pos1 = $positions[ $i ];
- my ( $ax, $ay ) = @{ $pos1->{'left'} };
- my ( $bx, $by ) = @{ $pos1->{'right'} };
+ my ( $ax, $ay ) = @{ $pos1->{'left'} || [] } or next;
+ my ( $bx, $by ) = @{ $pos1->{'right'} || [] } or next;
my $table1 = $pos1->{'table'};
my $fno1 = $pos1->{'field_no'};
my $is_pk = $pos1->{'is_pk'};
for my $j ( 0 .. $#positions ) {
my $pos2 = $positions[ $j ];
- my ( $cx, $cy ) = @{ $pos2->{'left'} };
- my ( $dx, $dy ) = @{ $pos2->{'right'} };
+ my ( $cx, $cy ) = @{ $pos2->{'left'} || [] } or next;
+ my ( $dx, $dy ) = @{ $pos2->{'right'} || [] } or next;
my $table2 = $pos2->{'table'};
my $fno2 = $pos2->{'field_no'};
+ next if $table1 eq $table2;
next if $done{ $fno1 }{ $fno2 };
next if $fno1 == $fno2;
$end = $col2_right + $diff;
}
- push @shapes, [ 'line', $x1, $y1, $start, $y1, 'lightblue' ];
- push @shapes, [ 'line', $start, $y1, $end, $y2, 'lightblue' ];
- push @shapes, [ 'line', $end, $y2, $x2, $y2, 'lightblue' ];
+ push @shapes, [ 'line', $x1, $y1, $start, $y1, 'cadetblue' ];
+ push @shapes, [ 'line', $start, $y1, $end, $y2, 'cadetblue' ];
+ push @shapes, [ 'line', $end, $y2, $x2, $y2, 'cadetblue' ];
+
+ if ( $is_directed ) {
+ if (
+ $side1 eq 'right' && $side2 eq 'left'
+ ||
+ $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 - 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 + 3, $y2 +3,
+ 'cadetblue'
+ ];
+ }
+ }
+
$done{ $fno1 }{ $fno2 } = 1;
$done{ $fno2 }{ $fno1 } = 1;
}
#
# Render the image.
#
-my $gd = GD::Image->new( $max_x + 10, $max_y );
+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";
}
[ beige => [ 245, 245, 220 ] ],
[ black => [ 0, 0, 0 ] ],
[ lightblue => [ 173, 216, 230 ] ],
+ [ cadetblue => [ 95, 158, 160 ] ],
[ lightgoldenrodyellow => [ 250, 250, 210 ] ],
[ khaki => [ 240, 230, 140 ] ],
+ [ red => [ 255, 0, 0 ] ],
);
$gd->interlaced( 'true' );
my $background_color = $add_color ? 'lightgoldenrodyellow' : 'white';
projects / dbsrgits/SQL-Translator.git / commitdiff