Map tester

[Tero Haatanen <Tero.Haatanen@lut.fi>]

This is a small perl-script which I made checking my maps after
they were converted from one format to another :). I find it so
useful, so I post it to this mailing-list. It wanderers through 
maps in given directories (in maps dir only), so dot (.) means all 
maps in maps dir. It print general mapinfo and problems what it founds.
Some checks doesn't seem to be problems any more (like player archetypes 
in maps). It's not very 'polished', so feel free edit your needs.

BTW: It also generates list used objects, and according that floors
are most common objects, so not trying animate them should certainly
speed up the server.

Following could be added to mapguide (any opinions, Mark?). 
Give all maps some meaningful name instead of default (map),
so that name can be used in every place where mapname is needed
(highscore, etc).  Players don't need to see those paths, since
they are just implementetion details :). And note mapinfo command
in game, which gives additional info about map.

  -Tero

PS. In first look (just installed) those 'chico' maps seems to be very good. 
Congratulations all authors!

---8<------8<------8<------8<------8<------8<------8<------8<------8<---
#!/usr/local/bin/perl
#
# This program is meant to use check crossfire (version 0.90.?) maps.
# Program wanderers through mapfiles and reports all objects that 
# can't be found in the archetypes, all exit that doesn't lead to
# anywhere and all corrupted mapfiles.
#
# Usage: wanderer.pl directory

$LIB   = "/net/contrib/crossfire/lib";
$ARCH  = "$LIB/archetypes";
$MAPS  = "$LIB/maps";

if (! $ARGV[0]) {
    print "Usage: wanderer.pl map-directory ... > output.log\n";
    exit;
}

# read filenames to @maps
chdir ($MAPS);
while ($area = shift) {
    &maplist ($area);
}

$* = 1;				# use multiline matches

# read archetypes
&archetypes;
%ex = &collect ("^type 66$");		# type 66 == exit
%tele = &collect ("^type 41$");		# type 41 == teleport
%conn = &collect ("^type (17|18|26|27|29|30|31|32|91|92|93|94)$");
delete $conn{"spikes_moving"};
%players = &collect ("^type 1$");	# type 1 == player

# check exits from archetypes
foreach $a (keys (%ex), keys (%tele)) {
    if ($arches {$a} =~ /^food -?\d+$/) {
	print "Warning: Archetype $a has food field.\n";
    }
}

# some general info
print "=" x 70, "\n";
print "Number of mapfiles = " , @maps + 0, "\n";
print "Number of archetypes = " , values(%arches)+0, ":\n";
print " - Exits ("            , values(%ex)+0,      ")\n";
print " - Teleports ("        , values(%tele)+0,    ")\n";
print " - Connected objects (", values(%conn)+0,    ")\n";
print " - Players ("          , values(%players)+0, ")\n";
print "=" x 70, "\n";

# check maps
while ($file = shift (@maps)) {
    &readmap;
}

# summary of missing archetypes 
if (%missing) {
    print "=" x 70, "\n";
    print "Missing archetypes: ", join (", ", sort keys (%missing)), "\n";
}
# if you don't want list of used objects, uncomment next line
# and you can comment also last line check_obj
# (This isn't very useful, but maybe tells something)

# exit;

print "=" x 70, "\nArchetype               count\n";
$total = 0;
foreach $a (sort by (keys (%objects))) {
    printf ("%-24s%d\n", $a, $objects{$a});
    $total +=  $objects{$a};
}
print '-' x 30, "\nTotal objects           $total\n";
exit;

# return table containing all objects in the map
sub readmap {
    local ($m);
    $last = "";

    $/ = "\nend\n";
    if (! open (IN, $file)) {
	print "Can't open map file $file\n";
	return;
    }
    $_ = <IN>;
    if (! /^arch map$/) {
	print "Error: file $file isn't mapfile.\n";
	return;
    }
    print "Testing $file, ";
    print /^name (.+)$/ ? $1 : "No mapname";
    print ", size [", /^x (\d+)$/ ? $1 : 16;
    print ",", /^y (\d+)/ ? $1 : 16, "]";

    if (! /^msg$/) {
	print ", No message\n";
    } elsif (/(\w+@\S+)/) {
	print ", $1\n";
    } else {
	print ", Unknown\n";
    }

    while (<IN>) {
	if (($m = (@_ = /^arch \S+$/g)) > 1) {
	    # object has inventory
	    local ($inv) = $_;
	    while (<IN>) {
		if (/((.|\n)*end\n)(arch (.|\n)*\nend\n)/) {
		    &check_obj ("$inv$1");
		    &check_obj ($3);
		    last;
		} elsif (/^arch (.|\n)*\nend$/) {
		    &check_obj ($_);
		} elsif (/^end$/) {
		    &check_obj ("$inv$_");
		} else {
		    print "  Error: Corrupted map file $file.\nSegment:\n$_";
		}
	    } 
	} elsif (/^More$/ || $m == 1) {
	    &check_obj ($_);
	} else {
	    print "  Error: Corrupted map file $file.\nSegment:\n$_"; 
	}
    }
    close (IN);
}

sub check_obj {
    $_ = shift @_;
    /^arch (\S+)$/;
    if (! $arches{$1} && $last ne $1) {
	$last = $1;
	print "  Error: Object $last is not defined in archetypes file.\n"; 
	$missing{$last}++;
    } elsif ($ex{$1}) {
	&examine_exit ($_);
    } elsif ($tele{$1} && /^food -?\d+$/) {
	print "  Error: Teleport $1 has food field.\n";
    } elsif ($conn{$1} && ! /^connected -?\d+$/ && $last ne $1) {
	$last = $1;
	print "  Warning: Object $last has not been connected.\n";
    } elsif ($players{$1} && $last ne $1) {
	$last = $1;
	print "  Error: Player $last found in the map.\n";
    } elsif ($1 eq "scroll" && ! /^msg$/ && $last ne $1) {
	$last = $1;
	print "  Warning: scroll without message, should be random_scroll?\n";
    } elsif ($1 eq "potion" && $last ne $1) {
	$last = $1;
	print "  Warning: potion found, should be random_potion or random_food?\n";
    }
#    $objects{$1}++;
}

sub by {
     $_ = $objects{$b} <=> $objects{$a};
     $_ ? $_ : $a cmp $b;
}

sub obj_name {
    $_  = shift(@_);
    local ($name) =  /^name (.+)$/;			# object's name
    local ($arch) =  /^arch (\S+)$/;
    if (!defined ($name) && $arches{$arch} =~ /^name (.+)$/) {
	$name = $1;					# archetype's name
    }
    return defined ($name) ? $name : $arch;		# archetype or name
}

sub examine_exit {
    $_  = shift(@_);
    local ($x) = $1+0, /^hp (\d+)$/;
    local ($y) = $1+0, /^sp (\d+)$/;
    local ($x1) = $1+0, /^x (\d+)$/;
    local ($y1) = $1+0, /^y (\d+)$/;
    local ($to) = /^slaying (\S+)$/;

    if (/^food (-?\d+)$/) {
	# old style exits, doesn't work with crossfire 0.90-1
	print "  Error: ", &obj_name($_), " ($x1,$y1) -> ", 
	      "Old style level [$1] ($x,$y)\n";
    } elsif (! defined ($to)) {
	print "  Closed: ", &obj_name($_), " ($x1,$y1)\n";
    } else {
	# These are currently used be crossfire
	if ($to =~ m!^/!) {
	    $cdir = "$MAPS";
	} else {
	    ($cdir) = $file =~ m!(.*/)!;
	}
	if (! -f "$cdir$to") {
	    print "  Missing: ", &obj_name($_), " ($x1,$y1) -> $to ($x,$y)\n";
	} else {
#	    print "  OK: ", &obj_name($_), " ($x1,$y1) -> $to ($x,$y)\n";
	}
    }
}

# @maps contains all filenames
sub maplist {
    local ($dir, $file, @dirs) = shift;

    opendir (DIR , $dir) || die "Can't open directory : $dir\n";
    while ($file = readdir (DIR)) {
	next if ($file eq "." || $file eq "..");
	$file = "$dir/$file";
	push (@dirs, $file) if (-d $file);
	push (@maps, $file) if (-f $file);
    }
    closedir (DIR);

    # recurcive handle sub-dirs too
    while ($_ = shift @dirs) {
	&maplist ($_);
    }
}

# collect all objects matching with reg.expr.
sub collect {
    local ($expr,$a, %col) = shift;

    foreach $a (keys %arches) {
	$_ = $arches{$a};
	if (/$expr/) {
	    $col{$a}++;
	}
    }
    return %col;
}

# collect all archetypes into associative array %arches
sub archetypes {
    open (IN, $ARCH) || die "Can't open achetype file $ARCH.\n";
    $/ = "\nend\n";
    while (<IN>) {
	if (/^Object (\S+)$/) {
	    $arches{$1} = $_;
	}
    }
    close (IN);
}
---8<------8<------8<------8<------8<------8<------8<------8<------8<---