384 lines
9.1 KiB
Perl
384 lines
9.1 KiB
Perl
#!/usr/bin/perl
|
|
#
|
|
# (C) Copyright Markus Weber, 1994. All rights reserved.
|
|
# Permission is granted to use, copy, and modify for non-commercial use.
|
|
#
|
|
|
|
# usage: check-consistency.pl [options]...
|
|
# Options:
|
|
# archdb=pathname-of-archetype-database *** not used ***
|
|
# default ./ARCHDB .{dir,pag}
|
|
# archetypes=pathname-of-archetypes-file
|
|
# default $cfdir/share/crossfire/archetypes
|
|
# cfdir=pathname-to-crossfire-installation
|
|
# default /opt/cf0901 (hardcoded)
|
|
# mapdir=pathname-of-map-directory
|
|
# default $cfdir/share/crossfire/maps
|
|
# start-map=map-path-of-starting map
|
|
# default (init in archetypes)
|
|
|
|
# %% make it a command line option
|
|
$debug = 1;
|
|
|
|
#
|
|
# ARGUMENT PROCESSING
|
|
#
|
|
# preset options
|
|
$cfdir = "/export/home/crossfire/cf-installroot";
|
|
|
|
# loop thru arg vector
|
|
while (@ARGV) {
|
|
$_ = @ARGV[0];
|
|
if (/^archdb=/) {
|
|
($junk,$archdb) = split(/=/,$ARGV[0]);
|
|
shift;
|
|
}
|
|
elsif (/^archetypes=/) {
|
|
($junk,$archetypes) = split(/=/,$ARGV[0]);
|
|
shift;
|
|
}
|
|
elsif (/^cfdir=/) {
|
|
($junk,$cfdir) = split(/=/,$ARGV[0]);
|
|
shift;
|
|
}
|
|
elsif (/^mapdir=/) {
|
|
($junk,$mapdir) = split(/=/,$ARGV[0]);
|
|
shift;
|
|
}
|
|
elsif (/^start-map=/) {
|
|
($junk,$start_map) = split(/=/,$ARGV[0]);
|
|
shift;
|
|
}
|
|
else {
|
|
print "Unknown option $ARGV[0]\n";
|
|
exit;
|
|
}
|
|
}
|
|
|
|
# post-process
|
|
$mapdir = "$cfdir/share/crossfire/maps" unless defined($mapdir);
|
|
$archetypes = "$cfdir/share/crossfire/archetypes" unless defined($archetypes);
|
|
print STDERR "DBG: archetypes=$archetypes\n" if $debug > 5;
|
|
print STDERR "DBG: archdb=$archdb\n" if $debug > 5;
|
|
print STDERR "DBG: mapdir=$mapdir\n" if $debug > 5;
|
|
|
|
|
|
#
|
|
# INIT ARCHETYPES DATABASE
|
|
#
|
|
print STDERR "DBG: initializing archetype database...\n" if $debug;
|
|
&init_archetypes_database; # unless $skip_db_init;
|
|
print STDERR "DBG: ...done\n" if $debug;
|
|
|
|
defined($start_map) || die "FATAL: no starting map";
|
|
print STDERR "DBG: start_map=$start_map\n" if $debug;
|
|
|
|
|
|
print STDERR "DBG: scanning for archetypes of special interest...\n" if $debug;
|
|
|
|
while ( ($arch,$type) = each(%ARCHDB) ) {
|
|
|
|
next if !defined($type); # skip if not special
|
|
|
|
$_ = $type; # see below
|
|
|
|
if ($type == 41 || $type == 66 || $type == 94) {
|
|
# EXITS: archetypes with exits to other maps
|
|
$EXITS{$arch} = 1;
|
|
}
|
|
# Bad Programming Style Alert. Don't try this at home!
|
|
elsif (/^1[78]$/ || /^2[679]$/ || /^3[012]$/ || /^9[123]$/) {
|
|
# CONNECT: "connected" archetypes,
|
|
# e.g. buttons, handles, gates, ...
|
|
$CONNECT{$arch} = 1;
|
|
}
|
|
if ($type == 85) {
|
|
$SB{$arch} = 1;
|
|
}
|
|
|
|
}
|
|
|
|
print STDERR "DBG: ...done.\n" if $debug;
|
|
|
|
#
|
|
# MAIN LOOP
|
|
#
|
|
|
|
# pathname of start_map is assumed to be absolute (e.g. /village/village
|
|
push(@MAPS,$start_map);
|
|
|
|
while ($map = pop(@MAPS)) {
|
|
|
|
# print STDERR "array stack size is $#MAPS\n";
|
|
next if $visited{$map}; # skip if been here before
|
|
$visited{$map} = 1; # flag it if not
|
|
|
|
# skip random maps
|
|
next if ($map =~ m#/!#);
|
|
|
|
print STDERR "DBG: visiting $map\n" if $debug;
|
|
#print "visiting $map\n" if $debug;
|
|
|
|
#
|
|
# side effect: check_map pushes any (legal) exits found on stack
|
|
#
|
|
&check_map($map);
|
|
}
|
|
|
|
print "Unused archetypes:\n";
|
|
foreach $key (sort(keys %ARCHDB)) {
|
|
print "$key\n" if (!defined($USED{$key}))
|
|
}
|
|
|
|
|
|
|
|
exit;
|
|
|
|
#
|
|
# ++++++++++++++++++++ END OF MAIN ++++++++++++++++++
|
|
#
|
|
|
|
#
|
|
# INIT ARCHETYPES DATABASE
|
|
#
|
|
# store (archname,type) pairs
|
|
#
|
|
sub init_archetypes_database {
|
|
local($arch_lines,$arches); # counters
|
|
local($arch,$type,$slaying); # values
|
|
local($junk);
|
|
|
|
print STDERR "DBG: opening archetypes: $archetypes\n" if $debug > 5;
|
|
open(ARCHETYPES,$archetypes) || die "can't open $archetypes";
|
|
|
|
$arch_lines = 0;
|
|
$arches = 0;
|
|
$type = 0;
|
|
|
|
while ( <ARCHETYPES> ) {
|
|
$arch_lines++;
|
|
if (/^Object\s/) {
|
|
($junk,$arch) = split;
|
|
if (!defined($arch)) {
|
|
print STDERR "$archetypes: bad Object, line $arch_lines\n";
|
|
}
|
|
}
|
|
elsif (/^type\s/) {
|
|
($junk,$type) = split;
|
|
if (!defined($type)) {
|
|
print STDERR "$archetypes: bad type, line $arch_lines\n";
|
|
}
|
|
}
|
|
elsif (/^slaying\s/ && $arch eq "map") {
|
|
($junk,$slaying) = split;
|
|
# don't care if defined or not (yet)
|
|
}
|
|
elsif (/^end$/) {
|
|
print STDERR "DBG: entered arch=$arch, optional type=$type\n" if $debug > 10;
|
|
next if (!defined($arch));
|
|
# don't care whether $type defined or not
|
|
$ARCHDB{$arch} = $type;
|
|
$arches++;
|
|
$type = 0;
|
|
}
|
|
elsif (/^end\s*$/) {
|
|
print STDERR "DBG: arch $arch is using end with space before newline\n";
|
|
next if (!defined($arch));
|
|
# don't care whether $type defined or not
|
|
$ARCHDB{$arch} = $type;
|
|
$arches++;
|
|
$type = 0;
|
|
}
|
|
}
|
|
|
|
#
|
|
# find start map
|
|
# print error message iff "map" arch not found or missing path
|
|
# assign start map (unless pre-defined on cmd line)
|
|
#
|
|
if (!defined($slaying)) {
|
|
print STDERR "***ERROR*** no map object or map path missing\n";
|
|
}
|
|
elsif (!defined($start_map)) {
|
|
$start_map = $slaying;
|
|
}
|
|
#print STDERR "DBG: start_map=$start_map\n";
|
|
|
|
close(ARCHETYPES);
|
|
print STDERR "DBG: closed $archetypes, $arch_lines lines, $arches arches\n"
|
|
if $debug > 5;
|
|
}
|
|
|
|
#
|
|
# CHECK MAP FOR ELEMENTARY CONSISTENCY
|
|
#
|
|
|
|
sub check_map {
|
|
local($map) = @_;
|
|
local($arch,$connected,$slaying,$exit,$x,$y, $rx, $ry);
|
|
local($lines,$fullmap);
|
|
local($junk);
|
|
$depth=0;
|
|
|
|
# build full pathname (nb: map path starts with /) and open map file
|
|
$fullmap = "$mapdir$map";
|
|
open(MAP,$fullmap) || die "can't open $fullmap";
|
|
print STDERR "DBG: opened $map\n" if $debug > 5;
|
|
|
|
$lines = 0;
|
|
|
|
while ( <MAP> ) {
|
|
if (/^tile_path_/) {
|
|
($junk,$slaying) = split;
|
|
$_ = "$map $slaying"; # easy matching :-)
|
|
s@^(/.*/)([^/]*)\s([^\./].*)$@\1\2 \1\3@;
|
|
s@^(/.*/)([^/]*)\s(\.\./.*)$@\1\2 \1\3@;
|
|
s@/[^/]*/\.\./@/@g;
|
|
($junk,$exit) = split;
|
|
next if $visited{$exit};
|
|
|
|
if ( (! -r "$mapdir$exit") && ( $exit ne "/!") ) {
|
|
print "ERROR: map $map, arch $arch, line $lines, no such exit $exit ($rx, $ry, to $x, $y)\n";
|
|
next;
|
|
}
|
|
push(@MAPS,$exit);
|
|
}
|
|
|
|
|
|
$lines++;
|
|
if (/^arch\s/) {
|
|
# Note we have to do some checks here - that is because
|
|
# if an object is inside an object, the value of $arch
|
|
# is clobbered.
|
|
($junk,$arch) = split;
|
|
# if ($SB{$arch}) {
|
|
# print "WARNING: spellbook found at map $map, line $lines, arch $arch\n";
|
|
# }
|
|
if (!defined($ARCHDB{$arch})) {
|
|
print "FATAL: map $map, line $lines, bad archetype: $arch ($rx, $ry)\n";
|
|
}
|
|
$USED{$arch}=1;
|
|
undef($slaying);
|
|
undef($x);
|
|
undef($y);
|
|
undef($rx);
|
|
undef($ry);
|
|
undef($connected);
|
|
$depth++;
|
|
}
|
|
elsif (/^connected\s/) {
|
|
($junk,$connected) = split;
|
|
}
|
|
elsif (/^slaying\s/) {
|
|
($junk,$slaying) = split;
|
|
}
|
|
elsif (/^hp\s/) {
|
|
($junk,$x) = split;
|
|
}
|
|
elsif (/^sp\s/) {
|
|
($junk,$y) = split;
|
|
}
|
|
elsif (/^x\s/) {
|
|
($junk, $rx) = split;
|
|
}
|
|
elsif (/^y\s/) {
|
|
($junk, $ry) = split;
|
|
}
|
|
elsif (/^anim$/) {
|
|
print "Map $fullmap has an anim command in it\n";
|
|
}
|
|
|
|
next if !/^end$/; # continue iff not end of arch
|
|
$depth--;
|
|
|
|
#
|
|
# CHECK 2: connect-arch actually connected?
|
|
# NB: if not, that's perfectly legal, but suspicious
|
|
#
|
|
# if ($CONNECT{$arch}) {
|
|
# if (!$connected) {
|
|
#print STDERR "WARNING: map $map, line $lines, arch $arch, not connected\n";
|
|
#print "WARNING: map $map, line $lines, arch $arch, not connected\n";
|
|
# }
|
|
# next;
|
|
# }
|
|
|
|
next if !$EXITS{$arch}; # continue if not an exit
|
|
|
|
|
|
#
|
|
# CHECK 3: exit-type arch, but no path given
|
|
# Presumably the path defaults to the local map,
|
|
# but in all probability this is an error
|
|
#
|
|
if (!defined($slaying)) {
|
|
if ($x || $y) {
|
|
#print STDERR "ERROR: map $map, line $lines, arch $arch, exit defaults\n";
|
|
#print "ERROR: map $map, line $lines, arch $arch, exit defaults\n";
|
|
}
|
|
else {
|
|
#print STDERR "INFO: map $map, line $lines, arch $arch, no exit defined\n";
|
|
#print "INFO: map $map, line $lines, arch $arch, no exit defined\n";
|
|
}
|
|
next;
|
|
}
|
|
|
|
#
|
|
# CHECK 4: verify that exit map exists
|
|
# if not, the game (hopefully!) won't crash, but
|
|
# chances are this _is_ an error
|
|
#
|
|
|
|
#
|
|
# normalize exit path (FullyQualifiedPathName :-)))
|
|
# (i.e. construct absolute pathname, rooted in CLibDir/maps)
|
|
# E.g.:
|
|
# current map: /village/somewhere
|
|
# EXIT PATH YIELDS
|
|
# /village/building /village/building
|
|
# townhouse /village/townhouse
|
|
# ../island /island
|
|
#
|
|
$_ = "$map $slaying"; # easy matching :-)
|
|
# /path/map exit --> /path/map /path/exit
|
|
s@^(/.*/)([^/]*)\s([^\./].*)$@\1\2 \1\3@;
|
|
# /path/map ../exit --> /path/map /path/../exit
|
|
s@^(/.*/)([^/]*)\s(\.\./.*)$@\1\2 \1\3@;
|
|
# /dir/../ --> / (all occurances)
|
|
s@/[^/]*/\.\./@/@g;
|
|
|
|
($junk,$exit) = split;
|
|
#print STDERR "DBG: exit $map $exit\n" if $debug > 5;
|
|
#print "exit $map $exit\n";
|
|
|
|
#
|
|
# shortcut: if the exit map was already checked, don't bother
|
|
# stacking it again.
|
|
# %% if a map is never pushed twice in the first place,
|
|
# the corresponding test in the main loop is probably
|
|
# in vain.
|
|
#
|
|
next if $visited{$exit};
|
|
|
|
#
|
|
# this is check 4, finally.
|
|
# if exit map can't be opened, complain and continue
|
|
#
|
|
if ( (! -r "$mapdir$exit") && ( $exit ne "/!") ) {
|
|
#print STDERR "ERROR: map $map, arch $arch, line $lines, no such exit $exit\n";
|
|
print "ERROR: map $map, arch $arch, line $lines, no such exit $exit ($rx, $ry, to $x, $y)\n";
|
|
next;
|
|
}
|
|
|
|
#
|
|
# the exit map looks good; push it and continue
|
|
push(@MAPS,$exit);
|
|
}
|
|
|
|
close(MAP);
|
|
if ($depth != 0) {
|
|
print "ERROR: map $map, mismatched arch/end, $depth\n";
|
|
}
|
|
}
|
|
|