Perl::Metrics::Simple::Analysis::File - Methods analyzing a single file.

  use Perl::Metrics::Simple::Analysis::File;
  my $object = Perl::Metrics::Simple::Analysis::File->new(file => 'path/to/file');

  my $file_results = BPerl::Metrics::Simple::Analysis::File->new( path => $path );

  {
    lines             => $lines,      # Line count outside subs. Skips comments and pod.
    mccabe_complexity => $complexity, # Cyclomatic complexity of all non-sub areas
    path              => '/path/to/file',
    name              => '{code not in named subroutines}',  # always the same name
  };

    !
    !~
    &&
    &&=
    //
    <
    <<=
    <=>
    ==
    =~
    >
    >>=
    ?
    and
    cmp
    eq
    gt
    lt
    ne
    not
    or
    xor
    ||
    ||=
    ~~

    else
    elsif
    for
    foreach 
    goto
    grep
    if
    last
    map
    next
    unless
    until
    while

   use Foo;
   print "Hello world.\n";
   exit;

   if ( $a ) {         # The "if" adds 1.
       # do something
   }

    sub foo {                              # 1: for non-empty code
       if ( @list ) {                      # 1: "if"
           foreach my $x ( @list ) {       # 1: "foreach"
               if ( ! $x ) {               # 2: 1 for "if" and 1 for "!"
                   do_something($x);
               }
               else {                      # 1 for "else"
                   do_something_else($x);
               }
           }
       }
       return;
    }

 %hash = Perl::Metrics::Simple::Analysis::File::hashify(@list);

 $boolean = Perl::Metrics::Simple::Analysis::File::is_hash_key($ppi_element);

  { foo => 123, bar => $a }

    Matisse Enzer
    CPAN ID: MATISSE
    Eigenstate Consulting, LLC
    matisse@eigenstate.net
    http://www.eigenstate.net/

# $Header: /Library/VersionControl/CVS/Perl-Metrics-Simple/lib/Perl/Metrics/Simple/Analysis/File.pm,v 1.23 2010/05/09 18:02:28 matisse Exp $
# $Revision: 1.23 $
# $Author: matisse $
# $Source: /Library/VersionControl/CVS/Perl-Metrics-Simple/lib/Perl/Metrics/Simple/Analysis/File.pm,v $
# $Date: 2010/05/09 18:02:28 $
###############################################################################

package Perl::Metrics::Simple::Analysis::File;
use strict;
use warnings;

use Carp qw(cluck confess);
use Data::Dumper;
use English qw(-no_match_vars);
use Perl::Metrics::Simple::Analysis;
use PPI;
use PPI::Document;
use Readonly;

our $VERSION = '0.15';

Readonly::Scalar my $ALL_NEWLINES_REGEX =>
    qr/ ( \Q$INPUT_RECORD_SEPARATOR\E ) /sxm;
Readonly::Array our @DEFAULT_LOGIC_OPERATORS => qw(
    !
    !~
    &&
    &&=
    //
    <
    <<=
    <=>
    ==
    =~
    >
    >>=
    ?
    and
    cmp
    eq
    gt
    lt
    ne
    not
    or
    xor
    ||
    ||=
    ~~
    );

Readonly::Array our @DEFAULT_LOGIC_KEYWORDS => qw(
    else
    elsif
    for
    foreach 
    goto
    grep
    if
    last
    map
    next
    unless
    until
    while
    );
Readonly::Scalar my $LAST_CHARACTER => -1;

our (@LOGIC_KEYWORDS, @LOGIC_OPERATORS); # For user-supplied values;

our (%LOGIC_KEYWORDS, %LOGIC_OPERATORS); # Populated in _init()

# Private instance variables:
my %_PATH       = ();
my %_MAIN_STATS = ();
my %_SUBS       = ();
my %_PACKAGES   = ();
my %_LINES      = ();
my %_LOGIC_KEYWORDS = ();
my %_LOGIC_OPERATORS = ();

sub new {
    my ( $class, %parameters ) = @_;
    my $self = {};
    bless $self, $class;
    $self->_init(%parameters);
    return $self;
}

sub _init {
    my ( $self, %parameters ) = @_;
    $_PATH{$self} = $parameters{'path'};

    my $path = $self->path();

    my $document;
    if (ref $path) {
        if (ref $path eq 'SCALAR') {
            $document = PPI::Document->new($path);
        } else {
            $document = $path;
        }
    } else {
        if ( !-r $path ) {
            Carp::confess "Path '$path' is missing or not readable!";
        }
        $document = _create_ppi_document($path);
    }
    $document = _make_pruned_document($document);

    if ( !defined $document ) {
        cluck "Could not make a PPI document from '$path'";
        return;
    }

    my $packages = _get_packages($document);

    my @logic_keywords = @LOGIC_KEYWORDS  ? @LOGIC_KEYWORDS : @DEFAULT_LOGIC_KEYWORDS;
    %LOGIC_KEYWORDS = hashify(@logic_keywords);
    $_LOGIC_OPERATORS{$self} = \%LOGIC_KEYWORDS;

    my @logic_operators = @LOGIC_OPERATORS ? @LOGIC_OPERATORS : @DEFAULT_LOGIC_OPERATORS;
    %LOGIC_OPERATORS = hashify(@logic_operators);
    $_LOGIC_OPERATORS{$self} = \%LOGIC_OPERATORS;

    my @sub_analysis = ();
    my $sub_elements = $document->find('PPI::Statement::Sub');
    @sub_analysis = @{ $self->_iterate_over_subs($sub_elements) };

    $_MAIN_STATS{$self}
        = $self->analyze_main( $document, $sub_elements, \@sub_analysis );
    $_SUBS{$self}     = \@sub_analysis;
    $_PACKAGES{$self} = $packages;
    $_LINES{$self}    = $self->get_node_length($document);

    return $self;
}

sub _create_ppi_document {
    my $path = shift;
    my $document;
    if ( -s $path ) {
        $document = PPI::Document->new($path);
    }
    else {

        # The file is empty. Create a PPI document with a single whitespace
        # chararacter. This makes sure that the PPI tokens() method
        # returns something, so we avoid a warning from
        # PPI::Document::index_locations() which expects tokens() to return
        # something other than undef.
        my $one_whitespace_character = q{ };
        $document = PPI::Document->new( \$one_whitespace_character );
    }
    return $document;
}

sub _make_pruned_document {
    my $document = shift;;
    $document = _prune_non_code_lines($document);
    $document->index_locations();
    $document->readonly(1);
    return $document;
}

sub all_counts {
    my $self       = shift;
    my $stats_hash = {
        path       => $self->path,
        lines      => $self->lines,
        main_stats => $self->main_stats,
        subs       => $self->subs,
        packages   => $self->packages,
    };
    return $stats_hash;
}

sub analyze_main {
    my $self         = shift;
    my $document     = shift;
    my $sub_elements = shift;
    my $sub_analysis = shift;

    if ( !$document->isa('PPI::Document') ) {
        Carp::confess('Did not supply a PPI::Document');
    }

    my $lines = $self->get_node_length($document);
    foreach my $sub ( @{$sub_analysis} ) {
        $lines -= $sub->{lines};
    }
    my $document_without_subs = $document->clone;
    $document_without_subs->prune('PPI::Statement::Sub');
    my $complexity = $self->measure_complexity($document_without_subs);
    my $results    = {
        name              => '{code not in named subroutines}',
        lines             => $lines,
        mccabe_complexity => $complexity,
        path              => $self->path,
    };
    return $results;
}

sub get_node_length {
    my ( $self, $node ) = @_;
    my $eval_result = eval { $node = _prune_non_code_lines($node); };
    return 0 if not $eval_result;
    return 0 if ( !defined $node );
    my $string = $node->content;
    return 0 if ( !length $string );

    # Replace whitespace-newline with newline
    $string =~ s/ \s+ \Q$INPUT_RECORD_SEPARATOR\E /$INPUT_RECORD_SEPARATOR/smxg;
    $string =~ s/\Q$INPUT_RECORD_SEPARATOR\E /$INPUT_RECORD_SEPARATOR/smxg;
    $string =~ s/ \A \s+ //msx;    # Remove leading whitespace
    my @newlines = ( $string =~ /$ALL_NEWLINES_REGEX/smxg );
    my $line_count = scalar @newlines;

 # if the string is not empty and the last character is not a newline then add 1
    if ( length $string ) {
        my $last_char = substr $string, $LAST_CHARACTER, 1;
        if ( $last_char ne "$INPUT_RECORD_SEPARATOR" ) {
            $line_count++;
        }
    }

    return $line_count;
}

sub path {
    my ($self) = @_;
    return $_PATH{$self};
}

sub main_stats {
    my ($self) = @_;
    return $_MAIN_STATS{$self};
}

sub subs {
    my ($self) = @_;
    return $_SUBS{$self};
}

sub packages {
    my ($self) = @_;
    return $_PACKAGES{$self};
}

sub lines {
    my ($self) = @_;
    return $_LINES{$self};
}

sub logic_keywords {
    my ($self) = @_;
    return wantarray ? @{$_LOGIC_KEYWORDS{$self}} : $_LOGIC_KEYWORDS{$self};
}

sub logic_operators {
    my ($self) = @_;
    return wantarray ? @{$_LOGIC_OPERATORS{$self}} : $_LOGIC_OPERATORS{$self};
}

sub measure_complexity {
    my $self = shift;
    my $elem = shift;

    my $complexity_count = 0;
    if ( $self->get_node_length($elem) == 0 ) {
        return $complexity_count;
    }

    if ($elem) {
        $complexity_count++;
    }

    # Count up all the logic keywords, weed out hash keys
    my $keywords_ref = $elem->find('PPI::Token::Word') || [];
    my @filtered = grep { !is_hash_key($_) } @{$keywords_ref};
    $complexity_count += grep { exists $LOGIC_KEYWORDS{$_} } @filtered;

    # Count up all the logic operators
    my $operators_ref = $elem->find('PPI::Token::Operator');
    if ($operators_ref) {
        $complexity_count
            += grep { exists $LOGIC_OPERATORS{$_} } @{$operators_ref};
    }
    return $complexity_count;
}

sub _get_packages {
    my $document = shift;

    my @unique_packages = ();
    my $found_packages  = $document->find('PPI::Statement::Package');

    return \@unique_packages
        if (
        !Perl::Metrics::Simple::Analysis::is_ref( $found_packages, 'ARRAY' ) );

    my %seen_packages = ();

    foreach my $package ( @{$found_packages} ) {
        $seen_packages{ $package->namespace() }++;
    }

    @unique_packages = sort keys %seen_packages;

    return \@unique_packages;
}

sub _iterate_over_subs {
    my $self       = shift;
    my $found_subs = shift;

    return []
        if ( !Perl::Metrics::Simple::Analysis::is_ref( $found_subs, 'ARRAY' ) );

    my @subs = ();

    foreach my $sub ( @{$found_subs} ) {
        my $sub_length = $self->get_node_length($sub);
        push @subs,
            {
            path              => $self->path,
            name              => $sub->name,
            lines             => $sub_length,
            mccabe_complexity => $self->measure_complexity($sub),
            };
    }
    return \@subs;
}

#-------------------------------------------------------------------------
# Copied from
# http://search.cpan.org/src/THALJEF/Perl-Critic-0.19/lib/Perl/Critic/Utils.pm
sub hashify {
    my @hash_keys = @_;
    return map { $_ => 1 } @hash_keys;
}

#-------------------------------------------------------------------------
# Copied and somehwat simplified from
# http://search.cpan.org/src/THALJEF/Perl-Critic-0.19/lib/Perl/Critic/Utils.pm
sub is_hash_key {
    my $ppi_elem = shift;

    my $is_hash_key = eval {
        my $parent      = $ppi_elem->parent();
        my $grandparent = $parent->parent();
        if ( $grandparent->isa('PPI::Structure::Subscript') ) {
            return 1;
        }
        my $sib = $ppi_elem->snext_sibling();
        if ( $sib->isa('PPI::Token::Operator') && $sib eq '=>' ) {
            return 1;
        }
        return;
    };

    return $is_hash_key;
}

sub _prune_non_code_lines {
    my $document = shift;
    if ( !defined $document ) {
        Carp::confess('Did not supply a document!');
    }
    $document->prune('PPI::Token::Comment');
    $document->prune('PPI::Token::Pod');
    $document->prune('PPI::Token::End');

    return $document;
}

1;

__END__