[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Producer / GraphViz.pm

package SQL::Translator::Producer::GraphViz;

# -------------------------------------------------------------------
# $Id: GraphViz.pm,v 1.4 2003-06-05 01:57:48 kycl4rk Exp $
# -------------------------------------------------------------------
# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>
#
# 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
# -------------------------------------------------------------------

use strict;
use GraphViz;
use Data::Dumper;
use SQL::Translator::Utils qw(debug);

use vars qw[ $VERSION $DEBUG ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0 unless defined $DEBUG;

use constant VALID_LAYOUT => {
    dot   => 1, 
    neato => 1, 
    twopi => 1,
};

use constant VALID_NODE_SHAPE => {
    record        => 1, 
    plaintext     => 1, 
    ellipse       => 1, 
    circle        => 1, 
    egg           => 1, 
    triangle      => 1, 
    box           => 1, 
    diamond       => 1, 
    trapezium     => 1, 
    parallelogram => 1, 
    house         => 1, 
    hexagon       => 1, 
    octagon       => 1, 
};

use constant VALID_OUTPUT => {
    canon => 1, 
    text  => 1, 
    ps    => 1, 
    hpgl  => 1,
    pcl   => 1, 
    mif   => 1, 
    pic   => 1, 
    gd    => 1, 
    gd2   => 1, 
    gif   => 1, 
    jpeg  => 1,
    png   => 1, 
    wbmp  => 1, 
    cmap  => 1, 
    ismap => 1, 
    imap  => 1, 
    vrml  => 1,
    vtx   => 1, 
    mp    => 1, 
    fig   => 1, 
    svg   => 1, 
    plain => 1,
};

sub produce {
    my ($t, $data) = @_;
    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 $layout          = $args->{'layout'}      || 'neato';
    my $node_shape      = $args->{'node_shape'}  || 'record';
    my $output_type     = $args->{'output_type'} || 'png';
    my $width           = defined $args->{'width'} 
                          ? $args->{'width'} : 8.5;
    my $height          = defined $args->{'height'}
                          ? $args->{'height'} : 11;
    my $show_fields     = defined $args->{'show_fields'} 
                          ? $args->{'show_fields'} : 1;
    my $add_color       = $args->{'add_color'};
    my $natural_join    = $args->{'natural_join'};
    my $join_pk_only    = $args->{'join_pk_only'};
    my $skip_fields     = $args->{'skip_fields'};
    my %skip            = map { s/^\s+|\s+$//g; $_, 1 }
                          split ( /,/, $skip_fields );
    $natural_join     ||= $join_pk_only;

    die "Invalid layout '$layout'" unless VALID_LAYOUT->{ $layout };
    die "Invalid output type: '$output_type'"
        unless VALID_OUTPUT->{ $output_type };
    die "Invalid node shape'$node_shape'" 
        unless VALID_NODE_SHAPE->{ $node_shape };

    for ( $height, $width ) {
        $_ = 0 unless $_ =~ /^\d+(.\d)?$/;
        $_ = 0 if $_ < 0;
    }

    #
    # Create GraphViz and see if we can produce the output type.
    #
    my %args = (
        directed      => $natural_join ? 0 : 1,
        layout        => $layout,
        no_overlap    => 1,
        bgcolor       => $add_color ? 'lightgoldenrodyellow' : 'white',
        node          => { 
            shape     => $node_shape, 
            style     => 'filled', 
            fillcolor => 'white' 
        }
    );
    $args{'width'}  = $width  if $width;
    $args{'height'} = $height if $height;

    my $gv =  GraphViz->new( %args ) or die "Can't create GraphViz object\n";

    my %nj_registry; # for locations of fields for natural joins
    my @fk_registry; # for locations of fields for foreign keys

    #
    # If necessary, pre-process fields to find foreign keys.
    #
    if ( $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;
                    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 @fields = 
            map  { $_->[1] }
            sort { $a->[0] <=> $b->[0] }
            map  { [ $_->{'order'}, $_ ] }
            values %{ $table->{'fields'} };

        my $field_str = join('\l', map { $_->{'name'} } @fields);
        my $label = $show_fields ? "{$table_name|$field_str}" : $table_name;
        $gv->add_node( $table_name, label => $label );

        debug("Processing table '$table_name'");

        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("Primary keys = ", join(', ', sort keys %pk));
        debug("Unique = ", join(', ', sort keys %unique));

        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 ( $natural_join ) {
                next unless $is_pk || $f->{'is_fk'};
            }
            else {
                next unless $is_pk ||
                    grep { $_->{'type'} eq 'foreign_key' }
                    @{ $f->{'constraints'} }
                ;
            }

            my $constraints = $f->{'constraints'};

            if ( $natural_join && !$skip{ $name } ) {
                push @{ $nj_registry{ $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, $fk_table ];
                    }
                }
            }
        }
    }

    #
    # Make the connections.
    #
    my @table_bunches;
    if ( $natural_join ) {
        for my $field_name ( keys %nj_registry ) {
            my @table_names = @{ $nj_registry{ $field_name } || [] } or next;
            next if scalar @table_names == 1;
            push @table_bunches, [ @table_names ];
        }
    }
    else {
        @table_bunches = @fk_registry;
    }

    my %done;
    for my $bunch ( @table_bunches ) {
        my @tables = @$bunch;

        for my $i ( 0 .. $#tables ) {
            my $table1 = $tables[ $i ];
            for my $j ( 0 .. $#tables ) {
                my $table2 = $tables[ $j ];
                next if $table1 eq $table2;
                next if $done{ $table1 }{ $table2 };
                $gv->add_edge( $table1, $table2 );
                $done{ $table1 }{ $table2 } = 1;
                $done{ $table2 }{ $table1 } = 1;
            }
        }
    }

    #
    # Print the image.
    #
    my $output_method = "as_$output_type";
    if ( $out_file ) {
        open my $fh, ">$out_file" or die "Can't write '$out_file': $!\n";
        print $fh $gv->$output_method;
        close $fh;
    }
    else {
        return $gv->$output_method;
    }
}

1;

=pod

=head1 NAME

SQL::Translator::Producer::GraphViz - GraphViz producer for SQL::Translator

=head1 AUTHOR

Ken Y. Clark E<lt>kclark@cpan.orgE<gt>

=cut
Commit	Line	Data
14d7eb56	1	package SQL::Translator::Producer::GraphViz;
	2
	3	# -------------------------------------------------------------------
e36752ea	4	# $Id: GraphViz.pm,v 1.4 2003-06-05 01:57:48 kycl4rk Exp $
14d7eb56	5	# -------------------------------------------------------------------
	6	# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>
	7	#
	8	# This program is free software; you can redistribute it and/or
	9	# modify it under the terms of the GNU General Public License as
	10	# published by the Free Software Foundation; version 2.
	11	#
	12	# This program is distributed in the hope that it will be useful, but
	13	# WITHOUT ANY WARRANTY; without even the implied warranty of
	14	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	15	# General Public License for more details.
	16	#
	17	# You should have received a copy of the GNU General Public License
	18	# along with this program; if not, write to the Free Software
	19	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	20	# 02111-1307 USA
	21	# -------------------------------------------------------------------
	22
	23	use strict;
	24	use GraphViz;
	25	use Data::Dumper;
	26	use SQL::Translator::Utils qw(debug);
	27
	28	use vars qw[ $VERSION $DEBUG ];
e36752ea	29	$VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
14d7eb56	30	$DEBUG = 0 unless defined $DEBUG;
	31
	32	use constant VALID_LAYOUT => {
	33	dot => 1,
	34	neato => 1,
	35	twopi => 1,
	36	};
	37
	38	use constant VALID_NODE_SHAPE => {
	39	record => 1,
	40	plaintext => 1,
	41	ellipse => 1,
	42	circle => 1,
	43	egg => 1,
	44	triangle => 1,
	45	box => 1,
	46	diamond => 1,
	47	trapezium => 1,
	48	parallelogram => 1,
	49	house => 1,
	50	hexagon => 1,
	51	octagon => 1,
	52	};
	53
	54	use constant VALID_OUTPUT => {
	55	canon => 1,
	56	text => 1,
	57	ps => 1,
	58	hpgl => 1,
	59	pcl => 1,
	60	mif => 1,
	61	pic => 1,
	62	gd => 1,
	63	gd2 => 1,
	64	gif => 1,
	65	jpeg => 1,
	66	png => 1,
	67	wbmp => 1,
	68	cmap => 1,
	69	ismap => 1,
	70	imap => 1,
	71	vrml => 1,
	72	vtx => 1,
	73	mp => 1,
	74	fig => 1,
	75	svg => 1,
	76	plain => 1,
	77	};
	78
	79	sub produce {
	80	my ($t, $data) = @_;
	81	my $args = $t->producer_args;
	82	local $DEBUG = $t->debug;
	83	debug("Data =\n", Dumper( $data ));
	84	debug("Producer args =\n", Dumper( $args ));
	85
0a0c85e8	86	my $out_file = $args->{'out_file'} \|\| '';
0a0c85e8	87	my $layout = $args->{'layout'} \|\| 'neato';
e36752ea	88	my $node_shape = $args->{'node_shape'} \|\| 'record';
0a0c85e8	89	my $output_type = $args->{'output_type'} \|\| 'png';
e36752ea	90	my $width = defined $args->{'width'}
	91	? $args->{'width'} : 8.5;
	92	my $height = defined $args->{'height'}
	93	? $args->{'height'} : 11;
	94	my $show_fields = defined $args->{'show_fields'}
	95	? $args->{'show_fields'} : 1;
14d7eb56	96	my $add_color = $args->{'add_color'};
	97	my $natural_join = $args->{'natural_join'};
	98	my $join_pk_only = $args->{'join_pk_only'};
	99	my $skip_fields = $args->{'skip_fields'};
	100	my %skip = map { s/^\s+\|\s+$//g; $_, 1 }
	101	split ( /,/, $skip_fields );
	102	$natural_join \|\|= $join_pk_only;
	103
	104	die "Invalid layout '$layout'" unless VALID_LAYOUT->{ $layout };
	105	die "Invalid output type: '$output_type'"
	106	unless VALID_OUTPUT->{ $output_type };
	107	die "Invalid node shape'$node_shape'"
	108	unless VALID_NODE_SHAPE->{ $node_shape };
	109
e36752ea	110	for ( $height, $width ) {
	111	$_ = 0 unless $_ =~ /^\d+(.\d)?$/;
	112	$_ = 0 if $_ < 0;
	113	}
	114
14d7eb56	115	#
	116	# Create GraphViz and see if we can produce the output type.
	117	#
e36752ea	118	my %args = (
14d7eb56	119	directed => $natural_join ? 0 : 1,
	120	layout => $layout,
	121	no_overlap => 1,
	122	bgcolor => $add_color ? 'lightgoldenrodyellow' : 'white',
	123	node => {
	124	shape => $node_shape,
	125	style => 'filled',
	126	fillcolor => 'white'
e36752ea	127	}
	128	);
	129	$args{'width'} = $width if $width;
	130	$args{'height'} = $height if $height;
	131
	132	my $gv = GraphViz->new( %args ) or die "Can't create GraphViz object\n";
14d7eb56	133
	134	my %nj_registry; # for locations of fields for natural joins
	135	my @fk_registry; # for locations of fields for foreign keys
	136
	137	#
	138	# If necessary, pre-process fields to find foreign keys.
	139	#
	140	if ( $natural_join ) {
	141	my ( %common_keys, %pk );
	142	for my $table ( values %$data ) {
	143	for my $index (
	144	@{ $table->{'indices'} \|\| [] },
	145	@{ $table->{'constraints'} \|\| [] },
	146	) {
	147	my @fields = @{ $index->{'fields'} \|\| [] } or next;
	148	if ( $index->{'type'} eq 'primary_key' ) {
	149	$pk{ $_ } = 1 for @fields;
	150	}
	151	}
	152
	153	for my $field ( values %{ $table->{'fields'} } ) {
	154	push @{ $common_keys{ $field->{'name'} } },
	155	$table->{'table_name'};
	156	}
	157	}
	158
	159	for my $field ( keys %common_keys ) {
	160	my @tables = @{ $common_keys{ $field } };
	161	next unless scalar @tables > 1;
	162	for my $table ( @tables ) {
	163	next if $join_pk_only and !defined $pk{ $field };
	164	$data->{ $table }{'fields'}{ $field }{'is_fk'} = 1;
	165	}
	166	}
	167	}
	168	else {
	169	for my $table ( values %$data ) {
	170	for my $field ( values %{ $table->{'fields'} } ) {
	171	for my $constraint (
	172	grep { $_->{'type'} eq 'foreign_key' }
	173	@{ $field->{'constraints'} }
	174	) {
	175	my $ref_table = $constraint->{'reference_table'} or next;
	176	my @ref_fields = @{ $constraint->{'reference_fields'}\|\|[] };
	177
	178	unless ( @ref_fields ) {
	179	for my $field (
	180	values %{ $data->{ $ref_table }{'fields'} }
	181	) {
	182	for my $pk (
	183	grep { $_->{'type'} eq 'primary_key' }
	184	@{ $field->{'constraints'} }
	185	) {
	186	push @ref_fields, @{ $pk->{'fields'} };
	187	}
	188	}
	189
	190	$constraint->{'reference_fields'} = [ @ref_fields ];
	191	}
	192
	193	for my $ref_field (@{$constraint->{'reference_fields'}}) {
	194	$data->{$ref_table}{'fields'}{$ref_field}{'is_fk'} = 1;
	195	}
	196	}
197	}
198	}
199	}
200
201	for my $table (
202	map { $_->[1] }
203	sort { $a->[0] <=> $b->[0] }
204	map { [ $_->{'order'}, $_ ] }
205	values %$data
206	) {
207	my $table_name = $table->{'table_name'};
14d7eb56	208	my @fields =
	209	map { $_->[1] }
	210	sort { $a->[0] <=> $b->[0] }
	211	map { [ $_->{'order'}, $_ ] }
	212	values %{ $table->{'fields'} };
	213
e36752ea	214	my $field_str = join('\l', map { $_->{'name'} } @fields);
	215	my $label = $show_fields ? "{$table_name\|$field_str}" : $table_name;
	216	$gv->add_node( $table_name, label => $label );
	217
	218	debug("Processing table '$table_name'");
	219
14d7eb56	220	debug("Fields = ", join(', ', map { $_->{'name'} } @fields));
	221
	222	my ( %pk, %unique );
	223	for my $index (
	224	@{ $table->{'indices'} \|\| [] },
	225	@{ $table->{'constraints'} \|\| [] },
	226	) {
	227	my @fields = @{ $index->{'fields'} \|\| [] } or next;
	228	if ( $index->{'type'} eq 'primary_key' ) {
	229	$pk{ $_ } = 1 for @fields;
	230	}
	231	elsif ( $index->{'type'} eq 'unique' ) {
	232	$unique{ $_ } = 1 for @fields;
	233	}
	234	}
	235
	236	debug("Primary keys = ", join(', ', sort keys %pk));
	237	debug("Unique = ", join(', ', sort keys %unique));
	238
	239	for my $f ( @fields ) {
	240	my $name = $f->{'name'} or next;
	241	my $is_pk = $pk{ $name };
	242	my $is_unique = $unique{ $name };
	243
	244	#
	245	# Decide if we should skip this field.
	246	#
	247	if ( $natural_join ) {
	248	next unless $is_pk \|\| $f->{'is_fk'};
	249	}
	250	else {
	251	next unless $is_pk \|\|
	252	grep { $_->{'type'} eq 'foreign_key' }
	253	@{ $f->{'constraints'} }
	254	;
	255	}
	256
	257	my $constraints = $f->{'constraints'};
	258
	259	if ( $natural_join && !$skip{ $name } ) {
	260	push @{ $nj_registry{ $name } }, $table_name;
	261	}
	262	elsif ( @{ $constraints \|\| [] } ) {
	263	for my $constraint ( @$constraints ) {
	264	next unless $constraint->{'type'} eq 'foreign_key';
	265	for my $fk_field (
	266	@{ $constraint->{'reference_fields'} \|\| [] }
	267	) {
	268	my $fk_table = $constraint->{'reference_table'};
	269	next unless defined $data->{ $fk_table };
	270	push @fk_registry, [ $table_name, $fk_table ];
	271	}
	272	}
	273	}
	274	}
	275	}
	276
	277	#
	278	# Make the connections.
	279	#
	280	my @table_bunches;
	281	if ( $natural_join ) {
	282	for my $field_name ( keys %nj_registry ) {
	283	my @table_names = @{ $nj_registry{ $field_name } \|\| [] } or next;
284	next if scalar @table_names == 1;
285	push @table_bunches, [ @table_names ];
286	}
287	}
288	else {
289	@table_bunches = @fk_registry;
290	}
291
292	my %done;
293	for my $bunch ( @table_bunches ) {
294	my @tables = @$bunch;
295
296	for my $i ( 0 .. $#tables ) {
297	my $table1 = $tables[ $i ];
298	for my $j ( 0 .. $#tables ) {
299	my $table2 = $tables[ $j ];
300	next if $table1 eq $table2;
301	next if $done{ $table1 }{ $table2 };
302	$gv->add_edge( $table1, $table2 );
303	$done{ $table1 }{ $table2 } = 1;
304	$done{ $table2 }{ $table1 } = 1;
305	}
306	}
307	}
308
309	#
310	# Print the image.
311	#
312	my $output_method = "as_$output_type";
313	if ( $out_file ) {
314	open my $fh, ">$out_file" or die "Can't write '$out_file': $!\n";
315	print $fh $gv->$output_method;
316	close $fh;
317	}
318	else {
319	return $gv->$output_method;
320	}
321	}
322
323	1;
324
325	=pod
326
327	=head1 NAME
328
329	SQL::Translator::Producer::GraphViz - GraphViz producer for SQL::Translator
330
331	=head1 AUTHOR
332
333	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
334
335	=cut