Class::Sniff - Look for class composition code smells

 use Class::Sniff;
 my $sniff = Class::Sniff->new({class => 'Some::class'});

 my $num_methods = $sniff->methods;
 my $num_classes = $sniff->classes;
 my @methods     = $sniff->methods;
 my @classes     = $sniff->classes;

 my $graph    = $sniff->graph;   # Graph::Easy
 my $graphviz = $graph->as_graphviz();
 open my $DOT, '|dot -Tpng -o graph.png' or die("Cannot open pipe to dot: $!");
 print $DOT $graphviz;

 print $sniff->to_string;
 my @unreachable = $sniff->unreachable;
 foreach my $method (@unreachable) {
     print "$method\n";
 }

 my $sniff = Class::Sniff->new({class => 'Some::Class'});
 print $sniff->report;

 my $sniff = Class::Sniff->new({
    class  => 'My::Class',
    ignore => qr/^DBIx::Class/,
 });

 my @sniffs = Class::Sniff->new_from_namespace({
     namespace => $some_root_namespace,
     universal => 1,
 });

 # Print reports for each class
 foreach my $sniff (@sniffs) {
     print $sniff->report;
 }

 # Print out the full inheritance heirarchy.
 my $sniff = pop @sniffs;
 my $graph = $sniff->combine_graphs(@sniffs);

 my $graphviz = $graph->as_graphviz();
 open my $DOT, '|dot -Tpng -o graph.png' or die("Cannot open pipe to dot: $!");
 print $DOT $graphviz;

 my $overridden = $sniff->overridden;

    my $exported = $sniff->exported;

 {
     $class1 => {
         $sub1 => $exported_from1,
         $sub2 => $exported_from2,
     },
     $class2 => { ... }
 }

 my @unreachable = $sniff->unreachable;
 for my $method (@unreachable) {
     print "Cannot reach '$method'\n";
 }

 my @paths = $sniff->paths;

 for my $i (0 .. $#paths) {
     my $path = join ' -> ' => @{ $paths[$i] };
     printf "Path #%d is ($path)\n" => $i + 1;
 }

               Animal
              /      \
    Animal::Duck   Animal::SpareParts
              \      /
          Animal::Platypus

 (
     ['Animal::Platypus', 'Animal::Duck',       'Animal'],
     ['Animal::Platypus', 'Animal::SpareParts', 'Animal'],
 )

 # Look ma, one hand (er, path)!
 $sniff->paths( 
     ['Animal::Platypus', 'Animal::Duck', 'Animal::SpareParts', 'Animal'],
 );

 my $num_classes = $sniff->multiple_inheritance;
 my @classes     = $sniff->multiple_inheritance;

 my $num_duplicates = $self->duplicate_methods;
 my @duplicates     = $self->duplicate_methods;

 sub inc {
    my ( $self, $value ) = @_;
    return $value + 1;
 }

 sub increment {
    my ( $proto, $number ) = @_;
    return $number + 1;
 }

 sub increment {
    my ( $proto, $number ) = @_;
    return 1 + $number;
 }

 my $num_long_methods = $sniff->long_methods;
 my %long_methods     = $sniff->long_methods;

 # defaults to 'target_class'
 my $num_parents = $sniff->parents;
 my @parents     = $sniff->parents;

 my $num_parents = $sniff->parents('Some::Class');
 my @parents     = $sniff->parents('Some::Class');

 print $sniff->report;

 Report for class: Grandchild

 Overridden Methods
 .--------+--------------------------------------------------------------------.
 | Method | Class                                                              |
 +--------+--------------------------------------------------------------------+
 | bar    | Grandchild                                                         |
 |        | Abstract                                                           |
 |        | Child2                                                             |
 | foo    | Grandchild                                                         |
 |        | Child1                                                             |
 |        | Abstract                                                           |
 |        | Child2                                                             |
 '--------+--------------------------------------------------------------------'
 Unreachable Methods
 .--------+--------------------------------------------------------------------.
 | Method | Class                                                              |
 +--------+--------------------------------------------------------------------+
 | bar    | Child2                                                             |
 | foo    | Child2                                                             |
 '--------+--------------------------------------------------------------------'
 Multiple Inheritance
 .------------+----------------------------------------------------------------.
 | Class      | Parents                                                        |
 +------------+----------------------------------------------------------------+
 | Grandchild | Child1                                                         |
 |            | Child2                                                         |
 '------------+----------------------------------------------------------------'

 $sniff->width(80);

 print $sniff->to_string;

 my $graph = $sniff->graph;

 my $graph    = $sniff->graph;   # Graph::Easy
 my $graphviz = $graph->as_graphviz();
 open my $DOT, '|dot -Tpng -o graph.png' or die("Cannot open pipe to dot: $!");
 print $DOT $graphviz;

 my $graph = $sniff->combine_graphs($sniff2, $sniff3);
 print $graph->as_ascii;

 my $class = $sniff->target_class;

 my $method_length = $sniff->method_length;

 my $ignore = $sniff->ignore;

 my $universal = $sniff->universal;

 my $num_classes = $sniff->classes;
 my @classes     = $sniff->classes;

 # defaults to 'target_class'
 my $num_children = $sniff->children;
 my @children     = $sniff->children;

 my $num_children = $sniff->children('Some::Class');
 my @children     = $sniff->children('Some::Class');

 # defaults to 'target_class'
 my $num_methods = $sniff->methods;
 my @methods     = $sniff->methods;

 my $num_methods = $sniff->methods('Some::Class');
 my @methods     = $sniff->methods('Some::Class');

    perldoc Class::Sniff

package Class::Sniff;

use warnings;
use strict;

use B::Concise;
use Carp ();
use Devel::Symdump;
use Digest::MD5;
use Graph::Easy;
use List::MoreUtils  ();
use Sub::Information ();
use Text::SimpleTable;

our $VERSION = '0.08';

sub new {
    my ( $class, $arg_for ) = @_;
    my $proto = $arg_for->{class}
      or Carp::croak("'class' argument not supplied to 'new'");
    my $target_class = ref $proto || $proto;
    if ( exists $arg_for->{ignore} && 'Regexp' ne ref $arg_for->{ignore} ) {
        Carp::croak("'ignore' requires a regex");
    }
    my $self = bless {
        classes       => {},
        duplicates    => {},
        exported      => {},
        graph         => undef,
        ignore        => $arg_for->{ignore},
        list_classes  => [$target_class],
        long_methods  => {},
        methods       => {},
        paths         => [ [$target_class] ],
        target        => $target_class,
        universal     => $arg_for->{universal},
        method_length => ( $arg_for->{method_length} || 50 ),
    } => $class;
    $self->_initialize;
    return $self;
}

sub new_from_namespace {
    my ( $class, $arg_for ) = @_;
    my $namespace = delete $arg_for->{namespace}
      or Carp::croak("new_from_namespace requires a 'namespace' argument");
    my @sniffs;
    my %seen;
    my $new_sniff = sub {
        my $symbol_name = shift;
        no warnings 'numeric';
        return if $seen{$symbol_name}++;    # prevent infinite loops
        if ( $symbol_name =~ /^$namespace/ ) {
            $symbol_name =~ s/::$//;
            $arg_for->{class} = $symbol_name;
            push @sniffs => Class::Sniff->new($arg_for);
        }
        return 1;
    };
    B::walksymtable( \%::, 'NAME', $new_sniff );
    return @sniffs;
}

sub _initialize {
    my $self         = shift;
    my $target_class = $self->target_class;
    $self->width(72);
    $self->_register_class($target_class);
    $self->{classes}{$target_class}{count} = 1;
    $self->{graph} = Graph::Easy->new;
    $self->{graph}->set_attribute( 'graph', 'flow', 'up' );
    $self->_build_hierarchy($target_class);

    $self->_finalize;
}

sub _finalize {
    my $self    = shift;
    my @classes = $self->classes;
    my $index   = 0;
    my %classes = map { $_ => $index++ } @classes;

    # sort in inheritance order
    while ( my ( $method, $classes ) = each %{ $self->{methods} } ) {
        @$classes = sort { $classes{$a} <=> $classes{$b} } @$classes;
    }
}

sub _register_class {
    my ( $self, $class ) = @_;
    return if exists $self->{classes}{$class};

    # Do I really want to throw this away?
    my $symdump = Devel::Symdump->new($class);
    my @methods = map { s/^$class\:://; $_ } $symdump->functions;

    foreach my $method (@methods) {
        my $coderef = $class->can($method)
          or Carp::croak("Panic: $class->can($method) returned false!");
        my $info = Sub::Information::inspect($coderef);
        if ( $info->package ne $class ) {
            $self->{exported}{$class}{$method} = $info->package;
        }
        else {

            # It's OK to throw away the exception.  The B:: modules can be
            # tricky and this is documented as experimental.
            local $@;
            eval {
                my $line   = $info->line;
                my $length = B::svref_2object($coderef)->GV->LINE - $line;
                if ( $length > $self->method_length ) {
                    $self->{long_methods}{"$class\::$method"} = $length;
                }
            };
        }

        my $walker = B::Concise::compile( '-terse', $coderef );    # 1
        B::Concise::walk_output( \my $buffer );
        $walker->();    # 1 renders -terse
        $buffer =~ s/^.*//;                          # strip method name
        $buffer =~ s/\(0x[^)]+\)/(0xHEXNUMBER)/g;    # normalize addresses
        my $digest = Digest::MD5::md5_hex($buffer);
        $self->{duplicates}{$digest} ||= [];
        push @{ $self->{duplicates}{$digest} } => [ $class, $method ];
    }

    for my $method (@methods) {
        $self->{methods}{$method} ||= [];
        push @{ $self->{methods}{$method} } => $class;
    }

    $self->{classes}{$class} = {
        parents  => [],
        children => [],
        methods  => \@methods,
        count    => 0,
    };
    return $self;
}

sub overridden {
    my $self = shift;
    my %methods;
    while ( my ( $method, $classes ) = each %{ $self->{methods} } ) {
        $methods{$method} = $classes if @$classes > 1;
    }
    return \%methods;
}

sub exported { $_[0]->{exported} }

sub unreachable {
    my $self       = shift;
    my $overridden = $self->overridden;
    my @paths      = $self->paths;

    # If we only have one path through our code, we don't have any unreachable
    # methods.
    return if @paths == 1;

    # Algorithm:  If we have overridden methods, then if we have multiple
    # paths through the code, a method is unreachable if a *previous* path
    # contains the method because Perl's default search order won't get to
    # successive paths.
    my @unreachable;
    while ( my ( $method, $classes ) = each %$overridden ) {
        my @classes;

      CLASS:
        for my $class (@$classes) {
            my $method_found = 0;
            for my $path (@paths) {

                # method was found in a *previous* path.
                if ($method_found) {
                    push @unreachable => "$class\::$method";
                    next CLASS;
                }
                for my $curr_class (@$path) {
                    next CLASS if $curr_class eq $class;
                    if ( not $method_found && $curr_class->can($method) ) {
                        $method_found = 1;
                    }
                }
            }
        }
    }
    return @unreachable;
}

sub paths {
    my $self = shift;
    return @{ $self->{paths} } unless @_;
    $self->{paths} = [@_];
    return $self;
}

sub multiple_inheritance {
    my $self = shift;
    return grep { $self->parents($_) > 1 } $self->classes;
}

sub duplicate_methods {
    my $self = shift;
    my @duplicates;
    foreach my $methods ( values %{ $self->{duplicates} } ) {
        if ( @$methods > 1 ) {
            push @duplicates => $methods;
        }
    }
    return @duplicates;
}

sub long_methods { %{ $_[0]->{long_methods} } }

sub parents {
    my ( $self, $class ) = @_;
    $class ||= $self->target_class;
    unless ( exists $self->{classes}{$class} ) {
        Carp::croak("No such class '$class' found in hierarchy");
    }
    return @{ $self->{classes}{$class}{parents} };
}

sub report {
    my $self = shift;

    my $report = $self->_get_overridden_report;
    $report .= $self->_get_unreachable_report;
    $report .= $self->_get_multiple_inheritance_report;
    $report .= $self->_get_exported_report;
    $report .= $self->_get_duplicate_method_report;
    $report .= $self->_get_long_method_report;

    if ($report) {
        my $target = $self->target_class;
        $report = "Report for class: $target\n\n$report";
    }
    return $report;
}

sub _get_duplicate_method_report {
    my $self = shift;

    my $report    = '';
    my @duplicate = $self->duplicate_methods;
    my ( @methods, @duplicates );
    if (@duplicate) {
        foreach my $duplicate (@duplicate) {
            push @methods => join '::' => @{ pop @$duplicate };
            push @duplicates => join "\n" => map { join '::' => @$_ }
              @$duplicate;
        }
        $report .= "Duplicate Methods (Experimental)\n"
          . $self->_build_report( 'Method', 'Duplicated In',
            \@methods, \@duplicates );
    }
    return $report;
}

sub _get_overridden_report {
    my $self = shift;

    my $report     = '';
    my $overridden = $self->overridden;
    if (%$overridden) {
        my @methods = sort keys %$overridden;
        my @classes;
        foreach my $method (@methods) {
            push @classes => join "\n" => @{ $overridden->{$method} };
        }
        $report .= "Overridden Methods\n"
          . $self->_build_report( 'Method', 'Class', \@methods, \@classes );
    }
    return $report;
}

sub _get_unreachable_report {
    my $self = shift;

    my $report = '';
    if ( my @unreachable = $self->unreachable ) {
        my ( @methods, @classes );
        for my $fq_method (@unreachable) {
            $fq_method =~ /^(.*)::(.*)$/;    # time to rethink the API
            push @methods => $2;
            push @classes => $1;
        }
        $report .= "Unreachable Methods\n"
          . $self->_build_report( 'Method', 'Class', \@methods, \@classes );
    }
    return $report;
}

sub _get_multiple_inheritance_report {
    my $self = shift;
    my $report .= '';
    if ( my @multis = $self->multiple_inheritance ) {
        my @classes = map { join "\n" => $self->parents($_) } @multis;
        $report .= "Multiple Inheritance\n"
          . $self->_build_report( 'Class', 'Parents', \@multis, \@classes );
    }
    return $report;
}

sub _get_exported_report {
    my $self     = shift;
    my $exported = $self->exported;
    my $report   = '';
    if ( my @classes = sort keys %$exported ) {
        my ( $longest_c, $longest_m ) = ( length('Class'), length('Method') );
        my ( @subs, @sources );
        foreach my $class (@classes) {
            my ( @temp_subs, @temp_sources );
            foreach my $sub ( sort keys %{ $exported->{$class} } ) {
                push @temp_subs    => $sub;
                push @temp_sources => $exported->{$class}{$sub};
                $longest_c = length($class) if length($class) > $longest_c;
                $longest_m = length($sub)   if length($sub) > $longest_m;
            }
            push @subs    => join "\n" => @temp_subs;
            push @sources => join "\n" => @temp_sources;
        }
        my $width = $self->width - 3;
        my $third = int( $width / 3 );
        $longest_c = $third if $longest_c > $third;
        $longest_m = $third if $longest_m > $third;
        my $rest = $width - ( $longest_c + $longest_m );
        my $text = Text::SimpleTable->new(
            [ $longest_c, 'Class' ],
            [ $longest_m, 'Method' ],
            [ $rest,      'Exported From Package' ]
        );
        for my $i ( 0 .. $#classes ) {
            $text->row( $classes[$i], $subs[$i], $sources[$i] );
        }
        $report .= "Exported Subroutines\n" . $text->draw;
    }
    return $report;
}

sub _get_long_method_report {
    my $self = shift;
    my $report .= '';
    my %long_methods = $self->long_methods;
    if ( my @methods = sort keys %long_methods ) {
        my @lengths;
        foreach my $method (@methods) {
            push @lengths => $long_methods{$method};
        }
        $report .= "Long Methods (experimental)\n"
          . $self->_build_report( 'Method', 'Approximate Length',
            \@methods, \@lengths );
    }
    return $report;
}

sub _build_report {
    my ( $self, $title1, $title2, $strings1, $strings2 ) = @_;
    unless ( @$strings1 == @$strings2 ) {
        Carp::croak("PANIC:  Attempt to build unbalanced report");
    }
    my ( $width1, $width2 ) = $self->_get_widths( $title1, @$strings1 );
    my $text =
      Text::SimpleTable->new( [ $width1, $title1 ], [ $width2, $title2 ] );
    for my $i ( 0 .. $#$strings1 ) {
        $text->row( $strings1->[$i], $strings2->[$i] );
    }
    return $text->draw;
}

sub _get_widths {
    my ( $self, $title, @strings ) = @_;

    my $width   = $self->width;
    my $longest = length($title);
    foreach my $string (@strings) {
        my $length = length $string;
        $longest = $length if $length > $longest;
    }
    $longest = int( $width / 2 ) if $longest > ( $width / 2 );
    return ( $longest, $width - $longest );
}

sub width {
    my $self = shift;
    return $self->{width} unless @_;
    my $number = shift;
    unless ( $number =~ /^\d+$/ && $number >= 40 ) {
        Carp::croak(
            "Argument to 'width' must be a number >= than 40, not ($number)");
    }
    $self->{width} = $number;
}

sub to_string { $_[0]->graph->as_ascii }

sub graph { $_[0]->{graph} }

sub combine_graphs {
    my ( $self, @sniffs ) = @_;

    my $graph = $self->graph->copy;

    foreach my $sniff (@sniffs) {
        unless ( $sniff->isa( ref $self ) ) {
            my $bad_class = ref $sniff;
            my $class     = ref $self;
            die
"Arguments to 'combine_graphs' must '$class' objects, not '$bad_class' objects";
        }
        my $next_graph = $sniff->graph;
        foreach my $edge ( $next_graph->edges ) {
            $graph->add_edge_once( $edge->from->name, $edge->to->name );
        }
    }
    return $graph;
}

sub target_class { $_[0]->{target} }

sub method_length { $_[0]->{method_length} }

sub ignore { $_[0]->{ignore} }

sub universal { $_[0]->{universal} }

sub classes { @{ $_[0]->{list_classes} } }

sub children {
    my ( $self, $class ) = @_;
    $class ||= $self->target_class;
    unless ( exists $self->{classes}{$class} ) {
        Carp::croak("No such class '$class' found in hierarchy");
    }
    return @{ $self->{classes}{$class}{children} };
}

sub methods {
    my ( $self, $class ) = @_;
    $class ||= $self->target_class;
    unless ( exists $self->{classes}{$class} ) {
        Carp::croak("No such class '$class' found in hierarchy");
    }
    return @{ $self->{classes}{$class}{methods} };
}

sub _get_parents {
    my ( $self, $class ) = @_;
    return if $class eq 'UNIVERSAL';
    no strict 'refs';

    my @parents = List::MoreUtils::uniq( @{"$class\::ISA"} );
    if ( $self->universal && not @parents ) {
        @parents = 'UNIVERSAL';
    }
    if ( my $ignore = $self->ignore ) {
        @parents = grep { !/$ignore/ } @parents;
    }
    return @parents;
}

# This is the heart of where we set just about everything up.
sub _build_hierarchy {
    my ( $self, @classes ) = @_;

    for my $class (@classes) {
        return unless my @parents = $self->_get_parents($class);
        $self->_register_class($_) foreach $class, @parents;
        $self->_add_children($class);
        $self->_build_paths($class);
        $self->_add_parents($class);
    }
}

# This method builds 'paths'.  These are the paths the inheritance hierarchy
# will take through the code to find a method.  This is based on Perl's
# default search order, not C3.
sub _build_paths {
    my ( $self, $class ) = @_;

    my @parents = $self->_get_parents($class);

    # XXX strictly speaking, we can skip $do_chg, but if path() get's
    # expensive (such as testing for valid classes), then we
    # need it.
    my $do_chg;
    my @paths;

    foreach my $path ( $self->paths ) {
        if ( $path->[-1] eq $class ) {
            foreach my $parent (@parents) {
                if ( grep { $parent eq $_ } @$path ) {
                    my $circular = join ' -> ' => @$path, $parent;
                    Carp::croak("Circular path found in path ($circular)");
                }
            }
            ++$do_chg;
            push @paths => map { [ @$path, $_ ] } @parents;
        }
        else {
            push @paths => $path;
        }
    }

    $self->paths(@paths) if $do_chg;
}

sub _add_parents {
    my ( $self, $class ) = @_;

    # This algorithm will follow classes in Perl's default inheritance
    # order
    foreach my $parent ( $self->_get_parents($class) ) {
        push @{ $self->{list_classes} } => $parent
          unless grep { $_ eq $parent } @{ $self->{list_classes} };
        $self->{classes}{$parent}{count}++;
        $self->_build_hierarchy($parent);
    }
}

sub _add_children {
    my ( $self, $class ) = @_;
    my @parents = $self->_get_parents($class);

    $self->{classes}{$class}{parents} = \@parents;
    foreach my $parent (@parents) {
        $self->_add_child( $parent, $class );
        $self->graph->add_edge_once( $class, $parent );
    }
    return $self;
}

sub _add_child {
    my ( $self, $class, $child ) = @_;

    my $children = $self->{classes}{$class}{children};
    unless ( grep { $child eq $_ } @$children ) {
        push @$children => $child;
    }
}

1;    # End of Class::Sniff