#!/usr/bin/perl
use strict;
use warnings;

=head1 graphit

A Nagios config visualiser that uses graphvis to shed light on complex
Nagios configurations.

A Nagios tool written by Martin Houston.

This takes the output of nagparse - it evals stdin as an object.

This design was inspired by Microsoft powershell - the tings sent through 'pipelines' are real .NET objects,
no need for explicit serialization.

This achieves a very similar approach by using the Data::Dumper module and expecting that data on stdin.

The advantage of this is that to some extent two cores get used.

The disadvantage is that there is NO INPUT CHECKING. Graphit trusts that you the user are feeding it good data.

We attempt to do a graph but only including objects that match any specified filters.

Globaly unique identifiers that work across object types are sadly not part of Nagios data design.

We cope with this by making the primary index of data comming from nagparse being the source file and line number of where
the definition of the captured object starts. We have to take the TYPE of that object into account to then infer and identifier for it.

Internally in this program we use these inferred identifiers prefixed with what object type they are - just in case
for example we have a host named the same as a service.

Filters should be prepended with the object type e.g. host.
All arguments to this script are considered to be filters.

If executed from a CGI environment each node of the graph will contain a URL that when clicked will cause the diagram to be redrawn
as if the object name was the wildcard. This will give you just that object plus any other objects with direct
relationships to it. Such a feature allows rapid 'drill-down' so that small features of a large configuration can be spot
checked.

This tool has been developed to aid a large scale re-factoring and rationalisation process of Nagios data.

WARNING WARNING WARNING
If no filters at all are given and the default regular expression of '.' is used  and if the config is non trivial an impossibly dense graph
will result. Be sensible in what you want to see!

The filter is a perl regular expression, understand what you put in. Incorrect expressions will blow the program up.
 
The output stream is graphvis sourcecode. This seems to work best piped to dot -Tsvg, which is wht the cgi front end called explorenagios does.

However you may like to try the other layout options such as sfd and neato.

If you are unsure about what is going on in the code below then referring to Data::Dumper dumps of the data being processed will
be helpful.

As a further twist of complication after the first working version of the code was used it was realised that some important 
relationships such as hosts --> hostgroups are only apparent if you consider 'use' inherritance.

We now take this into account but make the difference clear by using a dotted line instead of a solid one.

If an object is one that is the focus of the graph the use relationships will be directly plotted anyway.

The problem surfaces when the object being plotted is just a dependancy.

Lack of use chasing means that if a host has a relationship to a hostgroup through use inherritance that will be visible
when the host is the centre of focus but not the hostgroup.

The special tag of file: means the rest of the string is taken as a regular expression to apply to the actual filename
the object is to be found in. This gives a source file specific focus as well as the normal object specific focus.


=cut

use Data::Dumper;

=pod

We use CGI capability just so we can generate some URLs if we are invoked from a top level CGI program.
This program is 100% functional as a command line use tool.

=cut

use CGI::Pretty qw(-newstyle-urls :standard);


=pod

First digest the filters.

If any of these is NOT a valid regular expression the program will terminate at this point.

Precompiling is both efficent and means that bad expressions will fail here in the one place.

Note we hand onto the string form too as it makes for better error messages later on.


=cut

my @filestomatch = ();
my @filters = ();

for(@ARGV) {
    if(/^\^?file:/) {
        push @filestomatch, [qr{$'},$'];
    }
    else {
        # and ordianry pattern to match contents - either will do
        push @filters, [qr{$_},$_];
    }
}

# do we render a whole detailed display of the data or just its name.
my $detailed = (defined $ENV{DETAIL} ? 1 : 0);
my $config;

# if this is set to true then we dump out each of the intermediate working structures in turn.
# this allows logic problems to be debugged.
# will not work as input to graphvis tools if this is set however.
my $dumpworkings = 0;

=pod 

If the above did not blow up we have a set of filters to select objects
we want to show the objects that match the filter PLUS any other objects that directly relate to them.
Objects that neither match a filter or are related to them are NOT shown in the graph.

The key to this is the name that matches the pattern and the values are a list of
 objects that have some relationship to that object

=cut

my %objstokeep = ();

=pod 

We are after icons so collect those during the initial scan too.
Index agains the main object index.

=cut

my %icons = ();


=pod

And the ones we will also need because they are referred to in various ways.
Top level of this is the kind of reference, second level is pairs of indexes that refer to each other.

=cut

my %refs = ();

=pod

Next we evaluate the data so it becomes part of this program.

If there is anything wrong with this as a data dump the program will end here.

=cut

=head1 new_url

This uses CGI library to make us a URL that would make us a url that will invoke the enclosing CGI program that is using us
the same as it was invoked apart from a single parameter called 'pat' is now the requested value.

This parameter is what in turn is passed as our pattern to select on so that a crowded graph can be simplified
by clicking on any point just to show the relationships that object alone has.

=cut

sub new_url {
    my $pat = shift;
    my $base = shift || '/usr/local/nagios/etc'; # set this as a bodge for now
    my $q = new CGI;
    $q->param(-name=>'pat',-values=>[$pat]);
    $q->param(-name=>'base',-values=>[$base]);
    return '"' . $q->url(-query=>1,path_info=>1) . '"';
}

=head1 deref

Tricky code for deciding on if an object is derived via use or directly defined 
in that there is an extra ref for use derived objects.

What we do to mark such tings is put a one element hash, the key of which is where the value is derived and the value 
is what we otherwise use.

If the $suppress arg is defined and we are a ref instead return undef, or else it messes up
our object identification!

=cut

sub deref {
   my($x,$suppress) = @_;
   
   if(ref($x) =~ /^HASH/) { # this shows it is inherrited
       return undef if defined $suppress;
       for(keys %{$x}) {
	   # warn " $_ = ", $x->{$_};
	   return (wantarray ? ($x->{$_},$_) : $x->{$_});
       }
   }
   else {
       return (wantarray ? ($x,undef) : $x);
   }
}

=head1 get_ident

Nagios does not have a universal identifier that is globally unique across all object types.

This code is object type specific and makes up our best guess at what is going to be a suitable identifier
both for our referring to the object on the graph, and for fornding relationships between objects.

The identifier is prefixed with the object type as otherwise we would have big namespace collision issues.

There may be some of the minior object types still missing. Need to be added as required.

If we are evaluated in array context we add a second value which is true if the dereference was needed.

We suppress any use following for this - it would be bad! Rather have undef.

=cut

sub get_ident {
    my $obj = shift;
    return "Unknown - no TYPE" unless defined $obj->{TYPE};
    if($obj->{TYPE} eq 'host') {
        return "host:" . (scalar(deref($obj->{name},1)) || scalar(deref($obj->{host_name},1)) || scalar(deref($obj->{address},1)) || "UNKNOWN host");
    }
    elsif($obj->{TYPE} eq 'hostgroup') {
        return "hostgroup:" . (scalar(deref($obj->{name},1)) || scalar(deref($obj->{hostgroup_name},1)) || scalar(deref($obj->{alias},1)) || "UNKNOWN hostgroup");
    }
    elsif($obj->{TYPE} eq 'service') {
        return "service:" . (scalar(deref($obj->{name},1)) || scalar(deref($obj->{service_description},1)) || scalar(deref($obj->{alias},1)) || "UNKNOWN service");
    }
    elsif($obj->{TYPE} eq 'servicegroup') {
        return "servicegroup:" . (scalar(deref($obj->{name},1)) || scalar(deref($obj->{servicegroup_name},1)) || scalar(deref($obj->{alias},1)) || "UNKNOWN servicegroup");
    }
    elsif($obj->{TYPE} eq 'timeperiod') {
        return "timeperiod:" . (scalar(deref($obj->{name},1)) || scalar(deref($obj->{timeperiod_name},1)) || scalar(deref($obj->{alias},1)) || "UNKNOWN timeperiod");
    }
    elsif($obj->{TYPE} eq 'command') {
        return "command:" . (scalar(deref($obj->{name},1)) || scalar(deref($obj->{command_name},1)) || "UNKNOWN command");
    }
    elsif($obj->{TYPE} eq 'contact') {
        return "contact:" . (scalar(deref($obj->{name},1)) || scalar(deref($obj->{contact_name},1)) || scalar(deref($obj->{alias},1)) || "UNKNOWN contact");
    }
    elsif($obj->{TYPE} eq 'contactgroup') {
        return "contactgroup:" . (scalar(deref($obj->{name},1)) || scalar(deref($obj->{contactgroup_name},1)) || scalar(deref($obj->{alias},1)) || "UNKNOWN contactgroup");
    }
    else {
        # dont know how to deal with the rest yet - easy enough
	return $obj->{TYPE} . ":UNKNOWN!";
    }
}
    
    
my $c = join('',<STDIN>);

{
    no strict;
    $config  = eval $c;
    die "Nothing to work on!" unless ref($config);
    
}

undef $c;
# the raw config as output by nagparse,
# use relationships are decoded here and represented by a hash of index => value instead of the actual value.
# This allows each object to appear logically as it would to Nagios but with where particular
# values are actually set kept clear. The deref function defined above takes care of 
# extracting actual inherited values.

print Data::Dumper->Dump([$config],['config']) if $dumpworkings;

=head1 Main program processing starts here

First pass is to note which objects we are interested in keeping
we form a unique identifier of the object by concatenating its type with another field dependent
on that type. (the get_ident function does this).

If this identifier matches any of our regular expressions we note that by creating a record for its
primary ID under objs_to_keep.

=cut

for my $ob (keys %{$config}) {
     my $id = get_ident($config->{$ob});
     # does this id match any that we are after? $_->[0] is the regex, $_->[1] is the string form of the same.
     # we could have more than one match, it does not matter, we keep the object.
     # we save a 2 element list, the object itself and which regex it matches - the last one wins
     for(@filters) {
         if($id =~ $_->[0]) {
             $objstokeep{$id} = [$ob, $_->[1]];
         }
     }
     # now if we have any files to match we can add those
     if(@filestomatch) {
         for(@filestomatch) {
             if($ob =~ $_->[0]) { # look - we are matching $ob, not the id - this contains the path to the file
                 $objstokeep{$id} = [$ob, $_->[1]];
             }
         }
     }
     # store this icon for quick lookup later
     for my $itype (qw{icon vrml statusmap}) {
         if(defined $config->{$ob}->{$itype . '_image'}) {
             # dont care if this is inherreted or not
             my $ico = deref($config->{$ob}->{$itype . '_image'},undef);
             if(defined $ico) {
                 $icons{$ob} = $ico if -r $ico; # it is assumed we have a cwd where the images are!
             }
         }
     }
}

# The next phase is to apply our given regular expressions (typically only one) and selecting all objects where 
# the output of get_ident for that object matches one of the patterns we are after.
# We show selected objects on the graph in their own subgraphs as this makes the relationships
# between what we have focused on and what the relationships are to other objects we are NOT focused on.
print Data::Dumper->Dump([\%objstokeep, \%icons],['objstokeep', 'icons']) if $dumpworkings;

=pod

Now we have the full set of the things we want to keep defined.
 
what we have here is entries tagged by name with content of the main unique index from %config - so we can pull
out all the rest of the information if we need to.


Now we need to sort out the various relationships between objects
The relationships are:
=over 4
=item 1. 

use - one object includes another by saying use and the name of the other object

=item 2. 

host to hostgroup mapping by use of the host_group 

=item 3. 

hostgroup to host mapping by use of the members 
 
=item 4. 

service to host mapping by using host_name

=item 5. 

service to hostgroup mapping by using host_name

=item 6. 

servicegroup to service mapping by members directive

=item 7. 

servicegroup to hostgroup mapping by hostgroup_name 

=back
Need to do the rest later.

Data consist of object to look in field to look in, object to link to.

Special processing for check_command - split on ! and use first part

=cut

my @relationships = (
    [qw{service use service}],
    [qw{host use host}],
    [qw{host host_group hostgroup}],
    [qw{host contact_groups contactgroup}],
    [qw{hostgroup members host}],
    [qw{hostgroup hostgroup_members hostgroup}],
    [qw{service notification_period timeperiod}],
    [qw{host notification_period timeperiod}],
    [qw{host check_period timeperiod}],
    [qw{contact host_notification_period timeperiod}],
    [qw{contact service_notification_period timeperiod}],
    [qw{contactgroup host_notification_period timeperiod}],
    [qw{contactgroup service_notification_period timeperiod}],
    [qw{contactgroup members contact}],
    [qw{service host_name host}],
    [qw{service hostgroup_name hostgroup}],
    [qw{service servicegroup_name servicegroup}],
    [qw{service check_command command}],
    [qw{servicegroup members service}],
    [qw{servicegroup servicegroup_members servicegroup}],
);

=pod

Now we scan the objects again, looking for anything that is a valid relationship we want to bring out.
The problem here is not extracting too much data to show on any one graph.

We go through the object array again..

We use the get_ident function to extrapolate a useable id based on the type of the object.

This ident consists of a type and then the lable so we need to separate these.

=cut

for my $ob (keys %{$config}) {
     my $obj = $config->{$ob};
     my $id = get_ident($obj);
     my($type,$label) = split(/:/, $id, 2); 
 

=pod

$type is what this object is, so we are only interested in testing appropriate relationships, so we grep down the main list.

The type of the thing which has the relationship is the first thing in the list so $_->[0].

We create a list consisting of just the above relationship records for which the left hand side is the object type we
have in front of us.

=cut
     my @tests = grep { $_->[0] eq $type } @relationships;
     next unless scalar @tests; # nothing to do for this object so carry on to the next one

=pod

Next we see if we have any fields in this object of the type we are looking for - i.e. that we have a non empty value for the relationship
specified in this test.

e.g. are we a hostgroup and do we have a members test and our members field has data?

=cut
     my @livetests = grep { defined $obj->{$_->[1]} && $obj->{$_->[1]} ne '' } @tests;
     next unless scalar @livetests; # again cop out if there are no tests to do.

=pod

If we get this far then this object has some fields which might refer back to one of the things we are interested.

We need to solve the problem that if select a host get to see the services associated with that hostgroup but NOT
vica versa. This is because there is no explicit relationship in the other direction.



=cut
     for my $test (@livetests) {

=pod

This is where it gets tricky! What we have collected is a number of elements
Each element is a 3 element list this type, the relationship type and the type of thing being referred to.
Remember that %objstokeep is indexed on id which is objecttype:identifier so we need to see of the contents 
of the 'bridge' field match one of the object we want to keep if we were to prepend the type information onto it.

We need to do this bacause prepending the types is our convention - it is not in the Nagios data intrinsicaly and therefore
not in the links.

As a slight added complication the targets may be a comma separated list. We need to process each in turn.

Note if there are no commas then the split simply returns the whole item.

=cut
         # first we expand any array
         # warn "Looking at field " . $test->[1];
         if(!defined $obj->{$test->[1]}) {
	     # warn "No " . $test->[1] . " field in object";
             next;
         }
         # deref first - we may have got this from a use inherritance
         my ($exp,$expref) = deref($obj->{$test->[1]},undef);
         next unless defined $exp; # a tag with no value in the config?
         my (@expanded) = (ref($exp) =~ /^ARRAY/ ? @{$exp} : ($exp));
         for my $t (@expanded) {
             # warn $test->[0], " t=$t $exp from source $expref" if defined $expref;
             # special case for check_command
             if($test->[1] eq 'check_command') {
                 # warn "Splitting $exp";
                 $exp = (split(/!/,$exp))[0];
             }
             # warn "$t undefined \$test->[2]" unless defined $test->[2];
             my $typedtarget = $test->[2] . ':' . $t; # the type of the used thing
             my $typedref = $test->[0] . ':' . $test->[1];  # the user:field
             # warn "target = $typedtarget" if $typedtarget =~ /^host:/;
             # Is an object identified by typedtarget one of those we want?
             if(defined $objstokeep{$typedtarget}) {
	         $refs{$typedref} = [] unless defined $refs{$typedref};
	         $refs{'INVERSE:' . $typedref} = [] unless defined $refs{'INVERSE:' . $typedref};
                 # we save the four things the id, the thing is is related to and where to find more info, lastly is this inherrited by use?
                 # If we were a csv list the is inherrited flag is applicable to each member
                 # most often the split on comma will just return the single value
                 push @{$refs{$typedref}}, [$id,$typedtarget,$ob,$expref]; 
                 # EXPERIMENTAL - also store the inverse if A is related to be then it follows that B is related to A
                 push @{$refs{'INVERSE:' . $typedref}}, [$typedtarget,$id,$ob,$expref]; 

             }
         }
    }
}

# We now print out the things which are related to the objects we are after

print Data::Dumper->Dump([\%refs],['refs']) if $dumpworkings;

=pod

The data we now have is the %objstokeep hash, but we only really need to use the indexes unless want to go fetch extra fields.

the %refs hash consists of the id of the thing doing the referring, the id of the target, and a object for the thing doing the referring - again
in case we want to go pull out anything else from the original object.


Now we can start having fun drawing the graphs.

It is expected that this is where the program will change most in future as better ways of representing the data are found.

The options hash is the style options for the different object relationship lines.

Initially we are just using colour but this could also be thickness, dash patterns, labels or whatever.

=cut

my %options = (
    'service:use' => 'color=green ',
    'host:use' => 'color=purple ',
    'host:host_group' => 'color=black ',
    'hostgroup:members' => 'color=blue ',
    'host:contact_groups' => 'color=black ',
    'contactgroup:members' => 'color=blue ',
    'hostgroup:hostgroup_members' => 'color=cyan ',
    'service:host_name' => 'color=pink ',
    'service:hostgroup_name' => 'color=purple ',
    'service:servicegroup_name' => 'color=yellow ',
    'service:check_command' => 'color=blue ',
    'service:command' => 'color=gold ',
    'servicegroup:members' => 'color=red ' ,
    'INVERSE:service:use' => 'color=green, style=dotted ',
    'INVERSE:host:use' => 'color=purple, style=dotted ',
    'INVERSE:host:host_group' => 'color=black, style=dotted ',
    'INVERSE:hostgroup:members' => 'color=blue, style=dotted ',
    'INVERSE:host:contact_groups' => 'color=black, style=dotted ',
    'INVERSE:contactgroup:members' => 'color=blue, style=dotted ',
    'INVERSE:hostgroup:hostgroup_members' => 'color=cyan, style=dotted ',
    'INVERSE:service:host_name' => 'color=pink, style=dotted ',
    'INVERSE:service:hostgroup_name' => 'color=purple, style=dotted ',
    'INVERSE:service:servicegroup_name' => 'color=yellow, style=dotted ',
    'INVERSE:service:check_command' => 'color=blue, style=dotted ',
    'INVERSE:service:command' => 'color=gold, style=dotted ',
    'INVERSE:servicegroup:members' => 'color=red, style=dotted ' ,
);

# and make as black dashed lines any we have not explicity defined above

=pod

Now we graph, change with care, lots of trial and error to get a reasonable look with so much data.

Much room for further improvement however.

We print out a program in the DOT language to pipline direct into dot or neato or one of the other options.

=cut

my $siz=1000;
print "digraph Nagios_Hostgroups {\n";
print "\tsize=\"$siz,$siz\"; scale=BOTH; overlap=false; compound=true; rankdir=LR; ranksep=2; packMode=\"array_c4\"\n";
print "\tnode [shape=none]\n" if $detailed;

print "\tsubgraph cluster_Graph_legend { startType=random label=\"Graph Legend\" labelloc=\"b\" shape=box bgcolor=white ; \"" . join('"; "', grep {$_ !~ /^INVERSE:/ } sort keys %options) . "\";}\n";
print "\tsubgraph cluster_Graph_invlegend { startType=random label=\"Graph Legend (Inverse)\" labelloc=\"b\" shape=box bgcolor=white ; \"" . join('"; "', grep {/^INVERSE:/} sort keys %options) . "\";}\n";
print "\t\"$_\" [ shape=box, $options{$_} ];\n" for sort keys %options;
print "\n";
# and we make it look better by drawing the relations between the legends

for my $inv (grep {/^INVERSE:/} sort keys %options) {
    my $norm = $inv;
    $norm =~ s/^INVERSE://;
    
    my $label = join('->',$norm,$inv);
    my $extra = "";
    $extra = "style=dotted," if $norm =~ /:use$/; # we have a use inherritance
    print "\t \"$norm\" -> \"$inv\" [ $options{$norm}, $extra label=\"$label\" ];\n";
    $label = join('->',$inv,$norm);
    print "\t \"$inv\" -> \"$norm\" [ $options{$inv}, $extra label=\"$label\" ];\n";
}

=pod

Fancy format setup here:
We do a subgraph with a different background colour for the things we matched
and one for each type or relation amongst the dependancies - this keeps things things neatly
separated on the page.

Now we want to spit the object to keep so that all objects of the same type are in the same rank - will make clearer.

=cut 

my %bytype = ();
for(keys %objstokeep) {
    my($type,$label) = split(/:/,$_,2);
    $bytype{$type} = {} unless defined $bytype{$type};
    $bytype{$type}->{$_} = '';
}

print Data::Dumper->Dump([\%bytype],['bytype']) if $dumpworkings;

for my $bt (sort keys %bytype) {
    next if $bt =~ /^INVERSE/;
    my @filtered = sort keys %{$bytype{$bt}};
    print "\tsubgraph cluster_Matched_$bt { label=\"Selected $bt\" labelloc=\"b\" shape=box bgcolor=yellow; \"" . join('"; "',@filtered) . "\";}\n";
    for(@filtered) {
        if($detailed) {
            print "\t" . render_record($_, $objstokeep{$_}->[0], $config->{$objstokeep{$_}->[0]}) . "\n";
        }
        else {
            # Don't know why but showing Icons just does not seem to work, maybe need to upgrade graphvis software?
            if(defined $icons{$objstokeep{$_}->[0]}) {
                print "\t\"$_\" [ shape=box, color=cyan, image=\"$icons{$objstokeep{$_}->[0]}\", URL=" . new_url($_) . "];\n";
            }
            else {
                print "\t\"$_\" [ shape=box, color=black, URL=" . new_url($_) . "];\n";
            }
        }
    }
}


my %relations = ();
my %colour = ('hostgroup:members' =>'lightblue', 'service:check_command'=>'pink', 'service:host_name' =>'green');

for my $r (keys %refs) {
    $relations{$r} = {} unless defined $relations{$r};
    for my $tuple (@{$refs{$r}}) {
        $relations{$r}->{$tuple->[0]} = $tuple->[2]; # eliminate dups and get the object as need it later
    }
}
# note here -  eliminate any objects that we have already identified as matching our regular
# expresion as they cannot appear in more than one cluster.
print Data::Dumper->Dump([\%relations],[qw{relations}]) if $dumpworkings;

for my $r (sort keys %relations) {
    next if $r =~ /^INVERSE/;
    print "\tsubgraph \"cluster_$r\" { label=\"$r\" labelloc=\"t\" shape=box; bgcolor=" . ($colour{$r} || 'cyan') . "; \"";
    my @filtered = grep {not defined($objstokeep{$_}->[0])} keys %{$relations{$r}};
    print join('"; "', sort @filtered) . "\"};\n";
    # We want to be able to supply any special attributes for each object - in particular a new URL
    for(@filtered) {
        # warn "looking for $_ = " . $relations{$r}->{$_};
        if($detailed) {
            print "\t" . render_record($_, $relations{$r}->{$_}, $config->{$relations{$r}->{$_}}) . "\n";
        }
        elsif(defined $icons{$relations{$r}->{$_}}) {
            print "\t\"$_\" [ shape=box, color=pink, image=\"". $icons{$relations{$r}->{$_}} . "\", URL=" . new_url($_) . "];\n";
        }
        else {
           print "\t\"$_\" [ shape=box, color=black, URL=" . new_url($_) . "];\n";
        }
    }
}


# now the relations
for my $rtype (sort keys %refs) {
    print "# $rtype\n";
    # top level is the type of ref,
    # content is list of tuples id of this , it being referred, ref for more detail
    my @list = (@{$refs{$rtype}});
    my %seen = (); # so do not make exact dup relations
    for my $tuple (@list) {
        # warn "Need to define options for $rtype" unless defined $options{$rtype};
        $options{$rtype} = "color=black" unless defined $options{$rtype};
        my $label = join('->',$tuple->[0],$tuple->[1]);
        # warn "$label - join to self? " . $tuple->[2] if $tuple->[0] eq $tuple->[1];
        my $extra = "";
        $extra = "style=dotted " if defined $tuple->[3]; # we have a use inherritance
        # warn "$label $extra" if $extra ne '';
        print "\t \"", $tuple->[0], '" -> "', $tuple->[1] , "\" [ $options{$rtype} $extra label=\"$label\" ];\n" unless defined $seen{$label};
        $seen{$label} = ''; # so we do not print dups
    }
 
}

print "}\n";

=head1 render_record

do detailed level record rendering.
Done using html.

=cut

sub render_record {
    my($tag,$ob, $obj) = @_;
    my $rv = "\"$tag\" [label=<<table>";
    # $rv .= TR(td({-colspan=>2}, $ob)); # where to find THIS record
    # $rv .= TR(td({-colspan=>2}, hr())); 
    for(sort keys %{$obj}) {
        # fold up use relationships
        my $k = '';
        my $v = '';
        if(ref($obj->{$_}) =~ /HASH/) {
	    ($k, $v) = %{$obj->{$_}};
            $k = '*'; # just to show that this is inherrited from a use
        }
        else {
	    $k = '';
            $v = $obj->{$_};
        }
        if(ref($v) =~ /^ARRAY/) {
            $v = join(', ', @{$v});
        }
        $v =~ s/&/&amp;/g if defined $v;
        $v =~ s/"/&quot;/g if defined $v;
        # special treatment for icons
        if(/^(icon|vrml|statusmap)_image$/ && defined $icons{$ob}) {
            $rv .= TR(td({-bgcolor=>($k ne '' ? 'lightgray' : 'white')},[$_,qq{$icons{$ob} <IMG SCALE="TRUE" SRC="$icons{$ob}">}]));
        }
        else {
            $rv .= TR(td({-bgcolor=>($k ne '' ? 'lightgray' : 'white')},[$_,$v]));
        }
    }
    $rv .= "</table>> ];";
    return $rv;
}