File Coverage

blib/lib/Perl/Metric/Basic.pm

Criterion	Covered	Total	%
statement	64	67	95.5
branch	17	18	94.4
condition	3	3	100.0
subroutine	7	7	100.0
pod	1	1	100.0
total	92	96	95.8

package Perl::Metric::Basic;
use strict;
use base qw(Class::Accessor);
use Scalar::Util qw(blessed);
__PACKAGE__->mk_accessors(qw());
our $VERSION = '0.31';

sub measure {
  my $self     = shift;
  my $document = shift;

  die "No PPI::Document passed"
    unless blessed($document) && $document->isa('PPI::Document');

  my $metrics;

  # go though all the nodes
  my @packages;
  my $package;
  my @contents;
  foreach my $node ($document->children) {
    if ($node->isa('PPI::Statement::Package')) {
      if (@contents) {
        push @packages,
          {
          package  => $package,
          contents => [@contents],
          };
      }
      $package  = $node;
      @contents = ();
    } else {
      push @contents, $node;
    }
  }
  push @packages,
    {
    package  => $package,
    contents => [@contents],
    };

  foreach my $data (@packages) {
    my $package  = $data->{package};
    my $contents = $data->{contents};

    my $package_name = $self->_package_name($package);

    foreach my $node (@$contents) {
      next unless $node->isa('PPI::Statement::Sub');
      my $sub_name = $node->name;
      my $content  = $node->content;
      my $lines    = $content =~ tr/\n//;

      my $whitespace = join ',',
        map { $_->content } @{ $node->find('PPI::Token::Whitespace') };
      my $lines_of_code = $whitespace =~ tr/\n//;

      my $all_comments = $node->find('PPI::Token::Comment');
      my $comments     = 0;
      $comments = scalar(@$all_comments) if $all_comments;

      my $blank_lines           = 0;
      my $all_nodes             = $node->find(sub { 1 });
      my $last_node_was_newline = 0;
      foreach my $node (@$all_nodes) {
        if ($node->isa('PPI::Token::Whitespace')) {
          my $has_newline = $node->content =~ /\n/;
          if ($has_newline) {
            $blank_lines++ if $last_node_was_newline;
            $last_node_was_newline = 1;
          } else {
            $last_node_was_newline = 0;
          }
        }
      }

      my ($symbols, $symbols_unique) =
        $self->_unique($node->find('PPI::Token::Symbol'));

      my ($numbers, $numbers_unique) =
        $self->_unique($node->find('PPI::Token::Number'));

      my ($words, $words_unique) =
        $self->_unique($node->find('PPI::Token::Word'));

      my ($operators, $operators_unique) =
        $self->_unique($node->find('PPI::Token::Operator'));

      my $metric = {
        blank_lines      => $blank_lines,
        comments         => $comments,
        lines            => $lines,
        lines_of_code    => $lines_of_code,
        numbers          => $numbers,
        numbers_unique   => $numbers_unique,
        operators        => $operators,
        operators_unique => $operators_unique,
        symbols          => $symbols,
        symbols_unique   => $symbols_unique,
        words            => $words,
        words_unique     => $words_unique,
      };

      $metrics->{$package_name}->{$sub_name} = $metric;
    }
  }
  return $metrics;
}

# this should be rolled into PPI
sub _package_name {
  my ($self, $package) = @_;
  my $words = $package->find('PPI::Token::Word');
  return $words->[1]->content;
}

# return the total number of nodes and the number of nodes with unique
# content
sub _unique {
  my ($self, $nodes) = @_;
  return (0, 0) unless $nodes;
  my $count = scalar @$nodes;
  my %count;
  $count{ $_->content }++ foreach @$nodes;
  my $count_unique = (keys %count);
  return ($count, $count_unique);
}

__END__