source: fedkit/genviz.pl @ a65a65a

#!/usr/bin/perl

use strict;

use XML::Parser;
use IO::File;
use IO::Pipe;

sub genviz {
    my($file, $outfile)= @_;
    my %nodes;
    my $chars;
    my $in_node;
    my $in_lan;
    my $lan;
    my %links;
    my %lans;
    my $rv;
    my $dotfile = "/tmp/split$$.dot";
    my $neato = "/usr/local/bin/neato";
    my $g = new IO::File(">$dotfile") || return;
    my $p = new IO::Pipe() || return;
    my $out = new IO::File(">$outfile");

    sub start_element { 
        my($expat, $element) = @_;
        $in_node++ if $element eq "node";
        if ( $element eq "lan" ) {
            $in_lan++;
            $lan = {};
        }
    }

    sub end_element {
        my($expat, $element) = @_;

        $in_node = 0 if $element eq "node";
        $nodes{$chars} = "node" if $in_node && $element eq "vname";
        if ($in_lan) {
            if ( $element ne "lan") {
                $lan->{$element} = $chars if $element =~/(vname|vnode)/;
            }
            else {
                $in_lan = 0;
                my $vname = $lan->{'vname'};
                if ( $links{$vname} && @{$links{$vname}} ==2 ) {
                    # this link needs to be a lan
                    $nodes{$vname} = "lan";
                    $lans{$lan->{'vname'}} = ();
                    foreach my $l (@{$links{$vname}}) {
                        push(@{$lans{$vname}}, $l);
                    }
                    push(@{$lans{$vname}}, $lan->{'vnode'});
                    $links{$vname} = ();
                    $lan={};
                    return;
                }
                if ( $lans{$vname} && @{$lans{$vname}}) {
                    push(@{$lans{$vname}}, $lan->{'vnode'});
                    $lan = {};
                    return;
                }
                $links{$vname} = () unless $links{$vname};
                push(@{$links{$vname}}, $lan->{'vnode'});
                $lan = {};
                return;
            }
        }
    }
    sub found_chars { 
        my($expat, $data) = @_;
        $chars = $data;
    }

    my $parser = new XML::Parser(Handlers => { 
            Start => \&start_element, 
            End => \&end_element,
            Char => \&found_chars
        });

    print "$file\n";
    $parser->parsefile($file);

    print $g "graph G {\n";
    foreach my $n (keys %nodes) {
        print $g "\t$n\n";
    }
    foreach my $l (keys %links) {
        print $g "\t", join(" -- ", @{$links{$l}}), "\n";
    }
    foreach my $l (keys %lans) {
        foreach my $n (@{$lans{$l}}) {
            print $g "\t $n -- $l\n";
        }
    }
    print $g "}\n";
    $g->close();
    $p->reader("$neato  -Gstart=rand -Gepsilon=0.005 -Gmaxiter=20000 " .
        "-Gpack=true $dotfile");
    print $out "<vis>\n";
    while (<$p>) {
        /^\s*(\w+)\s+\[.*pos=\"(\d+),(\d+)\"/ && do {
            my ($n, $x, $y) = ($1, $2, $3);

            print "<node><name>$n</name><x>$x</x><y>$y</y><type>$nodes{$n}". 
                "</type></node>\n" if $nodes{$n};
        };
    }
    print $out "</vis>\n";
    $p->close();
    unlink("$dotfile");
}

genviz($ARGV[0], $ARGV[1]);