#!/usr/bin/perl
# This needs to be stackless, and its object must be a mooadmin.
#use Mooix::Thing;
run sub {
	my $this=shift;
	%_=@_;
	my $to = $_{to};
	my $object = $_{object} || $this->usage("missing object in move");

	if ($object->immobile) {
		return unless $_{teleport};
		require Mooix::CallStack;
		#require Mooix::Root;
		my $stack=Mooix::CallStack::get();
		$stack=$stack->nextsegment;
		# For the move to work, the whole second stack frame must
		# contain nothing but this object's owner or the object (or
		# admin).
		my $admin=$Mooix::Root->system->admin;
		my $owner=$object->owner;
		while ($stack) {
			if (length $stack->method &&
			    ($stack->index ne $owner->index &&
			     $stack->index ne $object->index &&
			     $stack->index ne $admin->index)) {
				return; # no can do
			}
			$stack=$stack->next;
			last if ! ref $stack || $stack->boundry;
		}
	}
	
	if ($to && ! ref $to) {
		$object->usage("bad destination");
	}

	# Sanity check, prevent any kind of loop..
	my $obj = $to;
	while (ref $obj) {
		if ($obj == $object) {
			return undef;
		}
		$obj = $obj->location;
	}
	# Avoid loops caused by eg, moving a room's parent into the room,
	# which has no location, and thus inherits itself as its location,
	# leading to loops.
	if (ref $to && ! $to->defines('location')) {
		if ($to->isa($object)) {
			return undef;
		}
	}

	# If there is a preposition, check it to see if the new location will
	# allow that preposition to be used. If not, get the default
	# prepositions. In any event, set @prepositions to the list of
	# prepositions it returns.
	my @prepositions;
	if ($to) {
		if (length $_{preposition}) {
			@prepositions=$to->get_preposition(preposition => $_{preposition}, object => $object);
		}
		else {
			@prepositions=$to->get_preposition(object => $object);
		}
		return unless @prepositions;
	}
	
	# Unfortunatly, moves can't be done atomically. Given the choice
	# between having the object be nowhere for a second, and having it
	# be in two places at once, I chose the former. So remove from old
	# location first.
	#
	# Also unfortunatly, this is quite slow, since it ends up calling a
	# number of methods. It's really noticible when picking up/dropping
	# objects.
	my $oldlocation=$object->location;
	# Of course, we may not need to move it really.
	if ($oldlocation != $to) {
		if (ref $oldlocation) {
			return unless $oldlocation->contents->remove(object => $object);
		}
		$object->location($to);
		if (ref $to) {
			unless ($to->contents->add(object => $object)) {
				if ($oldlocation) {
					# Back out changes..
					# if this fails, we're screwed.
					$oldlocation->contents->add(object => $object);
				}
				$object->location($oldlocation);
				return;
			}
		}

		if ($object->implements("onmove")) {
			$object->onmove(oldloc => $oldlocation);
		}

		# Use the internal _mass field for speed, to avoid calling
		# the mass method.
		my $mass = $object->_mass;
		if ($mass) {
			my %seen, %done;
			my @addmass;
			my $intersection;
			if (ref $to) {
				my $obj = $to;
				do {
					push @addmass, $obj;
					$seen{$obj->index} = 1;
					$obj = $obj->location;	
				} while (ref $obj);
			}
			if (ref $oldlocation) {
				my $removemass = -1 * $mass;
				
				my $obj = $oldlocation;
				LOOP:{ # perl bites
					do {
						# Stop removing mass at the
						# intersection.
						if ($seen{$obj->index}) {
							$intersection = $obj;
							last; # LOOP
						}
						if ($obj->implements('masschange')) {
							$removemass = $obj->masschange($removemass);
						}
						$obj->_mass($obj->_mass + $removemass);
						$obj = $obj->location;
					} while (ref $obj);
				}
			}
			# Now add mass, but only up to the intersection.
			foreach my $obj (@addmass) {
				last if $obj == $intersection;
				if ($obj->implements('masschange')) {
					$mass = $obj->masschange($mass);
				}
				$obj->_mass($obj->_mass + $mass);
			}
		}
	}
	
	# Now that the object is moved, update its preposition field with
	# the prepositions the location's get_preposition method returned
	# earlier. If there are none, just set it to an empty value.
	push @prepositions, "" unless @prepositions;
	$object->preposition(@prepositions);
	
	return $object;
}
