# A generic thing in the moo - parent of all other types of things.

package Thing;
use strict;
use Verb;
use VerbCall;
use Error;
use ActiveUser;
use ThingList;
use Utils;
use Method;
use Generics;
use vars qw($AUTOLOAD);
use UNIVERSAL qw(isa);

sub new {
	my $proto=shift;
	my $class = ref($proto) || $proto;
	my $this={};

	# All the data that needs to be different for every object.
	$this->{id}=ThingList::GetId();
	$this->{name}=''; # NOT undef!
	$this->{aliases}=[];
	$this->{location}=''; # NOT undef!

	# You can pass in a hash to set the initial values of the object.
	# This shouldn't be over-used, becuase it breaks the abstraction.
	# it's better to use the object methods to set values when possible,
	# becuase subclasses can override that.
	if (@_) {
		my %init=@_;
		foreach (keys %init) {
			$this->{$_}=$init{$_};
		}
	}

	# Use a closure so the values in $this can only be set if you have
	# the right permissions.
	my $closure = sub {
		my $field = shift;
		
		my $active=ActiveUser::getactive();
		my $owner=$this->{owner} || undef;
		my $parent=$this->{parent} || undef;

		# Special case: the owner of an object can get a ref to
		# its hash, breaking out of the closure. Note that this
		# ignores inheritance.
		if ($field eq 'all') {
			if ($owner == $active || isa($active,"Wizard")) {
				if (@_) {
					$this=shift;
				}	
				return $this;
			}
			else {
				return Error->new("Failure to get all: permission denied");
			}
		}
		
		# Handle permissions fields specially.
		if ($field eq 'perms_r' || $field eq 'perms_w') {
			my $f=shift;
			if (@_ && ($owner == $active ||
			           $this->{perms_w}{$field} ||
				   isa($active,"Wizard"))) {
				$this->{$field}{$f} = shift;
			}
			elsif (@_) {
				return Error->new("Failure to set perms: permission denied");
			}
			
			# I let everyone see perms, it simplifies a lot.
		    	if (! exists($this->{$field}{$f}) && $parent) {
				# Inherit permissions field from parent.
				return $parent->$field($f);
			}
			else {
				return $this->{$field}{$f};
			}
		}

		if (@_ && ($owner == $active ||
		           $this->{perms_w}{$field} ||
			   (! defined($this->{perms_w}{$field}) && $parent && $parent->perms_w($field)) ||
			   isa($active,"Wizard"))) {
			my $value=shift;
			if (ref($value) eq 'HASH' && $parent) {
				# Handle hashes extra-specially:
				# compare the new hash to our parent's
				# hash, and only store values in our hash that
				# are different from what's in the parent hash.
				my %value=%$value;
				my $parhash=$parent->$field();
				if ($parhash && ! Error::iserror($parhash)) {
					my %parhash=%{$parhash};
					my %newhash=undef;
					foreach (keys %value) {
						if (ref($value{$_}) eq undef) {
							if ($parhash{$_} ne $value{$_}) {
								$newhash{$_} = $value{$_};
							}
						}
						elsif ($parhash{$_} != $value{$_}) {
							$newhash{$_} = $value{$_};
						}
					}
					$this->{$field} = \%newhash;
				}
				else {
					$this->{$field} = $value;
				}
			}
			else {
				$this->{$field} = $value;
			}	
		}
		elsif (@_) {
			return Error->new("Failure to set $field to ".(shift).": permission denied");
		}

		if ($owner == $active ||
		    (exists($this->{perms_r}{$field}) && $this->{perms_r}{$field}) ||
		    (! exists($this->{perms_r}{$field}) && $parent && $parent->perms_r($field)) ||
		    isa($active,"Wizard")) {
			if (!exists($this->{$field}) && $parent) {
				# Handle simple inheritance.
				my $ret=$parent->$field();
				if (! Error::iserror($ret)) {
					return $ret;
				}
				else {
					return undef;
				}
				return $parent->$field();
			}
			if (ref($this->{$field}) eq 'HASH' && $parent) {
				# Merge our hash and the parent's.
				my $ret=$parent->$field();
				if (ref($ret) eq 'HASH' && ! Error::iserror($ret)) {
					my %hash=(%{$ret}, %{$this->{$field}});
					return \%hash;
				}
				else {
					return $this->{$field};
				}
			}
			else {
				return $this->{$field};
			}
		}
		else {
			return Error->new("Failure to get $field: permission denied");
		}
	};
	bless($closure, $class);

	# This has to come after the bless so we can pass the closure
	# to the thinglist.
	ThingList::add($closure);

	return $closure;
}

# Useful for all objects to accept this.
sub tell {}

# Do some sanity checks on a possible new name or alias. If it returns an
# Error object, the name is invalid.
sub is_invalid_name {
	my $this=shift;
	my $name=shift;

	if (length($name) == 0) {
		return Error->new("Name cannot be null.");
	}
	if ($name=~m/^([\$#*()])/) {
		return Error->new("Name cannot begin with '$1' characters.");
	}
	if ($name=~m/(["\\])/) {
		return Error->new("Name cannot contain '$1' characters.");
	}	
	if (lc($name) eq 'it' || lc($name) eq 'this' || 
	    lc($name) eq 'me' || lc($name) eq 'here') {
	    	return Error->new("Name cannot be \"$name\".");
	}
	return undef; # name ok.
}

# When setting a name, we do some simple sanity checks first.
sub name {
	my $this=shift;
	if (@_) {
		my $name=shift;
		return $this->is_invalid_name($name) || &{$this}('name', $name);
	}	
	else {
		# Call closure to get name.
		return &{$this}('name');
	}	
}

# Do sanity checks on aliases before setting.
sub aliases {
	my $this=shift;
	if (@_) {
		my $value=shift;
		foreach (@$value) {
			# Make sure it's a valid name.
			if ($this->is_invalid_name($_)) {
				return $this->is_invalid_name($_);
			}
		}
		# Now call the closure to set the aliases.
		return &{$this}('aliases',$value);
	}
	
	# Call closure to get aliases.
	return &{$this}('aliases');
}

# Cleans up before deleting this Thing.
sub remove {
	my $this=shift;
	
	if (ActiveUser::getactive() != $this->owner &&
		! isa(ActiveUser::getactive(),"Wizard")) {
		return Error->new("You do not own ".$this->name);
	}

	# Remove the object from its surrounds.
	if (isa($this->location,'Container')) {
		$this->location->contents_remove($this);
	}

	# Walk the thinglist and remove any remaining references to the thing
	# so it can really go away. Change ownership to the Wizard.
	my $adopter = Generics::findgeneric("wizard");
	my $olduser=ActiveUser::getactive();
	Utils::SuWizard();
	foreach (ThingList::All) {
		$_->owner($adopter) if ($_->owner == $this);
		$_->all(rec_delete($_->all(), $this));
	}
	ActiveUser::setactive($olduser);

	# Remove the object from the ThingList.
	ThingList::remove($this);
}

# Let's not change an object's id, ever.
# You can do it via the special all() method, if you really must.
sub id {
	my $this=shift;
	
	return &{$this}('id');
}

# Just here so AUTLOAD doesn't handle it.
sub DESTROY {
#	my $this=shift;
#	print "destroying a ".ref($this)." (".$this->name.")\n";
}

# Access properties of an object inside the closure.
sub AUTOLOAD {
	my $name = $AUTOLOAD;
	$name =~ s/.*://; # strip fully-qualified portion

	# First check to see if the methods hash has a special
	# method to run. I've restricted these methods to having names
	# ending in _safe, just because it means that this rather expensive
	# test doesn't need to run too often.
	if ($name=~m/_safe$/) {
		my $methods=&{ $_[0] }( 'methods' );
		if ($$methods{$name}) {
			return $$methods{$name}->run($name,@_);
		}
	}
	
	# Call the closure to set/get the value.
	&{ $_[0] }( $name, @_[ 1 .. $#_ ] )
}

sub verb_describe {
	my $this=shift;
	my $verbcall=shift;
	
	my $ret=$this->description($verbcall->word('indirect_object'));
	if (Error::iserror($ret)) {
		return $ret;
	}
	return "Description set.";
}

# Set name and aliases.
sub verb_rename {
	my $this=shift;
	my $verbcall=shift;

	my @aliases=split(',',$verbcall->word('indirect_object'));
	my $ret=$this->name(shift @aliases);
	if (Error::iserror($ret)) {
		return $ret;
	}
	$ret=$this->aliases([@aliases]);
	if (Error::iserror($ret)) {
		return $ret;
	}	
	return "Name changed."
}

# This is called when a person looks at the object.
sub verb_look {
	my $this=shift;
	my $verbcall=shift;

	return $this->look;
}

# This is called to show the object.
sub look {
	my $this=shift;
	
	return $this->description;
}

# Display help on the object.
# We just show any help associated with an object method.
sub verb_help {
	my $this=shift;
	my $verbcall=shift;
	
	if ($verbcall->word('preposition')) {
		my %help=$this->gethelp($verbcall->word('preposition'));
		if (keys(%help) == 0) {
			return "Sorry, no help is available on that command.";
		}
		elsif (keys(%help) == 1) {
			return values %help;
		}
		else {
			# Multiple possible matches.
			# TODO: use question_callback.
			return "Several help topics match your query:",
				sort(map("\t $_", keys %help));
		}
	}
	else {
		return "You need to specify a command you want help on.";
	}
}

# Passed a topic, either returns a hash of help topics and help texts that
# may match the given topic, or returns undef if there is no help.
sub gethelp {
	my $this=shift;
	my $topic=shift;
	
	my $help=$this->help;
	if (ref($help) eq 'HASH') {
		# Look for the things in the hash that match a substring
		# of what we were asked for help on. This also handles
		# the case of help topics being put in that are really
		# several help topics seperated by spaces.
		my %matches;
		my $key;
		foreach $key (keys %$help) {
			if ($key =~ m/(?:^|\s)(\Q$topic\E.*?)(?:\s|$)/) {
				$matches{$1}=${$help}{$key};
			}
		}
		
		return %matches;
	}
}

# Add a help text to the thing. Note that the topic can be a space delimted
# list of keys if you want to have the same help text for different topics
sub addhelp {
	my $this=shift;
	my $topic=shift;
	my $value=join("\r\n",@_);
	
	my %help;
	my $help=$this->help;
	if (ref($help) eq 'HASH') {
		%help=%$help;
	}
	
	$help{$topic}=$value;
	my $ret=$this->help(\%help);
	if (Error::iserror($ret)) {
		return $ret;
	}
	return 1;
}

# Remove a help topic from the hash.
sub removehelp {
	my $this=shift;
	my $topic=shift;

	my %help;
	my $help=$this->help;
	if (ref($help) eq 'HASH') {
		%help=%$help;
	}
	my $help=delete $help{$topic};
	$this->help(\%help) || return undef;
	return $help;
}

# Add a new verb to this item.
sub addverb {
	my $this=shift;
	my $verb=shift;

	my $verbs=$this->verbs;
	my %verbs;
	if ($verbs) {
		%verbs=%{$verbs};
	}
	# Use verb command name as hash index.
	$verbs{$verb->command} = $verb;
	my $ret=$this->verbs(\%verbs);
	if (Error::iserror($ret)) {
		return $ret;
	}
	return 1;
}

# Removes a verb from the hash. Pass the command name of the verb to remove.
# Returns the verb.
sub removeverb {
	my $this=shift;
	my $index=shift;
	
	my %verbs=%{$this->verbs};
	my $verb=delete $verbs{$index};
	$this->verbs(\%verbs) || return undef;
	return $verb;
}

# Returns all the verbs for this object as a list.
sub listverbs {
	my $this=shift;
	my $verbs=$this->verbs;
	if ($verbs) {
		return sort values %$verbs;
	}
}

# Returns the name of the subroutine in this object to call for a given
# verb. Returns undef if this object doesn't implement that verb.
sub getverbsub {
	my $this=shift;
	my $verbcall=shift;

	my $verb;
	foreach $verb ($this->listverbs) {
		if (ref($verb) eq 'Verb') {
			if ($verb->match($verbcall)) {
				return $verb->sub;
			}
		}	
		else {
			Utils::Log("notice",$this->name."(#".$this->id.") Oops in verblist ($verb)!!");
		}
	}

	return undef;
}

# Test to see if a passed alias is a valid one for this thing.
sub isalias {
	my $this=shift;
	my $name=lc(shift);

	return 1 if $name eq lc($this->name);
	if (ref($this->aliases) eq 'ARRAY') {
		map {return 1 if lc($_) eq $name} @{$this->aliases};
	}
	return undef;
}

# Passed a hash ref, merges the contents of the hash into this.
# Uses the special all() method, so it doesn't have to call methods for 
# each item in the hash.
# This is designed for loading up the db after a dump.
sub merge_all {
	my $this=shift;
	my $hash=shift;

	my $all=$this->all;
	my $key;

	foreach $key (keys %$hash) {
		# Treat subhashes as a special case - add elements to them,
		# instead of overwriting the whole hash.
		if (ref($hash->{$key}) eq "HASH" && ref($all->{$key}) eq "HASH") {
			my $subkey;
			foreach $subkey (keys %{$hash->{$key}}) {
				$all->{$key}->{$subkey} = $hash->{$key}->{$subkey};
			}
		}
		else {
			$all->{$key} = $hash->{$key};
		}
	}
	$this->all($all);
}

# Passed the name of a method that is in this thing's methods hash,
# it returns the object that actually defines that method. Ie, if the
# method is set on a parent, it'll return the parent.
sub method_definer {
	my $this=shift;
	my $method=shift;
	
	if (! $this->parent) {
		return $this;
	}

	# See if the parent's methods hash has the same value.
	my $methods=$this->methods;
	my $pmethods=$this->parent->methods;
	if ($$methods{$method} != $$pmethods{$method}) {
		# Nope. Ok, we defined the method, then.
		return $this;
	}
	# Recurse into our parent.
	return $this->parent->method_definer($method);
}

# This is meant for use by in-db methods only. It calls the parent's method
# with the passed parameters.
sub super {
	my $this=shift;
	my $method=$main::method;

	my $super_definer=$this->method_definer($method)->parent;
	my $methods=$super_definer->methods;
	if (! $$methods{$method}) {
		return Error->new("super called on #".$this->id." $method, but the parent does not define $method.");
	}
	return $$methods{$method}->run($method,$this,@_);
}

my $DELETE_MAX_DEPTH = 10; # a bit of a sanity check. we probably will never
                           # get that deep, but it's always good to be sure
# Remove all references in the passed thing to the passed object.
# The thing can be any perl data structure, except another object.
sub rec_delete {
	my $thing = shift;
	my $delobj = shift;
	my $depth = shift || 0;
	
	if ($depth > $DELETE_MAX_DEPTH) {
		Utils::Log("notice","rec_delete recursed too deep!");
		return $thing;
	}
	
	if (ref($thing)) {
		if ((ref($thing) eq "REF") || (ref($thing) eq "SCALAR")) {
			# if it's a simple reference, just dereference
			# it and try again
			$thing = rec_delete($$thing, $delobj, $depth+1);
	        }
		elsif (ref($thing) eq "ARRAY") {
			# for an array, look through each element for the object
			@$thing = map(rec_delete($_, $delobj, $depth+1), @$thing);
	        }
		elsif (ref($thing) eq "HASH") {
			my $key;
       			# for a hash, look for object in the values of the hash
			foreach $key (keys(%$thing)) {
				$$thing{$key} = rec_delete($$thing{$key}, $delobj, $depth+1);
			}
		}
		elsif ((ref($thing) eq "CODE") || (ref($thing) eq "GLOB")) {
			# nothing to do if it's code
		}
		else {
			# Finally, we found an object.
			# If it's what we are looking for, return a null ref.
			if ($thing == $delobj) {
				undef $thing;
				return undef;
			}
			
			# Else, we have another object. It should be dealt with
			# later, so ignore it.
		}
	}
	else {
		# This is just a simple scalar.
		# We shouldn't need to do anything unless it happens
		# to be what we need to delete.
		if ($thing == $delobj) {
			undef $thing;
			return undef;
		}
        }
	
	return $thing;
}

1