File Coverage

blib/lib/Module/UseFrom.pm

Criterion	Covered	Total	%
statement	108	111	97.3
branch	21	24	87.5
condition	9	10	90.0
subroutine	19	19	100.0
pod	0	5	0.0
total	157	169	92.9

package Module::UseFrom;
{
  $Module::UseFrom::VERSION = '0.03_001';
}

use strict;
use warnings;

use v5.8.1;

use Carp;
use Module::CoreList;
use Scalar::Util qw/dualvar/;
use ExtUtils::Installed;
use version 0.77;

use Devel::Declare ();

my $inst = ExtUtils::Installed->new();

our $verbose;
my %export_ok = (
  'use_from' => { const => \&rewrite_use_from },
  'use_if_available' => { const => \&rewrite_use_if_available },
);

######################
## utility functions

sub _my_warn {
  my $string = shift;
  if ($verbose) {
    if ((ref $verbose || '') eq 'SCALAR') {
      $$verbose .= "$string\n";
    } else {
      warn $string;
    }
  }
}

sub find_module_version {
  my $module = shift;

  my $version =
    eval { $inst->version($module) } ||
    exists $Module::CoreList::version{$]}{$module}
      ? ( $Module::CoreList::version{$]}{$module} || 1e-7 )
      : 0;

  # some core module do not have version numbers, they are returned as 1e-7

  $version = version->parse($version);

  _my_warn $version ? "\tFound version $version" : "\tCouldn't find version info for $module!";

  return $version;
}

sub get_varref_by_name {
  my ($caller, $var) = @_;
  my $varname = $caller . '::' . $var;

  _my_warn "\tInvestigating package $caller for variable $caller, resolved as $varname";

  no strict 'refs';
  my $varref =
    (defined ${$varname})
    ? \${$varname}
    : croak "Cannot access variable \$$varname";

  return $varref;
}

###########
## import

sub import {
  my $class = shift;

  # setup from explicit imports
  my $export = {};
  foreach my $keyword (@_) {

    # :all tag
    if ($keyword eq ':all') {
      $export = \%export_ok;
      last;
    }

    # check import is available
    unless ( exists $export_ok{$keyword} ) {
      carp "Keyword $keyword is not exported by Module::UseFrom";
      next;
    }

    # setup specific keyword
    $export->{$keyword} = $export_ok{$keyword};
  }

  # if called without explicit imports
  unless (keys %$export) {
    $export->{'use_from'} = $export_ok{'use_from'};
  }

  my $caller = caller;

  Devel::Declare->setup_for( $caller, $export );

  foreach my $keyword (keys %$export) {
    no strict 'refs';
    *{$caller.'::'.$keyword} = sub (@) {};
  }

}

##################
## rewrite rules

sub rewrite_use_from {
  my $linestr = Devel::Declare::get_linestr;

  _my_warn "use_from got: $linestr";

  my $caller = Devel::Declare::get_curstash_name;

  $linestr =~ s/use_from\s+\$(\w+)/
    my $varref = get_varref_by_name($caller, $1);
    my $module = $$varref;
    "use_from; use $module";
  /e;

  _my_warn "use_from returned: $linestr";

  Devel::Declare::set_linestr($linestr);
}

sub rewrite_use_if_available {
  my $linestr = Devel::Declare::get_linestr;

  _my_warn "use_if_available got: $linestr";

  my $caller = Devel::Declare::get_curstash_name;

  $linestr =~ s/use_if_available\s+\$(\w+)(\s+[^\s;]+)?/
    my $name = $1;
    my $version = $2;
    do_use_if_available($caller, $name, $version);
  /e;

  _my_warn "use_if_available returned: $linestr";

  Devel::Declare::set_linestr($linestr);
}

sub do_use_if_available {
  my ($caller, $name, $version) = @_;
  my $return = 'use_if_available ';

  my $varref = get_varref_by_name($caller, $name);
  my $module = $$varref;

  _my_warn "\tFound request for module $module";

  my $found_version = find_module_version($module);

  unless ($found_version) {
    my $dualvar = dualvar 0, $module;
    $$varref = $dualvar;
    return $return;
  }

  my $requested_version;
  if ($version) {
    $requested_version = eval { version->parse($version) };
    _my_warn "\tRequested version $requested_version";
  }

  if (defined $requested_version and $requested_version > $found_version) {
    _my_warn "\tInsufficient version found, skipping import!";
    my $dualvar = dualvar 0, $module;
    $$varref = $dualvar;
    return $return;
  }

  my $dualvar = dualvar $found_version->numify, $module;
  $$varref = $dualvar;

  $return .= "; use $module";
  $return .= $version if $version;

  return $return;
}

1;

__END__