File Coverage

blib/lib/PPIx/DocumentName.pm

Criterion	Covered	Total	%
statement	62	79	78.4
branch	25	34	73.5
condition	10	12	83.3
subroutine	14	18	77.7
pod	3	3	100.0
total	114	146	78.0

use 5.006;    # our
use strict;
use warnings;

package PPIx::DocumentName;

# ABSTRACT: Utility to extract a name from a PPI Document
our $VERSION = '1.00_01'; # TRIAL VERSION
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)

use PPI::Util qw( _Document );


sub log_info(&@);
sub log_debug(&@);
sub log_trace(&@);

my %callers;

BEGIN {
  if ( $INC{'Log/Contextual.pm'} ) {
    ## Hide from autoprereqs
    require 'Log/Contextual/WarnLogger.pm';    ## no critic (Modules::RequireBarewordIncludes)
    my $deflogger = Log::Contextual::WarnLogger->new( { env_prefix => 'PPIX_DOCUMENTNAME', } );
    Log::Contextual->import( 'log_info', 'log_debug', 'log_trace', '-default_logger' => $deflogger );
  }
  else {
    require Carp;
    *log_info  = sub (&@) { Carp::carp( $_[0]->() ) };
    *log_debug = sub (&@) { };
    *log_trace = sub (&@) { };
  }
}

sub import {
  my(undef, %args) = @_;
  if(defined $args{'-api'}) {
    if($args{'-api'} != 0 && $args{'-api'} != 1) {
      Carp::croak("illegal api level: $args{'-api'}");
    }
    if($] < 5.010) {
      my($package) = caller;
      $callers{$package} = $args{'-api'};
      require Carp;
      Carp::carp("Because of the age of your Perl, -api $args{'-api'} " .
                 'will be package scoped instead of block scoped. ' .
                 'Please upgrade to 5.10 or better.');
    } else {
      $^H{'PPIx::DocumentName/api'} = $args{'-api'};  ## no critic (Variables::RequireLocalizedPunctuationVars)
    }
  }
}

sub _api {
  my ( $api ) = @_;
  if($] < 5.010) {
    my($package) = caller 1;
    $api = $callers{$package} unless defined $api;
  } else {
    my $hh = (caller 1)[10];
    $api = $hh->{'PPIx::DocumentName/api'} if defined $hh && !defined $api;
  }
  $api = 0 unless defined $api;
  return $api;
}

sub _result {
  my($name, $ppi_document, $node) = @_;
  require PPIx::DocumentName::Result;
  PPIx::DocumentName::Result->_new($name, $ppi_document, $node);  ## no critic (Subroutines::ProtectPrivateSubs)
}

## OO


sub extract {
  my ( $self, $ppi_document ) = @_;
  my $api = _api(undef);
  my $result = $self->extract_via_comment($ppi_document, $api) || $self->extract_via_statement($ppi_document, $api);
  return $result;
}


sub extract_via_statement {
  my ( undef, $ppi_document, $api ) = @_;

  $api = _api($api);

  # Keep alive until done
  # https://github.com/adamkennedy/PPI/issues/112
  my $dom      = _Document($ppi_document);
  my $pkg_node = $dom->find_first('PPI::Statement::Package');
  if ( not $pkg_node ) {
    log_debug { "No PPI::Statement::Package found in <<$ppi_document>>" };
    # The old API was inconsistant here, for just this method, returns
    # empty list on failure.  This is unfortunately different from
    # extract_via_comment.
    return 1 == $api ? undef : ();
  }
  if ( not $pkg_node->namespace ) {
    log_debug { "PPI::Statement::Package $pkg_node has empty namespace in <<$ppi_document>>" };
    return 1 == $api ? undef : ();
  }
  my $name = $pkg_node->namespace;
  return 1 == $api ? _result($name, $dom, $pkg_node) : $name;
}


sub extract_via_comment {
  my ( undef, $ppi_document, $api ) = @_;

  $api = _api($api);
  my $node;

  my $regex = qr{ ^ \s* \#+ \s* PODNAME: \s* (.+) $ }x;    ## no critic (RegularExpressions)
  my $content;
  my $finder = sub {
    my $maybe = $_[1];
    return 0 unless $maybe->isa('PPI::Token::Comment');
    log_trace { "Found comment node $maybe" };
    if ( $maybe->content =~ $regex ) {
      $content = $1;
      $node = $maybe;
      return 1;
    }
    return 0;
  };

  # Keep alive until done
  # https://github.com/adamkennedy/PPI/issues/112
  my $dom = _Document($ppi_document);
  $dom->find_first($finder);

  log_debug { "<<$ppi_document>> has no PODNAME comment" } if not $content;

  return 1 == $api && defined $content ? _result($content, $dom, $node) : $content;
}

1;

__END__