view release on metacpan or  search on metacpan

Efun/Core/Core.pm  view on Meta::CPAN

	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;