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.60 by root, Mon Mar 27 17:23:35 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
… …
102 117
103 body_range body_arm body_torso body_head body_neck body_skill 118 body_range body_arm body_torso body_head body_neck body_skill
104 body_finger body_shoulder body_foot body_hand body_wrist body_waist 119 body_finger body_shoulder body_foot body_hand body_wrist body_waist
105)); 120));
106 121
122our %EVENT_TYPE = (
123 apply => 1,
124 attack => 2,
125 death => 3,
126 drop => 4,
127 pickup => 5,
128 say => 6,
129 stop => 7,
130 time => 8,
131 throw => 9,
132 trigger => 10,
133 close => 11,
134 timer => 12,
135);
136
107sub MOVE_WALK (){ 0x01 } 137sub MOVE_WALK (){ 0x01 }
108sub MOVE_FLY_LOW (){ 0x02 } 138sub MOVE_FLY_LOW (){ 0x02 }
109sub MOVE_FLY_HIGH (){ 0x04 } 139sub MOVE_FLY_HIGH (){ 0x04 }
110sub MOVE_FLYING (){ 0x06 } 140sub MOVE_FLYING (){ 0x06 }
111sub MOVE_SWIM (){ 0x08 } 141sub MOVE_SWIM (){ 0x08 }
112sub MOVE_BOAT (){ 0x10 } 142sub MOVE_BOAT (){ 0x10 }
113sub MOVE_KNOWN (){ 0x1f } # all of above 143sub MOVE_KNOWN (){ 0x1f } # all of above
114sub MOVE_ALLBIT (){ 0x10000 }
115sub 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}
116 232
117sub load_ref($) { 233sub load_ref($) {
118 my ($path) = @_; 234 my ($path) = @_;
119 235
120 open my $fh, "<", $path 236 open my $fh, "<:raw:perlio", $path
121 or die "$path: $!"; 237 or die "$path: $!";
122 binmode $fh;
123 local $/; 238 local $/;
124 239
125 thaw <$fh> 240 thaw <$fh>
126} 241}
127 242
128sub save_ref($$) { 243sub save_ref($$) {
129 my ($ref, $path) = @_; 244 my ($ref, $path) = @_;
130 245
131 open my $fh, ">", "$path~" 246 open my $fh, ">:raw:perlio", "$path~"
132 or die "$path~: $!"; 247 or die "$path~: $!";
133 binmode $fh;
134 print $fh freeze $ref; 248 print $fh freeze $ref;
135 close $fh; 249 close $fh;
136 rename "$path~", $path 250 rename "$path~", $path
137 or die "$path: $!"; 251 or die "$path: $!";
138} 252}
139 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
322# object as in "Object xxx", i.e. archetypes
140sub normalize_object($) { 323sub normalize_object($) {
141 my ($ob) = @_; 324 my ($ob) = @_;
142 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
345 # nuke outdated or never supported fields
143 delete $ob->{$_} for qw( 346 delete @$ob{qw(
144 can_knockback can_parry can_impale can_cut can_dam_armour 347 can_knockback can_parry can_impale can_cut can_dam_armour
145 can_apply pass_thru can_pass_thru 348 can_apply pass_thru can_pass_thru
146 ); 349 )};
147 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; }
354
355 # convert movement strings to bitsets
148 for my $attr (keys %FIELD_MOVEMENT) { 356 for my $attr (keys %FIELD_MOVEMENT) {
149 next unless exists $ob->{$attr}; 357 next unless exists $ob->{$attr};
150 358
151 $ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility 359 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
152
153 next if $ob->{$attr} =~ /^\d+$/;
154
155 my $flags = 0;
156
157 # assume list
158 for my $flag (map lc, split /\s+/, $ob->{$attr}) {
159 $flags |= MOVE_WALK if $flag eq "walk";
160 $flags |= MOVE_FLY_LOW if $flag eq "fly_low";
161 $flags |= MOVE_FLY_HIGH if $flag eq "fly_high";
162 $flags |= MOVE_FLYING if $flag eq "flying";
163 $flags |= MOVE_SWIM if $flag eq "swim";
164 $flags |= MOVE_BOAT if $flag eq "boat";
165 $flags |= MOVE_ALL if $flag eq "all";
166
167 $flags &= ~MOVE_WALK if $flag eq "-walk";
168 $flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
169 $flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
170 $flags &= ~MOVE_FLYING if $flag eq "-flying";
171 $flags &= ~MOVE_SWIM if $flag eq "-swim";
172 $flags &= ~MOVE_BOAT if $flag eq "-boat";
173 $flags &= ~MOVE_ALL if $flag eq "-all";
174 }
175
176 $ob->{$attr} = $flags;
177 } 360 }
178 361
362 # convert outdated movement flags to new movement sets
179 if (defined (my $v = delete $ob->{no_pass})) { 363 if (defined (my $v = delete $ob->{no_pass})) {
180 $ob->{move_block} = $v ? MOVE_ALL : 0; 364 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
181 } 365 }
182 if (defined (my $v = delete $ob->{slow_move})) { 366 if (defined (my $v = delete $ob->{slow_move})) {
183 $ob->{move_slow} |= MOVE_WALK; 367 $ob->{move_slow} += "walk";
184 $ob->{move_slow_penalty} = $v; 368 $ob->{move_slow_penalty} = $v;
185 } 369 }
186 if (defined (my $v = delete $ob->{walk_on})) { 370 if (defined (my $v = delete $ob->{walk_on})) {
187 $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" }
188 : $ob->{move_on} & ~MOVE_WALK;
189 } 372 }
190 if (defined (my $v = delete $ob->{walk_off})) { 373 if (defined (my $v = delete $ob->{walk_off})) {
191 $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" }
192 : $ob->{move_off} & ~MOVE_WALK;
193 } 375 }
194 if (defined (my $v = delete $ob->{fly_on})) { 376 if (defined (my $v = delete $ob->{fly_on})) {
195 $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" }
196 : $ob->{move_on} & ~MOVE_FLY_LOW;
197 } 378 }
198 if (defined (my $v = delete $ob->{fly_off})) { 379 if (defined (my $v = delete $ob->{fly_off})) {
199 $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" }
200 : $ob->{move_off} & ~MOVE_FLY_LOW;
201 } 381 }
202 if (defined (my $v = delete $ob->{flying})) { 382 if (defined (my $v = delete $ob->{flying})) {
203 $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" }
204 : $ob->{move_type} & ~MOVE_FLY_LOW;
205 } 384 }
385
386 # convert idiotic event_xxx things into objects
387 while (my ($event, $subtype) = each %EVENT_TYPE) {
388 if (exists $ob->{"event_${event}_plugin"}) {
389 push @{$ob->{inventory}}, {
390 _name => "event_$event",
391 title => delete $ob->{"event_${event}_plugin"},
392 slaying => delete $ob->{"event_${event}"},
393 name => delete $ob->{"event_${event}_options"},
394 };
395 }
396 }
397
398 # some archetypes had "+3" instead of the canonical "3", so fix
399 $ob->{dam} *= 1 if exists $ob->{dam};
206 400
207 $ob 401 $ob
208} 402}
209 403
404# arch as in "arch xxx", ie.. objects
210sub normalize_arch($) { 405sub normalize_arch($) {
211 my ($ob) = @_; 406 my ($ob) = @_;
212 407
213 normalize_object $ob; 408 normalize_object $ob;
214 409
… …
251 } 446 }
252 447
253 $ob 448 $ob
254} 449}
255 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
256sub read_pak($) { 469sub read_pak($) {
257 my ($path) = @_; 470 my ($path) = @_;
258 471
259 my %pak; 472 my %pak;
260 473
261 open my $fh, "<", $path 474 open my $fh, "<:raw:perlio", $path
262 or Carp::croak "$_[0]: $!"; 475 or Carp::croak "$_[0]: $!";
263 binmode $fh; 476 binmode $fh;
264 while (<$fh>) { 477 while (<$fh>) {
265 my ($type, $id, $len, $path) = split; 478 my ($type, $id, $len, $path) = split;
266 $path =~ s/.*\///; 479 $path =~ s/.*\///;
… …
268 } 481 }
269 482
270 \%pak 483 \%pak
271} 484}
272 485
273sub read_arch($) { 486sub read_arch($;$) {
274 my ($path) = @_; 487 my ($path, $toplevel) = @_;
275 488
276 my %arc; 489 my %arc;
277 my ($more, $prev); 490 my ($more, $prev);
491 my $comment;
278 492
279 open my $fh, "<", $path 493 open my $fh, "<:raw:perlio:utf8", $path
280 or Carp::croak "$path: $!"; 494 or Carp::croak "$path: $!";
281 495
282 binmode $fh; 496# binmode $fh;
283 497
284 my $parse_block; $parse_block = sub { 498 my $parse_block; $parse_block = sub {
285 my %arc = @_; 499 my %arc = @_;
286 500
287 while (<$fh>) { 501 while (<$fh>) {
288 s/\s+$//; 502 s/\s+$//;
289 if (/^end$/i) { 503 if (/^end$/i) {
290 last; 504 last;
505
291 } elsif (/^arch (\S+)$/i) { 506 } elsif (/^arch (\S+)$/i) {
292 push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1); 507 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
508
293 } elsif (/^lore$/i) { 509 } elsif (/^lore$/i) {
294 while (<$fh>) { 510 while (<$fh>) {
295 last if /^endlore\s*$/i; 511 last if /^endlore\s*$/i;
296 $arc{lore} .= $_; 512 $arc{lore} .= $_;
297 } 513 }
298 } elsif (/^msg$/i) { 514 } elsif (/^msg$/i) {
299 while (<$fh>) { 515 while (<$fh>) {
300 last if /^endmsg\s*$/i; 516 last if /^endmsg\s*$/i;
301 $arc{msg} .= $_; 517 $arc{msg} .= $_;
302 } 518 }
519 } elsif (/^anim$/i) {
520 while (<$fh>) {
521 last if /^mina\s*$/i;
522 chomp;
523 push @{ $arc{anim} }, $_;
524 }
303 } elsif (/^(\S+)\s*(.*)$/) { 525 } elsif (/^(\S+)\s*(.*)$/) {
304 $arc{lc $1} = $2; 526 $arc{lc $1} = $2;
305 } elsif (/^\s*($|#)/) { 527 } elsif (/^\s*#/) {
528 $arc{_comment} .= "$_\n";
529
530 } elsif (/^\s*$/) {
306 # 531 #
307 } else { 532 } else {
308 warn "$path: unparsable line '$_' in arch $arc{_name}"; 533 warn "$path: unparsable line '$_' in arch $arc{_name}";
309 } 534 }
310 } 535 }
… …
316 s/\s+$//; 541 s/\s+$//;
317 if (/^more$/i) { 542 if (/^more$/i) {
318 $more = $prev; 543 $more = $prev;
319 } elsif (/^object (\S+)$/i) { 544 } elsif (/^object (\S+)$/i) {
320 my $name = $1; 545 my $name = $1;
321 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';
322 550
323 if ($more) { 551 if ($more) {
324 $more->{more} = $arc; 552 $more->{more} = $arc;
325 } else { 553 } else {
326 $arc{$name} = $arc; 554 $arc{$name} = $arc;
327 } 555 }
328 $prev = $arc; 556 $prev = $arc;
329 $more = undef; 557 $more = undef;
330 } elsif (/^arch (\S+)$/i) { 558 } elsif (/^arch (\S+)$/i) {
331 my $name = $1; 559 my $name = $1;
332 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';
333 564
334 if ($more) { 565 if ($more) {
335 $more->{more} = $arc; 566 $more->{more} = $arc;
336 } else { 567 } else {
337 push @{ $arc{arch} }, $arc; 568 push @{ $arc{arch} }, $arc;
338 } 569 }
339 $prev = $arc; 570 $prev = $arc;
340 $more = undef; 571 $more = undef;
572 } elsif ($toplevel && /^(\S+)\s+(.*)$/) {
573 if ($1 eq "lev_array") {
574 while (<$fh>) {
575 last if /^endplst\s*$/;
576 push @{$toplevel->{lev_array}}, $_+0;
577 }
578 } else {
579 $toplevel->{$1} = $2;
580 }
581 } elsif (/^\s*#/) {
582 $comment .= "$_\n";
341 } elsif (/^\s*($|#)/) { 583 } elsif (/^\s*($|#)/) {
342 # 584 #
343 } else { 585 } else {
344 warn "$path: unparseable top-level line '$_'"; 586 die "$path: unparseable top-level line '$_'";
345 } 587 }
346 } 588 }
347 589
348 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.
349 591
350 \%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
351} 675}
352 676
353# 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
354# NOTE: the arrays in the hash values are references to 678# NOTE: the arrays in the hash values are references to
355# the archs from $ARCH 679# the archs from $ARCH
356sub editor_archs { 680sub editor_archs {
357 my %paths; 681 my %paths;
358 682
359 for (keys %ARCH) { 683 for (keys %ARCH) {
360 my $arch = $ARCH{$_}; 684 my $arch = $ARCH{$_};
361 push @{$paths{$arch->{editor_folder}}}, \$arch; 685 push @{$paths{$arch->{editor_folder}}}, $arch;
362 } 686 }
363 687
364 \%paths 688 \%paths
365} 689}
366 690
… …
376 my ($a) = @_; 700 my ($a) = @_;
377 701
378 my $o = $ARCH{$a->{_name}} 702 my $o = $ARCH{$a->{_name}}
379 or return; 703 or return;
380 704
381 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"}
382 or (warn "no face data found for arch '$a->{_name}'"), return; 708 or (warn "no face data found for arch '$a->{_name}'"), return;
709 }
383 710
384 if ($face->{w} > 1 || $face->{h} > 1) { 711 if ($face->{w} > 1 || $face->{h} > 1) {
385 # bigface 712 # bigface
386 return (0, 0, $face->{w} - 1, $face->{h} - 1); 713 return (0, 0, $face->{w} - 1, $face->{h} - 1);
387 714
… …
431 my $type = $obj->{type} || $arch->{type}; 758 my $type = $obj->{type} || $arch->{type};
432 759
433 if ($type > 0) { 760 if ($type > 0) {
434 $root = $Crossfire::Data::ATTR{$type}; 761 $root = $Crossfire::Data::ATTR{$type};
435 } else { 762 } else {
763 my %a = (%$arch, %$obj);
764
765 if ($a{is_floor} && !$a{alive}) {
766 $root = $Crossfire::Data::TYPE{Floor};
767 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
768 $root = $Crossfire::Data::TYPE{"Monster & NPC"};
769 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
770 $root = $Crossfire::Data::TYPE{Wall};
771 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
772 $root = $Crossfire::Data::TYPE{"Weak Wall"};
773 } else {
436 $root = $Crossfire::Data::TYPE{Misc}; 774 $root = $Crossfire::Data::TYPE{Misc};
437
438 type:
439 for (@Crossfire::Data::ATTR0) {
440 my $req = $_->{required}
441 or die "internal error: ATTR0 without 'required'";
442
443 keys %$req;
444 while (my ($k, $v) = each %$req) {
445 next type
446 unless $obj->{$k} == $v || $arch->{$k} == $v;
447 }
448
449 $root = $_;
450 } 775 }
451 } 776 }
452 777
453 my @import = ($root); 778 my @import = ($root);
454 779
… …
496 ]; 821 ];
497 822
498 $attr 823 $attr
499} 824}
500 825
501sub arch_edit_sections {
502# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
503# edit_type = 0;
504# else if (edit_type != 0) {
505# // all flags from 'check_type' must be unset in this arch because they get recalculated now
506# edit_type &= ~check_type;
507# }
508#
509# }
510# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
511# getAttributeValue("alive", defarch) == 1 &&
512# (getAttributeValue("monster", defarch) == 1 ||
513# getAttributeValue("generator", defarch) == 1)) {
514# // Monster: monsters/npcs/generators
515# edit_type |= IGUIConstants.TILE_EDIT_MONSTER;
516# }
517# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
518# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
519# // Walls
520# edit_type |= IGUIConstants.TILE_EDIT_WALL;
521# }
522# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
523# getAttributeValue("connected", defarch) != 0) {
524# // Connected Objects
525# edit_type |= IGUIConstants.TILE_EDIT_CONNECTED;
526# }
527# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
528# arch_type == 66 || arch_type == 41 || arch_type == 95) {
529# // Exit: teleporter/exit/trapdoors
530# edit_type |= IGUIConstants.TILE_EDIT_EXIT;
531# }
532# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
533# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 ||
534# arch_type == 5 || arch_type == 36 || arch_type == 60 ||
535# arch_type == 85 || arch_type == 111 || arch_type == 123 ||
536# arch_type == 124 || arch_type == 130)) {
537# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
538# edit_type |= IGUIConstants.TILE_EDIT_TREASURE;
539# }
540# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
541# arch_type == 20 || arch_type == 23 || arch_type == 26 ||
542# arch_type == 91 || arch_type == 21 || arch_type == 24) {
543# // Door: door/special door/gates + keys
544# edit_type |= IGUIConstants.TILE_EDIT_DOOR;
545# }
546# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
547# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
548# arch_type <= 16) || arch_type == 33 || arch_type == 34 ||
549# arch_type == 35 || arch_type == 39 || arch_type == 70 ||
550# arch_type == 87 || arch_type == 99 || arch_type == 100 ||
551# arch_type == 104 || arch_type == 109 || arch_type == 113 ||
552# arch_type == 122 || arch_type == 3)) {
553# // Equipment: weapons/armour/wands/rods
554# edit_type |= IGUIConstants.TILE_EDIT_EQUIP;
555# }
556#
557# return(edit_type);
558#
559#
560}
561
562sub cache_file($$&&) { 826sub cache_file($$&&) {
563 my ($src, $cache, $load, $create) = @_; 827 my ($src, $cache, $load, $create) = @_;
564 828
565 my ($size, $mtime) = (stat $src)[7,9] 829 my ($size, $mtime) = (stat $src)[7,9]
566 or Carp::croak "$src: $!"; 830 or Carp::croak "$src: $!";

Diff Legend

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