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.74 by root, Wed Sep 20 15:38:21 2006 UTC vs.
Revision 1.82 by root, Tue Feb 6 23:53:26 2007 UTC

… …
4 4
5=cut 5=cut
6 6
7package Crossfire; 7package Crossfire;
8 8
9our $VERSION = '0.91'; 9our $VERSION = '0.96';
10 10
11use strict; 11use strict;
12 12
13use base 'Exporter'; 13use base 'Exporter';
14 14
… …
33 JSON::Syck::Dump $_[0] 33 JSON::Syck::Dump $_[0]
34} 34}
35 35
36our $LIB = $ENV{CROSSFIRE_LIBDIR}; 36our $LIB = $ENV{CROSSFIRE_LIBDIR};
37 37
38our $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";
39 41
40mkdir $VARDIR, 0777; 42mkdir $VARDIR, 0777;
41 43
42sub TILESIZE (){ 32 } 44sub TILESIZE (){ 32 }
43 45
… …
197 while (my ($k, $v) = each %attack_mask) { 199 while (my ($k, $v) = each %attack_mask) {
198 $ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v; 200 $ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
199 } 201 }
200} 202}
201 203
204my %MATERIAL = reverse
205 paper => 1,
206 iron => 2,
207 glass => 4,
208 leather => 8,
209 wood => 16,
210 organic => 32,
211 stone => 64,
212 cloth => 128,
213 adamant => 256,
214 liquid => 512,
215 tin => 1024,
216 bone => 2048,
217 ice => 4096,
218;
219
202# object as in "Object xxx", i.e. archetypes 220# object as in "Object xxx", i.e. archetypes
203sub normalize_object($) { 221sub normalize_object($) {
204 my ($ob) = @_; 222 my ($ob) = @_;
223
224 # convert material bitset to materialname, if possible
225 if (exists $ob->{material}) {
226 if (!$ob->{material}) {
227 delete $ob->{material};
228 } elsif (exists $ob->{materialname}) {
229 if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
230 delete $ob->{material};
231 } else {
232 warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
233 delete $ob->{material}; # assume materilname is more specific and nuke material
234 }
235 } else {
236 if (my $name = $MATERIAL{$ob->{material}}) {
237 delete $ob->{material};
238 $ob->{materialname} = $name;
239 }
240 }
241 }
205 242
206 # nuke outdated or never supported fields 243 # nuke outdated or never supported fields
207 delete @$ob{qw( 244 delete @$ob{qw(
208 can_knockback can_parry can_impale can_cut can_dam_armour 245 can_knockback can_parry can_impale can_cut can_dam_armour
209 can_apply pass_thru can_pass_thru 246 can_apply pass_thru can_pass_thru
… …
382sub read_arch($;$) { 419sub read_arch($;$) {
383 my ($path, $toplevel) = @_; 420 my ($path, $toplevel) = @_;
384 421
385 my %arc; 422 my %arc;
386 my ($more, $prev); 423 my ($more, $prev);
424 my $comment;
387 425
388 open my $fh, "<:raw:perlio:utf8", $path 426 open my $fh, "<:raw:perlio:utf8", $path
389 or Carp::croak "$path: $!"; 427 or Carp::croak "$path: $!";
390 428
391# binmode $fh; 429# binmode $fh;
… …
395 433
396 while (<$fh>) { 434 while (<$fh>) {
397 s/\s+$//; 435 s/\s+$//;
398 if (/^end$/i) { 436 if (/^end$/i) {
399 last; 437 last;
438
400 } elsif (/^arch (\S+)$/i) { 439 } elsif (/^arch (\S+)$/i) {
401 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1); 440 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
441
402 } elsif (/^lore$/i) { 442 } elsif (/^lore$/i) {
403 while (<$fh>) { 443 while (<$fh>) {
404 last if /^endlore\s*$/i; 444 last if /^endlore\s*$/i;
405 $arc{lore} .= $_; 445 $arc{lore} .= $_;
406 } 446 }
… …
415 chomp; 455 chomp;
416 push @{ $arc{anim} }, $_; 456 push @{ $arc{anim} }, $_;
417 } 457 }
418 } elsif (/^(\S+)\s*(.*)$/) { 458 } elsif (/^(\S+)\s*(.*)$/) {
419 $arc{lc $1} = $2; 459 $arc{lc $1} = $2;
420 } elsif (/^\s*($|#)/) { 460 } elsif (/^\s*#/) {
461 $arc{_comment} .= "$_\n";
462
463 } elsif (/^\s*$/) {
421 # 464 #
422 } else { 465 } else {
423 warn "$path: unparsable line '$_' in arch $arc{_name}"; 466 warn "$path: unparsable line '$_' in arch $arc{_name}";
424 } 467 }
425 } 468 }
… …
431 s/\s+$//; 474 s/\s+$//;
432 if (/^more$/i) { 475 if (/^more$/i) {
433 $more = $prev; 476 $more = $prev;
434 } elsif (/^object (\S+)$/i) { 477 } elsif (/^object (\S+)$/i) {
435 my $name = $1; 478 my $name = $1;
436 my $arc = attr_thaw normalize_object $parse_block->(_name => $name); 479 my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
480 undef $comment;
481 delete $arc{_comment} unless length $arc{_comment};
437 $arc->{_atype} = 'object'; 482 $arc->{_atype} = 'object';
438 483
439 if ($more) { 484 if ($more) {
440 $more->{more} = $arc; 485 $more->{more} = $arc;
441 } else { 486 } else {
… …
443 } 488 }
444 $prev = $arc; 489 $prev = $arc;
445 $more = undef; 490 $more = undef;
446 } elsif (/^arch (\S+)$/i) { 491 } elsif (/^arch (\S+)$/i) {
447 my $name = $1; 492 my $name = $1;
448 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name); 493 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
494 undef $comment;
495 delete $arc{_comment} unless length $arc{_comment};
449 $arc->{_atype} = 'arch'; 496 $arc->{_atype} = 'arch';
450 497
451 if ($more) { 498 if ($more) {
452 $more->{more} = $arc; 499 $more->{more} = $arc;
453 } else { 500 } else {
… …
462 push @{$toplevel->{lev_array}}, $_+0; 509 push @{$toplevel->{lev_array}}, $_+0;
463 } 510 }
464 } else { 511 } else {
465 $toplevel->{$1} = $2; 512 $toplevel->{$1} = $2;
466 } 513 }
514 } elsif (/^\s*#/) {
515 $comment .= "$_\n";
467 } elsif (/^\s*($|#)/) { 516 } elsif (/^\s*($|#)/) {
468 # 517 #
469 } else { 518 } else {
470 die "$path: unparseable top-level line '$_'"; 519 die "$path: unparseable top-level line '$_'";
471 } 520 }
… …
491 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) { 540 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
492 $a{attack_movement} = (delete $a{attack_movement_bits_0_3}) 541 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
493 | (delete $a{attack_movement_bits_4_7}); 542 | (delete $a{attack_movement_bits_4_7});
494 } 543 }
495 544
545 if (my $comment = delete $a{_comment}) {
546 if ($comment =~ /[^\n\s#]/) {
547 $str .= $comment;
548 }
549 }
550
496 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n"; 551 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
497 552
498 my $inv = delete $a{inventory}; 553 my $inv = delete $a{inventory};
499 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some 554 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
500 my $anim = delete $a{anim}; 555 my $anim = delete $a{anim};
501 556
502 my @kv; 557 my @kv;
503 558
… …
559 if $anim; 614 if $anim;
560 } 615 }
561 616
562 $str .= "end\n"; 617 $str .= "end\n";
563 618
564 if (($a{_atype} eq 'object') && $more) { 619 if ($a{_atype} eq 'object') {
620 if ($more) {
565 $str .= "\nmore\n"; 621 $str .= "more\n";
566 $append->($more) if $more; 622 $append->($more) if $more;
623 } else {
624 $str .= "\n";
625 }
567 } 626 }
568 }; 627 };
569 628
570 for (@$arch) { 629 for (@$arch) {
571 $append->($_); 630 $append->($_);
… …
600 my ($a) = @_; 659 my ($a) = @_;
601 660
602 my $o = $ARCH{$a->{_name}} 661 my $o = $ARCH{$a->{_name}}
603 or return; 662 or return;
604 663
605 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"} 664 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"};
665 unless ($face) {
666 $face = $FACE{"blank.x11"}
606 or (warn "no face data found for arch '$a->{_name}'"), return; 667 or (warn "no face data found for arch '$a->{_name}'"), return;
668 }
607 669
608 if ($face->{w} > 1 || $face->{h} > 1) { 670 if ($face->{w} > 1 || $face->{h} > 1) {
609 # bigface 671 # bigface
610 return (0, 0, $face->{w} - 1, $face->{h} - 1); 672 return (0, 0, $face->{w} - 1, $face->{h} - 1);
611 673

Diff Legend

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