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.117 by root, Wed Dec 5 11:03:08 2007 UTC vs.
Revision 1.142 by root, Sat May 15 00:30:53 2010 UTC

1=head1 NAME 1=head1 NAME
2 2
3Crossfire - Crossfire maphandling 3Deliantra - Deliantra suppport module to read/write archetypes, maps etc.
4
5=over 4
4 6
5=cut 7=cut
6 8
7package Crossfire; 9package Deliantra;
8 10
9our $VERSION = '1.12'; 11our $VERSION = '1.30';
10 12
11use strict; 13use common::sense;
12 14
13use base 'Exporter'; 15use base 'Exporter';
14 16
15use Carp (); 17use Carp ();
16use File::Spec; 18use File::Spec;
… …
22 *ARCH $TILE *FACE *FACEDATA 24 *ARCH $TILE *FACE *FACEDATA
23 TILESIZE CACHESTRIDE 25 TILESIZE CACHESTRIDE
24 editor_archs arch_extents 26 editor_archs arch_extents
25); 27);
26 28
27use JSON::XS qw(from_json to_json); 29use JSON::XS qw(decode_json encode_json);
28 30
29our $LIB = $ENV{CROSSFIRE_LIBDIR}; 31our $LIB = $ENV{DELIANTRA_LIBDIR};
30 32
31our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" 33our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.deliantra"
32 : $ENV{AppData} ? "$ENV{APPDATA}/crossfire" 34 : $ENV{AppData} ? "$ENV{APPDATA}/deliantra"
33 : File::Spec->tmpdir . "/crossfire"; 35 : File::Spec->tmpdir . "/deliantra";
34 36
35mkdir $VARDIR, 0777; 37mkdir $VARDIR, 0777;
36 38
37sub TILESIZE (){ 32 } 39sub TILESIZE (){ 32 }
38sub CACHESTRIDE (){ 64 } 40sub CACHESTRIDE (){ 64 }
… …
54 56
55# same as in server save routine, to (hopefully) be compatible 57# same as in server save routine, to (hopefully) be compatible
56# to the other editors. 58# to the other editors.
57our @FIELD_ORDER_MAP = (qw( 59our @FIELD_ORDER_MAP = (qw(
58 file_format_version 60 file_format_version
59 name attach swap_time reset_timeout fixed_resettime difficulty region 61 name attach swap_time reset_timeout fixed_resettime difficulty
62 region music
60 shopitems shopgreed shopmin shopmax shoprace 63 shopitems shopgreed shopmin shopmax shoprace
61 darkness width height enter_x enter_y msg maplore 64 darkness width height enter_x enter_y msg maplore
62 unique template 65 unique template
63 outdoor temp pressure humid windspeed winddir sky nosmooth 66 outdoor temp pressure humid windspeed winddir sky nosmooth
64 tile_path_1 tile_path_2 tile_path_3 tile_path_4 67 tile_path_1 tile_path_2 tile_path_3 tile_path_4
… …
69 72
70 elevation 73 elevation
71 74
72 name name_pl custom_name attach title race 75 name name_pl custom_name attach title race
73 slaying skill msg lore other_arch 76 slaying skill msg lore other_arch
74 face animation is_animated 77 sound sound_destroy face animation is_animated
75 magicmap smoothlevel smoothface 78 magicmap smoothlevel smoothface
76 str dex con wis pow cha int 79 str dex con wis pow cha int
77 hp maxhp sp maxsp grace maxgrace 80 hp maxhp sp maxsp grace maxgrace
78 exp perm_exp expmul 81 exp perm_exp expmul
79 food dam luck wc ac x y speed speed_left move_state attack_movement 82 food dam luck wc ac x y speed speed_left move_state attack_movement
… …
151 boat => MOVE_BOAT, 154 boat => MOVE_BOAT,
152 ship => MOVE_SHIP, 155 ship => MOVE_SHIP,
153 all => MOVE_ALL, 156 all => MOVE_ALL,
154); 157);
155 158
156our @MOVE_TYPE = keys %MOVE_TYPE; 159our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat ship);
157 160
158{ 161{
159 package Crossfire::MoveType; 162 package Deliantra::MoveType;
160 163
161 use overload 164 use overload
162 '=' => sub { bless [@{$_[0]}], ref $_[0] }, 165 '=' => sub { bless [@{$_[0]}], ref $_[0] },
163 '""' => \&as_string, 166 '""' => \&as_string,
164 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef }, 167 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
168 '<=' => sub {
169 ($_[0][0] & $MOVE_TYPE{$_[1]}) == $MOVE_TYPE{$_[1]}
170 ? $_[0][1] & $MOVE_TYPE{$_[1]}
171 : undef
172 },
165 '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise }, 173 '+=' => 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 }, 174 '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
167 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise }, 175 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
168 'x=' => sub { 176 'x=' => sub { # toggle between off, + and -
169 my $cur = $_[0] >= $_[1]; 177 my $cur = $_[0] >= $_[1];
170 if (!defined $cur) { 178 if (!defined $cur) {
171 if ($_[0] >= "all") { 179 if ($_[0] >= "all") {
172 $_[0] -= $_[1]; 180 $_[0] -= $_[1];
173 } else { 181 } else {
… …
182 $_[0] 190 $_[0]
183 }, 191 },
184 'eq' => sub { "$_[0]" eq "$_[1]" }, 192 'eq' => sub { "$_[0]" eq "$_[1]" },
185 'ne' => sub { "$_[0]" ne "$_[1]" }, 193 'ne' => sub { "$_[0]" ne "$_[1]" },
186 ; 194 ;
187}
188 195
189sub Crossfire::MoveType::new { 196 sub TO_JSON {
197 $_[0][0]
198 }
199}
200
201sub Deliantra::MoveType::new {
190 my ($class, $string) = @_; 202 my ($class, $string) = @_;
191 203
192 my $mask; 204 my $mask;
193 my $value; 205 my $value;
194 206
… …
208 } 220 }
209 221
210 (bless [$mask, $value], $class)->normalise 222 (bless [$mask, $value], $class)->normalise
211} 223}
212 224
213sub Crossfire::MoveType::normalise { 225sub Deliantra::MoveType::normalise {
214 my ($self) = @_; 226 my ($self) = @_;
215 227
216 if ($self->[0] & MOVE_ALL) { 228 if ($self->[0] & MOVE_ALL) {
217 my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL); 229 my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
218 $self->[0] &= $mask; 230 $self->[0] &= $mask;
… …
222 $self->[1] &= $self->[0]; 234 $self->[1] &= $self->[0];
223 235
224 $self 236 $self
225} 237}
226 238
227sub Crossfire::MoveType::as_string { 239sub Deliantra::MoveType::as_string {
228 my ($self) = @_; 240 my ($self) = @_;
229 241
230 my @res; 242 my @res;
231 243
232 my ($mask, $value) = @$self; 244 my ($mask, $value) = @$self;
233 245
234 for (@Crossfire::MOVE_TYPE) { 246 for (@Deliantra::MOVE_TYPE) {
235 my $bit = $Crossfire::MOVE_TYPE{$_}; 247 my $bit = $Deliantra::MOVE_TYPE{$_};
236 if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) { 248 if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) {
237 $mask &= ~$bit; 249 $mask &= ~$bit;
238 push @res, $value & $bit ? $_ : "-$_"; 250 push @res, $value & $bit ? $_ : "-$_";
239 } 251 }
240 } 252 }
… …
333 345
334# object as in "Object xxx", i.e. archetypes 346# object as in "Object xxx", i.e. archetypes
335sub normalize_object($) { 347sub normalize_object($) {
336 my ($ob) = @_; 348 my ($ob) = @_;
337 349
350 delete $ob->{editable}; # deprecated
351
338 # convert material bitset to materialname, if possible 352 # convert material bitset to materialname, if possible
339 if (exists $ob->{material}) { 353 if (exists $ob->{material}) {
340 if (!$ob->{material}) { 354 if (!$ob->{material}) {
341 delete $ob->{material}; 355 delete $ob->{material};
342 } elsif (exists $ob->{materialname}) { 356 } elsif (exists $ob->{materialname}) {
… …
380 394
381 # convert movement strings to bitsets 395 # convert movement strings to bitsets
382 for my $attr (keys %FIELD_MOVEMENT) { 396 for my $attr (keys %FIELD_MOVEMENT) {
383 next unless exists $ob->{$attr}; 397 next unless exists $ob->{$attr};
384 398
385 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr}; 399 $ob->{$attr} = new Deliantra::MoveType $ob->{$attr};
386 } 400 }
387 401
388 # convert outdated movement flags to new movement sets 402 # convert outdated movement flags to new movement sets
389 if (defined (my $v = delete $ob->{no_pass})) { 403 if (defined (my $v = delete $ob->{no_pass})) {
390 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : ""; 404 $ob->{move_block} = new Deliantra::MoveType $v ? "all" : "0";
391 } 405 }
392 if (defined (my $v = delete $ob->{slow_move})) { 406 if (defined (my $v = delete $ob->{slow_move})) {
393 $ob->{move_slow} += "walk"; 407 $ob->{move_slow} += "walk";
394 $ob->{move_slow_penalty} = $v; 408 $ob->{move_slow_penalty} = $v;
395 } 409 }
396 if (defined (my $v = delete $ob->{walk_on})) { 410 if (defined (my $v = delete $ob->{walk_on})) {
397 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" } 411 $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
398 } 412 }
399 if (defined (my $v = delete $ob->{walk_off})) { 413 if (defined (my $v = delete $ob->{walk_off})) {
400 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" } 414 $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
401 } 415 }
402 if (defined (my $v = delete $ob->{fly_on})) { 416 if (defined (my $v = delete $ob->{fly_on})) {
403 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" } 417 $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
404 } 418 }
405 if (defined (my $v = delete $ob->{fly_off})) { 419 if (defined (my $v = delete $ob->{fly_off})) {
406 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" } 420 $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
407 } 421 }
408 if (defined (my $v = delete $ob->{flying})) { 422 if (defined (my $v = delete $ob->{flying})) {
409 $ob->{move_type} ||= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" } 423 $ob->{move_type} ||= new Deliantra::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
410 } 424 }
411 425
412 # convert idiotic event_xxx things into objects 426 # convert idiotic event_xxx things into objects
413 while (my ($event, $subtype) = each %EVENT_TYPE) { 427 while (my ($event, $subtype) = each %EVENT_TYPE) {
414 if (exists $ob->{"event_${event}_plugin"}) { 428 if (exists $ob->{"event_${event}_plugin"}) {
… …
430# arch as in "arch xxx", ie.. objects 444# arch as in "arch xxx", ie.. objects
431sub normalize_arch($) { 445sub normalize_arch($) {
432 my ($ob) = @_; 446 my ($ob) = @_;
433 447
434 normalize_object $ob; 448 normalize_object $ob;
449
450 return if $ob->{_atype} eq "object";
435 451
436 my $arch = $ARCH{$ob->{_name}} 452 my $arch = $ARCH{$ob->{_name}}
437 or (warn "$ob->{_name}: no such archetype", return $ob); 453 or (warn "$ob->{_name}: no such archetype", return $ob);
438 454
439 if ($arch->{type} == 22) { # map 455 if ($arch->{type} == 22) { # map
… …
475} 491}
476 492
477sub attr_thaw($) { 493sub attr_thaw($) {
478 my ($ob) = @_; 494 my ($ob) = @_;
479 495
480 $ob->{attach} = from_json $ob->{attach} 496 $ob->{attach} = decode_json $ob->{attach}
481 if exists $ob->{attach}; 497 if exists $ob->{attach};
482 498
483 $ob 499 $ob
484} 500}
485 501
486sub attr_freeze($) { 502sub attr_freeze($) {
487 my ($ob) = @_; 503 my ($ob) = @_;
488 504
489 $ob->{attach} = Crossfire::to_json $ob->{attach} 505 $ob->{attach} = JSON::XS->new->utf8->canonical->encode ($ob->{attach})
490 if exists $ob->{attach}; 506 if exists $ob->{attach};
491 507
492 $ob 508 $ob
493} 509}
494 510
… …
514 530
515 my %arc; 531 my %arc;
516 my ($more, $prev); 532 my ($more, $prev);
517 my $comment; 533 my $comment;
518 534
519 open my $fh, "<:raw:perlio:utf8", $path 535 open my $fh, "<:utf8", $path
520 or Carp::croak "$path: $!"; 536 or Carp::croak "$path: $!";
521 537
522# binmode $fh; 538# binmode $fh;
523 539
524 my $parse_block; $parse_block = sub { 540 my $parse_block; $parse_block = sub {
… …
624 my $str; 640 my $str;
625 641
626 my $append; $append = sub { 642 my $append; $append = sub {
627 my %a = %{$_[0]}; 643 my %a = %{$_[0]};
628 644
629 Crossfire::attr_freeze \%a; 645 Deliantra::attr_freeze \%a;
630 Crossfire::normalize_arch \%a; 646 Deliantra::normalize_arch \%a;
631 647
632 # undo the bit-split we did before 648 # undo the bit-split we did before
633 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) { 649 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
634 $a{attack_movement} = (delete $a{attack_movement_bits_0_3}) 650 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
635 | (delete $a{attack_movement_bits_4_7}); 651 | (delete $a{attack_movement_bits_4_7});
… …
653 } 669 }
654 670
655 my @kv; 671 my @kv;
656 672
657 for ($a{_name} eq "map" 673 for ($a{_name} eq "map"
658 ? @Crossfire::FIELD_ORDER_MAP 674 ? @Deliantra::FIELD_ORDER_MAP
659 : @Crossfire::FIELD_ORDER) { 675 : @Deliantra::FIELD_ORDER) {
660 push @kv, [$_, delete $a{$_}] 676 push @kv, [$_, delete $a{$_}]
661 if exists $a{$_}; 677 if exists $a{$_};
662 } 678 }
663 679
664 for (sort keys %a) { 680 for (sort keys %a) {
… …
667 } 683 }
668 684
669 for (@kv) { 685 for (@kv) {
670 my ($k, $v) = @$_; 686 my ($k, $v) = @$_;
671 687
672 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) { 688 if (my $end = $Deliantra::FIELD_MULTILINE{$k}) {
673 $v =~ s/\n$//; 689 $v =~ s/\n$//;
674 $str .= "$k\n$v\n$end\n"; 690 $str .= "$k\n$v\n$end\n";
675 } else { 691 } else {
676 $str .= "$k $v\n"; 692 $str .= "$k $v\n";
677 } 693 }
… …
773=cut 789=cut
774 790
775sub arch_attr($) { 791sub arch_attr($) {
776 my ($obj) = @_; 792 my ($obj) = @_;
777 793
778 require Crossfire::Data; 794 require Deliantra::Data;
779 795
780 my $root; 796 my $root;
781 my $attr = { }; 797 my $attr = { };
782 798
783 my $arch = $ARCH{ $obj->{_name} }; 799 my $arch = $ARCH{ $obj->{_name} };
784 my $type = $obj->{type} || $arch->{type}; 800 my $type = $obj->{type} || $arch->{type};
785 801
786 if ($type > 0) { 802 if ($type > 0) {
787 $root = $Crossfire::Data::ATTR{$type}; 803 $root = $Deliantra::Data::ATTR{$type};
788 } else { 804 } else {
789 my %a = (%$arch, %$obj); 805 my %a = (%$arch, %$obj);
790 806
791 if ($a{is_floor} && !$a{alive}) { 807 if ($a{is_floor} && !$a{alive}) {
792 $root = $Crossfire::Data::TYPE{Floor}; 808 $root = $Deliantra::Data::TYPE{Floor};
793 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) { 809 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
794 $root = $Crossfire::Data::TYPE{"Monster & NPC"}; 810 $root = $Deliantra::Data::TYPE{"Monster & NPC"};
795 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) { 811 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
796 $root = $Crossfire::Data::TYPE{Wall}; 812 $root = $Deliantra::Data::TYPE{Wall};
797 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) { 813 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
798 $root = $Crossfire::Data::TYPE{"Weak Wall"}; 814 $root = $Deliantra::Data::TYPE{"Weak Wall"};
799 } else { 815 } else {
800 $root = $Crossfire::Data::TYPE{Misc}; 816 $root = $Deliantra::Data::TYPE{Misc};
801 } 817 }
802 } 818 }
803 819
820 my (%ignore);
804 my @import = ($root); 821 my @import = ($root);
805
806 unshift @import, \%Crossfire::Data::DEFAULT_ATTR
807 unless $type == 116;
808 822
809 my (%ignore); 823 my @new_import;
810 my (@section_order, %section, @attr_order);
811
812 while (my $type = shift @import) { 824 while (my $type = shift @import) {
825 # first import everything we will need:
813 push @import, 826 push @import,
814 grep $_, 827 grep $_,
815 map $Crossfire::Data::TYPE{$_}, 828 map $Deliantra::Data::TYPE{$_},
816 @{$type->{import} || []}; 829 @{$type->{import} || []};
817 830
831 # and compute the ignored attributes
832 for (@{$type->{ignore} || []}) {
833 $ignore{$_}++ for ref $_ ? @$_ : $_;
834 }
835
836 push @new_import, $type;
837 }
838 (@import) = @new_import;
839
840 # then add defaults to the back of the list, so they are added
841 # as last resort.
842 push @import, \%Deliantra::Data::DEFAULT_ATTR
843 unless $type == 116;
844
845 my (@section_order, %section, @attr_order);
846
847 # @import = root, imported, default
848 while (my $type = pop @import) {
818 $attr->{$_} ||= $type->{$_} 849 $attr->{$_} ||= $type->{$_}
819 for qw(name desc use); 850 for qw(name desc use);
820
821 for (@{$type->{ignore} || []}) {
822 $ignore{$_}++ for ref $_ ? @$_ : $_;
823 }
824 851
825 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) { 852 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
826 my ($name, $attr) = @$_; 853 my ($name, $attr) = @$_;
827 push @section_order, $name; 854 push @section_order, $name;
828 for (@$attr) { 855 for (@$attr) {
829 my ($k, $v) = @$_; 856 my ($k, $v) = @$_;
830 push @attr_order, $k; 857 push @attr_order, $k;
831 $section{$name}{$k} ||= $v; 858 $section{$name}{$k} = $v; # overwrite, so that the root decides
832 }
833 } 859 }
860 }
861 }
862
863 # remove ignores for "root" type
864 for (
865 map @{$_->[1]}, # section attributes
866 [general => ($root->{attr} || [])],
867 @{$root->{section} || []}
868 ) {
869 my ($k, $v) = @$_;
870 # skip fixed attributes, if they are ignored thats fine
871 next if $v->{type} eq 'fixed';
872
873 delete $ignore{$k}; # if the attributes are defined explicitly they
874 # should NOT be ignored. ignore should mainly
875 # hit imported/inherited attributes.
834 } 876 }
835 877
836 $attr->{section} = [ 878 $attr->{section} = [
837 map !exists $section{$_} ? () : do { 879 map !exists $section{$_} ? () : do {
838 my $attr = delete $section{$_}; 880 my $attr = delete $section{$_};
… …
842 map exists $attr->{$_} && !$ignore{$_} 884 map exists $attr->{$_} && !$ignore{$_}
843 ? [$_ => delete $attr->{$_}] : (), 885 ? [$_ => delete $attr->{$_}] : (),
844 @attr_order 886 @attr_order
845 ] 887 ]
846 }, 888 },
847
848 exists $section{$_} ? [$_ => delete $section{$_}] : (), 889 exists $section{$_} ? [$_ => delete $section{$_}] : (),
849 @section_order 890 @section_order
850 ]; 891 ];
851 892
852 $attr 893 $attr
853} 894}
… …
981 1022
982 \%cache 1023 \%cache
983 }; 1024 };
984} 1025}
985 1026
1027=back
1028
986=head1 AUTHOR 1029=head1 AUTHOR
987 1030
988 Marc Lehmann <schmorp@schmorp.de> 1031 Marc Lehmann <schmorp@schmorp.de>
989 http://home.schmorp.de/ 1032 http://home.schmorp.de/
990 1033

Diff Legend

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