File Coverage

blib/lib/File/PackageIndexer/PPI/Inheritance.pm

Criterion	Covered	Total	%
statement	75	79	94.9
branch	31	46	67.3
condition	18	33	54.5
subroutine	7	7	100.0
pod	0	2	0.0
total	131	167	78.4

package File::PackageIndexer::PPI::Inheritance;

use 5.008001;
use strict;
use warnings;

our $VERSION = '0.01';


# The base case
sub handle_base {
  my $indexer = shift;
  my $statement = shift;
  my $curpkg = shift;
  my $pkgs = shift;
  if (not defined $curpkg) {
    $curpkg = $indexer->lazy_create_pkg($indexer->default_package, $pkgs);
  }

  my $list_start = $statement->schild(0)->snext_sibling;
  my $classes = File::PackageIndexer::PPI::Util::list_structure_to_array($list_start);

  return
    if not defined $classes or ref($classes) ne 'ARRAY';

  # remove options if 'parent'
  if ($list_start->content() eq 'parent') {
    @$classes = grep $_ !~ /^-/, @$classes;
  }

  push @{$curpkg->{begin_isa}}, @$classes
    if defined $classes and ref($classes) eq 'ARRAY';

  return 1;
}

# assumes that the statement contains @ISA somehow!
sub handle_isa {
  my $indexer = shift;
  my $statement = shift;
  my $curpkg = shift;
  my $pkgs = shift;
  my $in_scheduled_block = shift;

  # skip if @ISA is modified in END block.
  return
    if defined $in_scheduled_block and $in_scheduled_block eq 'END';

  return
    unless $statement->isa("PPI::Statement");

  my $child = $statement->schild(0);
  return if not $child;

  # push/unshift @ISA...
  if ($child->isa("PPI::Token::Word") and $child->content =~ /^(?:unshift|push)$/) {
    _handle_extend($indexer, $statement, $curpkg, $pkgs, $in_scheduled_block);
  }
  # our @ISA ...
  elsif ( $statement->isa("PPI::Statement::Variable") ) {
    if ( $statement->type eq 'our'
         and $statement->variables
         and ($statement->variables)[0] eq '@ISA' )
    {
      # declare and assign can probably be handled by the same code
      _handle_assign($indexer, $statement, $curpkg, $pkgs, $in_scheduled_block);
    }
    # else: do nothing. my/local shouldn't be used for @ISA!
  }
  # @ISA = ...
  # could this be done more elegantly?
  elsif (
    $statement->content =~ /\@ISA\s*\)?\s*=/
  ) {
    _handle_assign($indexer, $statement, $curpkg, $pkgs, $in_scheduled_block);
  }

}


sub _handle_extend {
  my $indexer = shift;
  my $statement = shift;
  my $curpkg = shift;
  my $pkgs = shift;
  my $in_scheduled_block = shift;

  if (not defined $curpkg) {
    $curpkg = $indexer->lazy_create_pkg($indexer->default_package, $pkgs);
  }

  my $child = $statement->schild(0);
  my $type = $child->content;

#  $child = $child->snext_sibling;
#  return unless defined $child;
  my $arguments = File::PackageIndexer::PPI::Util::list_structure_to_array($child);
  return
    unless defined $arguments
           and @$arguments
           and $arguments->[0] eq '@ISA';
  shift @$arguments;

  if ($type eq 'push')  {
    push @{ $in_scheduled_block eq 'BEGIN' ? $curpkg->{begin_isa} : $curpkg->{isa_push} }, @$arguments;
  }
  elsif ($type eq 'unshift') {
    unshift @{ $in_scheduled_block eq 'BEGIN' ? $curpkg->{begin_isa} : $curpkg->{isa_unshift} }, @$arguments;
  }
  else {
    die "Unknown operation on \@ISA: '$type'";
  }

  return();
}


# either "our @ISA" or "@ISA ="
sub _handle_assign {
  my $indexer = shift;
  my $statement = shift;
  my $curpkg = shift;
  my $pkgs = shift;
  my $in_scheduled_block = shift;

  if (not defined $curpkg) {
    $curpkg = $indexer->lazy_create_pkg($indexer->default_package, $pkgs);
  }

  my $child = $statement->schild(0);
  return unless $child;

  # skip until =
  $child = $child->snext_sibling()
    while $child
          and not $child->isa("PPI::Token::Operator")
          and not $child->content eq '=';
  return unless $child;

  my $arguments = File::PackageIndexer::PPI::Util::list_structure_to_array($child);

  return
    unless defined $arguments;

  if ($in_scheduled_block and $in_scheduled_block ne 'END') {
    @{ $curpkg->{begin_isa} } = @$arguments;
    $curpkg->{isa_cleared_at_compiletime} = 1;
  }
  elsif(!$in_scheduled_block) {
    @{ $curpkg->{isa_push} }    = @$arguments;
    @{ $curpkg->{isa_unshift} } = ();
    $curpkg->{isa_cleared_at_runtime} = 1;
  }
  else {
    # END, skip
  }

  return();
}

1;

__END__