#!/usr/bin/perl
-# $Id: auto-dia.pl,v 1.8 2003-04-03 19:29:08 kycl4rk Exp $
+# $Id: auto-dia.pl,v 1.9 2003-04-24 16:33:23 kycl4rk Exp $
=head1 NAME
use strict;
use Data::Dumper;
use Getopt::Long;
-use GD;
use Pod::Usage;
use SQL::Translator;
-my $VERSION = (qw$Revision: 1.8 $)[-1];
-
-use constant VALID_FONT_SIZE => {
- small => 1,
- medium => 1,
- large => 1,
- huge => 1,
-};
-
-use constant VALID_IMAGE_TYPE => {
- png => 1,
- jpeg => 1,
-};
+my $VERSION = (qw$Revision: 1.9 $)[-1];
#
# Get arguments.
my (
$out_file, $image_type, $db_driver, $title, $no_columns,
$no_lines, $font_size, $add_color, $debug, $show_fk_only,
- $natural_join, $join_pk_only, $skip_fields
+ $natural_join, $join_pk_only, $skip_fields, $help
);
GetOptions(
'natural-join-pk' => \$join_pk_only,
's|skip:s' => \$skip_fields,
'debug' => \$debug,
+ 'h|help' => \$help,
) or die pod2usage;
-my $file = shift @ARGV or pod2usage( -message => 'No input file' );
+my @files = @ARGV; # the create script(s) for the original db
+pod2usage(1) if $help;
pod2usage( -message => "No db driver specified" ) unless $db_driver;
-$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.
-#
-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 ( $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 %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] }
- map { [ $_->{'order'}, $_ ] }
- values %$data
-) {
- my $table_name = $table->{'table_name'};
- 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 = $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'} || [] },
- @{ $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;
- }
- }
-
- 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'} = '*';
- }
- elsif ( $is_unique ) {
- $name .= ' [U]';
- $legend{'Unique constraint'} = '[U]';
- }
-
- my $size = @{ $f->{'size'} || [] }
- ? '(' . join( ',', @{ $f->{'size'} } ) . ')'
- : '';
- my $desc = join( ' ', map { $_ || () } $f->{'data_type'}, $size );
-
- my $nlen = length $name;
- $max_name = $nlen if $nlen > $max_name;
- push @fld_desc, [ $name, $desc, $f->{'name'}, $is_pk ];
- }
-
- $max_name += 4;
- 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;
-
- push @shapes, [ 'string', $font, $this_col_x, $y, $desc, 'black' ];
- $y += $font->height + 2;
- my $length = $this_col_x + ( $font->width * length( $desc ) );
- $this_max_x = $length if $length > $this_max_x;
-
- my $constraints = $table->{'fields'}{ $orig_name }{'constraints'};
-
- if ( $natural_join && !$skip{ $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'} = {
- 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,
- };
- }
-
- $this_max_x += 5;
- $table_x{ $table_name } = $this_max_x + 5;
- 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',
- $bounds[0], $bounds[1],
- $this_max_x, $below_table_name,
- 'khaki'
- ];
- unshift @shapes, [ 'filledRectangle', @bounds, 'white' ];
- }
- push @shapes, [ 'rectangle', @bounds, 'black' ];
- $max_x = $this_max_x if $this_max_x > $max_x;
- $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 column
- $max_y = $y if $y > $max_y; # note the max y
- $y = $orig_y; # reset the y for next column
- }
-}
-
-#
-# Connect the lines.
-#
-my %horz_taken;
-my %done;
-unless ( $no_lines ) {
- my @position_bunches;
-
- if ( $natural_join ) {
- for my $field_name ( keys %nj_registry ) {
- my @positions;
- 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'};
- }
-
- push @position_bunches, [ @positions ];
- }
+pod2usage( -message => 'No input file' ) unless @files;
+
+my $translator = SQL::Translator->new(
+ from => $db_driver,
+ to => 'Diagram',
+ debug => $debug || 0,
+ producer_args => {
+ out_file => $out_file,
+ image_type => $image_type,
+ title => $title,
+ no_columns => $no_columns,
+ no_lines => $no_lines,
+ font_size => $font_size,
+ add_color => $add_color,
+ show_fk_only => $show_fk_only,
+ natural_join => $natural_join,
+ join_pk_only => $join_pk_only,
+ skip_fields => $skip_fields,
+ },
+) or die SQL::Translator->error;
+
+for my $file (@files) {
+ my $output = $translator->translate( $file ) or die
+ "Error: " . $translator->error;
+ if ( $out_file ) {
+ print "Image written to '$out_file'. Done.\n";
}
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'},
- ];
- }
+ print $output;
}
-
- 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'} || [] } or next;
- my ( $bx, $by ) = @{ $pos1->{'right'} || [] } or next;
- my $table1 = $pos1->{'table'};
- my $fno1 = $pos1->{'field_no'};
- my $is_pk = $pos1->{'is_pk'};
- next if $join_pk_only and !$is_pk;
-
- for my $j ( 0 .. $#positions ) {
- my $pos2 = $positions[ $j ];
- 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;
-
- my @distances = ();
- push @distances, [
- abs ( $ax - $cx ) + abs ( $ay - $cy ),
- [ $ax, $ay, $cx, $cy ],
- [ 'left', 'left' ]
- ];
- push @distances, [
- abs ( $ax - $dx ) + abs ( $ay - $dy ),
- [ $ax, $ay, $dx, $dy ],
- [ 'left', 'right' ],
- ];
- push @distances, [
- abs ( $bx - $cx ) + abs ( $by - $cy ),
- [ $bx, $by, $cx, $cy ],
- [ 'right', 'left' ],
- ];
- push @distances, [
- abs ( $bx - $dx ) + abs ( $by - $dy ),
- [ $bx, $by, $dx, $dy ],
- [ 'right', 'right' ],
- ];
- @distances = sort { $a->[0] <=> $b->[0] } @distances;
- my $shortest = $distances[0];
- my ( $x1, $y1, $x2, $y2 ) = @{ $shortest->[1] };
- my ( $side1, $side2 ) = @{ $shortest->[2] };
- my ( $start, $end );
- my $offset = 9;
- my $col1_right = $table_x{ $table1 };
- my $col2_right = $table_x{ $table2 };
-
- my $diff = 0;
- if ( $x1 == $x2 ) {
- while ( $horz_taken{ $x1 + $diff } ) {
- $diff = $side1 eq 'left' ? $diff - 2 : $diff + 2;
- }
- $horz_taken{ $x1 + $diff } = 1;
- }
-
- if ( $side1 eq 'left' ) {
- $start = $x1 - $offset + $diff;
- }
- else {
- $start = $col1_right + $diff;
- }
-
- if ( $side2 eq 'left' ) {
- $end = $x2 - $offset + $diff;
- }
- else {
- $end = $col2_right + $diff;
- }
-
- 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;
- }
- }
- }
-}
-
-#
-# Add the title, legend and signature.
-#
-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'
-];
-
-if ( %legend ) {
- $max_y += 5;
- 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 += 2;
-
- while ( my ( $key, $shape ) = each %legend ) {
- my $space = $longest - length $shape;
- push @shapes, [
- 'string', $font, $x, $max_y - $font->height - 4,
- join( '', $shape, ' ' x $space, $key ), 'black'
- ];
-
- $max_y += $font->height + 4;
- }
-}
-
-my $sig = "auto-dia.pl $VERSION";
-my $sig_len = $font->width * length $sig;
-push @shapes, [
- 'string', $font, $max_x - $sig_len, $max_y - $font->height - 4,
- $sig, 'black'
-];
-
-#
-# 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";
-}
-my %colors = map { $_->[0], $gd->colorAllocate( @{$_->[1]} ) } (
- [ white => [ 255, 255, 255 ] ],
- [ 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';
-$gd->fill( 0, 0, $colors{ $background_color } );
-for my $shape ( @shapes ) {
- my $method = shift @$shape;
- my $color = pop @$shape;
- $gd->$method( @$shape, $colors{ $color } );
-}
-
-#
-# Print the image.
-#
-if ( $out_file ) {
- open my $fh, ">$out_file" or die "Can't write '$out_file': $!\n";
- print $fh $gd->$image_type;
- close $fh;
- print "Image written to '$out_file'. Done.\n";
-}
-else {
- print $gd->$image_type;
}
=pod
projects / dbsrgits/SQL-Translator.git / commitdiff