369 lines
9.5 KiB
Perl
369 lines
9.5 KiB
Perl
#!/usr/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.
|
|
#
|
|
# By: Tero Haatanen <Tero.Haatanen@lut.fi>
|
|
#
|
|
# Usage: wanderer.pl directory
|
|
|
|
# Set if you want to get warnings about spikes, gates, buttons, et al that
|
|
# are not connected. This can be annoying at times, since many maps use
|
|
# these objects for decorations.
|
|
$CONNECTED = 0;
|
|
$LIB = "/export/home/crossfire/cf-installroot/share/crossfire";
|
|
$ARCH = "$LIB/archetypes";
|
|
$BMAPS = "$LIB/bmaps";
|
|
$ANIM = "$LIB/animations";
|
|
$MAPS = "$LIB/maps";
|
|
# Set VERBOSE=1 if you want more output
|
|
$VERBOSE=0;
|
|
$SHOW_UNUSED = 0;
|
|
|
|
if (! $ARGV[0]) {
|
|
print "Using $MAPS are starting map directory.\n";
|
|
$STARTING = $MAPS;
|
|
} else {
|
|
$STARTING = $ARGV[0];
|
|
}
|
|
|
|
|
|
# read filenames to @maps
|
|
chdir ($STARTING);
|
|
while ($area = shift) {
|
|
&maplist ($area);
|
|
}
|
|
|
|
$* = 1; # use multiline matches
|
|
|
|
&faces;
|
|
&animations;
|
|
# 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"};
|
|
delete $conn{"magic_ear"};
|
|
%players = &collect ('^type 1$'); # type 1 == player
|
|
#
|
|
# In theory, I don't think any of these should show up in maps.
|
|
# For now, I mostly ignore them so I can more easily check out the
|
|
# editor directory and verify everything is in place.
|
|
%abilities = &collect('^type (2|10|11|12|19|25|43|44|49|50|52|88|97|110|114|121|141|151)$');
|
|
|
|
# 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_usage();
|
|
|
|
if ($SHOW_UNUSED) {
|
|
print " Unused object\n";
|
|
foreach $a (sort(keys %arches)) {
|
|
print "$a\n" if (!$objects{$a} && !$players{$a} && !$abilities{$a})
|
|
}
|
|
}
|
|
|
|
exit;
|
|
|
|
sub print_usage() {
|
|
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";
|
|
}
|
|
# return table containing all objects in the map
|
|
sub readmap {
|
|
my ($m);
|
|
my($last);
|
|
my($parent);
|
|
$last = "";
|
|
$parent = "";
|
|
|
|
$/ = "\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;
|
|
}
|
|
if ($VERBOSE) {
|
|
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";
|
|
}
|
|
$printmap=0;
|
|
}
|
|
else {
|
|
$name= /^name (.+)$/ ? $1 : "No mapname";
|
|
$x= /^x (\d+)$/ ? $1 : 16;
|
|
$y= /^y (\d+)/ ? $1 : 16;
|
|
$mapname="Map $file, $name, size [$x, $y]\n" ;
|
|
$printmap=1;
|
|
}
|
|
|
|
|
|
while (<IN>) {
|
|
if (($m = (@_ = /^arch \S+\s*$/g)) > 1) {
|
|
$parent = /^arch (\S+)\s*$/;
|
|
# object has inventory
|
|
my ($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 {
|
|
# if ($printmap) { print "$mapname"; $printmap=0;}
|
|
# This doesn't work right - it gets confused when objects are within
|
|
# another object
|
|
# print " Error: Corrupted map file $file.\nSegment:\n$_\nLine: $.\n";
|
|
}
|
|
}
|
|
$parent="";
|
|
} elsif (/^More$/ || $m == 1) {
|
|
&check_obj ($_);
|
|
} else {
|
|
# if ($printmap) { print "$mapname"; $printmap=0;}
|
|
# print " Error: Corrupted map file $file.\nSegment:\n$_\nLine: $.\n";
|
|
}
|
|
}
|
|
close (IN);
|
|
}
|
|
|
|
sub check_obj {
|
|
$_ = shift @_;
|
|
|
|
local ($x) = (/^x (\d+)$/)?$1:0;
|
|
local ($y) = (/^y (\d+)$/)?$1:0;
|
|
local($arch) = /^arch (\S+)\s*$/;
|
|
|
|
if (! $arches{$1} && $last ne $1) {
|
|
$last = $1;
|
|
if ($printmap) { print "$mapname"; $printmap=0;}
|
|
print " Error: Object $last is not defined in archetypes file ($x,$y), arch=$arch\n";
|
|
$missing{$last}++;
|
|
} elsif ($ex{$1}) {
|
|
&examine_exit ($_);
|
|
} elsif ($tele{$1}) {
|
|
if (/^food -?\d+$/) {
|
|
if ($printmap) { print "$mapname"; $printmap=0;}
|
|
print " Error: Teleport $1 has food field.\n";
|
|
}
|
|
else {
|
|
&examine_exit ($_);
|
|
}
|
|
} elsif ($conn{$1} && ! /^connected -?\d+$/) {
|
|
$last = $1;
|
|
if ($CONNECTED) {
|
|
if ($printmap) { print "$mapname"; $printmap=0;}
|
|
print " Warning: Object $last has not been connected, $x,$y\n"
|
|
}
|
|
} elsif ($players{$1} && $last ne $1 && ! /^type / ) {
|
|
$last = $1;
|
|
if ($printmap) { print "$mapname"; $printmap=0;}
|
|
print " Error: Player $last found in the map.\n";
|
|
} elsif ($1 eq "scroll" && ! /^msg$/) {
|
|
$last = $1;
|
|
# print " Warning: scroll without message ($x, $y:$parent), 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";
|
|
} elsif ($1 eq "ring" || $1 eq "amulet") {
|
|
$last = $1;
|
|
# print " Warning: ring/amulet found ($x,$y:$parent), should be random_talisman?\n";
|
|
}
|
|
$objects{$1}++;
|
|
if (/^animation (\S+)$/) {
|
|
if (! $anim{$1}) {
|
|
if ($printmap) { print "$mapname"; $printmap=0;}
|
|
print "Error: Object $arch is using an unknown animation $1\n"
|
|
}
|
|
}
|
|
if (/^face (\S+)$/) {
|
|
if (! $faces{$1}) {
|
|
if ($printmap) { print "$mapname"; $printmap=0;}
|
|
print "Error: Object $arch is using an unknown face $1\n"
|
|
}
|
|
}
|
|
}
|
|
|
|
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) = (/^hp (\d+)$/)?$1:0;
|
|
local ($y) = (/^sp (\d+)$/)?$1:0;
|
|
local ($x1) = (/^x (\d+)$/)?$1:0;
|
|
local ($y1) = (/^y (\d+)$/)?$1:0;
|
|
local ($to) = /^slaying (\S+)$/;
|
|
|
|
if (/^food (-?\d+)$/) {
|
|
# old style exits, doesn't work with crossfire 0.90-1
|
|
if ($printmap) { print "$mapname"; $printmap=0;}
|
|
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 eq "/!") { # this is a random exit - if we
|
|
# have a final map, make sure it
|
|
# exists
|
|
local ($finalmap) = /^final_map (\S+)$/;
|
|
if ($finalmap ne "") {
|
|
if ($finalmap =~ m!^/!) { $cdir = "$MAPS"; }
|
|
else { ($cdir) = $file =~ m!(.*/)!; }
|
|
if (! -f "$cdir$finalmap") {
|
|
if ($printmap) { print "$mapname"; $printmap=0;}
|
|
print " Missing: ", &obj_name($_), " ($x1,$y1) -> $finalmap ($x,$y)\n";
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
if ($to =~ m!^/!) {
|
|
$cdir = "$MAPS";
|
|
} else {
|
|
($cdir) = $file =~ m!(.*/)!;
|
|
}
|
|
if (! -f "$cdir$to") {
|
|
if ($printmap) { print "$mapname"; $printmap=0;}
|
|
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 eq ".svn" || $file eq "unlinked" || $file eq "editor");
|
|
$file = "$dir/$file";
|
|
next if (-l $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 archetype file $ARCH.\n";
|
|
$/ = "\nend\n";
|
|
while (<IN>) {
|
|
while (/^Object (\S+)\s*$/g) {
|
|
$arches{$1} = $_;
|
|
}
|
|
}
|
|
close (IN);
|
|
}
|
|
|
|
sub faces {
|
|
open(IN, $BMAPS) || die ("Can't open faces file $BMAPS\n");
|
|
while (<IN>) {
|
|
chomp;
|
|
($num, $name) = split;
|
|
$faces{$name} = $name;
|
|
}
|
|
close(IN);
|
|
}
|
|
|
|
|
|
sub animations {
|
|
open(IN, $ANIM) || die ("Can't open animations file $ANIM\n");
|
|
while (<IN>) {
|
|
if (/^anim (\S+)\s*$/) {
|
|
$anim{$1} = $1;
|
|
}
|
|
}
|
|
close(IN);
|
|
}
|