File Coverage

blib/lib/autorequire.pm

Criterion	Covered	Total	%
statement	100	103	97.0
branch	39	44	88.6
condition	9	11	81.8
subroutine	18	18	100.0
pod	6	8	75.0
total	172	184	93.4

package autorequire ;

use strict ;
use Carp ;
use File::Spec ;
use IO::File ;


our $VERSION = '0.08' ;


sub import {
	my $class = shift ;
	my $sub = shift ;

	my $ar = $class->new($sub) ;
	$ar->insert(-1) if defined($sub) ;
}


sub new {
	my $class = shift ;
	my $sub = shift ;
	my $list = shift || \@INC ;

	my $this = {} ;
	$this->{'sub'} = $sub ;
	$this->{'list'} = $list ;

	bless($this, $class) ;
}


sub _get_sub {
	my $this = shift ;

	return $this->{'sub'} ;
}


sub _get_list {
	my $this = shift ;

	return $this->{'list'} ;
}


# Insert $this into @INC at the specified
# position.
sub insert {
	my $this = shift ;
	my $idx = shift ;

	my $l = $this->_get_list() ;
	if (! scalar(@{$l})){
		push @{$l}, $this ;
	}
	else {
		my $cur = $l->[$idx] ;
		splice(@{$l}, $idx, 1,
			($idx >= 0
				? (scalar(@{$l}) > $idx
					? ($this, $cur)
					: ($this))
				: ($cur, $this))) ;
	}
}


# Remove $this from the @INC array.
sub delete {
	my $this = shift ;

	for (my $i = 0 ; $i < scalar(@{$this->{'list'}}) ; $i++){
		if ($INC[$i] eq $this){
			splice(@{$this->{'list'}}, $i, 1) ;
			$i-- ;
		}
	}
}


sub enable {
	my $this = shift ;

	$this->{disabled} = 0 ;
}


sub disable {
	my $this = shift ;

	$this->{disabled} = 1 ;
}


sub autorequire::INC {
	my ($this, $f) = @_ ;

	return undef if $this->{disabled} ;

	my $s = $this->_get_sub() ;
	if (! ref($s)){
		# Symbolic reference. It may not be defined yet.
		return undef if !defined(&{$s}) ;
		$s = \&{$s} ;
	}

	my $ret = $s->($this, $f) ;
	if (defined($ret)){
		if (! _is_handle($ret)){
			# Maybe the value returned is the name of a file.
			if (($ret !~ /\n/)&&(-r $ret)){
				my $file = $ret ;
				$ret = undef ;
				open($ret, "<$file") or
					croak("Can't open '$file' for reading: $!") ;
			}
			else {
				my $code = $ret ;
				$ret = undef ;
				open($ret, '<', (ref($code) ? $code : \$code)) or
					croak("Can't open in-memory filehandle: $!") ;
			}
		}
	}

	return $ret ;
}


# Pasted from File::Copy
sub _is_handle {
	my $h = shift ;

	return (ref($h)
		? (ref($h) eq 'GLOB'
			|| UNIVERSAL::isa($h, 'GLOB')
				|| UNIVERSAL::isa($h, 'IO::Handle'))
		: (ref(\$h) eq 'GLOB')) ;
}


sub is_loaded {
	my $class = shift ;
	my $filename = shift ;
	my %opts = @_ ;

	my $I = $INC{$filename} ;
	return $class->_name_or_open_or_slurp_file($I, %opts) ;
}


sub is_installed {
	my $class = shift ;
	my $filename = shift ;
	my %opts = @_ ;

	my $file = undef ;
	if (File::Spec->file_name_is_absolute($filename)){
		$file = $filename ;
	}
	else {
		foreach my $I (@INC){
			next if ref($I) ;
			my $test = File::Spec->catfile($I, $filename) ;
			if (-r File::Spec->catfile($I, $filename)){
				$file = $test ;
				last ;
			}
		}
	}

	return $class->_name_or_open_or_slurp_file($file, %opts) ;
}


sub _name_or_open_or_slurp_file {
	my $class = shift ;
	my $file = shift ;
	my %opts = @_ ;

	return undef unless defined($file) ;

	if (($opts{'open'})||($opts{slurp})){
		my $fh = new IO::File("<$file") ;
		croak("Can't open '$file' for reading: $!") unless defined($fh) ;

		if ($opts{slurp}){
			local $/ = undef ;
			return <$fh> ;
		}

		return $fh ;
	}

	return $file ;
}


1 ;
__END__