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.62 by root, Tue Mar 28 14:44:52 2006 UTC vs.
Revision 1.95 by root, Mon Mar 5 01:10:30 2007 UTC

… …
4 4
5=cut 5=cut
6 6
7package Crossfire; 7package Crossfire;
8 8
9our $VERSION = '0.1'; 9our $VERSION = '0.97';
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 '=' => sub { bless [@{$_[0]}], ref $_[0] },
163 '""' => \&as_string,
164 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
165 '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise },
166 '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
167 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
168 'x=' => sub {
169 my $cur = $_[0] >= $_[1];
170 if (!defined $cur) {
171 if ($_[0] >= "all") {
172 $_[0] -= $_[1];
173 } else {
174 $_[0] += $_[1];
175 }
176 } elsif ($cur) {
177 $_[0] -= $_[1];
178 } else {
179 $_[0] /= $_[1];
180 }
181
182 $_[0]
183 },
184 'eq' => sub { "$_[0]" eq "$_[1]" },
185 'ne' => sub { "$_[0]" ne "$_[1]" },
186 ;
187}
188
189sub Crossfire::MoveType::new {
190 my ($class, $string) = @_;
191
192 my $mask;
193 my $value;
194
195 if ($string =~ /^\s*\d+\s*$/) {
196 $mask = MOVE_ALL;
197 $value = $string+0;
198 } else {
199 for (split /\s+/, lc $string) {
200 if (s/^-//) {
201 $mask |= $MOVE_TYPE{$_};
202 $value &= ~$MOVE_TYPE{$_};
203 } else {
204 $mask |= $MOVE_TYPE{$_};
205 $value |= $MOVE_TYPE{$_};
206 }
207 }
208 }
209
210 (bless [$mask, $value], $class)->normalise
211}
212
213sub Crossfire::MoveType::normalise {
214 my ($self) = @_;
215
216 if ($self->[0] & MOVE_ALL) {
217 my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
218 $self->[0] &= $mask;
219 $self->[1] &= $mask;
220 }
221
222 $self->[1] &= $self->[0];
223
224 $self
225}
226
227sub Crossfire::MoveType::as_string {
228 my ($self) = @_;
229
230 my @res;
231
232 my ($mask, $value) = @$self;
233
234 for (@Crossfire::MOVE_TYPE) {
235 my $bit = $Crossfire::MOVE_TYPE{$_};
236 if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) {
237 $mask &= ~$bit;
238 push @res, $value & $bit ? $_ : "-$_";
239 }
240 }
241
242 join " ", @res
243}
131 244
132sub load_ref($) { 245sub load_ref($) {
133 my ($path) = @_; 246 my ($path) = @_;
134 247
135 open my $fh, "<", $path 248 open my $fh, "<:raw:perlio", $path
136 or die "$path: $!"; 249 or die "$path: $!";
137 binmode $fh;
138 local $/; 250 local $/;
139 251
140 thaw <$fh> 252 thaw <$fh>
141} 253}
142 254
143sub save_ref($$) { 255sub save_ref($$) {
144 my ($ref, $path) = @_; 256 my ($ref, $path) = @_;
145 257
146 open my $fh, ">", "$path~" 258 open my $fh, ">:raw:perlio", "$path~"
147 or die "$path~: $!"; 259 or die "$path~: $!";
148 binmode $fh;
149 print $fh freeze $ref; 260 print $fh freeze $ref;
150 close $fh; 261 close $fh;
151 rename "$path~", $path 262 rename "$path~", $path
152 or die "$path: $!"; 263 or die "$path: $!";
153} 264}
154 265
266my %attack_mask = (
267 physical => 0x00000001,
268 magic => 0x00000002,
269 fire => 0x00000004,
270 electricity => 0x00000008,
271 cold => 0x00000010,
272 confusion => 0x00000020,
273 acid => 0x00000040,
274 drain => 0x00000080,
275 weaponmagic => 0x00000100,
276 ghosthit => 0x00000200,
277 poison => 0x00000400,
278 slow => 0x00000800,
279 paralyze => 0x00001000,
280 turn_undead => 0x00002000,
281 fear => 0x00004000,
282 cancellation => 0x00008000,
283 deplete => 0x00010000,
284 death => 0x00020000,
285 chaos => 0x00040000,
286 counterspell => 0x00080000,
287 godpower => 0x00100000,
288 holyword => 0x00200000,
289 blind => 0x00400000,
290 internal => 0x00800000,
291 life_stealing => 0x01000000,
292 disease => 0x02000000,
293);
294
295sub _add_resist($$$) {
296 my ($ob, $mask, $value) = @_;
297
298 while (my ($k, $v) = each %attack_mask) {
299 $ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
300 }
301}
302
303my %MATERIAL = reverse
304 paper => 1,
305 iron => 2,
306 glass => 4,
307 leather => 8,
308 wood => 16,
309 organic => 32,
310 stone => 64,
311 cloth => 128,
312 adamant => 256,
313 liquid => 512,
314 tin => 1024,
315 bone => 2048,
316 ice => 4096,
317
318 # guesses
319 runestone => 12,
320 bronze => 18,
321 "ancient wood" => 20,
322 glass => 36,
323 marble => 66,
324 ice => 68,
325 stone => 70,
326 stone => 80,
327 cloth => 136,
328 ironwood => 144,
329 adamantium => 258,
330 glacium => 260,
331 blood => 544,
332;
333
155# object as in "Object xxx", i.e. archetypes 334# object as in "Object xxx", i.e. archetypes
156sub normalize_object($) { 335sub normalize_object($) {
157 my ($ob) = @_; 336 my ($ob) = @_;
158 337
338 # convert material bitset to materialname, if possible
339 if (exists $ob->{material}) {
340 if (!$ob->{material}) {
341 delete $ob->{material};
342 } elsif (exists $ob->{materialname}) {
343 if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
344 delete $ob->{material};
345 } else {
346 warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
347 delete $ob->{material}; # assume materilname is more specific and nuke material
348 }
349 } elsif (my $name = $MATERIAL{$ob->{material}}) {
350 delete $ob->{material};
351 $ob->{materialname} = $name;
352 } else {
353 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
354 }
355 }
356
159 # nuke outdated or never supported fields 357 # nuke outdated or never supported fields
160 delete $ob->{$_} for qw( 358 delete @$ob{qw(
161 can_knockback can_parry can_impale can_cut can_dam_armour 359 can_knockback can_parry can_impale can_cut can_dam_armour
162 can_apply pass_thru can_pass_thru 360 can_apply pass_thru can_pass_thru
163 ); 361 )};
362
363 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
364 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
365 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
164 366
165 # convert movement strings to bitsets 367 # convert movement strings to bitsets
166 for my $attr (keys %FIELD_MOVEMENT) { 368 for my $attr (keys %FIELD_MOVEMENT) {
167 next unless exists $ob->{$attr}; 369 next unless exists $ob->{$attr};
168 370
169 $ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility 371 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
170
171 next if $ob->{$attr} =~ /^\d+$/;
172
173 my $flags = 0;
174
175 # assume list
176 for my $flag (map lc, split /\s+/, $ob->{$attr}) {
177 $flags |= MOVE_WALK if $flag eq "walk";
178 $flags |= MOVE_FLY_LOW if $flag eq "fly_low";
179 $flags |= MOVE_FLY_HIGH if $flag eq "fly_high";
180 $flags |= MOVE_FLYING if $flag eq "flying";
181 $flags |= MOVE_SWIM if $flag eq "swim";
182 $flags |= MOVE_BOAT if $flag eq "boat";
183 $flags |= MOVE_ALL if $flag eq "all";
184
185 $flags &= ~MOVE_WALK if $flag eq "-walk";
186 $flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
187 $flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
188 $flags &= ~MOVE_FLYING if $flag eq "-flying";
189 $flags &= ~MOVE_SWIM if $flag eq "-swim";
190 $flags &= ~MOVE_BOAT if $flag eq "-boat";
191 $flags &= ~MOVE_ALL if $flag eq "-all";
192 }
193
194 $ob->{$attr} = $flags;
195 } 372 }
196 373
197 # convert outdated movement flags to new movement sets 374 # convert outdated movement flags to new movement sets
198 if (defined (my $v = delete $ob->{no_pass})) { 375 if (defined (my $v = delete $ob->{no_pass})) {
199 $ob->{move_block} = $v ? MOVE_ALL : 0; 376 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
200 } 377 }
201 if (defined (my $v = delete $ob->{slow_move})) { 378 if (defined (my $v = delete $ob->{slow_move})) {
202 $ob->{move_slow} |= MOVE_WALK; 379 $ob->{move_slow} += "walk";
203 $ob->{move_slow_penalty} = $v; 380 $ob->{move_slow_penalty} = $v;
204 } 381 }
205 if (defined (my $v = delete $ob->{walk_on})) { 382 if (defined (my $v = delete $ob->{walk_on})) {
206 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK 383 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
207 : $ob->{move_on} & ~MOVE_WALK;
208 } 384 }
209 if (defined (my $v = delete $ob->{walk_off})) { 385 if (defined (my $v = delete $ob->{walk_off})) {
210 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK 386 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
211 : $ob->{move_off} & ~MOVE_WALK;
212 } 387 }
213 if (defined (my $v = delete $ob->{fly_on})) { 388 if (defined (my $v = delete $ob->{fly_on})) {
214 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW 389 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
215 : $ob->{move_on} & ~MOVE_FLY_LOW;
216 } 390 }
217 if (defined (my $v = delete $ob->{fly_off})) { 391 if (defined (my $v = delete $ob->{fly_off})) {
218 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW 392 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
219 : $ob->{move_off} & ~MOVE_FLY_LOW;
220 } 393 }
221 if (defined (my $v = delete $ob->{flying})) { 394 if (defined (my $v = delete $ob->{flying})) {
222 $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW 395 $ob->{move_type} ||= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
223 : $ob->{move_type} & ~MOVE_FLY_LOW;
224 } 396 }
225 397
226 # convert idiotic event_xxx things into objects 398 # convert idiotic event_xxx things into objects
227 while (my ($event, $subtype) = each %EVENT_TYPE) { 399 while (my ($event, $subtype) = each %EVENT_TYPE) {
228 if (exists $ob->{"event_${event}_plugin"}) { 400 if (exists $ob->{"event_${event}_plugin"}) {
… …
232 slaying => delete $ob->{"event_${event}"}, 404 slaying => delete $ob->{"event_${event}"},
233 name => delete $ob->{"event_${event}_options"}, 405 name => delete $ob->{"event_${event}_options"},
234 }; 406 };
235 } 407 }
236 } 408 }
409
410 # some archetypes had "+3" instead of the canonical "3", so fix
411 $ob->{dam} *= 1 if exists $ob->{dam};
237 412
238 $ob 413 $ob
239} 414}
240 415
241# arch as in "arch xxx", ie.. objects 416# arch as in "arch xxx", ie.. objects
… …
283 } 458 }
284 459
285 $ob 460 $ob
286} 461}
287 462
463sub attr_thaw($) {
464 my ($ob) = @_;
465
466 $ob->{attach} = from_json $ob->{attach}
467 if exists $ob->{attach};
468
469 $ob
470}
471
472sub attr_freeze($) {
473 my ($ob) = @_;
474
475 $ob->{attach} = Crossfire::to_json $ob->{attach}
476 if exists $ob->{attach};
477
478 $ob
479}
480
288sub read_pak($) { 481sub read_pak($) {
289 my ($path) = @_; 482 my ($path) = @_;
290 483
291 my %pak; 484 my %pak;
292 485
293 open my $fh, "<", $path 486 open my $fh, "<:raw:perlio", $path
294 or Carp::croak "$_[0]: $!"; 487 or Carp::croak "$_[0]: $!";
295 binmode $fh; 488 binmode $fh;
296 while (<$fh>) { 489 while (<$fh>) {
297 my ($type, $id, $len, $path) = split; 490 my ($type, $id, $len, $path) = split;
298 $path =~ s/.*\///; 491 $path =~ s/.*\///;
… …
300 } 493 }
301 494
302 \%pak 495 \%pak
303} 496}
304 497
305sub read_arch($) { 498sub read_arch($;$) {
306 my ($path) = @_; 499 my ($path, $toplevel) = @_;
307 500
308 my %arc; 501 my %arc;
309 my ($more, $prev); 502 my ($more, $prev);
503 my $comment;
310 504
311 open my $fh, "<", $path 505 open my $fh, "<:raw:perlio:utf8", $path
312 or Carp::croak "$path: $!"; 506 or Carp::croak "$path: $!";
313 507
314 binmode $fh; 508# binmode $fh;
315 509
316 my $parse_block; $parse_block = sub { 510 my $parse_block; $parse_block = sub {
317 my %arc = @_; 511 my %arc = @_;
318 512
319 while (<$fh>) { 513 while (<$fh>) {
320 s/\s+$//; 514 s/\s+$//;
321 if (/^end$/i) { 515 if (/^end$/i) {
322 last; 516 last;
517
323 } elsif (/^arch (\S+)$/i) { 518 } elsif (/^arch (\S+)$/i) {
324 push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1); 519 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
520
325 } elsif (/^lore$/i) { 521 } elsif (/^lore$/i) {
326 while (<$fh>) { 522 while (<$fh>) {
327 last if /^endlore\s*$/i; 523 last if /^endlore\s*$/i;
328 $arc{lore} .= $_; 524 $arc{lore} .= $_;
329 } 525 }
330 } elsif (/^msg$/i) { 526 } elsif (/^msg$/i) {
331 while (<$fh>) { 527 while (<$fh>) {
332 last if /^endmsg\s*$/i; 528 last if /^endmsg\s*$/i;
333 $arc{msg} .= $_; 529 $arc{msg} .= $_;
334 } 530 }
531 } elsif (/^anim$/i) {
532 while (<$fh>) {
533 last if /^mina\s*$/i;
534 chomp;
535 push @{ $arc{anim} }, $_;
536 }
335 } elsif (/^(\S+)\s*(.*)$/) { 537 } elsif (/^(\S+)\s*(.*)$/) {
336 $arc{lc $1} = $2; 538 $arc{lc $1} = $2;
337 } elsif (/^\s*($|#)/) { 539 } elsif (/^\s*#/) {
540 $arc{_comment} .= "$_\n";
541
542 } elsif (/^\s*$/) {
338 # 543 #
339 } else { 544 } else {
340 warn "$path: unparsable line '$_' in arch $arc{_name}"; 545 warn "$path: unparsable line '$_' in arch $arc{_name}";
341 } 546 }
342 } 547 }
… …
348 s/\s+$//; 553 s/\s+$//;
349 if (/^more$/i) { 554 if (/^more$/i) {
350 $more = $prev; 555 $more = $prev;
351 } elsif (/^object (\S+)$/i) { 556 } elsif (/^object (\S+)$/i) {
352 my $name = $1; 557 my $name = $1;
353 my $arc = normalize_object $parse_block->(_name => $name); 558 my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
559 undef $comment;
560 delete $arc{_comment} unless length $arc{_comment};
561 $arc->{_atype} = 'object';
354 562
355 if ($more) { 563 if ($more) {
356 $more->{more} = $arc; 564 $more->{more} = $arc;
357 } else { 565 } else {
358 $arc{$name} = $arc; 566 $arc{$name} = $arc;
359 } 567 }
360 $prev = $arc; 568 $prev = $arc;
361 $more = undef; 569 $more = undef;
362 } elsif (/^arch (\S+)$/i) { 570 } elsif (/^arch (\S+)$/i) {
363 my $name = $1; 571 my $name = $1;
364 my $arc = normalize_arch $parse_block->(_name => $name); 572 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
573 undef $comment;
574 delete $arc{_comment} unless length $arc{_comment};
575 $arc->{_atype} = 'arch';
365 576
366 if ($more) { 577 if ($more) {
367 $more->{more} = $arc; 578 $more->{more} = $arc;
368 } else { 579 } else {
369 push @{ $arc{arch} }, $arc; 580 push @{ $arc{arch} }, $arc;
370 } 581 }
371 $prev = $arc; 582 $prev = $arc;
372 $more = undef; 583 $more = undef;
584 } elsif ($toplevel && /^(\S+)\s+(.*)$/) {
585 if ($1 eq "lev_array") {
586 while (<$fh>) {
587 last if /^endplst\s*$/;
588 push @{$toplevel->{lev_array}}, $_+0;
589 }
590 } else {
591 $toplevel->{$1} = $2;
592 }
593 } elsif (/^\s*#/) {
594 $comment .= "$_\n";
373 } elsif (/^\s*($|#)/) { 595 } elsif (/^\s*($|#)/) {
374 # 596 #
375 } else { 597 } else {
376 warn "$path: unparseable top-level line '$_'"; 598 die "$path: unparseable top-level line '$_'";
377 } 599 }
378 } 600 }
379 601
380 undef $parse_block; # work around bug in perl not freeing $fh etc. 602 undef $parse_block; # work around bug in perl not freeing $fh etc.
381 603
382 \%arc 604 \%arc
605}
606
607sub archlist_to_string {
608 my ($arch) = @_;
609
610 my $str;
611
612 my $append; $append = sub {
613 my %a = %{$_[0]};
614
615 Crossfire::attr_freeze \%a;
616 Crossfire::normalize_arch \%a;
617
618 # undo the bit-split we did before
619 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
620 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
621 | (delete $a{attack_movement_bits_4_7});
622 }
623
624 if (my $comment = delete $a{_comment}) {
625 if ($comment =~ /[^\n\s#]/) {
626 $str .= $comment;
627 }
628 }
629
630 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
631
632 my $inv = delete $a{inventory};
633 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
634 my $anim = delete $a{anim};
635
636 if ($a{_atype} eq 'object') {
637 $str .= join "\n", "anim", @$anim, "mina\n"
638 if $anim;
639 }
640
641 my @kv;
642
643 for ($a{_name} eq "map"
644 ? @Crossfire::FIELD_ORDER_MAP
645 : @Crossfire::FIELD_ORDER) {
646 push @kv, [$_, delete $a{$_}]
647 if exists $a{$_};
648 }
649
650 for (sort keys %a) {
651 next if /^_/; # ignore our _-keys
652 push @kv, [$_, delete $a{$_}];
653 }
654
655 for (@kv) {
656 my ($k, $v) = @$_;
657
658 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
659 $v =~ s/\n$//;
660 $str .= "$k\n$v\n$end\n";
661 } else {
662 $str .= "$k $v\n";
663 }
664 }
665
666 if ($inv) {
667 $append->($_) for @$inv;
668 }
669
670 $str .= "end\n";
671
672 if ($a{_atype} eq 'object') {
673 if ($more) {
674 $str .= "more\n";
675 $append->($more) if $more;
676 } else {
677 $str .= "\n";
678 }
679 }
680 };
681
682 for (@$arch) {
683 $append->($_);
684 }
685
686 $str
383} 687}
384 688
385# put all archs into a hash with editor_face as it's key 689# put all archs into a hash with editor_face as it's key
386# NOTE: the arrays in the hash values are references to 690# NOTE: the arrays in the hash values are references to
387# the archs from $ARCH 691# the archs from $ARCH
… …
408 my ($a) = @_; 712 my ($a) = @_;
409 713
410 my $o = $ARCH{$a->{_name}} 714 my $o = $ARCH{$a->{_name}}
411 or return; 715 or return;
412 716
413 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"} 717 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"};
718 unless ($face) {
719 $face = $FACE{"blank.x11"}
414 or (warn "no face data found for arch '$a->{_name}'"), return; 720 or (warn "no face data found for arch '$a->{_name}'"), return;
721 }
415 722
416 if ($face->{w} > 1 || $face->{h} > 1) { 723 if ($face->{w} > 1 || $face->{h} > 1) {
417 # bigface 724 # bigface
418 return (0, 0, $face->{w} - 1, $face->{h} - 1); 725 return (0, 0, $face->{w} - 1, $face->{h} - 1);
419 726
… …
526 ]; 833 ];
527 834
528 $attr 835 $attr
529} 836}
530 837
531sub arch_edit_sections {
532# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
533# edit_type = 0;
534# else if (edit_type != 0) {
535# // all flags from 'check_type' must be unset in this arch because they get recalculated now
536# edit_type &= ~check_type;
537# }
538#
539# }
540# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
541# getAttributeValue("alive", defarch) == 1 &&
542# (getAttributeValue("monster", defarch) == 1 ||
543# getAttributeValue("generator", defarch) == 1)) {
544# // Monster: monsters/npcs/generators
545# edit_type |= IGUIConstants.TILE_EDIT_MONSTER;
546# }
547# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
548# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
549# // Walls
550# edit_type |= IGUIConstants.TILE_EDIT_WALL;
551# }
552# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
553# getAttributeValue("connected", defarch) != 0) {
554# // Connected Objects
555# edit_type |= IGUIConstants.TILE_EDIT_CONNECTED;
556# }
557# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
558# arch_type == 66 || arch_type == 41 || arch_type == 95) {
559# // Exit: teleporter/exit/trapdoors
560# edit_type |= IGUIConstants.TILE_EDIT_EXIT;
561# }
562# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
563# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 ||
564# arch_type == 5 || arch_type == 36 || arch_type == 60 ||
565# arch_type == 85 || arch_type == 111 || arch_type == 123 ||
566# arch_type == 124 || arch_type == 130)) {
567# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
568# edit_type |= IGUIConstants.TILE_EDIT_TREASURE;
569# }
570# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
571# arch_type == 20 || arch_type == 23 || arch_type == 26 ||
572# arch_type == 91 || arch_type == 21 || arch_type == 24) {
573# // Door: door/special door/gates + keys
574# edit_type |= IGUIConstants.TILE_EDIT_DOOR;
575# }
576# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
577# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
578# arch_type <= 16) || arch_type == 33 || arch_type == 34 ||
579# arch_type == 35 || arch_type == 39 || arch_type == 70 ||
580# arch_type == 87 || arch_type == 99 || arch_type == 100 ||
581# arch_type == 104 || arch_type == 109 || arch_type == 113 ||
582# arch_type == 122 || arch_type == 3)) {
583# // Equipment: weapons/armour/wands/rods
584# edit_type |= IGUIConstants.TILE_EDIT_EQUIP;
585# }
586#
587# return(edit_type);
588#
589#
590}
591
592sub cache_file($$&&) { 838sub cache_file($$&&) {
593 my ($src, $cache, $load, $create) = @_; 839 my ($src, $cache, $load, $create) = @_;
594 840
595 my ($size, $mtime) = (stat $src)[7,9] 841 my ($size, $mtime) = (stat $src)[7,9]
596 or Carp::croak "$src: $!"; 842 or Carp::croak "$src: $!";

Diff Legend

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