File Coverage

blib/lib/Module/Reader.pm

Criterion	Covered	Total	%
statement	171	212	80.6
branch	81	130	62.3
condition	30	62	48.3
subroutine	38	49	77.5
pod	10	11	90.9
total	330	464	71.1

package Module::Reader;
BEGIN { require 5.006 }
use strict;
use warnings;

our $VERSION = '0.003003';
$VERSION = eval $VERSION;

use Exporter (); BEGIN { *import = \&Exporter::import }
our @EXPORT_OK = qw(module_content module_handle);
our %EXPORT_TAGS = (all => [@EXPORT_OK]);

use File::Spec ();
use Scalar::Util qw(reftype refaddr openhandle);
use Carp qw(croak);
use Config ();
use Errno qw(EACCES);
use constant _OPEN_LAYERS     => "$]" >= 5.008_000 ? ':' : '';
use constant _ABORT_ON_EACCES => "$]" >= 5.017_001;
use constant _ALLOW_PREFIX    => "$]" >= 5.008009;
use constant _VMS             => $^O eq 'VMS' && !!require VMS::Filespec;
use constant _WIN32           => $^O eq 'MSWin32';
use constant _PMC_ENABLED     => !(
  exists &Config::non_bincompat_options
    ? grep { $_ eq 'PERL_DISABLE_PMC' } Config::non_bincompat_options()
    : $Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DISABLE_PMC\b/
);
use constant _FAKE_FILE_FORMAT => do {
  my $uvx = $Config::Config{uvxformat} || '';
  $uvx =~ tr/"\0//d;
  $uvx ||= 'lx';
  "/loader/0x%$uvx/%s"
};

sub _mod_to_file {
  my $module = shift;
  (my $file = "$module.pm") =~ s{::}{/}g;
  $file;
}

sub module_content {
  my $opts = ref $_[-1] eq 'HASH' && pop @_ || {};
  my $module = shift;
  $opts->{inc} = [@_]
    if @_;
  __PACKAGE__->new($opts)->module($module)->content;
}

sub module_handle {
  my $opts = ref $_[-1] eq 'HASH' && pop @_ || {};
  my $module = shift;
  $opts->{inc} = [@_]
    if @_;
  __PACKAGE__->new($opts)->module($module)->handle;
}

sub new {
  my $class = shift;
  my %options;
  if (@_ == 1 && ref $_[-1]) {
    %options = %{(pop)};
  }
  elsif (@_ % 2 == 0) {
    %options = @_;
  }
  else {
    croak "Expected hash ref, or key value pairs.  Got ".@_." arguments.";
  }

  $options{inc} ||= \@INC;
  $options{found} = \%INC
    if exists $options{found} && $options{found} eq 1;
  $options{pmc} = _PMC_ENABLED
    if !exists $options{pmc};
  $options{open} = 1
    if !exists $options{open};
  $options{abort_on_eacces} = _ABORT_ON_EACCES
    if !exists $options{abort_on_eacces};
  $options{check_hooks_for_nonsearchable} = 1
    if !exists $options{check_hooks_for_nonsearchable};
  bless \%options, $class;
}

sub module {
  my ($self, $module) = @_;
  $self->file(_mod_to_file($module));
}

sub modules {
  my ($self, $module) = @_;
  $self->files(_mod_to_file($module));
}

sub file {
  my ($self, $file) = @_;
  $self->_find($file);
}

sub files {
  my ($self, $file) = @_;
  $self->_find($file, 1);
}

sub _searchable {
  my $file = shift;
    File::Spec->file_name_is_absolute($file) ? 0
  : _WIN32 && $file =~ m{^\.\.?[/\\]}        ? 0
  : $file =~ m{^\.\.?/}                      ? 0
                                             : 1
}

sub _find {
  my ($self, $file, $all) = @_;

  my @found;
  eval {
    if (my $found = $self->{found}) {
      if (defined( my $full = $found->{$file} )) {
        my $open = length ref $full ? $self->_open_ref($full, $file)
                                    : $self->_open_file($full, $file);
        push @found, $open
          if $open;
      }
    }
  };
  if (!$all) {
    return $found[0]
      if @found;
    die $@
      if $@;
  }

  my $searchable = _searchable($file);
  if (!$searchable) {
    my $open = $self->_open_file($file);
    if ($all) {
      push @found, $open;
    }
    elsif ($open) {
      return $open;
    }
    else {
      croak "Can't locate $file";
    }
  }

  my $search = $self->{inc};
  for my $inc (@$search) {
    my $open;
    if (!$searchable) {
      last
        if !$self->{check_hooks_for_nonsearchable};
      next
        if !length ref $inc;
    }
    eval {
      if (!length ref $inc) {
        my $full = _VMS ? VMS::Filespec::unixpath($inc) : $inc;
        $full =~ s{/?$}{/};
        $full .= $file;
        $open = $self->_open_file($full, $file, $inc);
      }
      else {
        $open = $self->_open_ref($inc, $file);
      }
      push @found, $open
        if $open;
    };
    if (!$all) {
      return $found[0]
        if @found;
      die $@
        if $@;
    }
  }
  croak "Can't locate $file"
    if !$all;
  return @found;
}

sub _open_file {
  my ($self, $full, $file, $inc) = @_;
  $file = $full
    if !defined $file;
  for my $try (
    ($self->{pmc} && $file =~ /\.pm\z/ ? $full.'c' : ()),
    $full,
  ) {
    my $pmc = $full ne $try;
    if (-e $try) {
      next
        if -d _ || -b _;
      if (open my $fh, '<'._OPEN_LAYERS, $try) {
        return Module::Reader::File->new(
          filename        => $file,
          ($self->{open} ? (raw_filehandle => $fh) : ()),
          found_file      => $full,
          disk_file       => $try,
          is_pmc          => $pmc,
          (defined $inc ? (inc_entry => $inc) : ()),
        );
      }
    }

    croak "Can't locate $file:   $full: $!"
      if $self->{abort_on_eacces} && $! == EACCES && !$pmc;
  }
  return;
}

sub _open_ref {
  my ($self, $inc, $file) = @_;

  my @cb;
  {
    # strings in arrayrefs are taken as sub names relative to main
    package
      main;
    no strict 'refs';
    no warnings 'uninitialized';
    @cb = defined Scalar::Util::blessed $inc ? $inc->INC($file)
        : ref $inc eq 'ARRAY'                ? $inc->[0]->($inc, $file)
                                             : $inc->($inc, $file);
  }

  return
    unless length ref $cb[0];

  my $fake_file = sprintf _FAKE_FILE_FORMAT, refaddr($inc), $file;

  my $fh;
  my $prefix;
  my $cb;
  my $cb_options;

  if (_ALLOW_PREFIX && reftype $cb[0] eq 'SCALAR') {
    $prefix = shift @cb;
  }

  if ((reftype $cb[0]||'') eq 'GLOB' && openhandle $cb[0]) {
    $fh = shift @cb;
  }

  if ((reftype $cb[0]||'') eq 'CODE') {
    $cb = $cb[0];
    # only one or zero callback options will be passed
    $cb_options = @cb > 1 ? [ $cb[1] ] : undef;
  }
  elsif (!defined $fh && !defined $prefix) {
    return;
  }
  return Module::Reader::File->new(
    filename => $file,
    found_file => $fake_file,
    inc_entry => $inc,
    (defined $prefix ? (prefix => $prefix) : ()),
    (defined $fh ? (raw_filehandle => $fh) : ()),
    (defined $cb ? (read_callback => $cb) : ()),
    (defined $cb_options ? (read_callback_options => $cb_options) : ()),
  );
}

sub inc   { $_[0]->{inc} }
sub found { $_[0]->{found} }
sub pmc   { $_[0]->{pmc} }
sub open  { $_[0]->{open} }

{
  package Module::Reader::File;
  use constant _OPEN_STRING => "$]" >= 5.008 || !require IO::String;
  use Carp 'croak';

  sub new {
    my ($class, %opts) = @_;
    my $filename = $opts{filename};
    if (!exists $opts{module} && $opts{filename}
      && $opts{filename} =~ m{\A(\w+(?:/\w+)?)\.pm\z}) {
      my $module = $1;
      $module =~ s{/}{::}g;
      $opts{module} = $module;
    }
    bless \%opts, $class;
  }

  sub filename              { $_[0]->{filename} }
  sub module                { $_[0]->{module} }
  sub found_file            { $_[0]->{found_file} }
  sub disk_file             { $_[0]->{disk_file} }
  sub is_pmc                { $_[0]->{is_pmc} }
  sub inc_entry             { $_[0]->{inc_entry} }
  sub read_callback         { $_[0]->{read_callback} }
  sub read_callback_options { $_[0]->{read_callback_options} }
  sub raw_filehandle        {
    $_[0]->{raw_filehandle} ||= !$_[0]->{disk_file} ? undef : do {
      open my $fh, '<'.Module::Reader::_OPEN_LAYERS, $_[0]->{disk_file}
        or croak "Can't locate $_[0]->{disk_file}";
      $fh;
    };
  }

  sub content {
    my $self = shift;
    return $self->{content}
      if exists $self->{content};
    my $fh = $self->raw_filehandle;
    my $cb = $self->read_callback;
    my $content = defined $self->{prefix} ? ${$self->{prefix}} : '';
    if ($fh && !$cb) {
      local $/;
      $content .= <$fh>;
    }
    if ($cb) {
      my @params = @{$self->read_callback_options||[]};
      while (1) {
        local $_ = $fh ? <$fh> : '';
        $_ = ''
          if !defined;
        # perlfunc/require says that the first parameter will be a reference the
        # sub itself.  this is wrong.  0 will be passed.
        last if !$cb->(0, @params);
        $content .= $_;
      }
    }
    return $self->{content} = $content;
  }

  sub handle {
    my $self = shift;
    my $fh = $self->raw_filehandle;
    if ($fh && !$self->read_callback && -f $fh) {
      open my $dup, '<&', $fh
        or croak "can't dup file handle: $!";
      return $dup;
    }
    my $content = $self->content;
    if (_OPEN_STRING) {
      open my $fh, '<', \$content;
      return $fh;
    }
    else {
      return IO::String->new($content);
    }
  }
}

1;

__END__