File Coverage

blib/lib/Module/Reader.pm

Criterion	Covered	Total	%
statement	151	190	79.4
branch	72	112	64.2
condition	25	51	49.0
subroutine	36	47	76.6
pod	10	11	90.9
total	294	411	71.5

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

our $VERSION = '0.003002';
$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;
use Config ();
use Errno qw(EACCES);
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 _VMS => $^O eq 'VMS' && !!require VMS::Filespec;
use constant _WIN32 => $^O eq 'MSWin32';
use constant _FAKE_FILE_FORMAT => do {
  (my $uvx = $Config::Config{uvxformat}||'') =~ tr/"\0//d;
  $uvx ||= 'lx';
  "/loader/0x%$uvx/%s"
};
use constant _OPEN_LAYERS => "$]" >= 5.008 ? ':' : '';

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};
  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) = @_;

  if (!_searchable($file)) {
    my $open = $self->_open_file($file);
    return $open
      if $open;
    croak "Can't locate $file";
  }

  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 $search = $self->{inc};
  for my $inc (@$search) {
    my $open;
    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;
    next
      if -e $try ? (-d _ || -b _) : $! != EACCES;

    if (!$self->{open} ? -e _ : open my $fh, '<'._OPEN_LAYERS, $try) {
      return Module::Reader::File->new(
        filename        => $file,
        ($fh ? (raw_filehandle => $fh) : ()),
        found_file      => $full,
        disk_file       => $try,
        is_pmc          => $pmc,
        (defined $inc ? (inc_entry => $inc) : ()),
      );
    }
    croak "Can't locate $file:   $full: $!"
      unless $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 $cb;
  my $cb_options;

  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 (!$fh) {
    return;
  }
  return Module::Reader::File->new(
    filename => $file,
    found_file => $fake_file,
    inc_entry => $inc,
    (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, 0);
  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}";
    };
  }

  sub content {
    my $self = shift;
    return $self->{content}
      if exists $self->{content};
    my $fh = $self->raw_filehandle;
    my $cb = $self->read_callback;
    if ($fh && !$cb) {
      local $/;
      return scalar <$fh>;
    }
    my @params = @{$self->read_callback_options||[]};
    my $content = '';
    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__