File Coverage

blib/lib/File/PackageIndexer.pm

Criterion	Covered	Total	%
statement	149	166	89.7
branch	50	58	86.2
condition	14	33	42.4
subroutine	14	15	93.3
pod	5	6	83.3
total	232	278	83.4

package File::PackageIndexer;

use 5.008001;
use strict;
use warnings;

our $VERSION = '0.02';

use PPI;
use Carp;
require File::PackageIndexer::PPI::Util;
require File::PackageIndexer::PPI::ClassXSAccessor;
require File::PackageIndexer::PPI::Inheritance;

use Class::XSAccessor
  accessors => {
    default_package => 'default_package',
    clean => 'clean',
  };

sub new {
  my $class = shift;
  my $self = bless {
    clean => 1,
    @_
  } => $class;
  return $self;
}

sub parse {
  my $self = shift;
  my $def_pkg = $self->default_package;
  $def_pkg = 'main', $self->default_package('main')
    if not defined $def_pkg;

  my $doc = shift;
  if (not ref($doc) or not $doc->isa("PPI::Node")) {
    $doc = PPI::Document->new(\$doc);
  }
  if (not ref($doc)) {
    return();
  }

  my $curpkg;
  my $pkgs = {};

  # TODO: More accessor generators et al
  # TODO: More inheritance
  # TODO: package statement scopes

  my $in_scheduled_block = 0;
  my $finder;
  use Data::Dumper;
  $finder = sub {
    return(0) unless $_[1]->isa("PPI::Statement");
    my $statement = $_[1];

    my $class = $statement->class;
    # BEGIN/CHECK/INIT/UNITCHECK/END:
    # Recurse and set the block state, then break outer
    # recursion so we don't process twice
    if ( $class eq 'PPI::Statement::Scheduled' ) {
      my $temp_copy = $in_scheduled_block;
      $in_scheduled_block = $statement->type;
      $statement->find($finder);
      $in_scheduled_block = $temp_copy;
      return undef;
    }
    # new sub declaration
    elsif ( $class eq 'PPI::Statement::Sub' ) {
      my $subname = $statement->name;
      if (not defined $curpkg) {
        $curpkg = $self->lazy_create_pkg($def_pkg, $pkgs);
      }
      $curpkg->{subs}->{$subname} = 1;
    }
    # new package statement
    elsif ( $class eq 'PPI::Statement::Package' ) {
      my $namespace = $statement->namespace;
      $curpkg = $self->lazy_create_pkg($namespace, $pkgs);
    }
    # use()
    elsif ( $class eq 'PPI::Statement::Include' ) {
      $self->_handle_includes($statement, $curpkg, $pkgs);
    }
    elsif ( $statement->find_any(sub {$_[1]->class eq "PPI::Token::Symbol" and $_[1]->content eq '@ISA'}) ) {
      File::PackageIndexer::PPI::Inheritance::handle_isa($self, $statement, $curpkg, $pkgs, $in_scheduled_block);
    }
  };

  # run it
  $doc->find($finder);

  foreach my $token ( $doc->tokens ) {
    # find Class->method and __PACKAGE__->method
    my ($callee, $methodname) = File::PackageIndexer::PPI::Util::is_class_method_call($token);

    if ($callee and $methodname =~ /^(?:mk_(?:[rw]o_)?accessors)$/) {
      # resolve __PACKAGE__ to current package
      if ($callee eq '__PACKAGE__') {
        $callee = defined($curpkg) ? $curpkg->{name} : $def_pkg;
      }

      my $args = $token->snext_sibling->snext_sibling->snext_sibling; # class->op->method->structure
      if (defined $args and $args->isa("PPI::Structure::List")) {
        my $list = File::PackageIndexer::PPI::Util::list_structure_to_array($args);
        if (@$list) {
          my $pkg = $self->lazy_create_pkg($callee, $pkgs);
          $pkg->{subs}{$_} = 1 for @$list;
        }
      }

    }
  }


  # prepend unshift()d inheritance to the
  # compile-time ISA, then append the push()d
  # inheritance
  foreach my $pkgname (keys %$pkgs) {
    my $pkg = $pkgs->{$pkgname};

    my $isa = [ @{$pkg->{begin_isa}} ];
    if ($pkg->{isa_cleared_at_runtime}) {
      $isa = [];
    }

    unshift @$isa, @{ $pkg->{isa_unshift} };
    push    @$isa, @{ $pkg->{isa_push} };

    if ($self->clean) {
      delete $pkg->{begin_isa};
      delete $pkg->{isa_unshift};
      delete $pkg->{isa_push};
      delete $pkg->{isa_cleared_at_runtime};
      delete $pkg->{isa_cleared_at_compiletime};
    }

    $pkg->{isa} = $isa;
  }

  return $pkgs;
}

# generate empty, new package struct
sub lazy_create_pkg {
  my $self = shift;
  my $p_name = shift;
  my $pkgs = shift;
  return $pkgs->{$p_name} if exists $pkgs->{$p_name};
  $pkgs->{$p_name} = {
    name => $p_name,
    subs => {},
    isa_unshift => [], # usa entries unshifted at run-time
    isa_push => [], # isa entries pushed at run-time
    begin_isa  => [], # temporary storage for compile-time inheritance, will be deleted before returning from parse()
  };
  return $pkgs->{$p_name};
}


# try to deduce info from module loads
sub _handle_includes {
  my $self = shift;
  my $statement = shift;
  my $curpkg = shift;
  my $pkgs = shift;

  return
    if $statement->type ne 'use'
    or not defined $statement->module;

  my $module = $statement->module;

  if ($module =~ /^Class::XSAccessor(?:::Array)?$/) {
    File::PackageIndexer::PPI::ClassXSAccessor::handle_class_xsaccessor($self, $statement, $curpkg, $pkgs);
  }
  elsif ($module =~ /^(?:base|parent)$/) {
    File::PackageIndexer::PPI::Inheritance::handle_base($self, $statement, $curpkg, $pkgs);
  }

  # TODO: handle other generating modules loaded via use

  # TODO: Elsewhere, we need to handle Class->import()!
}


sub merge_results {
  my @results = @_;
  shift @results while @results and !ref($results[0]) || ref($results[0]) eq 'File::PackageIndexer';
  return merge_results_inplace({}, @results);
}

sub merge_results_inplace {
  my @results = @_;
  shift @results while @results and !ref($results[0]) || ref($results[0]) eq 'File::PackageIndexer';

  return @results if @results == 1;

  # check that the user used things right
  foreach my $r (@results) {
    foreach my $pkg (values %$r) {
      if (not exists $pkg->{begin_isa}) {
        croak("Can't merge results that have been cleaned. Set the 'clean' option of the parser to a false value to disable cleaning of the result structures. Also RTFM.");
      }
    }
  }

  my $res = shift(@results);
  foreach my $in (@results) {

    foreach my $pkgname (keys %$in) {
      my $inpkg = $in->{$pkgname};
      if (not exists $res->{$pkgname}) {
        $res->{$pkgname} = $inpkg;
      }
      # merge!
      else {
        my $pkg = $res->{$pkgname};

        # handle compile time isa
        if ($inpkg->{isa_cleared_at_compiletime}) {
          $pkg->{begin_isa} = [@{$inpkg->{begin_isa}}];
          $pkg->{isa_cleared_at_compiletime} = 1;
        }
        else {
          push @{$pkg->{begin_isa}}, @{$inpkg->{begin_isa}};
        }

        # handle run-time isa
        if ($inpkg->{isa_cleared_at_runtime}) {
          $pkg->{isa_unshift} = [@{$inpkg->{isa_unshift}}];
          $pkg->{isa_push}    = [@{$inpkg->{isa_push}}];
          $pkg->{isa_cleared_at_runtime} ||= $inpkg->{isa_cleared_at_runtime};
        }
        else {
          unshift @{$pkg->{isa_unshift}}, @{$inpkg->{isa_unshift}};
          push    @{$pkg->{isa_push}},    @{$inpkg->{isa_push}};
        }

        # finalize isa
        my $isa = [];
        @$isa = @{$pkg->{begin_isa}};
        if ($pkg->{isa_cleared_at_runtime}) {
          $isa = [];
        }

        unshift @$isa, @{ $pkg->{isa_unshift} };
        push    @$isa, @{ $pkg->{isa_push} };

        $pkg->{isa} = $isa;

        # merge subs
        my $subs = $pkg->{subs};
        foreach my $insub (keys %{$inpkg->{subs}}) {
          $subs->{$insub} = 1;
        }

      } # end merge

    } #  end foreach packages
  } # end foreach @results

  return $res;
}


sub clean_results {
  my @results = @_;
  shift @results while @results and !ref($results[0]) || ref($results[0]) eq 'File::PackageIndexer';

  return({}) if not @results;
  my $in = $results[0];

  my $res = {};
  foreach my $pkgname (keys %{$in}) {
    my $inpkg = $in->{$pkgname};
    my $pkg = $res->{$pkgname} = {};
    $pkg->{subs} = {%{$inpkg->{subs}}};
    $pkg->{isa} = [@{$inpkg->{isa}}];
    $pkg->{name} = $inpkg->{name};
  }

  return $res;
}

1;

__END__