5 |
use lib "$ENV{HOME}/public_perl/"; |
use lib "$ENV{HOME}/public_perl/"; |
6 |
use Zot; |
use Zot; |
7 |
|
|
8 |
our ($f, $l, $h, $c); |
our ($f, $l, $h, $c, $t); |
9 |
|
|
10 |
my $compact = $c ? 1 : 0; |
my $compact = $c ? 1 : 0; |
11 |
my $full = $f ? 1 : 0; |
my $full = $f ? 1 : 0; |
12 |
my $labels = $l ? 1 : 0; |
my $labels = $l ? 1 : 0; |
13 |
my $history = $h ? 1 : 0; |
my $history = $h ? 1 : 0; |
14 |
|
my %target_tables; |
15 |
|
$target_tables{$_}++ |
16 |
|
foreach (split /,/, $t); |
17 |
|
|
18 |
my $zot = Zot->new(shift); |
my $zot = Zot->new(shift); |
19 |
$zot->parse; |
$zot->parse; |
24 |
'rel' => { 'node' => 'fontsize=8 shape=diamond style=filled fillcolor="#dddddd"', |
'rel' => { 'node' => 'fontsize=8 shape=diamond style=filled fillcolor="#dddddd"', |
25 |
'tail' => 'arrowhead=none', |
'tail' => 'arrowhead=none', |
26 |
'head' => '', |
'head' => '', |
27 |
'private' => 'color="#7f7f7f" fontcolor="#7f7f7f"'}, |
'private' => 'color="#7f7f7f" fontcolor="#7f7f7f" '}, |
28 |
'attr' => { 'node' => 'fontsize=8', |
'attr' => { 'node' => 'fontsize=8', |
29 |
'edge' => 'arrowhead=none', |
'edge' => 'arrowhead=none', |
30 |
'private' => 'color="#7f7f7f" fontcolor="#7f7f7f"', |
'private' => 'color="#7f7f7f" fontcolor="#7f7f7f"', |
35 |
); |
); |
36 |
|
|
37 |
|
|
38 |
my $out = "digraph foo {\n graph [ overlap=scale epsilon=0.00000001 pack=false remincross=true fontsize=11 ];\n" |
my $out = "digraph foo {\n graph [ overlap=scale epsilon=0.00000001 pack=false remincross=true fontsize=11 compound=true ];\n" |
39 |
. "edge [ fontsize=\"8\" decorate=true ];\n"; |
. "edge [ fontsize=\"8\" decorate=true ];\n"; |
40 |
my $rels = " node [shape=diamond, style=filled, fillcolor=gray];\n"; |
my $rels = " node [shape=diamond, style=filled, fillcolor=gray];\n"; |
41 |
my $tables = " node [shape=ellipse style=filled fillcolor=\"white\", fontsize=\"10\" ];\n"; |
my $tables = " node [shape=ellipse style=filled fillcolor=\"white\", fontsize=\"10\" ];\n"; |
42 |
my $subgr = ''; |
my $subgr = ''; |
43 |
|
|
44 |
|
my %relh; |
45 |
|
my @Tables; |
46 |
|
|
47 |
foreach my $root ($zot->roots) |
foreach my $root ($zot->roots) |
48 |
{ |
{ |
49 |
my @kids = @{$zot->root($root)}; |
my @kids = @{$zot->root($root)}; |
50 |
|
next if %target_tables and not grep $_, @target_tables{@kids}; |
51 |
|
push @Tables, @kids; |
52 |
my $mult = (@kids > 2) || ( (@kids == 2) && !( ($kids[0] eq "_$kids[1]_data") || ($kids[1] eq "_$kids[0]_data"))); |
my $mult = (@kids > 2) || ( (@kids == 2) && !( ($kids[0] eq "_$kids[1]_data") || ($kids[1] eq "_$kids[0]_data"))); |
53 |
|
|
54 |
$tables .= " subgraph cluster_HIERARCHY_$root {\n" |
$tables .= " subgraph cluster_HIERARCHY_$root {\n" |
105 |
$table->name, $rel, $rel, |
$table->name, $rel, $rel, |
106 |
$style{'rel'}{'node'}, |
$style{'rel'}{'node'}, |
107 |
$rel eq '_table' ? $style{'rel'}{'private'} : '' ); |
$rel eq '_table' ? $style{'rel'}{'private'} : '' ); |
108 |
$a{$table->name} .= sprintf( " %s -> \"%s::%s\" [%s];\n", |
$a{$table->name} .= sprintf( " %s -> \"%s::%s\" [%s %s];\n", |
109 |
$table->name, $table->name, $rel, |
$table->name, $table->name, $rel, |
110 |
$style{'rel'}{'tail'}); |
$style{'rel'}{'tail'}); |
111 |
|
|
112 |
$rels .= sprintf( " \"%s::%s\" -> %s [lhead=\"cluster_%s\" %s %s];\n", |
$relh{$table->name}{$table->rel($rel)} .= sprintf( " \"%s::%s\" -> %s [lhead=\"cluster_%s\" %s %s];\n", |
113 |
$table->name, $rel, $table->rel($rel), $table->rel($rel), |
$table->name, $rel, $table->rel($rel), $table->rel($rel), |
114 |
$style{'rel'}{'head'}, |
$style{'rel'}{'head'}, |
115 |
$labels ? qq'label="$rel"' : ''); |
$labels ? qq'label="$rel"' : ''); |
148 |
if ($mult); |
if ($mult); |
149 |
} |
} |
150 |
|
|
151 |
|
foreach my $table (keys %relh) |
152 |
|
{ |
153 |
|
foreach my $other (keys %{$relh{$table}}) |
154 |
|
{ |
155 |
|
$rels .= $relh{$table}{$other} if grep $_ eq $other, @Tables; |
156 |
|
} |
157 |
|
} |
158 |
print $out . $tables . $rels . $subgr. "}\n"; |
print $out . $tables . $rels . $subgr. "}\n"; |