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.131 by root, Tue Sep 1 21:37:25 2009 UTC vs.
Revision 1.140 by elmex, Fri Mar 19 23:11:43 2010 UTC

1=head1 NAME 1=head1 NAME
2 2
3Deliantra - Deliantra suppport module to read/write archetypes, maps etc. 3Deliantra - Deliantra suppport module to read/write archetypes, maps etc.
4 4
5=over 4
6
5=cut 7=cut
6 8
7package Deliantra; 9package Deliantra;
8 10
9our $VERSION = '1.24'; 11our $VERSION = '1.29';
10 12
11use common::sense; 13use common::sense;
12 14
13use base 'Exporter'; 15use base 'Exporter';
14 16
… …
151 boat => MOVE_BOAT, 153 boat => MOVE_BOAT,
152 ship => MOVE_SHIP, 154 ship => MOVE_SHIP,
153 all => MOVE_ALL, 155 all => MOVE_ALL,
154); 156);
155 157
156our @MOVE_TYPE = qw(all ship boat swim flying fly_high fly_low walk); 158our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat ship);
157 159
158{ 160{
159 package Deliantra::MoveType; 161 package Deliantra::MoveType;
160 162
161 use overload 163 use overload
162 '=' => sub { bless [@{$_[0]}], ref $_[0] }, 164 '=' => sub { bless [@{$_[0]}], ref $_[0] },
163 '""' => \&as_string, 165 '""' => \&as_string,
164 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef }, 166 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
167 '<=' => sub {
168 ($_[0][0] & $MOVE_TYPE{$_[1]}) == $MOVE_TYPE{$_[1]}
169 ? $_[0][1] & $MOVE_TYPE{$_[1]}
170 : undef
171 },
165 '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise }, 172 '+=' => 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 }, 173 '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
167 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise }, 174 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
168 'x=' => sub { 175 'x=' => sub { # toggle between off, + and -
169 my $cur = $_[0] >= $_[1]; 176 my $cur = $_[0] >= $_[1];
170 if (!defined $cur) { 177 if (!defined $cur) {
171 if ($_[0] >= "all") { 178 if ($_[0] >= "all") {
172 $_[0] -= $_[1]; 179 $_[0] -= $_[1];
173 } else { 180 } else {
… …
337 344
338# object as in "Object xxx", i.e. archetypes 345# object as in "Object xxx", i.e. archetypes
339sub normalize_object($) { 346sub normalize_object($) {
340 my ($ob) = @_; 347 my ($ob) = @_;
341 348
349 delete $ob->{editable}; # deprecated
350
342 # convert material bitset to materialname, if possible 351 # convert material bitset to materialname, if possible
343 if (exists $ob->{material}) { 352 if (exists $ob->{material}) {
344 if (!$ob->{material}) { 353 if (!$ob->{material}) {
345 delete $ob->{material}; 354 delete $ob->{material};
346 } elsif (exists $ob->{materialname}) { 355 } elsif (exists $ob->{materialname}) {
… …
389 $ob->{$attr} = new Deliantra::MoveType $ob->{$attr}; 398 $ob->{$attr} = new Deliantra::MoveType $ob->{$attr};
390 } 399 }
391 400
392 # convert outdated movement flags to new movement sets 401 # convert outdated movement flags to new movement sets
393 if (defined (my $v = delete $ob->{no_pass})) { 402 if (defined (my $v = delete $ob->{no_pass})) {
394 $ob->{move_block} = new Deliantra::MoveType $v ? "all" : ""; 403 $ob->{move_block} = new Deliantra::MoveType $v ? "all" : "0";
395 } 404 }
396 if (defined (my $v = delete $ob->{slow_move})) { 405 if (defined (my $v = delete $ob->{slow_move})) {
397 $ob->{move_slow} += "walk"; 406 $ob->{move_slow} += "walk";
398 $ob->{move_slow_penalty} = $v; 407 $ob->{move_slow_penalty} = $v;
399 } 408 }
400 if (defined (my $v = delete $ob->{walk_on})) { 409 if (defined (my $v = delete $ob->{walk_on})) {
401 $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" } 410 $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
402 } 411 }
403 if (defined (my $v = delete $ob->{walk_off})) { 412 if (defined (my $v = delete $ob->{walk_off})) {
404 $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" } 413 $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
405 } 414 }
406 if (defined (my $v = delete $ob->{fly_on})) { 415 if (defined (my $v = delete $ob->{fly_on})) {
… …
805 } else { 814 } else {
806 $root = $Deliantra::Data::TYPE{Misc}; 815 $root = $Deliantra::Data::TYPE{Misc};
807 } 816 }
808 } 817 }
809 818
819 my (%ignore);
810 my @import = ($root); 820 my @import = ($root);
811
812 unshift @import, \%Deliantra::Data::DEFAULT_ATTR
813 unless $type == 116;
814 821
815 my (%ignore); 822 my @new_import;
816 my (@section_order, %section, @attr_order);
817
818 while (my $type = shift @import) { 823 while (my $type = shift @import) {
824 # first import everything we will need:
819 push @import, 825 push @import,
820 grep $_, 826 grep $_,
821 map $Deliantra::Data::TYPE{$_}, 827 map $Deliantra::Data::TYPE{$_},
822 @{$type->{import} || []}; 828 @{$type->{import} || []};
823 829
830 # and compute the ignored attributes
831 for (@{$type->{ignore} || []}) {
832 $ignore{$_}++ for ref $_ ? @$_ : $_;
833 }
834
835 push @new_import, $type;
836 }
837 (@import) = @new_import;
838
839 # then add defaults to the back of the list, so they are added
840 # as last resort.
841 push @import, \%Deliantra::Data::DEFAULT_ATTR
842 unless $type == 116;
843
844 my (@section_order, %section, @attr_order);
845
846 # @import = root, imported, default
847 while (my $type = pop @import) {
824 $attr->{$_} ||= $type->{$_} 848 $attr->{$_} ||= $type->{$_}
825 for qw(name desc use); 849 for qw(name desc use);
826
827 for (@{$type->{ignore} || []}) {
828 $ignore{$_}++ for ref $_ ? @$_ : $_;
829 }
830 850
831 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) { 851 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
832 my ($name, $attr) = @$_; 852 my ($name, $attr) = @$_;
833 push @section_order, $name; 853 push @section_order, $name;
834 for (@$attr) { 854 for (@$attr) {
835 my ($k, $v) = @$_; 855 my ($k, $v) = @$_;
836 push @attr_order, $k; 856 push @attr_order, $k;
837 $section{$name}{$k} ||= $v; 857 $section{$name}{$k} = $v; # overwrite, so that the root decides
838 }
839 } 858 }
859 }
860 }
861
862 # remove ignores for "root" type
863 for (
864 map @{$_->[1]}, # section attributes
865 [general => ($root->{attr} || [])],
866 @{$root->{section} || []}
867 ) {
868 my ($k, $v) = @$_;
869 # skip fixed attributes, if they are ignored thats fine
870 next if $v->{type} eq 'fixed';
871
872 delete $ignore{$k}; # if the attributes are defined explicitly they
873 # should NOT be ignored. ignore should mainly
874 # hit imported/inherited attributes.
840 } 875 }
841 876
842 $attr->{section} = [ 877 $attr->{section} = [
843 map !exists $section{$_} ? () : do { 878 map !exists $section{$_} ? () : do {
844 my $attr = delete $section{$_}; 879 my $attr = delete $section{$_};
… …
848 map exists $attr->{$_} && !$ignore{$_} 883 map exists $attr->{$_} && !$ignore{$_}
849 ? [$_ => delete $attr->{$_}] : (), 884 ? [$_ => delete $attr->{$_}] : (),
850 @attr_order 885 @attr_order
851 ] 886 ]
852 }, 887 },
853
854 exists $section{$_} ? [$_ => delete $section{$_}] : (), 888 exists $section{$_} ? [$_ => delete $section{$_}] : (),
855 @section_order 889 @section_order
856 ]; 890 ];
857 891
858 $attr 892 $attr
859} 893}
… …
987 1021
988 \%cache 1022 \%cache
989 }; 1023 };
990} 1024}
991 1025
1026=back
1027
992=head1 AUTHOR 1028=head1 AUTHOR
993 1029
994 Marc Lehmann <schmorp@schmorp.de> 1030 Marc Lehmann <schmorp@schmorp.de>
995 http://home.schmorp.de/ 1031 http://home.schmorp.de/
996 1032

Diff Legend

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