view release on metacpan or  search on metacpan

lib/PPIx/DocumentName.pm  view on Meta::CPAN

use 5.006;    # our
use strict;
use warnings;

package PPIx::DocumentName;

# ABSTRACT: Utility to extract a name from a PPI Document
our $VERSION = '1.01'; # VERSION

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 {