File Coverage

blib/lib/version/Restrict.pm

Criterion	Covered	Total	%
statement	56	57	98.2
branch	11	14	78.5
condition	5	6	83.3
subroutine	7	7	100.0
pod			n/a
total	79	84	94.0

package version::Restrict;

use strict;
use warnings;
use version 0.77;

our $VERSION = '0.01'; # VERSION

my $v0 = version->parse("0");

sub import {
    my $self = shift;
    my %restricted = @_;
    my @ranges = keys %restricted;
    my $package = (caller())[0];

    no strict 'refs';

    for my $range (@ranges) {
        my ($lb, $lower, $upper, $ub) =
            ($range =~ /(.)([0-9.]+),([0-9.]+)(.)/);
        $lb = '>' . ( $lb eq '[' ? '=' : '');
        $ub = '<' . ( $ub eq ']' ? '=' : '');
        $lower = version->parse($lower);
        $upper = version->parse($upper);
        ${"$package\::__version_required"} = 1
            if $lb eq '>=' && $lower == $v0;
        my $test = "sub { \$_[0] $lb version->parse('$lower') && ".
            "\$_[0] $ub version->parse('$upper') }";
        $restricted{$range} = [eval($test), $restricted{$range}];
    }

    *{"$package\::VERSION"} = sub {
        my ($package, $req) = @_;
        $req = version->parse($req);
        my $version = version->parse(${"$package\::VERSION"});
        if ($req > $version) {
            die "$package version $req required--this is only version $version";
        }
        for my $range (@ranges) {
            if ($restricted{$range}[0]->($req)) {
                die "Cannot 'use $package $req': $restricted{$range}[1]\n";
            }
	}
        ${"$package\::__version_checked"} = 1;

        #print "required=", ${"$package\::__version_required"}, "\n";
        return $version;
    };

    my $has_import  = defined(&{"$package\::import"});
    my $orig_import = \&{"$package\::import"};
    #print "pkg=$package, has_import=$has_import\n";

    *{"$package\::import"} = sub {
        my $self = shift;

        #print "checked=", ${"$package\::__version_checked"}, "\n";
        #print "required=", ${"$package\::__version_required"}, "\n";

        my $version = version->parse(${"$package\::VERSION"});
        die "Cannot 'use $package': must specify desired version, ".
            "e.g. 'use $package $version';\n"
                if ${"$package\::__version_required"} &&
                    !${"$package\::__version_checked"};
        ${"$package\::__version_checked"} = 0;

        if ($has_import) {
            $orig_import->($self, @_);
        } else {
            # XXX if Exporter-based only?
            $self->SUPER::import(@_);
        }
    };

}

1;
#ABSTRACT: Control permitted versions that can be use'd

__END__