blog.8-p.info

Previously I wrote “merge_graph” method to drawing inheritance tree with Class::Sniff. But now, new Class::Sniff shipped with “combine_graphs” method and make obsolete my code :D

So I rewrite my two scripts:

use strict;
use warnings;
use Class::Sniff;

sub package_of {
    my ($path) = @_;

    if ($path !~ m|/?lib/(.*)\.pm$|) {
      die;
    }

    my $result = $1;
    $result =~ s|/|::|g;
    return $result;
}

my @sniffs = map {
    my $package = package_of($_);
    eval "use $package";

    Class::Sniff->new({ class => $package });
} @ARGV;

my $sniff = pop @sniffs;
print $sniff->combine_graphs(@sniffs)->as_graphviz;

use strict;
use warnings;
use Class::Sniff;

sub package_of {
    my ($path) = @_;

    if ($path !~ m|/?lib/(.*)\.pm$|) {
      die;
    }

    my $result = $1;
    $result =~ s|/|::|g;
    return $result;
}

sub new_methods {
    my ($sniffer) = @_;
    my %count_of;

    for my $method ($sniffer->methods) {
        $count_of{$method}++;
    }

    my $klass = $sniffer->target_class;
    for my $method (keys %{ $sniffer->exported->{ $klass } }) {
        $count_of{$method}--;
    }

    grep { $_ } map {
        my $method = $_;

        ($count_of{$method} > 0)? $method : undef;
    } (keys %count_of);
}

my @sniffs = map {
    my $package = package_of($_);
    eval "use $package";

    Class::Sniff->new({ class => $package });
} @ARGV;

my $labels = join "\n", map {
    my @methods = new_methods($_);

    my $label = '{\N\n|' . join('\l', sort @methods) . '\l}';
    $label =~ s/"/\\"/g;

    sprintf('"%s" [label="%s"]', $_->target_class, $label);
} @sniffs;

my $sniff = pop @sniffs;
my $graphviz = $sniff->combine_graphs(@sniffs)->as_graphviz;

# it's dirty...
$graphviz =~ s/}/$labels }/g;
$graphviz =~ s/shape=box/shape=record/g;

print $graphviz;

And update my gist with second.