File Coverage

blib/lib/only.pm

Criterion	Covered	Total	%
statement	227	295	76.9
branch	93	150	62.0
condition	27	45	60.0
subroutine	39	41	95.1
pod	9	28	32.1
total	395	559	70.6

package only;
$VERSION = '0.28';
use strict;
use 5.006001;
use only::config;
use File::Spec;
use Config;
use Carp;
use overload '""' => \&stringify;

BEGIN {
    *qv = eval {require 'version.pm'} ? \&version::qv : sub{$_[0]};
}

# sub X { require Data::Dumper; die Data::Dumper::Dumper(@_) }
# sub Y { require Data::Dumper; print Data::Dumper::Dumper(@_) }

my $versionlib = '';

sub import {
    goto &_install if @_ == 2 and $_[1] eq 'install';
    my $class = shift;
    my $args = {};
    my $module = (($_[0]||"") =~ /\A!?-?\d/) ? 'perl itself' : shift;
    return unless defined $module and $module;
    if (ref $module eq 'HASH') {
        $args = $module;
        $module = shift || '';
    }

    my (@sets, $s);
    if (not @_) {
        @sets = (['']);
    }
    elsif (ref($_[0]) eq 'ARRAY') {
        @sets = @_;
    }
    else {
        @sets = ([@_]);
    }


    my $loaded = 0;
    for my $set (@sets) {
        $s = $class->new;
        $s->initialize($args, $module, $set) or return;
        if ($module ne 'perl itself' && $s->search) {
            $s->include;
            local $^W = 0;
            eval "require " . $s->module;
            croak 'Trouble loading ' . $s->found_path . "\n$@" if $@;
            fix_INC();     # fix 5.6.1 %INC bug
            $loaded = 1;
            last;
        }
    }

    if ($module eq 'perl itself') {
        my $perl_version = qv( $] );
        my $required_version = $_[0];
        $required_version =~ s/!\s*/other than /g;
        $required_version =~ s/(?<=\D)-/no later than /g;
        $required_version =~ s/-(?=\D)/ or later/g;
        croak "Perl version $required_version required ",
              "but this is perl $perl_version.\nstopped"
            unless $s->check_version($perl_version);
        return;
    }
    elsif (not defined $INC{$s->canon_path}) {
        eval "require " . $s->module;
        $loaded = not($@) && $s->check_version($s->module->VERSION);
    }

    if (not $loaded) {
        $s->module_not_found;
    }

    my $import = $s->export
      or return;

    @_ = ($s->module, @{$s->arguments});
    goto &$import;
}

sub new {
    my ($class) = @_;
    my $s = bless {}, $class;
    $s->found_path('');
    $s->versionlib($versionlib || &only::config::versionlib);
    return $s;
}

sub initialize {
    my ($s, $args, $module, $set) = @_;
    my ($condition, @arguments) = @$set;

    if (defined $args->{versionlib}) {
        $s->versionlib($args->{versionlib});
        if (not $module) {
            only->versionlib($args->{versionlib});
        }
    }

    return 0 unless $module;
    $s->module($module || '');
    $s->condition($condition || '');
    $s->arguments(\@arguments);

    $s->no_export(@arguments == 1 and
                  ref($arguments[0]) eq 'ARRAY' and
                  @{$arguments[0]} == 0
                 );

    return 1;
}

# Try to squish most occurences of a 5.6.1 bug.
my ($fix_key, $fix_value) = ('', '');
sub fix_INC {
    if ($fix_key) {
        $INC{$fix_key} = $fix_value;
        $fix_key = $fix_value = '';
    }
}
INIT { fix_INC }


sub only::INC {
    my ($s, $module_path) = @_;
    fix_INC;
    $s->search unless $s->found_path;
    return unless defined $s->distribution_modules->{$module_path};

    my $version = $s->distribution_version;

    my $lib_path  = File::Spec->catfile($s->versionlib,
                                        $version,
                                        split('/', $module_path),
                                       );
    my $arch_path = File::Spec->catfile($s->versionarch,
                                        $version,
                                        split('/', $module_path),
                                       );
    for my $path ($lib_path, $arch_path) {
        if (-f $path) {
            open my $fh, $path
              or die "Can't open $path for input\n";
            $INC{$module_path} = $path;
            ($fix_key, $fix_value) = ($module_path, $path);
            return $fh;
        }
    }
    die "Can't load versioned $module_path\n";
}

sub search {
    my ($s) = @_;
    $s->found_path('');

    if (defined $INC{$s->canon_path}) {
        return $s->check_version($s->get_loaded_version);
    }

    my @versions;
    if ($s->fancy) {
        @versions = grep $s->check_version($_), $s->all_versions();
    }
    else {
        @versions = map { $_->[0] } @{$s->condition_spec};
    }

    for my $version (sort { $b <=> $a } @versions) {
        my $lib_path = File::Spec->catfile($s->versionlib,
                                           $version, $s->mod_path);
        my $arch_path = File::Spec->catfile($s->versionarch,
                                            $version, $s->mod_path);
        for my $path ($lib_path, $arch_path) {
            if (-f $path) {
                $s->found_path($path);
                $s->distribution_modules($s->found_path);
                $s->distribution_version($version);
                return 1;
            }
        }
    }
    return 0;
}

sub stringify {
    my ($s) = @_;
    'only:' . $s->module . ':' .
      File::Spec->catdir($s->versionlib, $s->distribution_version)
}

sub include {
    my ($s) = @_;
    $s->remove;
    unshift @INC, $s;
    $s
}

sub remove {
    my ($s) = @_;
    my $strval = overload::StrVal $s;
    my @inc = grep {not(ref($_)) or overload::StrVal($_) ne $strval} @INC;
    @INC = @inc;
    $s
}

# Generic OO accessors
for (qw( found_path mod_path canon_path
         condition_str condition_spec fancy
         versionarch arguments no_export
         distribution_version
    )) {
    eval <
sub $_ {
    my \$s = shift;
    if (\@_) {
        \$s->{$_} = shift;
        return \$s
    }
    else {
        return defined \$s->{$_} ? \$s->{$_} : '';
    }
}
END
}

sub DESTROY {} # To avoid autoloading it.

sub module {
    my $s = shift;
    if (@_) {
        $s->found_path('');
        $s->{module} = shift;
        $s->mod_path(File::Spec->catdir(split '::', $s->{module}) . '.pm');
        $s->canon_path(join('/',split('::', $s->{module})).'.pm');
        return $s;
    }
    else {
        return $s->{module};
    }
}

sub condition {
    my $s = shift;
    if (@_) {
        $s->found_path('');
        $s->condition_str(shift);
        $s->parse_condition;
        return $s;
    }
    else {
        return $s->condition_str;
    }
}

sub versionlib {
    my $s = shift;
    if (ref $s) {
        if (@_) {
            $s->found_path('');
            $s->{versionlib} = shift;
            $s->versionarch(File::Spec->catdir($s->{versionlib},
                                               $Config{archname}
                                              ));
            return $s;
        }
        else {
            return $s->{versionlib};
        }
    }
    elsif (@_) {
        $versionlib = shift;
    }
    return $versionlib;
}

sub distribution_modules {
    my ($s, $path) = (@_, '');
    $s->{distribution_modules} ||= {};
    return $s->{distribution_modules}
      unless $path;
    $path =~ s/\.pm$/\.yaml/
      or return {};
    open META, $path
      or return {};
    $s->{distribution_modules} = {};
    my $meta = do {local $/; };
    close META;
    $s->{distribution_modules}{$_} = 1 for ($meta =~ /^  - (\S+)/gm);
    $s->{distribution_modules}
}

sub export {
    my ($s) = @_;
    return if $s->no_export;
    $s->module->can('import')
}

sub get_loaded_version {
    my ($s) = @_;
    my $path = $INC{$s->canon_path};
    my $version = $s->module->VERSION;
    if ($path =~ s/\.pm$/\.yaml/ and -f $path) {
        open META, $path
          or croak "Can't open $path for input:\n$!";
        my $meta = do {local $/;};
        close META;
        if ($meta =~ /^install_version\s*:\s*(\S+)$/m) {
            $version = $1;
        }
    }
    $version
}

sub parse_condition {
    my ($s) = @_;
    my @condition = split /\s+/, $s->condition_str;
    $s->fancy(@condition ? 0 : 1);
    @condition = map {
        my $v;
        if (/^(!)?(\d[\d\.]*)?(?:(-)(\d[\d\.]*)?)?$/) {
            $s->fancy(1)
              if defined($1) or defined($3);
            my $lower = qv($2 || '0.00');
            my $upper = defined($4) ? qv($4) :
                        defined($3) ? '99999999' :
                        $lower;
            my $negate = defined($1) ? 1 : 0;
            croak "Lower bound > upper bound in '$_'\n"
              if $lower > $upper;
            $v = [$lower, $upper, $negate];
        }
        else {
            croak "Invalid condition '$_' specified for 'only'\n";
        }
        $v;
    } @condition;
    $s->condition_spec(\@condition)
}

sub all_versions {
    my ($s) = @_;
    my %versions;
    for my $lib ($s->versionlib, $s->versionarch) {
        opendir LIB, $s->versionlib;
        while (my $dir = readdir(LIB)) {
            next unless $dir =~ /^\d[\d\.]*$/;
            next if $dir eq $Config{version};
            $versions{$dir} = 1;
        }
        closedir(LIB);
    }
    keys %versions
}

sub check_version {
    my ($s, $version) = @_;
    my @specs = @{$s->condition_spec};
    return 1 unless @specs;
    my $match = 0;
    for my $spec (@specs) {
        my ($lower, $upper, $negate) = @$spec;
        next if $match and not $negate;
        if ($version >= $lower and $version <= $upper) {
            return 0 if $negate;
            $match = 1;
        }
    }
    $match
}

sub module_not_found {
    use Data::Dumper;
    my ($s) = @_;
    my $p = $s->module;
    if (defined $INC{$s->canon_path}) {
        my $v = qv($s->get_loaded_version);
        my $req = $s->condition_str();
        croak <
Loaded $p, but version ($v) did not satisfy the requirement:

    use only $p => '$req';

END
    }
    my $faux_inc = 'only:' . $s->module . ':' . $s->versionlib;
    my $inc = join "\n", map "  - $_", ($faux_inc, @INC);
    croak <
Can't locate desired version of $p in \@INC:
$inc
END
}

sub _install {
    require only::install;
    my %args;
    if (@ARGV == 1 and $ARGV[0] =~ /^[\d\.]+$/) {
        $args{version} = $ARGV[0];
    }
    else {
        for (@ARGV) {
            unless (/^(\w+)=(\S+)$/) {
                croak "Invalid option format '$_' for only=install\n";
            }
            $args{$1} = $2;
        }
    }
    only::install::install(%args);
    exit 0;
}

1;

__END__