File Coverage

blib/lib/Anarres/Mud/Driver/Efun/Core.pm

Criterion	Covered	Total	%
statement	27	80	33.7
branch	0	20	0.0
condition			n/a
subroutine	9	41	21.9
pod			n/a
total	36	141	25.5

package Anarres::Mud::Driver::Efun::Core;

use strict;
use warnings;
use vars qw($VERSION @ISA);

# XXX Where should I be requiring these: before or after bootstrap?

use Anarres::Mud::Driver::Compiler::Type qw(:all);	# We do this twice?!

# Efuns need to be normal functions in a program symbol table but
# will not inherit or issue a warning if redefined.

# Note that we don't actually register all available efuns. We
# register only those which are visible as efuns to the LPC code.
# We may have more efuns, an individual efun typecheck_call method
# may decide to rebless the node into a different efun class.
# For example, map => map_array or map_mapping. In this way we
# can use the Perl object oriented dispatch mechanism to speed up
# many operations where a pure Perl conditional would be slower.

require DynaLoader;

$VERSION = 0.10;
@ISA = qw(DynaLoader);

bootstrap Anarres::Mud::Driver::Efun::Core;

use Anarres::Mud::Driver::Compiler::Type qw(:all);	# We do this twice?!
use Anarres::Mud::Driver::Program::Efun qw(register);
use Anarres::Mud::Driver::Program::Method;

{
	# As traditional, [ flags, return type, argtype .... ]
	my $pflags = M_PURE | M_NOMASK;	# This just lets me format nicely.
	my %efuns = (
		# Common stuff

		copy			=> [ 0,		T_UNKNOWN, T_UNKNOWN, ],

		# Object stuff

		this_object		=> [ 0,		T_OBJECT, ],
		previous_object	=> [ 0,		T_OBJECT, T_INTEGER, ],
	all_previous_objects=> [ 0,		T_OBJECT->array ],
		file_name		=> [ 0,		T_STRING, T_OBJECT, ],
		find_object		=> [ 0,		T_OBJECT, T_STRING, ],
		load_object		=> [ 0,		T_OBJECT, T_STRING, ],
		clone_object	=> [ 0,		T_OBJECT, T_STRING, ],
		destruct		=> [ 0,		T_INTEGER, T_OBJECT, ],
		children		=> [ 0,		T_OBJECT->array, T_STRING, ],
		objects			=> [ 0,		T_OBJECT->array, ],

		# String stuff

		implode		=> [ M_PURE, T_STRING, T_STRING->array, T_STRING ],
		explode		=> [ M_PURE, T_STRING->array, T_STRING, T_STRING ],
		lower_case		=> [ M_PURE, T_STRING, T_STRING, ],
		upper_case		=> [ M_PURE, T_STRING, T_STRING, ],
		strlen			=> [ M_PURE, T_INTEGER, T_STRING, ],
		replace_string	=> [ M_PURE, T_STRING, T_STRING, T_STRING, T_STRING, ],
		substr			=> [ M_PURE, T_STRING,
										T_STRING,
										T_INTEGER, T_INTEGER,	# off
										T_INTEGER, T_INTEGER, ],# end
		subchar			=> [ M_PURE, T_INTEGER,
										T_STRING,		# offset
										T_INTEGER, ],	# from end?
		capitalize		=> [ M_PURE, T_STRING, T_STRING, ],
		strsrch			=> [ M_PURE, T_INTEGER, T_STRING, T_STRING, ],
		regexp			=> [ M_PURE, T_INTEGER, T_STRING, T_STRING, ],

		# XXX varargs
		sprintf			=> [ M_PURE, T_STRING, T_STRING, T_ARRAY, ],
		sscanf			=> [ M_PURE, T_STRING, T_STRING, T_ARRAY, ],

		# Array stuff

		member_array	=> [ M_PURE, T_INTEGER, T_UNKNOWN, T_ARRAY, ],
		unique_array	=> [ M_PURE, T_ARRAY->array, T_ARRAY, T_CLOSURE],
			# XXX We can map mappings. :-(
		map				=> [ 0,		T_ARRAY, T_ARRAY, T_CLOSURE, ],
		filter			=> [ 0,		T_ARRAY, T_ARRAY, T_CLOSURE, ],
		allocate		=> [ 0,		T_ARRAY, T_INTEGER, T_UNKNOWN, ],

		# Mapping stuff

		keys			=> [ M_PURE,	T_STRING->array, T_MAPPING, ],
		values			=> [ M_PURE,	T_ARRAY, T_MAPPING, ],
		map_delete		=> [ 0,			T_UNKNOWN, T_MAPPING,T_STRING,],

		# Type stuff

		to_int			=> [ M_PURE,	T_INTEGER, T_STRING, ],
		to_string		=> [ M_PURE,	T_STRING, T_INTEGER, ],
		typeof			=> [ M_PURE,	T_STRING, T_UNKNOWN, ],
		sizeof			=> [ M_PURE,	T_INTEGER, T_UNKNOWN, ],

		intp			=> [ $pflags,	T_BOOL, T_UNKNOWN, ],
		stringp			=> [ $pflags,	T_BOOL, T_UNKNOWN, ],
		arrayp			=> [ $pflags,	T_BOOL, T_UNKNOWN, ],
		mapp			=> [ $pflags,	T_BOOL, T_UNKNOWN, ],
		functionp		=> [ $pflags,	T_BOOL, T_UNKNOWN, ],
		classp			=> [ $pflags,	T_BOOL, T_UNKNOWN, ],
		objectp			=> [ $pflags,	T_BOOL, T_UNKNOWN, ],
		clonep			=> [ M_PURE,	T_BOOL, T_UNKNOWN, ],
		undefinedp		=> [ M_PURE,	T_BOOL, T_UNKNOWN, ],

		# Closure stuff

		# XXX varargs
		evaluate		=> [ 0,		T_UNKNOWN, T_CLOSURE, T_ARRAY, ],

		# Reflection

		function_exists	=> [ 0,		T_OBJECT, T_STRING, T_INTEGER, ],
		functions		=> [ 0,		T_OBJECT, T_INTEGER, ],
		variables		=> [ 0,		T_OBJECT, T_INTEGER, ],
		inherits		=> [ M_PURE,	T_INTEGER, T_STRING, T_OBJECT, ],
		call_stack		=> [ 0,		T_STRING->array, T_INTEGER, ],

		# File stuff

		file_size		=> [ 0,		T_INTEGER, T_STRING, ],
		read_file		=> [ 0,		T_STRING, T_STRING, ],
		write_file		=> [ 0,		T_INTEGER, T_STRING, T_STRING, ],

		# System stuff

		time			=> [ 0,		T_INTEGER, ],

		debug_message	=> [ 0,		T_STRING, T_STRING, ],
		error			=> [ 0,		T_INTEGER, T_STRING, ],
		catch			=> [ 0,		T_STRING, T_UNKNOWN, ],
		shutdown		=> [ 0,		T_INTEGER, ],

		trace			=> [ 0,		T_INTEGER, T_INTEGER, ],
			);

	# We call this as an exported function since ISA isn't yet set up.
	foreach (keys %efuns) {
		register(__PACKAGE__ . "::" . $_, @{ $efuns{$_} });
	}
}

{
	package Anarres::Mud::Driver::Efun::Core::time;
	sub generate_call { "time()" }
}

{
	package Anarres::Mud::Driver::Efun::Core::debug_message;
	sub generate_call { "print STDERR $_[1], '\\n'" }
}

{
	package Anarres::Mud::Driver::Efun::Core::previous_object;
	sub invoke { undef }
}

{
	package Anarres::Mud::Driver::Efun::Core::file_name;
	sub generate_call {
		"Anarres::Mud::Driver::Program::package_to_path(ref($_[1]))"
	}
}

{
	package Anarres::Mud::Driver::Efun::Core::find_object;
	# sub generate_call { "undef" }
	sub invoke { undef }
}

{
	package Anarres::Mud::Driver::Efun::Core::to_string;
	# XXX This only works for CONSTANT integers, of course.
	# sub generate_call { '"' . $_[1] . '"' }
	# This works for any integer which is about to be evaluated as
	# a string by Perl. 6 . 7 == "67";
	sub generate_call { ('' . $_[1]) }
}

{
	package Anarres::Mud::Driver::Efun::Core::strlen;
	sub generate_call { "length($_[1])" }
}

{
	package Anarres::Mud::Driver::Efun::Core::error;
	sub generate_call { "die('LPC: ' . $_[1])" }
}

{
	package Anarres::Mud::Driver::Efun::Core::catch;
	sub generate_call { "do { eval { $_[1] }; $@; }"; }
}

{
	package Anarres::Mud::Driver::Efun::Core::implode;
	sub generate_call { "join($_[2], \@{ $_[1] })" }
}

{
	package Anarres::Mud::Driver::Efun::Core::explode;
	# invoke is an XSUB
}

{
	package Anarres::Mud::Driver::Efun::Core::replace_string;
	# invoke is an XSUB
}

{
	package Anarres::Mud::Driver::Efun::Core::intp;
	# sub generate_call { "(defined($_[1]) && !ref($_[1]))" }
	# invoke is an XSUB
}

{
	package Anarres::Mud::Driver::Efun::Core::stringp;
	# sub generate_call { "(defined($_[1]) && !ref($_[1]))" }
	# invoke is an XSUB
}

{
	package Anarres::Mud::Driver::Efun::Core::arrayp;
	sub generate_call { "ref($_[1]) eq 'ARRAY'" }
}

{
	package Anarres::Mud::Driver::Efun::Core::mapp;
	sub generate_call { "ref($_[1]) eq 'HASH'" }
}

{
	package Anarres::Mud::Driver::Efun::Core::objectp;
	sub generate_call { "ref($_[1]) =~ /::/" }	# XXX
}

{
	package Anarres::Mud::Driver::Efun::Core::clonep;
	sub generate_call { "ref($_[1]) =~ /::/" }	# XXX
}

{
	package Anarres::Mud::Driver::Efun::Core::undefinedp;
	sub generate_call { "defined($_[1])" }
}

{
	package Anarres::Mud::Driver::Efun::Core::keys;
	sub generate_call { "keys(\%{$_[1]})" }
}

{
	package Anarres::Mud::Driver::Efun::Core::values;
	sub generate_call { "values(\%{$_[1]})" }
}

{
	package Anarres::Mud::Driver::Efun::Core::map_delete;
	sub generate_call { "delete(\${$_[1]}->{$_[2]})" }
}

{
	package Anarres::Mud::Driver::Efun::Core::regexp;
	sub generate_call { "XXX($_[1] =~ m/$_[2]/)" }
}

{
	package Anarres::Mud::Driver::Efun::Core::clone_object;
	sub generate_call { "$_[1]\->new()" }
}

{
	package Anarres::Mud::Driver::Efun::Core::this_object;
	sub generate_call { '$self' }
}

{
	package Anarres::Mud::Driver::Efun::Core::strsrch;
	sub generate_call { "index($_[1], $_[2])" }
}

{
	package Anarres::Mud::Driver::Efun::Core::lower_case;
	sub generate_call { "lc($_[1])" }
}

{
	package Anarres::Mud::Driver::Efun::Core::upper_case;
	sub generate_call { "uc($_[1])" }
}

{
	package Anarres::Mud::Driver::Efun::Core::substr;
	# invoke is an XSUB
}

{
	package Anarres::Mud::Driver::Efun::Core::subchar;
	# invoke is an XSUB
}

{
	package Anarres::Mud::Driver::Efun::Core::capitalize;
	sub generate_call { "ucfirst($_[1])" }
}

{
	package Anarres::Mud::Driver::Efun::Core::allocate;
	sub generate_call {
		my $val = defined $_[2] ? $_[2] : 'undef';
		return "[ ($val) x $_[1] ]"
	}
}

{
	package Anarres::Mud::Driver::Efun::Core::to_int;
	sub generate_call { "(0 + ($_[1]))" }
}

{
	package Anarres::Mud::Driver::Efun::Core::copy;
	sub invoke { $_[1] }	# XXX dclone - but not for objects.
}

{
	package Anarres::Mud::Driver::Efun::Core::inherits;
	sub generate_call { "($_[2])->isa(XXX_to_package($_[1]))" }
}

{
	package Anarres::Mud::Driver::Efun::Core::sizeof;
	sub generate_call {
		# XXX Arse - use typechecking info!
		# XXX Deal with ints
		'do { my $__a = ' . $_[1] . '; my $__r = ref($__a); ' .
				# ($#$__a + 1) ?
				'$__r eq "ARRAY" ? scalar(@{$__a}) : ' .
				'$__r eq "HASH" ? scalar(keys %{$__a}) : ' .
				'$__r eq "" ? length($__a) : ' .
				'die "Cannot take sizeof($__r)"; }';
	}
}

{
	package Anarres::Mud::Driver::Efun::Core::file_size;
	use Fcntl qw(:mode);
	sub invoke {
		my @stat = stat($_[1]);
		return -1 unless @stat;
		return -2 if ($stat[2] & S_IFDIR);
		return $stat[2];
	}
}

{
	package Anarres::Mud::Driver::Efun::Core::map;
	use Anarres::Mud::Driver::Compiler::Type qw(:all);
	sub typecheck_call {
		my ($self, $program, $values, @rest) = @_;
		my $val = $values->[1];
		my $func = $values->[2];

		$func = $func->infer(T_CLOSURE);
		unless ($func) {
			$program->error("Argument 2 to map must be a closure.");
		}

		if (my $arr = $val->infer(T_ARRAY)) {
			# $values->[0] = "(pointer to map_array)";
			$values->[1] = $arr;
			$arr->typecheck($program, undef, @rest) unless $arr == $val;
			return $arr->type;
		}
		elsif (my $map = $val->infer(T_MAPPING)) {
			# $values->[0] = "(pointer to map_mapping)";
			$values->[1] = $map;
			$map->typecheck($program, undef, @rest) unless $map == $val;
			return $map->type;
		}
		elsif (my $str = $val->infer(T_STRING)) {
			$values->[1] = $str;
			$str->typecheck($program, undef, @rest) unless $str == $val;
			return $str->type;
		}
		else {
			$program->error("Argument 1 to map must be a mapping " .
							"or an array.");
			return undef;
		}
	}
}

1;