#!/usr/bin/perl
# Show various things about an object.
# If it's called as "showall", it displays inherited stuff too.
#use Mooix::Thing;

my %fieldfiles;
my %inheritedfields;
my %types;
my %documented;

my %headers;
sub header {
	my $header=shift;
	if (! $headers{$header}) {
		$headers{$header}=1;
		return ucfirst($header).":";
	}
	return;
}

sub showfield {
	my $this=shift;
	my $field=shift;
	my $maxlen=shift() + 3; # three space indent tacked on
	my $type=shift;

	my $indent=' ' x ($maxlen - length($field));
	my @ret;

	if ($type eq 'id') {
		push @ret, "\t$this";
	}
	elsif (! -r $fieldfiles{$field}) {
		@ret="\t$field$indent\[Unreadable]";
	}
	elsif ($type eq 'messages' || $type eq 'fields') {
		my @values;
		unless (-c $fieldfiles{$field} || -b $fieldfiles{$field} || -S $fieldfiles{$field} ) {
			# I assume that messages will not have binary data
			# in them..
			if ($type eq 'fields' && ! -T $fieldfiles{$field}) {
				@values = "$! [".(-s $fieldfiles{$field} )." bytes of binary data]";
			}
			else {
				@values = $this->$field;
			}
		}
		if (@values == 0) {
			push @ret, "\t$field$indent[unreadable]";
		}
		else {
			# Display multiple values sanely.
			push @ret, "\t$field$indent".shift(@values)."";
			foreach (@values) {
				push @ret, "\t".(' ' x $maxlen).$_;
			}
		}
	}
	elsif ($type eq 'references' || $type eq 'commands') {
		my @values;
		if ($type eq 'references' && $field eq 'id') {
			@values=$this;
		}
		else {
			@values = grep { ! /^\s*#/ } $this->$field;
		}
		if (@values == 0 && $type eq 'commands') {
			push @ret, "\t$field$indent\[bad prototype]";
		}
		else {
			# Display multiple values sanely.
			push @ret, "\t$field$indent".shift(@values)."";
			foreach (@values) {
				push @ret, "\t".(' ' x $maxlen)."$_";
			}
		}
	}
	elsif ($type eq 'methods') {
		my $flags='';
		if (-k $fieldfiles{$field}) {
			$flags='[stackless]';
		}
		if (open(METHFILE, $fieldfiles{$field})) {
			my @lines=<METHFILE>;
			if ($lines[0] =~ /^#!.*\/(.+)/) {
				my $what=$1;
				if ($what eq 'sh') { $what="shell script" }
				push @ret, "\t$field$indent".($#lines + 1)." lines of $what $flags";
			}
			else {
				push @ret, "\t$field$indent".(-s $fieldfiles{$field})." bytes $flags";
			}
		}
		else {
			push @ret, "\t$field$indent[unreadable]";
		}
	}
	else {
		print STDERR "bad type $type for field $field\n";
	}

	# Add flags at start of line.
	if (@ret) {
		my $flags="";

		# Add asterisk if there is inheritance going on.
		if ($fieldfiles{$field} !~ m!/parent/!) {
			$flags.=" ";
		}
		else {
			$flags.="*";
		}
		
		# Add question mark if the field is undocumented.
		if (! $documented{$field}) {
			$flags.="?";
		}
		else {
			$flags.=" ";
		}
		$ret[0]=$flags.$ret[0];
		# Add corresponding spaces to any other lines too, to ensure
		# they line up perfectly.
		$flags=(' ' x length($flags)) if @ret > 1;
		foreach (@ret[1..$#ret]) {
			$_=$flags.$_;
		}
	}

	return @ret;
}


run sub {
	my $this=shift;
	%_=@_;
	my $object=$_{direct_object} || $this->usage("bad direct object");
	
	# Make sure that this command is not spoofed, just in case.
        if ($_{avatar} != $this) {
		fail "No!"; 
	}
	
	my $showall=1 if $0 =~ /showall/;
	
	# Iterate over fields, and categorize.
	my %cats;
	foreach my $field ($object->fields) {
		next if $field =~ /^\./; # private/hidden
		next if $field =~ /~$/; # editor backup files
		
		$fieldfiles{$field}=$object->fieldfile("$field");

		if (! $showall && $fieldfiles{$field} =~ m!/parent/!) {
			$inheritedfields{$field} = 1;
		}
		
		if (-f $fieldfiles{$field} && -x _) {
			my $safefield = ".$field-safe";
			if (! $object->$safefield) {
				if ($field =~ /_verb$/) {
					$documented{$field}=1; # doesn't need docs
				}
				push @{$cats{methods}}, $field;
				push @{$types{$field}}, 'methods';
				next;
			}
			else {
				# It's hard to tell if these should only
				# show on showall, or not.
				$inheritedfields{$field} = 0;
				# Fall through to normal field processing..
			}
		}
		
		
		# sticky nonexecutable fields hold lists of references
		if (-d $fieldfiles{$field} || -k _ ) {
			push @{$cats{references}}, $field;
			push @{$types{$field}}, 'references';
		}
		elsif ($field =~ /.msg$/) {
			push @{$cats{messages}}, $field;
			push @{$types{$field}}, 'messages';
			$documented{$field}=1; # don't need docs
		}
		elsif ($field =~ /\.cmd$/) {
			push @{$cats{commands}}, $field;
			push @{$types{$field}}, 'commands';
			$documented{$field}=1; # don't need docs
		}
		elsif ($field =~ /(.*)\.inf$/) {
			$documented{$1}=1;
		}
		elsif ($field =~ /(.*)\.hlp$/) {
			$documented{$1}=1;
		}
		else {
			push @{$cats{fields}}, $field;
			push @{$types{$field}}, 'fields';
		}
	}
	
	# id category
	push @{$cats{id}}, '';
	$documented{''}=1;
	
	# Just display a single field (but there may be multiple matches of
	# different types).
	if (exists $_{field} && exists $fieldfiles{$_{field}} && ! exists $cats{$_{field}}) {
		my @ret;
		foreach my $type (@{$types{$_{field}}}) {
			push @ret, header($type);
			push @ret, showfield($object, $_{field}, length($_{field}), $type);
		}
		$_{session}->write(@ret);
		return;
	}
	elsif (exists $_{field} && ! exists $cats{$_{field}}) {
		fail "No such category or field.";
	}

	# Generate output.
	my @ret;
	foreach my $cat (qw{fields messages references commands methods id}) {
		next if exists $_{field} and lc($_{field}) ne $cat;

		# Work out indentation level, so everything lines up inside
		# each subsection.
		my $maxlen=0;
		foreach my $field (sort @{$cats{$cat}}) {
			$maxlen = length $field if length $field > $maxlen;
		}
		
		foreach my $field (sort @{$cats{$cat}}) {
			next if ! $showall && $inheritedfields{$field};
			push @ret, header($cat);
			push @ret, showfield($object, $field, $maxlen, $cat);
		}
	}

	fail "Nothing to show; perhaps you should use showall."
		if ! @ret && ! $showall;
	
	# Page result.
	$_{session}->page(@ret);
}
