File Coverage

blib/lib/lib/restrict.pm

Criterion	Covered	Total	%
statement	23	55	41.8
branch	4	28	14.2
condition	6	18	33.3
subroutine	4	5	80.0
pod			n/a
total	37	106	34.9

package lib::restrict;

use strict;
use warnings;
our $VERSION = '0.0.5';

use base 'lib';

sub import {
    shift;

    my %uid;
    my %okd;
    my $chk = '';
    if(defined $_[-1] && (ref $_[-1] eq 'ARRAY' || $_[-1] =~ m/^\d+$/ || ref $_[-1] eq 'CODE')) {
        if(ref $_[-1]) {
            if(ref $_[-1] eq 'ARRAY') {
    	        @uid{ grep { m/^\d+$/ } @{$_[-1]} } = ();
    	    }
    	    else {
    	        $chk = $_[-1];
    	    }
        }
        else {
    	    $uid{ $_[-1] } = $_[-1];
        }
        pop @_;
    }

    for (@_) {
	    my $path = $_; # we'll be modifying it, so break the alias, is there an echo in here :)
	    eval {
	        $path    = lib::_nativize($path);
	    }; # we eval since older lib.pm's don't have this

	    if(!-d $path && ref $ENV{'lib::restrict-!-d_ok_in'} eq 'ARRAY') {
	        my $ok = 0;
	        require File::Spec;
	        require File::Basename;

	        my $absolute = File::Spec->file_name_is_absolute($path) ? $path : File::Spec->rel2abs( $path );
	        my $pathless = File::Basename::dirname($absolute);

	        if(File::Spec->file_name_is_absolute($absolute)) {
    	        for my $base (@{ $ENV{'lib::restrict-!-d_ok_in'} }) {
                    $base =  File::Spec->rel2abs($base) if !File::Spec->file_name_is_absolute($base);
    	            my $grow = ''; # IE '/'
    	            for my $part (File::Spec->splitdir($base)) {
    	                $grow = File::Spec->catdir($grow, $part);
    	                $ok = 1 if $pathless eq $grow;
    	            }
    	        }
    	        $okd{ $_ } = 1;
    	        next if $ok;
            }
	    }

	    if( (keys %uid && !exists $uid{ _get_owner($path) }) || (ref $chk eq 'CODE' && !$chk->($_)) ) {
	        if( !$ENV{'lib::restrict-quiet'} ) {
	            require Carp;
	            Carp::carp('Parameter to use lib::restrict is not allowed');
            }
	        @_ = grep { !m/^$path$/ } @_;
        }
    }

    lib->import(@_); # SUPER instead ??
    @lib::restrict::ORIG_INC = @lib::ORIG_INC;

    if(keys %uid) {
        @INC = grep { exists $uid{_get_owner($_)} || exists $okd{ $_ } } @INC; # uninit value ??
    }

    return;
}

sub _get_owner {
    my $own = (stat shift)[4];
	return defined $own ? $own : '';
}

1;

__END__