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

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

# -------------------------------------------------------------------
# $Id: GraphViz.pm,v 1.3 2003-05-26 22:29:48 allenday 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.3 $ =~ /(\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 $width           = $args->{'width'}       || 8.5;
    my $height          = $args->{'height'}      || 11;
    my $out_file        = $args->{'out_file'}    || '';
    my $layout          = $args->{'layout'}      || 'neato';
    my $node_shape      = $args->{'node_shape'}  || 'ellipse';
    my $output_type     = $args->{'output_type'} || 'png';
    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 };

    #
    # Create GraphViz and see if we can produce the output type.
    #
    my $gv            =  GraphViz->new(
        directed      => $natural_join ? 0 : 1,
        width         => $width,
        height        => $height,
        layout        => $layout,
        no_overlap    => 1,
        bgcolor       => $add_color ? 'lightgoldenrodyellow' : 'white',
        node          => { 
            shape     => $node_shape, 
            style     => 'filled', 
            fillcolor => 'white' 
        },
    ) 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'};
        $gv->add_node( $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("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	# -------------------------------------------------------------------
cce2cd78	4	# $Id: GraphViz.pm,v 1.3 2003-05-26 22:29:48 allenday 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 ];
cce2cd78	29	$VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\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
cce2cd78	86	my $width = $args->{'width'} \|\| 8.5;
cce2cd78	87	my $height = $args->{'height'} \|\| 11;
0a0c85e8	88	my $out_file = $args->{'out_file'} \|\| '';
	89	my $layout = $args->{'layout'} \|\| 'neato';
	90	my $node_shape = $args->{'node_shape'} \|\| 'ellipse';
	91	my $output_type = $args->{'output_type'} \|\| 'png';
14d7eb56	92	my $add_color = $args->{'add_color'};
	93	my $natural_join = $args->{'natural_join'};
	94	my $join_pk_only = $args->{'join_pk_only'};
	95	my $skip_fields = $args->{'skip_fields'};
	96	my %skip = map { s/^\s+\|\s+$//g; $_, 1 }
	97	split ( /,/, $skip_fields );
	98	$natural_join \|\|= $join_pk_only;
	99
	100	die "Invalid layout '$layout'" unless VALID_LAYOUT->{ $layout };
	101	die "Invalid output type: '$output_type'"
	102	unless VALID_OUTPUT->{ $output_type };
	103	die "Invalid node shape'$node_shape'"
	104	unless VALID_NODE_SHAPE->{ $node_shape };
	105
	106	#
	107	# Create GraphViz and see if we can produce the output type.
	108	#
	109	my $gv = GraphViz->new(
	110	directed => $natural_join ? 0 : 1,
cce2cd78	111	width => $width,
cce2cd78	112	height => $height,
14d7eb56	113	layout => $layout,
	114	no_overlap => 1,
	115	bgcolor => $add_color ? 'lightgoldenrodyellow' : 'white',
	116	node => {
	117	shape => $node_shape,
	118	style => 'filled',
	119	fillcolor => 'white'
	120	},
	121	) or die "Can't create GraphViz object\n";
	122
	123	my %nj_registry; # for locations of fields for natural joins
	124	my @fk_registry; # for locations of fields for foreign keys
	125
	126	#
	127	# If necessary, pre-process fields to find foreign keys.
	128	#
	129	if ( $natural_join ) {
	130	my ( %common_keys, %pk );
	131	for my $table ( values %$data ) {
	132	for my $index (
	133	@{ $table->{'indices'} \|\| [] },
	134	@{ $table->{'constraints'} \|\| [] },
	135	) {
	136	my @fields = @{ $index->{'fields'} \|\| [] } or next;
	137	if ( $index->{'type'} eq 'primary_key' ) {
	138	$pk{ $_ } = 1 for @fields;
	139	}
	140	}
	141
	142	for my $field ( values %{ $table->{'fields'} } ) {
	143	push @{ $common_keys{ $field->{'name'} } },
	144	$table->{'table_name'};
	145	}
	146	}
	147
	148	for my $field ( keys %common_keys ) {
	149	my @tables = @{ $common_keys{ $field } };
	150	next unless scalar @tables > 1;
	151	for my $table ( @tables ) {
	152	next if $join_pk_only and !defined $pk{ $field };
	153	$data->{ $table }{'fields'}{ $field }{'is_fk'} = 1;
	154	}
	155	}
	156	}
	157	else {
	158	for my $table ( values %$data ) {
	159	for my $field ( values %{ $table->{'fields'} } ) {
	160	for my $constraint (
	161	grep { $_->{'type'} eq 'foreign_key' }
	162	@{ $field->{'constraints'} }
	163	) {
	164	my $ref_table = $constraint->{'reference_table'} or next;
	165	my @ref_fields = @{ $constraint->{'reference_fields'}\|\|[] };
	166
	167	unless ( @ref_fields ) {
	168	for my $field (
	169	values %{ $data->{ $ref_table }{'fields'} }
	170	) {
	171	for my $pk (
	172	grep { $_->{'type'} eq 'primary_key' }
	173	@{ $field->{'constraints'} }
	174	) {
	175	push @ref_fields, @{ $pk->{'fields'} };
	176	}
177	}
178
179	$constraint->{'reference_fields'} = [ @ref_fields ];
180	}
181
182	for my $ref_field (@{$constraint->{'reference_fields'}}) {
183	$data->{$ref_table}{'fields'}{$ref_field}{'is_fk'} = 1;
184	}
185	}
186	}
187	}
188	}
189
190	for my $table (
191	map { $_->[1] }
192	sort { $a->[0] <=> $b->[0] }
193	map { [ $_->{'order'}, $_ ] }
194	values %$data
195	) {
196	my $table_name = $table->{'table_name'};
197	$gv->add_node( $table_name );
198
199	debug("Processing table '$table_name'");
200
201	my @fields =
202	map { $_->[1] }
203	sort { $a->[0] <=> $b->[0] }
204	map { [ $_->{'order'}, $_ ] }
205	values %{ $table->{'fields'} };
206
207	debug("Fields = ", join(', ', map { $_->{'name'} } @fields));
208
209	my ( %pk, %unique );
210	for my $index (
211	@{ $table->{'indices'} \|\| [] },
212	@{ $table->{'constraints'} \|\| [] },
213	) {
214	my @fields = @{ $index->{'fields'} \|\| [] } or next;
215	if ( $index->{'type'} eq 'primary_key' ) {
216	$pk{ $_ } = 1 for @fields;
217	}
218	elsif ( $index->{'type'} eq 'unique' ) {
219	$unique{ $_ } = 1 for @fields;
220	}
221	}
222
223	debug("Primary keys = ", join(', ', sort keys %pk));
224	debug("Unique = ", join(', ', sort keys %unique));
225
226	for my $f ( @fields ) {
227	my $name = $f->{'name'} or next;
228	my $is_pk = $pk{ $name };
229	my $is_unique = $unique{ $name };
230
231	#
232	# Decide if we should skip this field.
233	#
234	if ( $natural_join ) {
235	next unless $is_pk \|\| $f->{'is_fk'};
236	}
237	else {
238	next unless $is_pk \|\|
239	grep { $_->{'type'} eq 'foreign_key' }
240	@{ $f->{'constraints'} }
241	;
242	}
243
244	my $constraints = $f->{'constraints'};
245
246	if ( $natural_join && !$skip{ $name } ) {
247	push @{ $nj_registry{ $name } }, $table_name;
248	}
249	elsif ( @{ $constraints \|\| [] } ) {
250	for my $constraint ( @$constraints ) {
251	next unless $constraint->{'type'} eq 'foreign_key';
252	for my $fk_field (
253	@{ $constraint->{'reference_fields'} \|\| [] }
254	) {
255	my $fk_table = $constraint->{'reference_table'};
256	next unless defined $data->{ $fk_table };
257	push @fk_registry, [ $table_name, $fk_table ];
258	}
259	}
260	}
261	}
262	}
263
264	#
265	# Make the connections.
266	#
267	my @table_bunches;
268	if ( $natural_join ) {
269	for my $field_name ( keys %nj_registry ) {
270	my @table_names = @{ $nj_registry{ $field_name } \|\| [] } or next;
271	next if scalar @table_names == 1;
272	push @table_bunches, [ @table_names ];
273	}
274	}
275	else {
276	@table_bunches = @fk_registry;
277	}
278
279	my %done;
280	for my $bunch ( @table_bunches ) {
281	my @tables = @$bunch;
282
283	for my $i ( 0 .. $#tables ) {
284	my $table1 = $tables[ $i ];
285	for my $j ( 0 .. $#tables ) {
286	my $table2 = $tables[ $j ];
287	next if $table1 eq $table2;
288	next if $done{ $table1 }{ $table2 };
289	$gv->add_edge( $table1, $table2 );
290	$done{ $table1 }{ $table2 } = 1;
291	$done{ $table2 }{ $table1 } = 1;
292	}
293	}
294	}
295
296	#
297	# Print the image.
298	#
299	my $output_method = "as_$output_type";
300	if ( $out_file ) {
301	open my $fh, ">$out_file" or die "Can't write '$out_file': $!\n";
302	print $fh $gv->$output_method;
303	close $fh;
304	}
305	else {
306	return $gv->$output_method;
307	}
308	}
309
310	1;
311
312	=pod
313
314	=head1 NAME
315
316	SQL::Translator::Producer::GraphViz - GraphViz producer for SQL::Translator
317
318	=head1 AUTHOR
319
320	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
321
322	=cut