File Coverage

blib/lib/Inline/Select.pm

Criterion	Covered	Total	%
statement	37	44	84.0
branch	10	22	45.4
condition			n/a
subroutine	6	7	85.7
pod	0	3	0.0
total	53	76	69.7

package Inline::Select ;

use strict ;
use Carp ;
use Data::Dumper ;


$Inline::Select::VERSION = '0.01' ;

%Inline::Select::GROUPS = () ;


sub import {
	my $class = shift ;

	return $class->bind(@_) ;
}


sub register {
	my $class = shift ;
	my %args = @_ ;

	my $group = delete $args{PACKAGE} ;
	croak("PACKAGE configuration attribute not defined") unless $group ;

	my $inline = delete $args{Inline} ;
	croak("Inline configuration attribute not defined") unless $inline ;
	croak("Inline configuration attribute must be an ARRAY reference")
		unless UNIVERSAL::isa($inline, 'ARRAY') ;

	# Registration mode
	my $language = $inline->[0] ;
	$Inline::Select::GROUPS{$group}->{$language} = $inline ;
	debug($inline) ;
}


sub bind {
	my $class = shift ;
	my %args = @_ ;

	my $group = delete $args{PACKAGE} ;
	croak("PACKAGE configuration attribute not defined") unless $group ;

	my $inline = delete $args{Inline} ;
	croak("Inline configuration attribute not defined") unless $inline ;
	croak("Inline configuration attribute must be a SCALAR") unless ! ref($inline) ;

	# Selection mode
	my $caller = caller() ;
	debug(\%Inline::Select::GROUPS) ;
	my $code = undef ;
	if ($inline !~ /^perl$/i){
		require Inline ;
		$code = <
package $caller ;
use Inline (\@{\$Inline::Select::GROUPS{'$group'}->{'$inline'}}) ;
CODE
	}
	else {
		croak("Source must be a CODE reference in the case of the 'Perl' language")
			unless UNIVERSAL::isa($Inline::Select::GROUPS{$group}->{$inline}->[1], 'CODE') ;
		$code = <
package $caller ;
\$Inline::Select::GROUPS{'$group'}->{'$inline'}->[1]->() ;
CODE
	}
	debug($code) ;
	eval $code ;
	croak($@) if $@ ;
}


sub debug {
	my $msg = shift ;

	if ($ENV{PERL_INLINE_SELECT_DEBUG}){
		if (ref($msg)){
			print STDERR Dumper($msg) ;
		}
		else{
			print STDERR "$msg\n" ;
		}
	}
}



1 ;