File Coverage

lib/provide.pm

Criterion	Covered	Total	%
statement	84	85	98.8
branch	12	18	66.6
condition	7	15	46.6
subroutine	23	23	100.0
pod	1	3	33.3
total	127	144	88.1

use strict;
use warnings;
package provide;

use Exporter; # we shove it onto other people's @ISA, so we should load it ourselves

our $VERSION = 0.03;

sub import {
  my ($class, @args) = @_;

  my ($calling_class) = caller;

  my $match = pick_module_to_load(@args);
  die "Couldn't parse @args, are you sure I know what I'm doing?" if !$match;
  load($match);

  # set up the calling class as though it inherited from Exporter
  {
    no strict 'refs';
    push @{"$calling_class\::ISA"}, qw(Exporter);
    push @{"$calling_class\::EXPORT"}, @{"$match\::EXPORT"};
  }

  # export functions from $match to $calling_class so that users of $calling_class get them as
  # though they were implemented in $calling_class, not in $match
  {
    no strict 'refs';
    for my $function (@{"$match\::EXPORT"}) {
      *{"$calling_class\::$function"} = \&{"$match\::$function"};
    }
  }
}

sub looks_like_a_module { return shift() =~ m{^[\w:]+} }

# try to load a module or die trying
sub load {
  my ($module) = @_;

  if (looks_like_a_module($module)) {
    local $@;
    eval "use $module";
    die $@ if $@;
  } else {
    die "hit $module but it doesn't look like a module name, refusing to load it";
  }
}

sub pick_module_to_load {
  my (@args) = @_;

  my @clauses = ([]);

  foreach (@args) {
    push @{$clauses[-1]}, $_;
    push @clauses, [] if $clauses[-1][0] =~ /if|elsif/ && @{$clauses[-1]} == 4;
  }

  my %condition = (
    gt => sub { $] >  shift() },
    ge => sub { $] >= shift() },
    eq => sub { $] == shift() },
    ne => sub { $] != shift() },
    le => sub { $] <= shift() },
    lt => sub { $] <  shift() },
  );

  foreach (@clauses) {
    if (@$_ == 4) {
      my ($if, $condition, $version, $module) = @$_;

      die "can't handle line: @$_\n" unless
        ($if =~ /if|elsif/) &&
        exists $condition{$condition} &&
        $version =~ /^\d[\.\d]*$/ &&
        looks_like_a_module($module);

      return $module if $condition{$condition}->($version);
    } elsif (@$_ == 2) {
      my ($else, $module) = @$_;

      die "can't handle line: @$_\n" unless
        $else eq 'else' &&
        looks_like_a_module($module);

      return $module;
    }
  }
}

1;

__END__