#!/usr/bin/perl -w
use strict;
######################################################################
# This is best used like...
# ./parser.pl --nodmx --hook starry-lisp.pm captures/artemis-blah | perl
# It will collect all the object fields,
# and output them all on every heartbeat
######################################################################

BEGIN { require "parser.pl"; } # we are based on parser.pl EXCEPT...

# object types we care about, and what to call them:
my %want_obj = (
    0x01 => 'pcs',
    0x05 => 'npc', # note was 0x04 before v2.1.5
);
# fields we wanna keep:
my @want_field = qw( _id X Y Z );

my %obj; # will store all the details of all the objects "in-game"

# because we are about to legitimately redefine some functions...
no warnings qw(redefine);

# Override this so we do NOT attempt to output DEADBEEF binary from
# any of the "normal" parser.pl perl-to-binary functions we've NOT
# overridden:
sub SendPacket {}

# Override this so we keep strings in UTF8, NOT convert to Artemis UTF16:
sub UTF16 { return shift; }

# Override this so we can store the params passed to ObjNPC or whatever:
sub ObjGeneric {
    my ($type, $id, %params) = @_;
    return $id unless %params; # because objectDelete(ObjTorpedo(1960)) needs to work
    return unless $want_obj{$type};
    
    # if this is the first time we have seen it...
    my $this = $obj{$id} //= {
	_type => $type,
	_name => $want_obj{$type},
	_id   => $id,
    };
    # store other values we want:
    for (@want_field) {
	next unless defined $params{$_};
	$this->{$_} = $params{$_};
    }
}

sub objectDelete {
    my $id = shift;
    delete $obj{$id};
}

# Override this so we can OUTPUT all the objects we collected so far:
sub heartbeat {
    for my $type (sort keys %want_obj) {
	print "(update-", $want_obj{$type};
	for my $id (sort keys %obj) {
	    my $this = $obj{$id};
	    next unless $this->{_type} == $type;
	    print " (list";
	    for my $field(@want_field) {
		print " ", $this->{$field} // 0;
	    }
	    print ")";
	}
	print ")\n";
    }
    print "\n";
}

1; # valid perl modules need to return true