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.17 by root, Wed Feb 22 22:36:45 2006 UTC vs.
Revision 1.83 by root, Wed Feb 7 00:14:48 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
15use Carp (); 15use Carp ();
16use Storable; 16use File::Spec;
17use List::Util qw(min max); 17use List::Util qw(min max);
18use Storable qw(freeze thaw);
18 19
19#XXX: The map_* procedures scream for a map-object
20
21our @EXPORT = 20our @EXPORT = qw(
22 qw(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);
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 or Carp::croak "\$CROSSFIRE_LIBDIR must be set\n"; 37
38our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire"
39 : $ENV{AppData} ? "$ENV{APPDATA}/crossfire"
40 : File::Spec->tmpdir . "/crossfire";
41
42mkdir $VARDIR, 0777;
26 43
27sub TILESIZE (){ 32 } 44sub TILESIZE (){ 32 }
28 45
29our $CACHEDIR;
30our %ARCH; 46our %ARCH;
31our %FACE; 47our %FACE;
32our $TILE; 48our $TILE;
33 49
34our %FIELD_MULTILINE = ( 50our %FIELD_MULTILINE = (
35 msg => "endmsg", 51 msg => "endmsg",
36 lore => "endlore", 52 lore => "endlore",
53 maplore => "endmaplore",
37); 54);
38 55
39# not used yet, maybe alphabetical is ok 56# movement bit type, PITA
57our %FIELD_MOVEMENT = map +($_ => undef),
58 qw(move_type move_block move_allow move_on move_off move_slow);
59
60# same as in server save routine, to (hopefully) be compatible
61# to the other editors.
62our @FIELD_ORDER_MAP = (qw(
63 name attach swap_time reset_timeout fixed_resettime difficulty region
64 shopitems shopgreed shopmin shopmax shoprace
65 darkness width height enter_x enter_y msg maplore
66 unique template
67 outdoor temp pressure humid windspeed winddir sky nosmooth
68 tile_path_1 tile_path_2 tile_path_3 tile_path_4
69));
70
40our @FIELD_ORDER = (qw(name name_pl)); 71our @FIELD_ORDER = (qw(
72 elevation
41 73
74 name name_pl custom_name attach title race
75 slaying skill msg lore other_arch face
76 #todo-events
77 animation is_animated
78 str dex con wis pow cha int
79 hp maxhp sp maxsp grace maxgrace
80 exp perm_exp expmul
81 food dam luck wc ac x y speed speed_left move_state attack_movement
82 nrof level direction type subtype attacktype
83
84 resist_physical resist_magic resist_fire resist_electricity
85 resist_cold resist_confusion resist_acid resist_drain
86 resist_weaponmagic resist_ghosthit resist_poison resist_slow
87 resist_paralyze resist_turn_undead resist_fear resist_cancellation
88 resist_deplete resist_death resist_chaos resist_counterspell
89 resist_godpower resist_holyword resist_blind resist_internal
90 resist_life_stealing resist_disease
91
92 path_attuned path_repelled path_denied material materialname
93 value carrying weight invisible state magic
94 last_heal last_sp last_grace last_eat
95 connected glow_radius randomitems npx_status npc_program
96 run_away pick_up container will_apply smoothlevel
97 current_weapon_script weapontype tooltype elevation client_type
98 item_power duration range
99 range_modifier duration_modifier dam_modifier gen_sp_armour
100 move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty
101
102 alive wiz was_wiz applied unpaid can_use_shield no_pick is_animated monster
103 friendly generator is_thrown auto_apply treasure player sold see_invisible
104 can_roll overlay_floor is_turnable is_used_up identified reflecting changing
105 splitting hitback startequip blocksview undead scared unaggressive
106 reflect_missile reflect_spell no_magic no_fix_player is_lightable tear_down
107 run_away pick_up unique no_drop can_cast_spell can_use_scroll can_use_range
108 can_use_bow can_use_armour can_use_weapon can_use_ring has_ready_range
109 has_ready_bow xrays is_floor lifesave no_strength sleep stand_still
110 random_move only_attack confused stealth cursed damned see_anywhere
111 known_magical known_cursed can_use_skill been_applied has_ready_scroll
112 can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly
113 has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark
114 is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage
115 activate_on_push activate_on_release is_water use_content_on_gen is_buildable
116
117 body_range body_arm body_torso body_head body_neck body_skill
118 body_finger body_shoulder body_foot body_hand body_wrist body_waist
119));
120
121our %EVENT_TYPE = (
122 apply => 1,
123 attack => 2,
124 death => 3,
125 drop => 4,
126 pickup => 5,
127 say => 6,
128 stop => 7,
129 time => 8,
130 throw => 9,
131 trigger => 10,
132 close => 11,
133 timer => 12,
134);
135
42sub MOVE_WALK (){ 0x1 } 136sub MOVE_WALK (){ 0x01 }
43sub MOVE_FLY_LOW (){ 0x2 } 137sub MOVE_FLY_LOW (){ 0x02 }
44sub MOVE_FLY_HIGH (){ 0x4 } 138sub MOVE_FLY_HIGH (){ 0x04 }
45sub MOVE_FLYING (){ 0x6 } 139sub MOVE_FLYING (){ 0x06 }
46sub MOVE_SWIM (){ 0x8 } 140sub MOVE_SWIM (){ 0x08 }
47sub MOVE_ALL (){ 0xf } 141sub MOVE_BOAT (){ 0x10 }
142sub MOVE_KNOWN (){ 0x1f } # all of above
143sub MOVE_ALLBIT (){ 0x10000 }
144sub MOVE_ALL (){ 0x1001f } # very special value, more PITA
48 145
146sub load_ref($) {
147 my ($path) = @_;
148
149 open my $fh, "<:raw:perlio", $path
150 or die "$path: $!";
151 local $/;
152
153 thaw <$fh>
154}
155
156sub save_ref($$) {
157 my ($ref, $path) = @_;
158
159 open my $fh, ">:raw:perlio", "$path~"
160 or die "$path~: $!";
161 print $fh freeze $ref;
162 close $fh;
163 rename "$path~", $path
164 or die "$path: $!";
165}
166
167my %attack_mask = (
168 physical => 0x00000001,
169 magic => 0x00000002,
170 fire => 0x00000004,
171 electricity => 0x00000008,
172 cold => 0x00000010,
173 confusion => 0x00000020,
174 acid => 0x00000040,
175 drain => 0x00000080,
176 weaponmagic => 0x00000100,
177 ghosthit => 0x00000200,
178 poison => 0x00000400,
179 slow => 0x00000800,
180 paralyze => 0x00001000,
181 turn_undead => 0x00002000,
182 fear => 0x00004000,
183 cancellation => 0x00008000,
184 deplete => 0x00010000,
185 death => 0x00020000,
186 chaos => 0x00040000,
187 counterspell => 0x00080000,
188 godpower => 0x00100000,
189 holyword => 0x00200000,
190 blind => 0x00400000,
191 internal => 0x00800000,
192 life_stealing => 0x01000000,
193 disease => 0x02000000,
194);
195
196sub _add_resist($$$) {
197 my ($ob, $mask, $value) = @_;
198
199 while (my ($k, $v) = each %attack_mask) {
200 $ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
201 }
202}
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 # guesses
220 runestone => 12,
221 bronze => 18,
222 "ancient wood" => 20,
223 glass => 36,
224 marble => 66,
225 ice => 68,
226 stone => 70,
227 stone => 80,
228 cloth => 136,
229 ironwood => 144,
230 blood => 544,
231;
232
233# object as in "Object xxx", i.e. archetypes
234sub normalize_object($) {
235 my ($ob) = @_;
236
237 # convert material bitset to materialname, if possible
238 if (exists $ob->{material}) {
239 if (!$ob->{material}) {
240 delete $ob->{material};
241 } elsif (exists $ob->{materialname}) {
242 if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
243 delete $ob->{material};
244 } else {
245 warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
246 delete $ob->{material}; # assume materilname is more specific and nuke material
247 }
248 } elsif (my $name = $MATERIAL{$ob->{material}}) {
249 delete $ob->{material};
250 $ob->{materialname} = $name;
251 } else {
252 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
253 }
254 }
255
256 # nuke outdated or never supported fields
257 delete @$ob{qw(
258 can_knockback can_parry can_impale can_cut can_dam_armour
259 can_apply pass_thru can_pass_thru
260 )};
261
262 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
263 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
264 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
265
266 # convert movement strings to bitsets
267 for my $attr (keys %FIELD_MOVEMENT) {
268 next unless exists $ob->{$attr};
269
270 $ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility
271
272 next if $ob->{$attr} =~ /^\d+$/;
273
274 my $flags = 0;
275
276 # assume list
277 for my $flag (map lc, split /\s+/, $ob->{$attr}) {
278 $flags |= MOVE_WALK if $flag eq "walk";
279 $flags |= MOVE_FLY_LOW if $flag eq "fly_low";
280 $flags |= MOVE_FLY_HIGH if $flag eq "fly_high";
281 $flags |= MOVE_FLYING if $flag eq "flying";
282 $flags |= MOVE_SWIM if $flag eq "swim";
283 $flags |= MOVE_BOAT if $flag eq "boat";
284 $flags |= MOVE_ALL if $flag eq "all";
285
286 $flags &= ~MOVE_WALK if $flag eq "-walk";
287 $flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
288 $flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
289 $flags &= ~MOVE_FLYING if $flag eq "-flying";
290 $flags &= ~MOVE_SWIM if $flag eq "-swim";
291 $flags &= ~MOVE_BOAT if $flag eq "-boat";
292 $flags &= ~MOVE_ALL if $flag eq "-all";
293 }
294
295 $ob->{$attr} = $flags;
296 }
297
298 # convert outdated movement flags to new movement sets
299 if (defined (my $v = delete $ob->{no_pass})) {
300 $ob->{move_block} = $v ? MOVE_ALL : 0;
301 }
302 if (defined (my $v = delete $ob->{slow_move})) {
303 $ob->{move_slow} |= MOVE_WALK;
304 $ob->{move_slow_penalty} = $v;
305 }
306 if (defined (my $v = delete $ob->{walk_on})) {
307 $ob->{move_on} = MOVE_ALL unless exists $ob->{move_on};
308 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK
309 : $ob->{move_on} & ~MOVE_WALK;
310 }
311 if (defined (my $v = delete $ob->{walk_off})) {
312 $ob->{move_off} = MOVE_ALL unless exists $ob->{move_off};
313 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK
314 : $ob->{move_off} & ~MOVE_WALK;
315 }
316 if (defined (my $v = delete $ob->{fly_on})) {
317 $ob->{move_on} = MOVE_ALL unless exists $ob->{move_on};
318 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW
319 : $ob->{move_on} & ~MOVE_FLY_LOW;
320 }
321 if (defined (my $v = delete $ob->{fly_off})) {
322 $ob->{move_off} = MOVE_ALL unless exists $ob->{move_off};
323 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW
324 : $ob->{move_off} & ~MOVE_FLY_LOW;
325 }
326 if (defined (my $v = delete $ob->{flying})) {
327 $ob->{move_type} = MOVE_ALL unless exists $ob->{move_type};
328 $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW
329 : $ob->{move_type} & ~MOVE_FLY_LOW;
330 }
331
332 # convert idiotic event_xxx things into objects
333 while (my ($event, $subtype) = each %EVENT_TYPE) {
334 if (exists $ob->{"event_${event}_plugin"}) {
335 push @{$ob->{inventory}}, {
336 _name => "event_$event",
337 title => delete $ob->{"event_${event}_plugin"},
338 slaying => delete $ob->{"event_${event}"},
339 name => delete $ob->{"event_${event}_options"},
340 };
341 }
342 }
343
344 # some archetypes had "+3" instead of the canonical "3", so fix
345 $ob->{dam} *= 1 if exists $ob->{dam};
346
347 $ob
348}
349
350# arch as in "arch xxx", ie.. objects
49sub normalize_arch($) { 351sub normalize_arch($) {
50 my ($ob) = @_; 352 my ($ob) = @_;
51 353
354 normalize_object $ob;
355
52 my $arch = $ARCH{$ob->{_name}} 356 my $arch = $ARCH{$ob->{_name}}
53 or (warn "$ob->{_name}: no such archetype", return $ob); 357 or (warn "$ob->{_name}: no such archetype", return $ob);
54
55 delete $ob->{$_} for qw(can_knockback can_parry can_impale can_cut can_dam_armour can_apply);
56 358
57 if ($arch->{type} == 22) { # map 359 if ($arch->{type} == 22) { # map
58 my %normalize = ( 360 my %normalize = (
59 "enter_x" => "hp", 361 "enter_x" => "hp",
60 "enter_y" => "sp", 362 "enter_y" => "sp",
… …
70 while (my ($k2, $k1) = each %normalize) { 372 while (my ($k2, $k1) = each %normalize) {
71 if (defined (my $v = delete $ob->{$k1})) { 373 if (defined (my $v = delete $ob->{$k1})) {
72 $ob->{$k2} = $v; 374 $ob->{$k2} = $v;
73 } 375 }
74 } 376 }
75 } 377 } else {
76
77 if (defined (my $v = delete $ob->{no_pass})) {
78 $ob->{move_block} = $v ? MOVE_ALL : 0;
79 }
80 if (defined (my $v = delete $ob->{walk_on})) {
81 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK
82 : $ob->{move_on} & ~MOVE_WALK;
83 }
84 if (defined (my $v = delete $ob->{walk_off})) {
85 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK
86 : $ob->{move_off} & ~MOVE_WALK;
87 }
88 if (defined (my $v = delete $ob->{fly_on})) {
89 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW
90 : $ob->{move_on} & ~MOVE_FLY_LOW;
91 }
92 if (defined (my $v = delete $ob->{fly_off})) {
93 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW
94 : $ob->{move_off} & ~MOVE_FLY_LOW;
95 }
96 if (defined (my $v = delete $ob->{flying})) {
97 $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW
98 : $ob->{move_type} & ~MOVE_FLY_LOW;
99 }
100
101 # if value matches archetype default, delete 378 # if value matches archetype default, delete
102 while (my ($k, $v) = each %$ob) { 379 while (my ($k, $v) = each %$ob) {
103 if (exists $arch->{$k} and $arch->{$k} eq $v) { 380 if (exists $arch->{$k} and $arch->{$k} eq $v) {
104 next if $k eq "_name"; 381 next if $k eq "_name";
105 delete $ob->{$k}; 382 delete $ob->{$k};
106 } 383 }
384 }
385 }
386
387 # a speciality for the editor
388 if (exists $ob->{attack_movement}) {
389 my $am = delete $ob->{attack_movement};
390 $ob->{attack_movement_bits_0_3} = $am & 15;
391 $ob->{attack_movement_bits_4_7} = $am & 240;
107 } 392 }
108 393
109 $ob 394 $ob
110} 395}
111 396
397sub attr_thaw($) {
398 my ($ob) = @_;
399
400 $ob->{attach} = from_json $ob->{attach}
401 if exists $ob->{attach};
402
403 $ob
404}
405
406sub attr_freeze($) {
407 my ($ob) = @_;
408
409 $ob->{attach} = Crossfire::to_json $ob->{attach}
410 if exists $ob->{attach};
411
412 $ob
413}
414
112sub read_pak($;$) { 415sub read_pak($) {
113 my ($path, $cache) = @_; 416 my ($path) = @_;
114 417
115 eval {
116 defined $cache
117 && -M $cache < -M $path
118 && Storable::retrieve $cache
119 } or do {
120 my %pak; 418 my %pak;
121 419
122 open my $fh, "<:raw", $path 420 open my $fh, "<:raw:perlio", $path
123 or Carp::croak "$_[0]: $!"; 421 or Carp::croak "$_[0]: $!";
422 binmode $fh;
124 while (<$fh>) { 423 while (<$fh>) {
125 my ($type, $id, $len, $path) = split; 424 my ($type, $id, $len, $path) = split;
126 $path =~ s/.*\///; 425 $path =~ s/.*\///;
127 read $fh, $pak{$path}, $len; 426 read $fh, $pak{$path}, $len;
128 } 427 }
129 428
130 Storable::nstore \%pak, $cache
131 if defined $cache;
132
133 \%pak 429 \%pak
134 }
135} 430}
136 431
137sub read_arch($;$) { 432sub read_arch($;$) {
138 my ($path, $cache) = @_; 433 my ($path, $toplevel) = @_;
139 434
140 eval {
141 defined $cache
142 && -M $cache < -M $path
143 && Storable::retrieve $cache
144 } or do {
145 my %arc; 435 my %arc;
146 my ($more, $prev); 436 my ($more, $prev);
437 my $comment;
147 438
148 open my $fh, "<:raw", $path 439 open my $fh, "<:raw:perlio:utf8", $path
149 or Carp::croak "$path: $!"; 440 or Carp::croak "$path: $!";
150 441
442# binmode $fh;
443
151 my $parse_block; $parse_block = sub { 444 my $parse_block; $parse_block = sub {
152 my %arc = @_; 445 my %arc = @_;
153
154 while (<$fh>) {
155 s/\s+$//;
156 if (/^end$/i) {
157 last;
158 } elsif (/^arch (\S+)$/) {
159 push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);
160 } elsif (/^lore$/) {
161 while (<$fh>) {
162 last if /^endlore\s*$/i;
163 $arc{lore} .= $_;
164 }
165 } elsif (/^msg$/) {
166 while (<$fh>) {
167 last if /^endmsg\s*$/i;
168 $arc{msg} .= $_;
169 }
170 } elsif (/^(\S+)\s*(.*)$/) {
171 $arc{lc $1} = $2;
172 } elsif (/^\s*($|#)/) {
173 #
174 } else {
175 warn "$path: unparsable line '$_' in arch $arc{_name}";
176 }
177 }
178
179 \%arc
180 };
181 446
182 while (<$fh>) { 447 while (<$fh>) {
183 s/\s+$//; 448 s/\s+$//;
184 if (/^more$/i) { 449 if (/^end$/i) {
185 $more = $prev; 450 last;
451
186 } elsif (/^object (\S+)$/i) { 452 } elsif (/^arch (\S+)$/i) {
187 my $name = $1; 453 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
188 my $arc = $parse_block->(_name => $name);
189 454
190 if ($more) { 455 } elsif (/^lore$/i) {
191 $more->{more} = $arc; 456 while (<$fh>) {
192 } else { 457 last if /^endlore\s*$/i;
193 $arc{$name} = $arc; 458 $arc{lore} .= $_;
194 } 459 }
195 $prev = $arc; 460 } elsif (/^msg$/i) {
196 $more = undef; 461 while (<$fh>) {
462 last if /^endmsg\s*$/i;
463 $arc{msg} .= $_;
464 }
465 } elsif (/^anim$/i) {
466 while (<$fh>) {
467 last if /^mina\s*$/i;
468 chomp;
469 push @{ $arc{anim} }, $_;
470 }
197 } elsif (/^arch (\S+)$/i) { 471 } elsif (/^(\S+)\s*(.*)$/) {
198 push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1); 472 $arc{lc $1} = $2;
199 } elsif (/^\s*($|#)/) { 473 } elsif (/^\s*#/) {
474 $arc{_comment} .= "$_\n";
475
476 } elsif (/^\s*$/) {
200 # 477 #
201 } else { 478 } else {
202 warn "$path: unparseable top-level line '$_'"; 479 warn "$path: unparsable line '$_' in arch $arc{_name}";
203 }
204 } 480 }
205 481 }
206 undef $parse_block; # work around bug in perl not freeing $fh etc.
207
208 Storable::nstore \%arc, $cache
209 if defined $cache;
210 482
211 \%arc 483 \%arc
212 } 484 };
485
486 while (<$fh>) {
487 s/\s+$//;
488 if (/^more$/i) {
489 $more = $prev;
490 } elsif (/^object (\S+)$/i) {
491 my $name = $1;
492 my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
493 undef $comment;
494 delete $arc{_comment} unless length $arc{_comment};
495 $arc->{_atype} = 'object';
496
497 if ($more) {
498 $more->{more} = $arc;
499 } else {
500 $arc{$name} = $arc;
501 }
502 $prev = $arc;
503 $more = undef;
504 } elsif (/^arch (\S+)$/i) {
505 my $name = $1;
506 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
507 undef $comment;
508 delete $arc{_comment} unless length $arc{_comment};
509 $arc->{_atype} = 'arch';
510
511 if ($more) {
512 $more->{more} = $arc;
513 } else {
514 push @{ $arc{arch} }, $arc;
515 }
516 $prev = $arc;
517 $more = undef;
518 } elsif ($toplevel && /^(\S+)\s+(.*)$/) {
519 if ($1 eq "lev_array") {
520 while (<$fh>) {
521 last if /^endplst\s*$/;
522 push @{$toplevel->{lev_array}}, $_+0;
523 }
524 } else {
525 $toplevel->{$1} = $2;
526 }
527 } elsif (/^\s*#/) {
528 $comment .= "$_\n";
529 } elsif (/^\s*($|#)/) {
530 #
531 } else {
532 die "$path: unparseable top-level line '$_'";
533 }
534 }
535
536 undef $parse_block; # work around bug in perl not freeing $fh etc.
537
538 \%arc
539}
540
541sub archlist_to_string {
542 my ($arch) = @_;
543
544 my $str;
545
546 my $append; $append = sub {
547 my %a = %{$_[0]};
548
549 Crossfire::attr_freeze \%a;
550 Crossfire::normalize_arch \%a;
551
552 # undo the bit-split we did before
553 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
554 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
555 | (delete $a{attack_movement_bits_4_7});
556 }
557
558 if (my $comment = delete $a{_comment}) {
559 if ($comment =~ /[^\n\s#]/) {
560 $str .= $comment;
561 }
562 }
563
564 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
565
566 my $inv = delete $a{inventory};
567 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
568 my $anim = delete $a{anim};
569
570 my @kv;
571
572 for ($a{_name} eq "map"
573 ? @Crossfire::FIELD_ORDER_MAP
574 : @Crossfire::FIELD_ORDER) {
575 push @kv, [$_, delete $a{$_}]
576 if exists $a{$_};
577 }
578
579 for (sort keys %a) {
580 next if /^_/; # ignore our _-keys
581 push @kv, [$_, delete $a{$_}];
582 }
583
584 for (@kv) {
585 my ($k, $v) = @$_;
586
587 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
588 $v =~ s/\n$//;
589 $str .= "$k\n$v\n$end\n";
590 } elsif (exists $Crossfire::FIELD_MOVEMENT{$k}) {
591 if ($v & ~Crossfire::MOVE_ALL or !$v) {
592 $str .= "$k $v\n";
593
594 } elsif ($v & Crossfire::MOVE_ALLBIT) {
595 $str .= "$k all";
596
597 $str .= " -walk" unless $v & Crossfire::MOVE_WALK;
598 $str .= " -fly_low" unless $v & Crossfire::MOVE_FLY_LOW;
599 $str .= " -fly_high" unless $v & Crossfire::MOVE_FLY_HIGH;
600 $str .= " -swim" unless $v & Crossfire::MOVE_SWIM;
601 $str .= " -boat" unless $v & Crossfire::MOVE_BOAT;
602
603 $str .= "\n";
604
605 } else {
606 $str .= $k;
607
608 $str .= " walk" if $v & Crossfire::MOVE_WALK;
609 $str .= " fly_low" if $v & Crossfire::MOVE_FLY_LOW;
610 $str .= " fly_high" if $v & Crossfire::MOVE_FLY_HIGH;
611 $str .= " swim" if $v & Crossfire::MOVE_SWIM;
612 $str .= " boat" if $v & Crossfire::MOVE_BOAT;
613
614 $str .= "\n";
615 }
616 } else {
617 $str .= "$k $v\n";
618 }
619 }
620
621 if ($inv) {
622 $append->($_) for @$inv;
623 }
624
625 if ($a{_atype} eq 'object') {
626 $str .= join "\n", "anim", @$anim, "mina\n"
627 if $anim;
628 }
629
630 $str .= "end\n";
631
632 if ($a{_atype} eq 'object') {
633 if ($more) {
634 $str .= "more\n";
635 $append->($more) if $more;
636 } else {
637 $str .= "\n";
638 }
639 }
640 };
641
642 for (@$arch) {
643 $append->($_);
644 }
645
646 $str
213} 647}
214 648
215# put all archs into a hash with editor_face as it's key 649# put all archs into a hash with editor_face as it's key
216# NOTE: the arrays in the hash values are references to 650# NOTE: the arrays in the hash values are references to
217# the archs from $ARCH 651# the archs from $ARCH
218sub editor_archs { 652sub editor_archs {
219 my %paths; 653 my %paths;
220 654
221 for (keys %ARCH) { 655 for (keys %ARCH) {
222 my $arch = $ARCH{$_}; 656 my $arch = $ARCH{$_};
223 push @{$paths{$arch->{editor_folder}}}, \$arch; 657 push @{$paths{$arch->{editor_folder}}}, $arch;
224 } 658 }
225 659
226 \%paths 660 \%paths
227} 661}
228 662
… …
238 my ($a) = @_; 672 my ($a) = @_;
239 673
240 my $o = $ARCH{$a->{_name}} 674 my $o = $ARCH{$a->{_name}}
241 or return; 675 or return;
242 676
243 my $face = $FACE{$a->{face} || $o->{face}} 677 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"};
678 unless ($face) {
679 $face = $FACE{"blank.x11"}
244 or (warn "no face data found for arch '$a->{_name}'"), return; 680 or (warn "no face data found for arch '$a->{_name}'"), return;
681 }
245 682
246 if ($face->{w} > 1 || $face->{h} > 1) { 683 if ($face->{w} > 1 || $face->{h} > 1) {
247 # bigface 684 # bigface
248 return (0, 0, $face->{w} - 1, $face->{h} - 1); 685 return (0, 0, $face->{w} - 1, $face->{h} - 1);
249 686
… …
264 # single face 701 # single face
265 return (0, 0, 0, 0); 702 return (0, 0, 0, 0);
266 } 703 }
267} 704}
268 705
269sub init($) {
270 my ($cachedir) = @_;
271
272 return if %ARCH;
273
274 *ARCH = read_arch "$LIB/archetypes", "$cachedir/archetypes.pst";
275}
276
277=item $data = arch_attr $arch 706=item $type = arch_attr $arch
278 707
279Returns a hashref describing the object and its attributes. It can contain 708Returns a hashref describing the object and its attributes. It can contain
280the following keys: 709the following keys:
281 710
282 name the name, suitable for display purposes 711 name the name, suitable for display purposes
283 ignore 712 ignore
284 attr 713 attr
285 desc 714 desc
286 use 715 use
287 section => [name => \%attr, name => \%attr] 716 section => [name => \%attr, name => \%attr]
717 import
288 718
289=cut 719=cut
290 720
291sub arch_attr($) { 721sub arch_attr($) {
292 my ($arch) = @_; 722 my ($obj) = @_;
293 723
294 require Crossfire::Data; 724 require Crossfire::Data;
295 725
296 my %attr; 726 my $root;
727 my $attr = { };
728
729 my $arch = $ARCH{ $obj->{_name} };
730 my $type = $obj->{type} || $arch->{type};
297 731
298 if ($arch->{type} > 0) { 732 if ($type > 0) {
299 %attr = %{ $Crossfire::Data::ATTR{$arch->{type}+0} || {} }; 733 $root = $Crossfire::Data::ATTR{$type};
300 } else { 734 } else {
301 die; 735 my %a = (%$arch, %$obj);
736
737 if ($a{is_floor} && !$a{alive}) {
738 $root = $Crossfire::Data::TYPE{Floor};
739 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
740 $root = $Crossfire::Data::TYPE{"Monster & NPC"};
741 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
742 $root = $Crossfire::Data::TYPE{Wall};
743 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
744 $root = $Crossfire::Data::TYPE{"Weak Wall"};
745 } else {
746 $root = $Crossfire::Data::TYPE{Misc};
747 }
748 }
749
750 my @import = ($root);
302 } 751
752 unshift @import, \%Crossfire::Data::DEFAULT_ATTR
753 unless $type == 116;
303 754
304 use PApp::Util; 755 my (%ignore);
305 warn PApp::Util::dumpval \%attr; 756 my (@section_order, %section, @attr_order);
757
758 while (my $type = shift @import) {
759 push @import, @{$type->{import} || []};
760
761 $attr->{$_} ||= $type->{$_}
762 for qw(name desc use);
763
764 for (@{$type->{ignore} || []}) {
765 $ignore{$_}++ for ref $_ ? @$_ : $_;
766 }
767
768 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
769 my ($name, $attr) = @$_;
770 push @section_order, $name;
771 for (@$attr) {
772 my ($k, $v) = @$_;
773 push @attr_order, $k;
774 $section{$name}{$k} ||= $v;
775 }
776 }
777 }
778
779 $attr->{section} = [
780 map !exists $section{$_} ? () : do {
781 my $attr = delete $section{$_};
782
783 [
784 $_,
785 map exists $attr->{$_} && !$ignore{$_}
786 ? [$_ => delete $attr->{$_}] : (),
787 @attr_order
788 ]
789 },
790
791 exists $section{$_} ? [$_ => delete $section{$_}] : (),
792 @section_order
793 ];
794
795 $attr
306} 796}
307 797
308sub arch_edit_sections { 798sub arch_edit_sections {
309# if (edit_type == IGUIConstants.TILE_EDIT_NONE) 799# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
310# edit_type = 0; 800# edit_type = 0;
… …
364# return(edit_type); 854# return(edit_type);
365# 855#
366# 856#
367} 857}
368 858
369$CACHEDIR ||= "$ENV{HOME}/.crossfire"; 859sub cache_file($$&&) {
860 my ($src, $cache, $load, $create) = @_;
370 861
371init $CACHEDIR; 862 my ($size, $mtime) = (stat $src)[7,9]
863 or Carp::croak "$src: $!";
864
865 if (-e $cache) {
866 my $ref = eval { load_ref $cache };
867
868 if ($ref->{version} == 1
869 && $ref->{size} == $size
870 && $ref->{mtime} == $mtime
871 && eval { $load->($ref->{data}); 1 }) {
872 return;
873 }
874 }
875
876 my $ref = {
877 version => 1,
878 size => $size,
879 mtime => $mtime,
880 data => $create->(),
881 };
882
883 $load->($ref->{data});
884
885 save_ref $ref, $cache;
886}
887
888=item set_libdir $path
889
890Sets the library directory to the given path
891(default: $ENV{CROSSFIRE_LIBDIR}).
892
893You have to (re-)load the archetypes and tilecache manually after steting
894the library path.
895
896=cut
897
898sub set_libdir($) {
899 $LIB = $_[0];
900}
901
902=item load_archetypes
903
904(Re-)Load archetypes into %ARCH.
905
906=cut
907
908sub load_archetypes() {
909 cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
910 *ARCH = $_[0];
911 }, sub {
912 read_arch "$LIB/archetypes"
913 };
914}
915
916=item load_tilecache
917
918(Re-)Load %TILE and %FACE.
919
920=cut
921
922sub load_tilecache() {
923 require Gtk2;
924
925 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
926 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
927 or die "$VARDIR/tilecache.png: $!";
928 *FACE = $_[0];
929 }, sub {
930 my $tile = read_pak "$LIB/crossfire.0";
931
932 my %cache;
933
934 my $idx = 0;
935
936 for my $name (sort keys %$tile) {
937 my $pb = new Gtk2::Gdk::PixbufLoader;
938 $pb->write ($tile->{$name});
939 $pb->close;
940 my $pb = $pb->get_pixbuf;
941
942 my $tile = $cache{$name} = {
943 pb => $pb,
944 idx => $idx,
945 w => int $pb->get_width / TILESIZE,
946 h => int $pb->get_height / TILESIZE,
947 };
948
949
950 $idx += $tile->{w} * $tile->{h};
951 }
952
953 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
954
955 while (my ($name, $tile) = each %cache) {
956 my $tpb = delete $tile->{pb};
957 my $ofs = $tile->{idx};
958
959 for my $x (0 .. $tile->{w} - 1) {
960 for my $y (0 .. $tile->{h} - 1) {
961 my $idx = $ofs + $x + $y * $tile->{w};
962 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
963 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
964 }
965 }
966 }
967
968 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
969
970 \%cache
971 };
972}
372 973
373=head1 AUTHOR 974=head1 AUTHOR
374 975
375 Marc Lehmann <schmorp@schmorp.de> 976 Marc Lehmann <schmorp@schmorp.de>
376 http://home.schmorp.de/ 977 http://home.schmorp.de/

Diff Legend

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