1 |
root |
1.1 |
#!/usr/bin/perl |
2 |
|
|
# |
3 |
|
|
# This program is meant to use check crossfire (version 0.90.?) maps. |
4 |
|
|
# Program wanderers through mapfiles and reports all objects that |
5 |
|
|
# can't be found in the archetypes, all exit that doesn't lead to |
6 |
|
|
# anywhere and all corrupted mapfiles. |
7 |
|
|
# |
8 |
|
|
# By: Tero Haatanen <Tero.Haatanen@lut.fi> |
9 |
|
|
# |
10 |
|
|
# Usage: wanderer.pl directory |
11 |
|
|
|
12 |
|
|
# Set if you want to get warnings about spikes, gates, buttons, et al that |
13 |
|
|
# are not connected. This can be annoying at times, since many maps use |
14 |
|
|
# these objects for decorations. |
15 |
|
|
$CONNECTED = 0; |
16 |
|
|
$LIB = "/export/home/crossfire/cf-installroot/share/crossfire"; |
17 |
|
|
$ARCH = "$LIB/archetypes"; |
18 |
|
|
$BMAPS = "$LIB/bmaps"; |
19 |
|
|
$ANIM = "$LIB/animations"; |
20 |
|
|
$MAPS = "$LIB/maps"; |
21 |
|
|
# Set VERBOSE=1 if you want more output |
22 |
|
|
$VERBOSE=0; |
23 |
|
|
$SHOW_UNUSED = 0; |
24 |
|
|
|
25 |
|
|
if (! $ARGV[0]) { |
26 |
|
|
print "Using $MAPS are starting map directory.\n"; |
27 |
|
|
$STARTING = $MAPS; |
28 |
|
|
} else { |
29 |
|
|
$STARTING = $ARGV[0]; |
30 |
|
|
} |
31 |
|
|
|
32 |
|
|
|
33 |
|
|
# read filenames to @maps |
34 |
|
|
chdir ($STARTING); |
35 |
|
|
while ($area = shift) { |
36 |
|
|
&maplist ($area); |
37 |
|
|
} |
38 |
|
|
|
39 |
|
|
$* = 1; # use multiline matches |
40 |
|
|
|
41 |
|
|
&faces; |
42 |
|
|
&animations; |
43 |
|
|
# read archetypes |
44 |
|
|
&archetypes; |
45 |
|
|
|
46 |
|
|
|
47 |
|
|
%ex = &collect ('^type 66$'); # type 66 == exit |
48 |
|
|
%tele = &collect ('^type 41$'); # type 41 == teleport |
49 |
|
|
%conn = &collect ('^type (17|18|26|27|29|30|31|32|91|92|93|94)$'); |
50 |
|
|
delete $conn{"spikes_moving"}; |
51 |
|
|
delete $conn{"magic_ear"}; |
52 |
|
|
%players = &collect ('^type 1$'); # type 1 == player |
53 |
|
|
# |
54 |
|
|
# In theory, I don't think any of these should show up in maps. |
55 |
|
|
# For now, I mostly ignore them so I can more easily check out the |
56 |
|
|
# editor directory and verify everything is in place. |
57 |
|
|
%abilities = &collect('^type (2|10|11|12|19|25|43|44|49|50|52|88|97|110|114|121|141|151)$'); |
58 |
|
|
|
59 |
|
|
# check exits from archetypes |
60 |
|
|
foreach $a (keys (%ex), keys (%tele)) { |
61 |
|
|
if ($arches {$a} =~ /^food -?\d+$/) { |
62 |
|
|
print "Warning: Archetype $a has food field.\n"; |
63 |
|
|
} |
64 |
|
|
} |
65 |
|
|
|
66 |
|
|
# some general info |
67 |
|
|
print "=" x 70, "\n"; |
68 |
|
|
print "Number of mapfiles = " , @maps + 0, "\n"; |
69 |
|
|
print "Number of archetypes = " , values(%arches)+0, ":\n"; |
70 |
|
|
print " - Exits (" , values(%ex)+0, ")\n"; |
71 |
|
|
print " - Teleports (" , values(%tele)+0, ")\n"; |
72 |
|
|
print " - Connected objects (", values(%conn)+0, ")\n"; |
73 |
|
|
print " - Players (" , values(%players)+0, ")\n"; |
74 |
|
|
print "=" x 70, "\n"; |
75 |
|
|
|
76 |
|
|
# check maps |
77 |
|
|
while ($file = shift (@maps)) { |
78 |
|
|
&readmap; |
79 |
|
|
} |
80 |
|
|
|
81 |
|
|
# summary of missing archetypes |
82 |
|
|
if (%missing) { |
83 |
|
|
print "=" x 70, "\n"; |
84 |
|
|
print "Missing archetypes: ", join (", ", sort keys (%missing)), "\n"; |
85 |
|
|
} |
86 |
|
|
# if you don't want list of used objects, uncomment next line |
87 |
|
|
# and you can comment also last line check_obj |
88 |
|
|
# (This isn't very useful, but maybe tells something) |
89 |
|
|
|
90 |
|
|
#exit; |
91 |
|
|
|
92 |
|
|
#&print_usage(); |
93 |
|
|
|
94 |
|
|
if ($SHOW_UNUSED) { |
95 |
|
|
print " Unused object\n"; |
96 |
|
|
foreach $a (sort(keys %arches)) { |
97 |
|
|
print "$a\n" if (!$objects{$a} && !$players{$a} && !$abilities{$a}) |
98 |
|
|
} |
99 |
|
|
} |
100 |
|
|
|
101 |
|
|
exit; |
102 |
|
|
|
103 |
|
|
sub print_usage() { |
104 |
|
|
print "=" x 70, "\nArchetype count\n"; |
105 |
|
|
$total = 0; |
106 |
|
|
foreach $a (sort by (keys (%objects))) { |
107 |
|
|
printf ("%-24s%d\n", $a, $objects{$a}); |
108 |
|
|
$total += $objects{$a}; |
109 |
|
|
} |
110 |
|
|
print '-' x 30, "\nTotal objects $total\n"; |
111 |
|
|
} |
112 |
|
|
# return table containing all objects in the map |
113 |
|
|
sub readmap { |
114 |
|
|
my ($m); |
115 |
|
|
my($last); |
116 |
|
|
my($parent); |
117 |
|
|
$last = ""; |
118 |
|
|
$parent = ""; |
119 |
|
|
|
120 |
|
|
$/ = "\nend\n"; |
121 |
|
|
if (! open (IN, $file)) { |
122 |
|
|
print "Can't open map file $file\n"; |
123 |
|
|
return; |
124 |
|
|
} |
125 |
|
|
$_ = <IN>; |
126 |
|
|
if (! /^arch map$/) { |
127 |
|
|
# print "Error: file $file isn't mapfile.\n"; |
128 |
|
|
return; |
129 |
|
|
} |
130 |
|
|
if ($VERBOSE) { |
131 |
|
|
print "Testing $file, "; |
132 |
|
|
print /^name (.+)$/ ? $1 : "No mapname"; |
133 |
|
|
print ", size [", /^x (\d+)$/ ? $1 : 16; |
134 |
|
|
print ",", /^y (\d+)/ ? $1 : 16, "]"; |
135 |
|
|
|
136 |
|
|
if (! /^msg$/) { |
137 |
|
|
print ", No message\n"; |
138 |
|
|
} elsif (/(\w+@\S+)/) { |
139 |
|
|
print ", $1\n"; |
140 |
|
|
} else { |
141 |
|
|
print ", Unknown\n"; |
142 |
|
|
} |
143 |
|
|
$printmap=0; |
144 |
|
|
} |
145 |
|
|
else { |
146 |
|
|
$name= /^name (.+)$/ ? $1 : "No mapname"; |
147 |
|
|
$x= /^x (\d+)$/ ? $1 : 16; |
148 |
|
|
$y= /^y (\d+)/ ? $1 : 16; |
149 |
|
|
$mapname="Map $file, $name, size [$x, $y]\n" ; |
150 |
|
|
$printmap=1; |
151 |
|
|
} |
152 |
|
|
|
153 |
|
|
|
154 |
|
|
while (<IN>) { |
155 |
|
|
if (($m = (@_ = /^arch \S+\s*$/g)) > 1) { |
156 |
|
|
$parent = /^arch (\S+)\s*$/; |
157 |
|
|
# object has inventory |
158 |
|
|
my ($inv) = $_; |
159 |
|
|
while (<IN>) { |
160 |
|
|
if (/((.|\n)*end\n)(arch (.|\n)*\nend\n)/) { |
161 |
|
|
&check_obj ("$inv$1"); |
162 |
|
|
&check_obj ($3); |
163 |
|
|
last; |
164 |
|
|
} elsif (/^arch (.|\n)*\nend$/) { |
165 |
|
|
&check_obj ($_); |
166 |
|
|
} elsif (/^end$/) { |
167 |
|
|
&check_obj ("$inv$_"); |
168 |
|
|
} else { |
169 |
|
|
# if ($printmap) { print "$mapname"; $printmap=0;} |
170 |
|
|
# This doesn't work right - it gets confused when objects are within |
171 |
|
|
# another object |
172 |
|
|
# print " Error: Corrupted map file $file.\nSegment:\n$_\nLine: $.\n"; |
173 |
|
|
} |
174 |
|
|
} |
175 |
|
|
$parent=""; |
176 |
|
|
} elsif (/^More$/ || $m == 1) { |
177 |
|
|
&check_obj ($_); |
178 |
|
|
} else { |
179 |
|
|
# if ($printmap) { print "$mapname"; $printmap=0;} |
180 |
|
|
# print " Error: Corrupted map file $file.\nSegment:\n$_\nLine: $.\n"; |
181 |
|
|
} |
182 |
|
|
} |
183 |
|
|
close (IN); |
184 |
|
|
} |
185 |
|
|
|
186 |
|
|
sub check_obj { |
187 |
|
|
$_ = shift @_; |
188 |
|
|
|
189 |
|
|
local ($x) = (/^x (\d+)$/)?$1:0; |
190 |
|
|
local ($y) = (/^y (\d+)$/)?$1:0; |
191 |
|
|
local($arch) = /^arch (\S+)\s*$/; |
192 |
|
|
|
193 |
|
|
if (! $arches{$1} && $last ne $1) { |
194 |
|
|
$last = $1; |
195 |
|
|
if ($printmap) { print "$mapname"; $printmap=0;} |
196 |
|
|
print " Error: Object $last is not defined in archetypes file ($x,$y), arch=$arch\n"; |
197 |
|
|
$missing{$last}++; |
198 |
|
|
} elsif ($ex{$1}) { |
199 |
|
|
&examine_exit ($_); |
200 |
|
|
} elsif ($tele{$1}) { |
201 |
|
|
if (/^food -?\d+$/) { |
202 |
|
|
if ($printmap) { print "$mapname"; $printmap=0;} |
203 |
|
|
print " Error: Teleport $1 has food field.\n"; |
204 |
|
|
} |
205 |
|
|
else { |
206 |
|
|
&examine_exit ($_); |
207 |
|
|
} |
208 |
|
|
} elsif ($conn{$1} && ! /^connected -?\d+$/) { |
209 |
|
|
$last = $1; |
210 |
|
|
if ($CONNECTED) { |
211 |
|
|
if ($printmap) { print "$mapname"; $printmap=0;} |
212 |
|
|
print " Warning: Object $last has not been connected, $x,$y\n" |
213 |
|
|
} |
214 |
|
|
} elsif ($players{$1} && $last ne $1 && ! /^type / ) { |
215 |
|
|
$last = $1; |
216 |
|
|
if ($printmap) { print "$mapname"; $printmap=0;} |
217 |
|
|
print " Error: Player $last found in the map.\n"; |
218 |
|
|
} elsif ($1 eq "scroll" && ! /^msg$/) { |
219 |
|
|
$last = $1; |
220 |
|
|
# print " Warning: scroll without message ($x, $y:$parent), should be random_scroll?\n"; |
221 |
|
|
} elsif ($1 eq "potion" && $last ne $1) { |
222 |
|
|
$last = $1; |
223 |
|
|
# print " Warning: potion found, should be random_potion or random_food?\n"; |
224 |
|
|
} elsif ($1 eq "ring" || $1 eq "amulet") { |
225 |
|
|
$last = $1; |
226 |
|
|
# print " Warning: ring/amulet found ($x,$y:$parent), should be random_talisman?\n"; |
227 |
|
|
} |
228 |
|
|
$objects{$1}++; |
229 |
|
|
if (/^color_fg (\S+)$/ || /^color_bg (\S+)$/) { |
230 |
|
|
$last = $arch; |
231 |
|
|
if ($printmap) { print "$mapname"; $printmap=0;} |
232 |
|
|
print " Warning: Object ".$arch." is setting color ($1), $x,$y\n"; |
233 |
|
|
} |
234 |
|
|
if (/^animation (\S+)$/) { |
235 |
|
|
if (! $anim{$1}) { |
236 |
|
|
if ($printmap) { print "$mapname"; $printmap=0;} |
237 |
|
|
print "Error: Object $arch is using an unknown animation $1\n" |
238 |
|
|
} |
239 |
|
|
} |
240 |
|
|
if (/^face (\S+)$/) { |
241 |
|
|
if (! $faces{$1}) { |
242 |
|
|
if ($printmap) { print "$mapname"; $printmap=0;} |
243 |
|
|
print "Error: Object $arch is using an unknown face $1\n" |
244 |
|
|
} |
245 |
|
|
} |
246 |
|
|
} |
247 |
|
|
|
248 |
|
|
sub by { |
249 |
|
|
$_ = $objects{$b} <=> $objects{$a}; |
250 |
|
|
$_ ? $_ : $a cmp $b; |
251 |
|
|
} |
252 |
|
|
|
253 |
|
|
sub obj_name { |
254 |
|
|
$_ = shift(@_); |
255 |
|
|
local ($name) = /^name (.+)$/; # object's name |
256 |
|
|
local ($arch) = /^arch (\S+)$/; |
257 |
|
|
if (!defined ($name) && $arches{$arch} =~ /^name (.+)$/) { |
258 |
|
|
$name = $1; # archetype's name |
259 |
|
|
} |
260 |
|
|
return defined ($name) ? $name : $arch; # archetype or name |
261 |
|
|
} |
262 |
|
|
|
263 |
|
|
sub examine_exit { |
264 |
|
|
$_ = shift(@_); |
265 |
|
|
|
266 |
|
|
local ($x) = (/^hp (\d+)$/)?$1:0; |
267 |
|
|
local ($y) = (/^sp (\d+)$/)?$1:0; |
268 |
|
|
local ($x1) = (/^x (\d+)$/)?$1:0; |
269 |
|
|
local ($y1) = (/^y (\d+)$/)?$1:0; |
270 |
|
|
local ($to) = /^slaying (\S+)$/; |
271 |
|
|
|
272 |
|
|
if (/^food (-?\d+)$/) { |
273 |
|
|
# old style exits, doesn't work with crossfire 0.90-1 |
274 |
|
|
if ($printmap) { print "$mapname"; $printmap=0;} |
275 |
|
|
print " Error: ", &obj_name($_), " ($x1,$y1) -> ", |
276 |
|
|
"Old style level [$1] ($x,$y)\n"; |
277 |
|
|
} elsif (! defined ($to)) { |
278 |
|
|
# print " Closed: ", &obj_name($_), " ($x1,$y1)\n"; |
279 |
|
|
} else { |
280 |
|
|
# These are currently used be crossfire |
281 |
|
|
if ($to eq "/!") { # this is a random exit - if we |
282 |
|
|
# have a final map, make sure it |
283 |
|
|
# exists |
284 |
|
|
local ($finalmap) = /^final_map (\S+)$/; |
285 |
|
|
if ($finalmap ne "") { |
286 |
|
|
if ($finalmap =~ m!^/!) { $cdir = "$MAPS"; } |
287 |
|
|
else { ($cdir) = $file =~ m!(.*/)!; } |
288 |
|
|
if (! -f "$cdir$finalmap") { |
289 |
|
|
if ($printmap) { print "$mapname"; $printmap=0;} |
290 |
|
|
print " Missing: ", &obj_name($_), " ($x1,$y1) -> $finalmap ($x,$y)\n"; |
291 |
|
|
} |
292 |
|
|
} |
293 |
|
|
return; |
294 |
|
|
} |
295 |
|
|
if ($to =~ m!^/!) { |
296 |
|
|
$cdir = "$MAPS"; |
297 |
|
|
} else { |
298 |
|
|
($cdir) = $file =~ m!(.*/)!; |
299 |
|
|
} |
300 |
|
|
if (! -f "$cdir$to") { |
301 |
|
|
if ($printmap) { print "$mapname"; $printmap=0;} |
302 |
|
|
print " Missing: ", &obj_name($_), " ($x1,$y1) -> $to ($x,$y)\n"; |
303 |
|
|
} else { |
304 |
|
|
# print " OK: ", &obj_name($_), " ($x1,$y1) -> $to ($x,$y)\n"; |
305 |
|
|
} |
306 |
|
|
} |
307 |
|
|
} |
308 |
|
|
|
309 |
|
|
# @maps contains all filenames |
310 |
|
|
sub maplist { |
311 |
|
|
local ($dir, $file, @dirs) = shift; |
312 |
|
|
|
313 |
|
|
opendir (DIR , $dir) || die "Can't open directory : $dir\n"; |
314 |
|
|
while ($file = readdir (DIR)) { |
315 |
|
|
next if ($file eq "." || $file eq ".." || $file eq "CVS" || $file eq "unlinked" || $file eq "editor"); |
316 |
|
|
$file = "$dir/$file"; |
317 |
|
|
next if (-l $file); |
318 |
|
|
push (@dirs, $file) if (-d $file); |
319 |
|
|
push (@maps, $file) if (-f $file); |
320 |
|
|
} |
321 |
|
|
closedir (DIR); |
322 |
|
|
|
323 |
|
|
# recurcive handle sub-dirs too |
324 |
|
|
while ($_ = shift @dirs) { |
325 |
|
|
&maplist ($_); |
326 |
|
|
} |
327 |
|
|
} |
328 |
|
|
|
329 |
|
|
# collect all objects matching with reg.expr. |
330 |
|
|
sub collect { |
331 |
|
|
local ($expr,$a, %col) = shift; |
332 |
|
|
|
333 |
|
|
foreach $a (keys %arches) { |
334 |
|
|
$_ = $arches{$a}; |
335 |
|
|
if (/$expr/) { |
336 |
|
|
$col{$a}++; |
337 |
|
|
} |
338 |
|
|
} |
339 |
|
|
return %col; |
340 |
|
|
} |
341 |
|
|
|
342 |
|
|
# collect all archetypes into associative array %arches |
343 |
|
|
sub archetypes { |
344 |
|
|
open (IN, $ARCH) || die "Can't open archetype file $ARCH.\n"; |
345 |
|
|
$/ = "\nend\n"; |
346 |
|
|
while (<IN>) { |
347 |
|
|
while (/^Object (\S+)\s*$/g) { |
348 |
|
|
$arches{$1} = $_; |
349 |
|
|
} |
350 |
|
|
} |
351 |
|
|
close (IN); |
352 |
|
|
} |
353 |
|
|
|
354 |
|
|
sub faces { |
355 |
|
|
open(IN, $BMAPS) || die ("Can't open faces file $BMAPS\n"); |
356 |
|
|
while (<IN>) { |
357 |
|
|
chomp; |
358 |
|
|
($num, $name) = split; |
359 |
|
|
$faces{$name} = $name; |
360 |
|
|
} |
361 |
|
|
close(IN); |
362 |
|
|
} |
363 |
|
|
|
364 |
|
|
|
365 |
|
|
sub animations { |
366 |
|
|
open(IN, $ANIM) || die ("Can't open animations file $ANIM\n"); |
367 |
|
|
while (<IN>) { |
368 |
|
|
if (/^anim (\S+)\s*$/) { |
369 |
|
|
$anim{$1} = $1; |
370 |
|
|
} |
371 |
|
|
} |
372 |
|
|
close(IN); |
373 |
|
|
} |
374 |
|
|
|
375 |
|
|
|