view release on metacpan or  search on metacpan

lib/File/PackageIndexer.pm  view on Meta::CPAN

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