… | |
… | |
4 | |
4 | |
5 | =cut |
5 | =cut |
6 | |
6 | |
7 | package Crossfire; |
7 | package Crossfire; |
8 | |
8 | |
9 | our $VERSION = '0.96'; |
9 | our $VERSION = '0.97'; |
10 | |
10 | |
11 | use strict; |
11 | use strict; |
12 | |
12 | |
13 | use base 'Exporter'; |
13 | use base 'Exporter'; |
14 | |
14 | |
… | |
… | |
157 | |
157 | |
158 | { |
158 | { |
159 | package Crossfire::MoveType; |
159 | package Crossfire::MoveType; |
160 | |
160 | |
161 | use overload |
161 | use overload |
|
|
162 | '=' => sub { bless [@{$_[0]}], ref $_[0] }, |
162 | '""' => \&as_string, |
163 | '""' => \&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]} : 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 }, |
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 }, |
166 | '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise }, |
167 | '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise }, |
167 | 'x=' => sub { |
168 | 'x=' => sub { |
168 | my $cur = $_[0] >= $_[1]; |
169 | my $cur = $_[0] >= $_[1]; |
169 | if (!defined $cur) { |
170 | if (!defined $cur) { |
|
|
171 | if ($_[0] >= "all") { |
|
|
172 | $_[0] -= $_[1]; |
|
|
173 | } else { |
170 | $_[0] += $_[1]; |
174 | $_[0] += $_[1]; |
|
|
175 | } |
171 | } elsif ($cur) { |
176 | } elsif ($cur) { |
172 | $_[0] -= $_[1]; |
177 | $_[0] -= $_[1]; |
173 | } else { |
178 | } else { |
174 | $_[0] /= $_[1]; |
179 | $_[0] /= $_[1]; |
175 | } |
180 | } |
176 | |
181 | |
177 | $_[0] |
182 | $_[0] |
178 | }, |
183 | }, |
|
|
184 | 'eq' => sub { "$_[0]" eq "$_[1]" }, |
|
|
185 | 'ne' => sub { "$_[0]" ne "$_[1]" }, |
179 | ; |
186 | ; |
180 | } |
187 | } |
181 | |
188 | |
182 | sub Crossfire::MoveType::new { |
189 | sub Crossfire::MoveType::new { |
183 | my ($class, $string) = @_; |
190 | my ($class, $string) = @_; |
184 | |
191 | |
185 | my $mask; |
192 | my $mask; |
186 | my $value; |
193 | my $value; |
187 | |
194 | |
|
|
195 | if ($string =~ /^\s*\d+\s*$/) { |
|
|
196 | $mask = MOVE_ALL; |
|
|
197 | $value = $string+0; |
|
|
198 | } else { |
188 | for (split /\s+/, lc $string) { |
199 | for (split /\s+/, lc $string) { |
189 | if (s/^-//) { |
200 | if (s/^-//) { |
190 | $mask |= $MOVE_TYPE{$_}; |
201 | $mask |= $MOVE_TYPE{$_}; |
191 | $value &= ~$MOVE_TYPE{$_}; |
202 | $value &= ~$MOVE_TYPE{$_}; |
192 | } else { |
203 | } else { |
193 | $mask |= $MOVE_TYPE{$_}; |
204 | $mask |= $MOVE_TYPE{$_}; |
194 | $value |= $MOVE_TYPE{$_}; |
205 | $value |= $MOVE_TYPE{$_}; |
|
|
206 | } |
195 | } |
207 | } |
196 | } |
208 | } |
197 | |
209 | |
198 | (bless [$mask, $value], $class)->normalise |
210 | (bless [$mask, $value], $class)->normalise |
199 | } |
211 | } |
… | |
… | |
340 | } else { |
352 | } else { |
341 | warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n"; |
353 | warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n"; |
342 | } |
354 | } |
343 | } |
355 | } |
344 | |
356 | |
|
|
357 | # color_fg is used as default for magicmap if magicmap does not exist |
|
|
358 | $ob->{magicmap} ||= delete $ob->{color_fg} if exists $ob->{color_fg}; |
|
|
359 | |
345 | # nuke outdated or never supported fields |
360 | # nuke outdated or never supported fields |
346 | delete @$ob{qw( |
361 | delete @$ob{qw( |
347 | can_knockback can_parry can_impale can_cut can_dam_armour |
362 | can_knockback can_parry can_impale can_cut can_dam_armour |
348 | can_apply pass_thru can_pass_thru |
363 | can_apply pass_thru can_pass_thru color_bg |
349 | )}; |
364 | )}; |
350 | |
365 | |
351 | if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; } |
366 | if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; } |
352 | if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; } |
367 | if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; } |
353 | if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; } |
368 | if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; } |