File Coverage

lib/PPIx/Element/Package.pm

Criterion	Covered	Total	%
statement	33	33	100.0
branch	16	18	88.8
condition	5	9	55.5
subroutine	8	8	100.0
pod	3	3	100.0
total	65	71	91.5

use 5.006;    # our
use strict;
use warnings;

package PPIx::Element::Package;

our $VERSION = '0.001000'; # TRIAL

# ABSTRACT: Derive the package an element is defined in

our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY

use Scalar::Util qw( refaddr );
use Exporter 5.57 qw( import );
our @EXPORT_OK = qw( identify_package identify_package_namespace identify_package_in_previous_siblings );










sub identify_package {
  my ($element) = @_;

  # Packages are their own owners
  return $element if $element->isa('PPI::Statement::Package');

  # Elements without parents have no Package
  return unless $element->can('parent') and my $parent = $element->parent;

  # Any element which is directly a child of a Package is also the Package
  # ( These are the package tokens themselves )
  return $parent if $parent->isa('PPI::Statement::Package');

  # Check any sibling nodes previous to the current one
  # and return the nearest Package, if present.
  my $package = identify_package_in_previous_siblings($element);
  return $package if defined $package;

  # Otherwise, recursively assume the Package of whatever your
  # parent is.
  return identify_package($parent);
}













sub identify_package_namespace {
  my ($element) = @_;
  my $package = identify_package($element);

  return ( defined $package and defined $package->namespace ) ? $package->namespace : 'main';
}













sub identify_package_in_previous_siblings {
  my ($element) = @_;

  # elements without parents or children can't hold siblings
  return unless $element->can('parent') and my $parent = $element->parent;
  return unless $parent->can('children');

  my $self_addr = refaddr($element);
  my $last_package;

  for my $sibling ( $parent->children ) {

    # Record most recently found Package
    $last_package = $sibling if $sibling->isa('PPI::Statement::Package');

    # Return whatever package was found as soon as we find ourselves
    # ( Because we don't care about Packages after ourselves.
    return $last_package if $self_addr eq refaddr($sibling);
  }
  return;
}

1;

__END__