ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra/Deliantra.pm
(Generate patch)

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.65 by root, Wed May 3 19:34:31 2006 UTC vs.
Revision 1.90 by root, Sat Mar 3 18:58:25 2007 UTC

… …
4 4
5=cut 5=cut
6 6
7package Crossfire; 7package Crossfire;
8 8
9our $VERSION = '0.1'; 9our $VERSION = '0.96';
10 10
11use strict; 11use strict;
12 12
13use base 'Exporter'; 13use base 'Exporter';
14 14
… …
19 19
20our @EXPORT = qw( 20our @EXPORT = qw(
21 read_pak read_arch *ARCH TILESIZE $TILE *FACE editor_archs arch_extents 21 read_pak read_arch *ARCH TILESIZE $TILE *FACE editor_archs arch_extents
22); 22);
23 23
24use JSON::Syck (); #TODO#d# replace by JSON::PC when it becomes available == working
25
26sub from_json($) {
27 $JSON::Syck::ImplicitUnicode = 1;
28 JSON::Syck::Load $_[0]
29}
30
31sub to_json($) {
32 $JSON::Syck::ImplicitUnicode = 0;
33 JSON::Syck::Dump $_[0]
34}
35
24our $LIB = $ENV{CROSSFIRE_LIBDIR}; 36our $LIB = $ENV{CROSSFIRE_LIBDIR};
25 37
26our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire"; 38our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire"
39 : $ENV{AppData} ? "$ENV{APPDATA}/crossfire"
40 : File::Spec->tmpdir . "/crossfire";
27 41
28mkdir $VARDIR, 0777; 42mkdir $VARDIR, 0777;
29 43
30sub TILESIZE (){ 32 } 44sub TILESIZE (){ 32 }
31 45
… …
44 qw(move_type move_block move_allow move_on move_off move_slow); 58 qw(move_type move_block move_allow move_on move_off move_slow);
45 59
46# same as in server save routine, to (hopefully) be compatible 60# same as in server save routine, to (hopefully) be compatible
47# to the other editors. 61# to the other editors.
48our @FIELD_ORDER_MAP = (qw( 62our @FIELD_ORDER_MAP = (qw(
63 file_format_version
49 name swap_time reset_timeout fixed_resettime difficulty region 64 name attach swap_time reset_timeout fixed_resettime difficulty region
50 shopitems shopgreed shopmin shopmax shoprace 65 shopitems shopgreed shopmin shopmax shoprace
51 darkness width height enter_x enter_y msg maplore 66 darkness width height enter_x enter_y msg maplore
52 unique template 67 unique template
53 outdoor temp pressure humid windspeed winddir sky nosmooth 68 outdoor temp pressure humid windspeed winddir sky nosmooth
54 tile_path_1 tile_path_2 tile_path_3 tile_path_4 69 tile_path_1 tile_path_2 tile_path_3 tile_path_4
55)); 70));
56 71
57our @FIELD_ORDER = (qw( 72our @FIELD_ORDER = (qw(
58 elevation 73 elevation
59 74
60 name name_pl custom_name title race 75 name name_pl custom_name attach title race
61 slaying skill msg lore other_arch face 76 slaying skill msg lore other_arch face
62 #todo-events 77 #todo-events
63 animation is_animated 78 animation is_animated
64 str dex con wis pow cha int 79 str dex con wis pow cha int
65 hp maxhp sp maxsp grace maxgrace 80 hp maxhp sp maxsp grace maxgrace
… …
124sub MOVE_FLY_HIGH (){ 0x04 } 139sub MOVE_FLY_HIGH (){ 0x04 }
125sub MOVE_FLYING (){ 0x06 } 140sub MOVE_FLYING (){ 0x06 }
126sub MOVE_SWIM (){ 0x08 } 141sub MOVE_SWIM (){ 0x08 }
127sub MOVE_BOAT (){ 0x10 } 142sub MOVE_BOAT (){ 0x10 }
128sub MOVE_KNOWN (){ 0x1f } # all of above 143sub MOVE_KNOWN (){ 0x1f } # all of above
129sub MOVE_ALLBIT (){ 0x10000 }
130sub MOVE_ALL (){ 0x1001f } # very special value, more PITA 144sub MOVE_ALL (){ 0x10000 } # very special value
145
146our %MOVE_TYPE = (
147 walk => MOVE_WALK,
148 fly_low => MOVE_FLY_LOW,
149 fly_high => MOVE_FLY_HIGH,
150 flying => MOVE_FLYING,
151 swim => MOVE_SWIM,
152 boat => MOVE_BOAT,
153 all => MOVE_ALL,
154);
155
156our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat);
157
158{
159 package Crossfire::MoveType;
160
161 use overload
162 '""' => \&as_string,
163 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
164 '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise },
165 '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
166 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
167 'x=' => sub {
168 my $cur = $_[0] >= $_[1];
169 if (!defined $cur) {
170 $_[0] += $_[1];
171 } elsif ($cur) {
172 $_[0] -= $_[1];
173 } else {
174 $_[0] /= $_[1];
175 }
176
177 $_[0]
178 },
179 ;
180}
181
182sub Crossfire::MoveType::new {
183 my ($class, $string) = @_;
184
185 my $mask;
186 my $value;
187
188 for (split /\s+/, lc $string) {
189 if (s/^-//) {
190 $mask |= $MOVE_TYPE{$_};
191 $value &= ~$MOVE_TYPE{$_};
192 } else {
193 $mask |= $MOVE_TYPE{$_};
194 $value |= $MOVE_TYPE{$_};
195 }
196 }
197
198 (bless [$mask, $value], $class)->normalise
199}
200
201sub Crossfire::MoveType::normalise {
202 my ($self) = @_;
203
204 if ($self->[0] & MOVE_ALL) {
205 my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
206 $self->[0] &= $mask;
207 $self->[1] &= $mask;
208 }
209
210 $self->[1] &= $self->[0];
211
212 $self
213}
214
215sub Crossfire::MoveType::as_string {
216 my ($self) = @_;
217
218 my @res;
219
220 my ($mask, $value) = @$self;
221
222 for (@Crossfire::MOVE_TYPE) {
223 my $bit = $Crossfire::MOVE_TYPE{$_};
224 if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) {
225 $mask &= ~$bit;
226 push @res, $value & $bit ? $_ : "-$_";
227 }
228 }
229
230 join " ", @res
231}
131 232
132sub load_ref($) { 233sub load_ref($) {
133 my ($path) = @_; 234 my ($path) = @_;
134 235
135 open my $fh, "<:raw:perlio", $path 236 open my $fh, "<:raw:perlio", $path
… …
148 close $fh; 249 close $fh;
149 rename "$path~", $path 250 rename "$path~", $path
150 or die "$path: $!"; 251 or die "$path: $!";
151} 252}
152 253
254my %attack_mask = (
255 physical => 0x00000001,
256 magic => 0x00000002,
257 fire => 0x00000004,
258 electricity => 0x00000008,
259 cold => 0x00000010,
260 confusion => 0x00000020,
261 acid => 0x00000040,
262 drain => 0x00000080,
263 weaponmagic => 0x00000100,
264 ghosthit => 0x00000200,
265 poison => 0x00000400,
266 slow => 0x00000800,
267 paralyze => 0x00001000,
268 turn_undead => 0x00002000,
269 fear => 0x00004000,
270 cancellation => 0x00008000,
271 deplete => 0x00010000,
272 death => 0x00020000,
273 chaos => 0x00040000,
274 counterspell => 0x00080000,
275 godpower => 0x00100000,
276 holyword => 0x00200000,
277 blind => 0x00400000,
278 internal => 0x00800000,
279 life_stealing => 0x01000000,
280 disease => 0x02000000,
281);
282
283sub _add_resist($$$) {
284 my ($ob, $mask, $value) = @_;
285
286 while (my ($k, $v) = each %attack_mask) {
287 $ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
288 }
289}
290
291my %MATERIAL = reverse
292 paper => 1,
293 iron => 2,
294 glass => 4,
295 leather => 8,
296 wood => 16,
297 organic => 32,
298 stone => 64,
299 cloth => 128,
300 adamant => 256,
301 liquid => 512,
302 tin => 1024,
303 bone => 2048,
304 ice => 4096,
305
306 # guesses
307 runestone => 12,
308 bronze => 18,
309 "ancient wood" => 20,
310 glass => 36,
311 marble => 66,
312 ice => 68,
313 stone => 70,
314 stone => 80,
315 cloth => 136,
316 ironwood => 144,
317 adamantium => 258,
318 glacium => 260,
319 blood => 544,
320;
321
153# object as in "Object xxx", i.e. archetypes 322# object as in "Object xxx", i.e. archetypes
154sub normalize_object($) { 323sub normalize_object($) {
155 my ($ob) = @_; 324 my ($ob) = @_;
156 325
326 # convert material bitset to materialname, if possible
327 if (exists $ob->{material}) {
328 if (!$ob->{material}) {
329 delete $ob->{material};
330 } elsif (exists $ob->{materialname}) {
331 if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
332 delete $ob->{material};
333 } else {
334 warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
335 delete $ob->{material}; # assume materilname is more specific and nuke material
336 }
337 } elsif (my $name = $MATERIAL{$ob->{material}}) {
338 delete $ob->{material};
339 $ob->{materialname} = $name;
340 } else {
341 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
342 }
343 }
344
157 # nuke outdated or never supported fields 345 # nuke outdated or never supported fields
158 delete $ob->{$_} for qw( 346 delete @$ob{qw(
159 can_knockback can_parry can_impale can_cut can_dam_armour 347 can_knockback can_parry can_impale can_cut can_dam_armour
160 can_apply pass_thru can_pass_thru 348 can_apply pass_thru can_pass_thru
161 ); 349 )};
350
351 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
352 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
353 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
162 354
163 # convert movement strings to bitsets 355 # convert movement strings to bitsets
164 for my $attr (keys %FIELD_MOVEMENT) { 356 for my $attr (keys %FIELD_MOVEMENT) {
165 next unless exists $ob->{$attr}; 357 next unless exists $ob->{$attr};
166 358
167 $ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility 359 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
168
169 next if $ob->{$attr} =~ /^\d+$/;
170
171 my $flags = 0;
172
173 # assume list
174 for my $flag (map lc, split /\s+/, $ob->{$attr}) {
175 $flags |= MOVE_WALK if $flag eq "walk";
176 $flags |= MOVE_FLY_LOW if $flag eq "fly_low";
177 $flags |= MOVE_FLY_HIGH if $flag eq "fly_high";
178 $flags |= MOVE_FLYING if $flag eq "flying";
179 $flags |= MOVE_SWIM if $flag eq "swim";
180 $flags |= MOVE_BOAT if $flag eq "boat";
181 $flags |= MOVE_ALL if $flag eq "all";
182
183 $flags &= ~MOVE_WALK if $flag eq "-walk";
184 $flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
185 $flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
186 $flags &= ~MOVE_FLYING if $flag eq "-flying";
187 $flags &= ~MOVE_SWIM if $flag eq "-swim";
188 $flags &= ~MOVE_BOAT if $flag eq "-boat";
189 $flags &= ~MOVE_ALL if $flag eq "-all";
190 }
191
192 $ob->{$attr} = $flags;
193 } 360 }
194 361
195 # convert outdated movement flags to new movement sets 362 # convert outdated movement flags to new movement sets
196 if (defined (my $v = delete $ob->{no_pass})) { 363 if (defined (my $v = delete $ob->{no_pass})) {
197 $ob->{move_block} = $v ? MOVE_ALL : 0; 364 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
198 } 365 }
199 if (defined (my $v = delete $ob->{slow_move})) { 366 if (defined (my $v = delete $ob->{slow_move})) {
200 $ob->{move_slow} |= MOVE_WALK; 367 $ob->{move_slow} += "walk";
201 $ob->{move_slow_penalty} = $v; 368 $ob->{move_slow_penalty} = $v;
202 } 369 }
203 if (defined (my $v = delete $ob->{walk_on})) { 370 if (defined (my $v = delete $ob->{walk_on})) {
204 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK 371 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
205 : $ob->{move_on} & ~MOVE_WALK;
206 } 372 }
207 if (defined (my $v = delete $ob->{walk_off})) { 373 if (defined (my $v = delete $ob->{walk_off})) {
208 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK 374 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
209 : $ob->{move_off} & ~MOVE_WALK;
210 } 375 }
211 if (defined (my $v = delete $ob->{fly_on})) { 376 if (defined (my $v = delete $ob->{fly_on})) {
212 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW 377 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
213 : $ob->{move_on} & ~MOVE_FLY_LOW;
214 } 378 }
215 if (defined (my $v = delete $ob->{fly_off})) { 379 if (defined (my $v = delete $ob->{fly_off})) {
216 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW 380 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
217 : $ob->{move_off} & ~MOVE_FLY_LOW;
218 } 381 }
219 if (defined (my $v = delete $ob->{flying})) { 382 if (defined (my $v = delete $ob->{flying})) {
220 $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW 383 $ob->{move_type} ||= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
221 : $ob->{move_type} & ~MOVE_FLY_LOW;
222 } 384 }
223 385
224 # convert idiotic event_xxx things into objects 386 # convert idiotic event_xxx things into objects
225 while (my ($event, $subtype) = each %EVENT_TYPE) { 387 while (my ($event, $subtype) = each %EVENT_TYPE) {
226 if (exists $ob->{"event_${event}_plugin"}) { 388 if (exists $ob->{"event_${event}_plugin"}) {
… …
230 slaying => delete $ob->{"event_${event}"}, 392 slaying => delete $ob->{"event_${event}"},
231 name => delete $ob->{"event_${event}_options"}, 393 name => delete $ob->{"event_${event}_options"},
232 }; 394 };
233 } 395 }
234 } 396 }
397
398 # some archetypes had "+3" instead of the canonical "3", so fix
399 $ob->{dam} *= 1 if exists $ob->{dam};
235 400
236 $ob 401 $ob
237} 402}
238 403
239# arch as in "arch xxx", ie.. objects 404# arch as in "arch xxx", ie.. objects
… …
281 } 446 }
282 447
283 $ob 448 $ob
284} 449}
285 450
451sub attr_thaw($) {
452 my ($ob) = @_;
453
454 $ob->{attach} = from_json $ob->{attach}
455 if exists $ob->{attach};
456
457 $ob
458}
459
460sub attr_freeze($) {
461 my ($ob) = @_;
462
463 $ob->{attach} = Crossfire::to_json $ob->{attach}
464 if exists $ob->{attach};
465
466 $ob
467}
468
286sub read_pak($) { 469sub read_pak($) {
287 my ($path) = @_; 470 my ($path) = @_;
288 471
289 my %pak; 472 my %pak;
290 473
… …
303sub read_arch($;$) { 486sub read_arch($;$) {
304 my ($path, $toplevel) = @_; 487 my ($path, $toplevel) = @_;
305 488
306 my %arc; 489 my %arc;
307 my ($more, $prev); 490 my ($more, $prev);
491 my $comment;
308 492
309 open my $fh, "<:raw:perlio:utf8", $path 493 open my $fh, "<:raw:perlio:utf8", $path
310 or Carp::croak "$path: $!"; 494 or Carp::croak "$path: $!";
311 495
312 binmode $fh; 496# binmode $fh;
313 497
314 my $parse_block; $parse_block = sub { 498 my $parse_block; $parse_block = sub {
315 my %arc = @_; 499 my %arc = @_;
316 500
317 while (<$fh>) { 501 while (<$fh>) {
318 s/\s+$//; 502 s/\s+$//;
319 if (/^end$/i) { 503 if (/^end$/i) {
320 last; 504 last;
505
321 } elsif (/^arch (\S+)$/i) { 506 } elsif (/^arch (\S+)$/i) {
322 push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1); 507 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
508
323 } elsif (/^lore$/i) { 509 } elsif (/^lore$/i) {
324 while (<$fh>) { 510 while (<$fh>) {
325 last if /^endlore\s*$/i; 511 last if /^endlore\s*$/i;
326 $arc{lore} .= $_; 512 $arc{lore} .= $_;
327 } 513 }
… …
336 chomp; 522 chomp;
337 push @{ $arc{anim} }, $_; 523 push @{ $arc{anim} }, $_;
338 } 524 }
339 } elsif (/^(\S+)\s*(.*)$/) { 525 } elsif (/^(\S+)\s*(.*)$/) {
340 $arc{lc $1} = $2; 526 $arc{lc $1} = $2;
341 } elsif (/^\s*($|#)/) { 527 } elsif (/^\s*#/) {
528 $arc{_comment} .= "$_\n";
529
530 } elsif (/^\s*$/) {
342 # 531 #
343 } else { 532 } else {
344 warn "$path: unparsable line '$_' in arch $arc{_name}"; 533 warn "$path: unparsable line '$_' in arch $arc{_name}";
345 } 534 }
346 } 535 }
… …
352 s/\s+$//; 541 s/\s+$//;
353 if (/^more$/i) { 542 if (/^more$/i) {
354 $more = $prev; 543 $more = $prev;
355 } elsif (/^object (\S+)$/i) { 544 } elsif (/^object (\S+)$/i) {
356 my $name = $1; 545 my $name = $1;
357 my $arc = normalize_object $parse_block->(_name => $name); 546 my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
547 undef $comment;
548 delete $arc{_comment} unless length $arc{_comment};
549 $arc->{_atype} = 'object';
358 550
359 if ($more) { 551 if ($more) {
360 $more->{more} = $arc; 552 $more->{more} = $arc;
361 } else { 553 } else {
362 $arc{$name} = $arc; 554 $arc{$name} = $arc;
363 } 555 }
364 $prev = $arc; 556 $prev = $arc;
365 $more = undef; 557 $more = undef;
366 } elsif (/^arch (\S+)$/i) { 558 } elsif (/^arch (\S+)$/i) {
367 my $name = $1; 559 my $name = $1;
368 my $arc = normalize_arch $parse_block->(_name => $name); 560 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
561 undef $comment;
562 delete $arc{_comment} unless length $arc{_comment};
563 $arc->{_atype} = 'arch';
369 564
370 if ($more) { 565 if ($more) {
371 $more->{more} = $arc; 566 $more->{more} = $arc;
372 } else { 567 } else {
373 push @{ $arc{arch} }, $arc; 568 push @{ $arc{arch} }, $arc;
… …
381 push @{$toplevel->{lev_array}}, $_+0; 576 push @{$toplevel->{lev_array}}, $_+0;
382 } 577 }
383 } else { 578 } else {
384 $toplevel->{$1} = $2; 579 $toplevel->{$1} = $2;
385 } 580 }
581 } elsif (/^\s*#/) {
582 $comment .= "$_\n";
386 } elsif (/^\s*($|#)/) { 583 } elsif (/^\s*($|#)/) {
387 # 584 #
388 } else { 585 } else {
389 die "$path: unparseable top-level line '$_'"; 586 die "$path: unparseable top-level line '$_'";
390 } 587 }
391 } 588 }
392 589
393 undef $parse_block; # work around bug in perl not freeing $fh etc. 590 undef $parse_block; # work around bug in perl not freeing $fh etc.
394 591
395 \%arc 592 \%arc
593}
594
595sub archlist_to_string {
596 my ($arch) = @_;
597
598 my $str;
599
600 my $append; $append = sub {
601 my %a = %{$_[0]};
602
603 Crossfire::attr_freeze \%a;
604 Crossfire::normalize_arch \%a;
605
606 # undo the bit-split we did before
607 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
608 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
609 | (delete $a{attack_movement_bits_4_7});
610 }
611
612 if (my $comment = delete $a{_comment}) {
613 if ($comment =~ /[^\n\s#]/) {
614 $str .= $comment;
615 }
616 }
617
618 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
619
620 my $inv = delete $a{inventory};
621 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
622 my $anim = delete $a{anim};
623
624 if ($a{_atype} eq 'object') {
625 $str .= join "\n", "anim", @$anim, "mina\n"
626 if $anim;
627 }
628
629 my @kv;
630
631 for ($a{_name} eq "map"
632 ? @Crossfire::FIELD_ORDER_MAP
633 : @Crossfire::FIELD_ORDER) {
634 push @kv, [$_, delete $a{$_}]
635 if exists $a{$_};
636 }
637
638 for (sort keys %a) {
639 next if /^_/; # ignore our _-keys
640 push @kv, [$_, delete $a{$_}];
641 }
642
643 for (@kv) {
644 my ($k, $v) = @$_;
645
646 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
647 $v =~ s/\n$//;
648 $str .= "$k\n$v\n$end\n";
649 } else {
650 $str .= "$k $v\n";
651 }
652 }
653
654 if ($inv) {
655 $append->($_) for @$inv;
656 }
657
658 $str .= "end\n";
659
660 if ($a{_atype} eq 'object') {
661 if ($more) {
662 $str .= "more\n";
663 $append->($more) if $more;
664 } else {
665 $str .= "\n";
666 }
667 }
668 };
669
670 for (@$arch) {
671 $append->($_);
672 }
673
674 $str
396} 675}
397 676
398# put all archs into a hash with editor_face as it's key 677# put all archs into a hash with editor_face as it's key
399# NOTE: the arrays in the hash values are references to 678# NOTE: the arrays in the hash values are references to
400# the archs from $ARCH 679# the archs from $ARCH
… …
421 my ($a) = @_; 700 my ($a) = @_;
422 701
423 my $o = $ARCH{$a->{_name}} 702 my $o = $ARCH{$a->{_name}}
424 or return; 703 or return;
425 704
426 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"} 705 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"};
706 unless ($face) {
707 $face = $FACE{"blank.x11"}
427 or (warn "no face data found for arch '$a->{_name}'"), return; 708 or (warn "no face data found for arch '$a->{_name}'"), return;
709 }
428 710
429 if ($face->{w} > 1 || $face->{h} > 1) { 711 if ($face->{w} > 1 || $face->{h} > 1) {
430 # bigface 712 # bigface
431 return (0, 0, $face->{w} - 1, $face->{h} - 1); 713 return (0, 0, $face->{w} - 1, $face->{h} - 1);
432 714
… …
539 ]; 821 ];
540 822
541 $attr 823 $attr
542} 824}
543 825
544sub arch_edit_sections {
545# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
546# edit_type = 0;
547# else if (edit_type != 0) {
548# // all flags from 'check_type' must be unset in this arch because they get recalculated now
549# edit_type &= ~check_type;
550# }
551#
552# }
553# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
554# getAttributeValue("alive", defarch) == 1 &&
555# (getAttributeValue("monster", defarch) == 1 ||
556# getAttributeValue("generator", defarch) == 1)) {
557# // Monster: monsters/npcs/generators
558# edit_type |= IGUIConstants.TILE_EDIT_MONSTER;
559# }
560# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
561# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
562# // Walls
563# edit_type |= IGUIConstants.TILE_EDIT_WALL;
564# }
565# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
566# getAttributeValue("connected", defarch) != 0) {
567# // Connected Objects
568# edit_type |= IGUIConstants.TILE_EDIT_CONNECTED;
569# }
570# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
571# arch_type == 66 || arch_type == 41 || arch_type == 95) {
572# // Exit: teleporter/exit/trapdoors
573# edit_type |= IGUIConstants.TILE_EDIT_EXIT;
574# }
575# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
576# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 ||
577# arch_type == 5 || arch_type == 36 || arch_type == 60 ||
578# arch_type == 85 || arch_type == 111 || arch_type == 123 ||
579# arch_type == 124 || arch_type == 130)) {
580# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
581# edit_type |= IGUIConstants.TILE_EDIT_TREASURE;
582# }
583# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
584# arch_type == 20 || arch_type == 23 || arch_type == 26 ||
585# arch_type == 91 || arch_type == 21 || arch_type == 24) {
586# // Door: door/special door/gates + keys
587# edit_type |= IGUIConstants.TILE_EDIT_DOOR;
588# }
589# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
590# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
591# arch_type <= 16) || arch_type == 33 || arch_type == 34 ||
592# arch_type == 35 || arch_type == 39 || arch_type == 70 ||
593# arch_type == 87 || arch_type == 99 || arch_type == 100 ||
594# arch_type == 104 || arch_type == 109 || arch_type == 113 ||
595# arch_type == 122 || arch_type == 3)) {
596# // Equipment: weapons/armour/wands/rods
597# edit_type |= IGUIConstants.TILE_EDIT_EQUIP;
598# }
599#
600# return(edit_type);
601#
602#
603}
604
605sub cache_file($$&&) { 826sub cache_file($$&&) {
606 my ($src, $cache, $load, $create) = @_; 827 my ($src, $cache, $load, $create) = @_;
607 828
608 my ($size, $mtime) = (stat $src)[7,9] 829 my ($size, $mtime) = (stat $src)[7,9]
609 or Carp::croak "$src: $!"; 830 or Carp::croak "$src: $!";

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines