Math::BigInt::SubProcess

Math-BigInt-SubProcess.pm

package Math::BigInt::SubProcess;
use 5.010;
use strict;
use warnings;
use warnings qw,FATAL io uninitialized,;
use Scalar::Util qw,weaken,;
use Fatal qw,fork waitpid pipe open close,;
use version 0.77 (); our $VERSION = version->declare('v0.0.0.2016.01.16_1');

use constant DEBUGGING => !!$::{'B::'} || defined &DB::sub;

UNITCHECK {
	# Namespace cleaning, what fun!
	# namespace::autoclean would be a nontrivial dependency.
	my $stash;
	my @imports;
	BEGIN {
		$stash = do { no strict 'refs'; \%{__PACKAGE__ . q{::}} };
		@imports = grep { defined &$_ } keys %$stash;
	}
	if( not DEBUGGING ) {
		delete @{$stash}{grep /^_my_.*[^:]\z/, keys %$stash};
		delete @{$stash}{@imports};
	}
}

my (@ids, $pid, $writer, $reader, $error);

sub import {
	shift;
	return if defined $pid;
	my ($c_reader, $c_writer, $c_error);
	pipe $c_reader, $writer;
	pipe $reader, $c_writer;
	pipe $error, $c_error;
	if( $pid = fork ) {
		close $_ for $c_reader, $c_writer, $c_error;
		# In the parent process, we simply return, which causes this
		# package to be used as a backend.
		return;
	}
	eval {
		close $_ for $reader, $writer, $error;
		( $reader, $writer, $error ) =
			( $c_reader, $c_writer, $c_error );
		open STDERR, '>&', $error;
		1;
	} or do {
		print STDERR $@;
		exit 1;
	};
	Math::BigInt::_register_callback( __PACKAGE__, sub {
		eval {
			_my_childproc(@_);
			1;
		} or print $error $@;
		exit 1;
	} );
	# By dying here, we allow Math::BigInt to finish it's initialization
	# in it's own sub import, which allows the child process to make use of
	# the 'real' Math::BigInt backend
	die "unseen\n";
}

{
	no warnings 'once';
	*unimport = \&_my_cleanup;
}

sub _my_carp {
	require Carp;
	return &Carp::carp;
}

sub _my_croak {
	require Carp;
	return &Carp::croak;
}

sub _my_cleanup {
	return unless defined $pid;
	undef $$_ for @ids;
	@ids = ();
	close $writer;
	1 while defined readline $reader;
	my $e = do { local $/; readline $error };
	waitpid $pid, 0;
	close $reader;
	close $error;
	$reader = $writer = $error = $pid = undef;
	_my_croak($e) if $e;
	return;
}


END { _my_cleanup() }

sub _my_write {
	for ( @_ ) {
		next unless /\s/;
		_my_croak("Unexpected embeded whitespace in argument '$_'");
	}
	unless( print $writer join q{ }, @_ ) {
		my $e = $!;
		_my_cleanup();
		_my_croak("Error writing to child process: \$! == $e");
	}
	return;
}

sub _my_read() {
	my $line;
	unless( defined( $line = readline $reader ) ) {
		my $e = $!;
		_my_cleanup();
		_my_croak("Unexpected EOF: \$! == $e");
	}
	chomp $line;
	return $line;
}


sub _my_new {
	my $new = scalar @ids;
	push @ids, \$new;
	weaken( $ids[ -1 ] );
	return bless \$new, shift;
}

sub DESTROY {
	_my_write( 'DESTROY', &_my_marshal );
	my $self = shift;
	if( $$self == $#ids ) {
		pop @ids;
	} else {
		my $other = $ids[ $$self ] = pop @ids;
		$$other = $$self;
		weaken( $ids[ $$other ] );
	}
	return;
}

BEGIN {
	no warnings 'once';
	*isa = \&UNIVERSAL::isa;
}

sub _my_marshal {
	my @i;
	for ( @_ ) {
		if( ref and isa( $_, __PACKAGE__ ) ) {
			push @i, $$_;
		} else {
			last;
		}
	}
	splice @_, 0, scalar(@i), @i;
	return (scalar(@i), @_);
}

my %constructor = map {;"_$_" => 1} qw,
	new copy zero one two ten from_bin from_oct from_hex 1ex,;

my %simple = map {;"_$_" => 1} qw,
	add sub mul div dec inc mod sqrt root fac pow
	modpow rsft lsft gcd and or xor
	nok signed_or signed_and signed_xor ,;

# log_int returns a status, modinv returns a sign.
my %listop = map {;"_$_" => 1} qw,log_int modinv,;

sub _sub {
	shift;
	if( $_[2] ) {
		_my_write( '_sub1', &_my_marshal );
		return $_[1];
	} else {
		_my_write( '_sub', &_my_marshal );
		return $_[0];
	}
}

sub _div {
	my $class = shift;
	_my_write( '_div', &_my_marshal );
	return ($_[0], _my_new($class));
}

sub _check {
	my $class = shift;
	my ($self) = @_;
	return 'Not a reference' unless ref $self;
	return 'Not a blessed '.__PACKAGE__ unless isa( $self, __PACKAGE__ );
	return 'Package has been cleaned up' if !defined $$self;
	return 'Does not look like a positive number' unless $$self =~ /^[1-9]\d*\Z/;
	return 'Array index out of bounds' if $$self > @ids;
	return 0 if !$class->can( '_check' );
	_my_write( '_check', &_my_marshal, 0 );
	my $fail = _my_read();
	return 0 if !$fail or $fail eq 'undef';
	return $fail;
}

sub api_version {
	return unless shift->can('api_version');
	_my_write( 'api_version', &_my_marshal, 0 );
	my $v = _my_read();
	if( $v > 2 ) {
		state $warned = 0;
		_my_carp( __PACKAGE__.' was written for api_version 2 or earlier; falling back to 2' )
			if !$warned;
		$warned = 1;
		return 2;
	}
	return $v;
}

BEGIN {
	# This class's 'can' method returns a true value for any method which is
	# defined in this package and is NOT part of the Math::BigInt backend API.

	# It also returns true for any method which is part of the API, AND which
	# is defined (in the other process) by whichever backend M::BI chooses to
	# load after this class's import dies.
	my %cache;
	UNITCHECK {
		no strict;
		for (keys %{ __PACKAGE__ . q{::} }) {
			next if /^_/ or /::\z/ or not defined &$_;
			$cache{$_} = \&$_;
		}
		delete $cache{api_version};
	}
	sub can {
		my $class = shift;
		my ($meth) = @_;
		return $cache{$meth} if exists $cache{$meth};
		_my_write('can', &_my_marshal, 0);
		my $ret = _my_read();
		if( $ret eq 'undef' or !$ret ) {
			undef $cache{$meth};
		} else {
			no strict 'refs';
			$cache{$meth} = \&$meth;
		}
		return $cache{$meth};
	}
}

for my $name (keys %constructor) {
	my $sub = sub {
		my $class = shift;
		_my_write( $name, &_my_marshal );
		return _my_new($class);
	};
	no strict 'refs';
	*$name = $sub;
}

for my $name (keys %simple) {
	next if defined &$name;
	my $sub = sub {
		shift;
		_my_write( $name, &_my_marshal );
		return $_[0];
	};
	no strict 'refs';
	*$name = $sub;
}

for my $name (keys %listop) {
	my $sub = sub {
		shift;
		_my_write( $name, &_my_marshal );
		my @rets = split / /, scalar(_my_read()), -1 or return;
		$_ eq 'undef' and undef $_ for @rets;
		return $_[0], @rets;
	};
	no strict 'refs';
	*$name = $sub;
}

sub AUTOLOAD {
	(my $name = our $AUTOLOAD) =~ s/.*:://;
	my $sub = sub {
		shift;
		_my_write( $name, &_my_marshal, wantarray );
		my @ret = split / /, _my_read(), -1;
		$_ eq 'undef' and undef $_ for @ret;
		return wantarray ? @ret : $ret[0];
	};
	no strict 'refs';
	*$name = $sub;
	return &$sub;
}

BEGIN {
	my (%dispatch, $fallback);
	my @objs;
	my ($calc, $cmd, @args, $zero, $one);
	@dispatch{keys %simple} = (sub {
		$objs[ $zero ] = $calc->$cmd( @args );
	}) x keys %simple;

	$dispatch{_sub1} = sub {
		$objs[ $one ] = $calc->$cmd( @args );
	};

	$dispatch{_div} = sub {
		my $new = @objs;
		@objs[ $zero, $new ] = $calc->_div( @args );
	};

	@dispatch{keys %listop} = (sub {
		my ($result, @etc) = $calc->$cmd( @args );
		$objs[ $zero ] = $result;
		defined or $_ = 'undef' for @etc;
		print $writer join(q{ }, @etc), "\n"
			or __carp("Error writing results: $!");
	}) x keys %listop;

	@dispatch{keys %constructor} = (sub {
		push @objs, scalar $calc->$cmd( @args );
	}) x keys %constructor;

	$dispatch{DESTROY} = sub {
		if( $zero == $#objs ) {
			pop @objs;
		} else {
			$objs[ $zero ] = pop @objs;
		}
	};

	$fallback = sub {
		my $wantarray = pop @args;
		my @ret = $wantarray ? $calc->$cmd( @args )
			: scalar( $calc->$cmd( @args ) );
		defined or $_ = 'undef' for @ret;
		if( $wantarray ) {
			/\s/ and _my_croak("Unexpected whitespace in result '$_'")
				for @ret;
		} else {
			/\n/ and _my_croak("Unexpected newline in result '$_'")
				for @ret;
		}
		print $writer join(' ', @ret), "\n"
			or __carp("Error printing results: $!");
	};

	sub _my_childproc {
		$calc = shift;
		{
			no warnings 'once';
			$Math::BigInt::CAN{$_} = $calc->can($_) ? 1 : 0
				for qw,signed_and signed_or signed_xor,;
		}

		my $is_calc = $calc->can('_check') ? sub {
			!$calc->_check( $_ );
		} : sub {
			ref and ref->isa($calc);
		};
		while(defined( $_ = readline $reader )) {
			chomp;
			($cmd, @args) = split / /, $_, -1;
			my $objcnt = shift @args;
			my @indices = splice @args, 0, $objcnt;
			($zero, $one) = @indices;
			unshift @args, @objs[ @indices ];
			($dispatch{$cmd} || $fallback)->();
		}
		exit 0;
	}
}

sub STORABLE_freeze {
	my ($self, $cloning) = @_;
	return $$self if $cloning;
	return ref($self)->_as_hex($self);
}

sub STORABLE_attach {
	my ($class, $cloning, $str) = @_;
	if( $cloning ) {
		_my_write( '_copy', 1, $str );
		return _my_new( $class );
	}
	return $class->_from_hex( $str );
}

1;

__DATA__

=head1 NAME

Math::BigInt::SubProcess - perform math operations in a separate process

=head1 SYNOPSYS

	use Math::BigInt lib => 'SubProcess, GMP, PARI, FastCalc, Calc';

	## See Math::BigInt for usage

=head1 DESCRIPTION

By using IPC, potentially costly math operations are offloaded to another process.

Whether this will be faster remains to be seen.

=head1 BUGS

Probably.

=head1 AUTHOR

Ben Goldberg C<ben-goldberg@hotmail.com>

=cut