File Coverage

blib/lib/Inline/Interp.pm

Criterion	Covered	Total	%
statement	52	64	81.2
branch	9	22	40.9
condition	3	6	50.0
subroutine	11	15	73.3
pod	4	9	44.4
total	79	116	68.1

package Inline::Interp;

$VERSION = '0.06';

use strict;
use Carp;

sub usage_config {
	my $key = shift;
	"'$key' is not a valid config option for Inline::Interp\n";
}

sub validate {
}

sub build {
	my $o = shift;
	my $package = ref $o;

	my $code = $o->{API}{code};
	my $pattern = $o->{ILSM}{PATTERN};

	my $funcs = {
		'class'	=> $package,
		'code'	=> '',
	};

	eval "${package}::do_load(\$funcs, \$code);";
	$code = $funcs->{code};
	{
		package Inline::Interp::Loader;
		eval $code;
	}
	croak "Build failed:\n$@" if $@;
	my $path = "$o->{API}{install_lib}/auto/$o->{API}{modpname}";
	my $obj = $o->{API}{location};
	$o->mkpath($path) unless -d $path;
	open FOO_OBJ, "> $obj" or croak "Can't open $obj for output\n$!";
	print FOO_OBJ $code;
	close \*FOO_OBJ;
}

sub add_func {
	my ($funcs, $name, $code) = @_;

	$code =~ s/\|/\\|/g;
	$funcs->{code} .= "sub $name { return Inline::Interp::run('$funcs->{class}', q|$code|, \$_[0]); }\n";
}

sub load {
	my $o = shift;
	my $obj = $o->{API}{location};
	open FOO_OBJ, "< $obj" or croak "Can't open $obj for output\n$!";
	my $code = join '', ;
	close \*FOO_OBJ;
	eval "package $o->{API}{pkg};\n$code";
	croak "Unable to load Foo module $obj:\n$@" if $@;
}

sub info {
	my $o = shift;
}

sub run {
	my ($class, $code, $data) = @_;

	my @data;
	my $input_callback;
	my $output_callback;
	my $echo = 1;

	if (ref $data eq 'HASH'){
		@data = split(//, ${$data}{input}) if ${$data}{input};
		$input_callback = ${$data}{input_callback} || 0;
		$output_callback = ${$data}{output_callback} || 0;
		$echo = ${$data}{echo} || 0;
	}elsif (defined $data){
		@data = split(//, $data);
	}

	my $io = {
		'echo'			=> $echo,
		'buffer'		=> '',
		'output_callback'	=> $output_callback,
		'input_callback'	=> $input_callback,
		'data'			=> \@data,
	};

	eval "&${class}::do_run(\$code, \$io);";

	return $io->{buffer};
}

sub output_char {
	my ($io, $char) = @_;

	print $char if $io->{echo};
	$io->{buffer} .= $char;
	&{$io->{output_callback}}($char) if $io->{output_callback};
}

sub input_char {
	my ($io) = @_;
	return ($io->{input_callback})?&{$io->{input_callback}}:shift @{$io->{data}};
}

1;

__END__