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.18 by root, Wed Feb 22 22:41:22 2006 UTC vs.
Revision 1.68 by elmex, Sun Jul 30 17:29:29 2006 UTC

… …
4 4
5=cut 5=cut
6 6
7package Crossfire; 7package Crossfire;
8 8
9our $VERSION = '0.1'; 9our $VERSION = '0.8';
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
24our $LIB = $ENV{CROSSFIRE_LIBDIR} 24our $LIB = $ENV{CROSSFIRE_LIBDIR};
25 or Carp::croak "\$CROSSFIRE_LIBDIR must be set\n"; 25
26our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire";
27
28mkdir $VARDIR, 0777;
26 29
27sub TILESIZE (){ 32 } 30sub TILESIZE (){ 32 }
28 31
29our $CACHEDIR;
30our %ARCH; 32our %ARCH;
31our %FACE; 33our %FACE;
32our $TILE; 34our $TILE;
33 35
34our %FIELD_MULTILINE = ( 36our %FIELD_MULTILINE = (
35 msg => "endmsg", 37 msg => "endmsg",
36 lore => "endlore", 38 lore => "endlore",
39 maplore => "endmaplore",
37); 40);
38 41
39# not used yet, maybe alphabetical is ok 42# movement bit type, PITA
43our %FIELD_MOVEMENT = map +($_ => undef),
44 qw(move_type move_block move_allow move_on move_off move_slow);
45
46# same as in server save routine, to (hopefully) be compatible
47# to the other editors.
48our @FIELD_ORDER_MAP = (qw(
49 name swap_time reset_timeout fixed_resettime difficulty region
50 shopitems shopgreed shopmin shopmax shoprace
51 darkness width height enter_x enter_y msg maplore
52 unique template
53 outdoor temp pressure humid windspeed winddir sky nosmooth
54 tile_path_1 tile_path_2 tile_path_3 tile_path_4
55));
56
40our @FIELD_ORDER = (qw(name name_pl)); 57our @FIELD_ORDER = (qw(
58 elevation
41 59
60 name name_pl custom_name title race
61 slaying skill msg lore other_arch face
62 #todo-events
63 animation is_animated
64 str dex con wis pow cha int
65 hp maxhp sp maxsp grace maxgrace
66 exp perm_exp expmul
67 food dam luck wc ac x y speed speed_left move_state attack_movement
68 nrof level direction type subtype attacktype
69
70 resist_physical resist_magic resist_fire resist_electricity
71 resist_cold resist_confusion resist_acid resist_drain
72 resist_weaponmagic resist_ghosthit resist_poison resist_slow
73 resist_paralyze resist_turn_undead resist_fear resist_cancellation
74 resist_deplete resist_death resist_chaos resist_counterspell
75 resist_godpower resist_holyword resist_blind resist_internal
76 resist_life_stealing resist_disease
77
78 path_attuned path_repelled path_denied material materialname
79 value carrying weight invisible state magic
80 last_heal last_sp last_grace last_eat
81 connected glow_radius randomitems npx_status npc_program
82 run_away pick_up container will_apply smoothlevel
83 current_weapon_script weapontype tooltype elevation client_type
84 item_power duration range
85 range_modifier duration_modifier dam_modifier gen_sp_armour
86 move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty
87
88 alive wiz was_wiz applied unpaid can_use_shield no_pick is_animated monster
89 friendly generator is_thrown auto_apply treasure player sold see_invisible
90 can_roll overlay_floor is_turnable is_used_up identified reflecting changing
91 splitting hitback startequip blocksview undead scared unaggressive
92 reflect_missile reflect_spell no_magic no_fix_player is_lightable tear_down
93 run_away pick_up unique no_drop can_cast_spell can_use_scroll can_use_range
94 can_use_bow can_use_armour can_use_weapon can_use_ring has_ready_range
95 has_ready_bow xrays is_floor lifesave no_strength sleep stand_still
96 random_move only_attack confused stealth cursed damned see_anywhere
97 known_magical known_cursed can_use_skill been_applied has_ready_scroll
98 can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly
99 has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark
100 is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage
101 activate_on_push activate_on_release is_water use_content_on_gen is_buildable
102
103 body_range body_arm body_torso body_head body_neck body_skill
104 body_finger body_shoulder body_foot body_hand body_wrist body_waist
105));
106
107our %EVENT_TYPE = (
108 apply => 1,
109 attack => 2,
110 death => 3,
111 drop => 4,
112 pickup => 5,
113 say => 6,
114 stop => 7,
115 time => 8,
116 throw => 9,
117 trigger => 10,
118 close => 11,
119 timer => 12,
120);
121
42sub MOVE_WALK (){ 0x1 } 122sub MOVE_WALK (){ 0x01 }
43sub MOVE_FLY_LOW (){ 0x2 } 123sub MOVE_FLY_LOW (){ 0x02 }
44sub MOVE_FLY_HIGH (){ 0x4 } 124sub MOVE_FLY_HIGH (){ 0x04 }
45sub MOVE_FLYING (){ 0x6 } 125sub MOVE_FLYING (){ 0x06 }
46sub MOVE_SWIM (){ 0x8 } 126sub MOVE_SWIM (){ 0x08 }
47sub MOVE_ALL (){ 0xf } 127sub MOVE_BOAT (){ 0x10 }
128sub MOVE_KNOWN (){ 0x1f } # all of above
129sub MOVE_ALLBIT (){ 0x10000 }
130sub MOVE_ALL (){ 0x1001f } # very special value, more PITA
48 131
132sub load_ref($) {
133 my ($path) = @_;
134
135 open my $fh, "<:raw:perlio", $path
136 or die "$path: $!";
137 local $/;
138
139 thaw <$fh>
140}
141
142sub save_ref($$) {
143 my ($ref, $path) = @_;
144
145 open my $fh, ">:raw:perlio", "$path~"
146 or die "$path~: $!";
147 print $fh freeze $ref;
148 close $fh;
149 rename "$path~", $path
150 or die "$path: $!";
151}
152
153# object as in "Object xxx", i.e. archetypes
154sub normalize_object($) {
155 my ($ob) = @_;
156
157 # nuke outdated or never supported fields
158 delete $ob->{$_} for qw(
159 can_knockback can_parry can_impale can_cut can_dam_armour
160 can_apply pass_thru can_pass_thru
161 );
162
163 # convert movement strings to bitsets
164 for my $attr (keys %FIELD_MOVEMENT) {
165 next unless exists $ob->{$attr};
166
167 $ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility
168
169 next if $ob->{$attr} =~ /^\d+$/;
170
171 my $flags = 0;
172
173 # assume list
174 for my $flag (map lc, split /\s+/, $ob->{$attr}) {
175 $flags |= MOVE_WALK if $flag eq "walk";
176 $flags |= MOVE_FLY_LOW if $flag eq "fly_low";
177 $flags |= MOVE_FLY_HIGH if $flag eq "fly_high";
178 $flags |= MOVE_FLYING if $flag eq "flying";
179 $flags |= MOVE_SWIM if $flag eq "swim";
180 $flags |= MOVE_BOAT if $flag eq "boat";
181 $flags |= MOVE_ALL if $flag eq "all";
182
183 $flags &= ~MOVE_WALK if $flag eq "-walk";
184 $flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
185 $flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
186 $flags &= ~MOVE_FLYING if $flag eq "-flying";
187 $flags &= ~MOVE_SWIM if $flag eq "-swim";
188 $flags &= ~MOVE_BOAT if $flag eq "-boat";
189 $flags &= ~MOVE_ALL if $flag eq "-all";
190 }
191
192 $ob->{$attr} = $flags;
193 }
194
195 # convert outdated movement flags to new movement sets
196 if (defined (my $v = delete $ob->{no_pass})) {
197 $ob->{move_block} = $v ? MOVE_ALL : 0;
198 }
199 if (defined (my $v = delete $ob->{slow_move})) {
200 $ob->{move_slow} |= MOVE_WALK;
201 $ob->{move_slow_penalty} = $v;
202 }
203 if (defined (my $v = delete $ob->{walk_on})) {
204 $ob->{move_on} = MOVE_ALL unless exists $ob->{move_on};
205 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK
206 : $ob->{move_on} & ~MOVE_WALK;
207 }
208 if (defined (my $v = delete $ob->{walk_off})) {
209 $ob->{move_off} = MOVE_ALL unless exists $ob->{move_off};
210 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK
211 : $ob->{move_off} & ~MOVE_WALK;
212 }
213 if (defined (my $v = delete $ob->{fly_on})) {
214 $ob->{move_on} = MOVE_ALL unless exists $ob->{move_on};
215 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW
216 : $ob->{move_on} & ~MOVE_FLY_LOW;
217 }
218 if (defined (my $v = delete $ob->{fly_off})) {
219 $ob->{move_off} = MOVE_ALL unless exists $ob->{move_off};
220 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW
221 : $ob->{move_off} & ~MOVE_FLY_LOW;
222 }
223 if (defined (my $v = delete $ob->{flying})) {
224 $ob->{move_type} = MOVE_ALL unless exists $ob->{move_type};
225 $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW
226 : $ob->{move_type} & ~MOVE_FLY_LOW;
227 }
228
229 # convert idiotic event_xxx things into objects
230 while (my ($event, $subtype) = each %EVENT_TYPE) {
231 if (exists $ob->{"event_${event}_plugin"}) {
232 push @{$ob->{inventory}}, {
233 _name => "event_$event",
234 title => delete $ob->{"event_${event}_plugin"},
235 slaying => delete $ob->{"event_${event}"},
236 name => delete $ob->{"event_${event}_options"},
237 };
238 }
239 }
240
241 $ob
242}
243
244# arch as in "arch xxx", ie.. objects
49sub normalize_arch($) { 245sub normalize_arch($) {
50 my ($ob) = @_; 246 my ($ob) = @_;
51 247
248 normalize_object $ob;
249
52 my $arch = $ARCH{$ob->{_name}} 250 my $arch = $ARCH{$ob->{_name}}
53 or (warn "$ob->{_name}: no such archetype", return $ob); 251 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 252
57 if ($arch->{type} == 22) { # map 253 if ($arch->{type} == 22) { # map
58 my %normalize = ( 254 my %normalize = (
59 "enter_x" => "hp", 255 "enter_x" => "hp",
60 "enter_y" => "sp", 256 "enter_y" => "sp",
… …
70 while (my ($k2, $k1) = each %normalize) { 266 while (my ($k2, $k1) = each %normalize) {
71 if (defined (my $v = delete $ob->{$k1})) { 267 if (defined (my $v = delete $ob->{$k1})) {
72 $ob->{$k2} = $v; 268 $ob->{$k2} = $v;
73 } 269 }
74 } 270 }
75 } 271 } 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 272 # if value matches archetype default, delete
102 while (my ($k, $v) = each %$ob) { 273 while (my ($k, $v) = each %$ob) {
103 if (exists $arch->{$k} and $arch->{$k} eq $v) { 274 if (exists $arch->{$k} and $arch->{$k} eq $v) {
104 next if $k eq "_name"; 275 next if $k eq "_name";
105 delete $ob->{$k}; 276 delete $ob->{$k};
106 } 277 }
278 }
279 }
280
281 # a speciality for the editor
282 if (exists $ob->{attack_movement}) {
283 my $am = delete $ob->{attack_movement};
284 $ob->{attack_movement_bits_0_3} = $am & 15;
285 $ob->{attack_movement_bits_4_7} = $am & 240;
107 } 286 }
108 287
109 $ob 288 $ob
110} 289}
111 290
112sub read_pak($;$) { 291sub read_pak($) {
113 my ($path, $cache) = @_; 292 my ($path) = @_;
114 293
115 eval {
116 defined $cache
117 && -M $cache < -M $path
118 && Storable::retrieve $cache
119 } or do {
120 my %pak; 294 my %pak;
121 295
122 open my $fh, "<:raw", $path 296 open my $fh, "<:raw:perlio", $path
123 or Carp::croak "$_[0]: $!"; 297 or Carp::croak "$_[0]: $!";
298 binmode $fh;
124 while (<$fh>) { 299 while (<$fh>) {
125 my ($type, $id, $len, $path) = split; 300 my ($type, $id, $len, $path) = split;
126 $path =~ s/.*\///; 301 $path =~ s/.*\///;
127 read $fh, $pak{$path}, $len; 302 read $fh, $pak{$path}, $len;
128 } 303 }
129 304
130 Storable::nstore \%pak, $cache
131 if defined $cache;
132
133 \%pak 305 \%pak
134 }
135} 306}
136 307
137sub read_arch($;$) { 308sub read_arch($;$) {
138 my ($path, $cache) = @_; 309 my ($path, $toplevel) = @_;
139 310
140 eval {
141 defined $cache
142 && -M $cache < -M $path
143 && Storable::retrieve $cache
144 } or do {
145 my %arc; 311 my %arc;
146 my ($more, $prev); 312 my ($more, $prev);
147 313
148 open my $fh, "<:raw", $path 314 open my $fh, "<:raw:perlio:utf8", $path
149 or Carp::croak "$path: $!"; 315 or Carp::croak "$path: $!";
150 316
317# binmode $fh;
318
151 my $parse_block; $parse_block = sub { 319 my $parse_block; $parse_block = sub {
152 my %arc = @_; 320 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 321
182 while (<$fh>) { 322 while (<$fh>) {
183 s/\s+$//; 323 s/\s+$//;
184 if (/^more$/i) { 324 if (/^end$/i) {
185 $more = $prev; 325 last;
186 } elsif (/^object (\S+)$/i) { 326 } elsif (/^arch (\S+)$/i) {
187 my $name = $1; 327 push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);
188 my $arc = $parse_block->(_name => $name); 328 } elsif (/^lore$/i) {
189 329 while (<$fh>) {
190 if ($more) { 330 last if /^endlore\s*$/i;
191 $more->{more} = $arc;
192 } else {
193 $arc{$name} = $arc; 331 $arc{lore} .= $_;
194 } 332 }
195 $prev = $arc; 333 } elsif (/^msg$/i) {
196 $more = undef; 334 while (<$fh>) {
335 last if /^endmsg\s*$/i;
336 $arc{msg} .= $_;
337 }
338 } elsif (/^anim$/i) {
339 while (<$fh>) {
340 last if /^mina\s*$/i;
341 chomp;
342 push @{ $arc{anim} }, $_;
343 }
197 } elsif (/^arch (\S+)$/i) { 344 } elsif (/^(\S+)\s*(.*)$/) {
198 push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1); 345 $arc{lc $1} = $2;
199 } elsif (/^\s*($|#)/) { 346 } elsif (/^\s*($|#)/) {
200 # 347 #
201 } else { 348 } else {
202 warn "$path: unparseable top-level line '$_'"; 349 warn "$path: unparsable line '$_' in arch $arc{_name}";
203 } 350 }
204 } 351 }
205 352
206 undef $parse_block; # work around bug in perl not freeing $fh etc.
207
208 Storable::nstore \%arc, $cache
209 if defined $cache;
210
211 \%arc 353 \%arc
212 } 354 };
355
356 while (<$fh>) {
357 s/\s+$//;
358 if (/^more$/i) {
359 $more = $prev;
360 } elsif (/^object (\S+)$/i) {
361 my $name = $1;
362 my $arc = normalize_object $parse_block->(_name => $name);
363
364 if ($more) {
365 $more->{more} = $arc;
366 } else {
367 $arc{$name} = $arc;
368 }
369 $prev = $arc;
370 $more = undef;
371 } elsif (/^arch (\S+)$/i) {
372 my $name = $1;
373 my $arc = normalize_arch $parse_block->(_name => $name);
374
375 if ($more) {
376 $more->{more} = $arc;
377 } else {
378 push @{ $arc{arch} }, $arc;
379 }
380 $prev = $arc;
381 $more = undef;
382 } elsif ($toplevel && /^(\S+)\s+(.*)$/) {
383 if ($1 eq "lev_array") {
384 while (<$fh>) {
385 last if /^endplst\s*$/;
386 push @{$toplevel->{lev_array}}, $_+0;
387 }
388 } else {
389 $toplevel->{$1} = $2;
390 }
391 } elsif (/^\s*($|#)/) {
392 #
393 } else {
394 die "$path: unparseable top-level line '$_'";
395 }
396 }
397
398 undef $parse_block; # work around bug in perl not freeing $fh etc.
399
400 \%arc
213} 401}
214 402
215# put all archs into a hash with editor_face as it's key 403# put all archs into a hash with editor_face as it's key
216# NOTE: the arrays in the hash values are references to 404# NOTE: the arrays in the hash values are references to
217# the archs from $ARCH 405# the archs from $ARCH
218sub editor_archs { 406sub editor_archs {
219 my %paths; 407 my %paths;
220 408
221 for (keys %ARCH) { 409 for (keys %ARCH) {
222 my $arch = $ARCH{$_}; 410 my $arch = $ARCH{$_};
223 push @{$paths{$arch->{editor_folder}}}, \$arch; 411 push @{$paths{$arch->{editor_folder}}}, $arch;
224 } 412 }
225 413
226 \%paths 414 \%paths
227} 415}
228 416
… …
238 my ($a) = @_; 426 my ($a) = @_;
239 427
240 my $o = $ARCH{$a->{_name}} 428 my $o = $ARCH{$a->{_name}}
241 or return; 429 or return;
242 430
243 my $face = $FACE{$a->{face} || $o->{face}} 431 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"}
244 or (warn "no face data found for arch '$a->{_name}'"), return; 432 or (warn "no face data found for arch '$a->{_name}'"), return;
245 433
246 if ($face->{w} > 1 || $face->{h} > 1) { 434 if ($face->{w} > 1 || $face->{h} > 1) {
247 # bigface 435 # bigface
248 return (0, 0, $face->{w} - 1, $face->{h} - 1); 436 return (0, 0, $face->{w} - 1, $face->{h} - 1);
… …
264 # single face 452 # single face
265 return (0, 0, 0, 0); 453 return (0, 0, 0, 0);
266 } 454 }
267} 455}
268 456
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 457=item $type = arch_attr $arch
278 458
279Returns a hashref describing the object and its attributes. It can contain 459Returns a hashref describing the object and its attributes. It can contain
280the following keys: 460the following keys:
281 461
282 name the name, suitable for display purposes 462 name the name, suitable for display purposes
283 ignore 463 ignore
284 attr 464 attr
285 desc 465 desc
286 use 466 use
287 section => [name => \%attr, name => \%attr] 467 section => [name => \%attr, name => \%attr]
468 import
288 469
289=cut 470=cut
290 471
291sub arch_attr($) { 472sub arch_attr($) {
292 my ($arch) = @_; 473 my ($obj) = @_;
293 474
294 require Crossfire::Data; 475 require Crossfire::Data;
295 476
477 my $root;
296 my $attr; 478 my $attr = { };
479
480 my $arch = $ARCH{ $obj->{_name} };
481 my $type = $obj->{type} || $arch->{type};
297 482
298 if ($arch->{type} > 0) { 483 if ($type > 0) {
299 $attr = $Crossfire::Data::ATTR{$arch->{type}+0}; 484 $root = $Crossfire::Data::ATTR{$type};
300 } else { 485 } else {
486 my %a = (%$arch, %$obj);
487
488 if ($a{is_floor} && !$a{alive}) {
489 $root = $Crossfire::Data::TYPE{Floor};
490 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
491 $root = $Crossfire::Data::TYPE{"Monster & NPC"};
492 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
493 $root = $Crossfire::Data::TYPE{Wall};
494 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
495 $root = $Crossfire::Data::TYPE{"Weak Wall"};
496 } else {
301 $attr = $Crossfire::Data::TYPE{Misc}; 497 $root = $Crossfire::Data::TYPE{Misc};
498 }
499 }
302 500
303 type: 501 my @import = ($root);
304 for (@Crossfire::Data::ATTR0) { 502
305 my $req = $_->{required} 503 unshift @import, \%Crossfire::Data::DEFAULT_ATTR
306 or die "internal error: ATTR0 without 'required'"; 504 unless $type == 116;
307 505
308 while (my ($k, $v) = each %$req) { 506 my (%ignore);
309 next type 507 my (@section_order, %section, @attr_order);
310 unless $arch->{$k} == $v; 508
509 while (my $type = shift @import) {
510 push @import, @{$type->{import} || []};
511
512 $attr->{$_} ||= $type->{$_}
513 for qw(name desc use);
514
515 for (@{$type->{ignore} || []}) {
516 $ignore{$_}++ for ref $_ ? @$_ : $_;
517 }
518
519 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
520 my ($name, $attr) = @$_;
521 push @section_order, $name;
522 for (@$attr) {
523 my ($k, $v) = @$_;
524 push @attr_order, $k;
525 $section{$name}{$k} ||= $v;
311 } 526 }
527 }
528 }
312 529
313 $attr = $_; 530 $attr->{section} = [
531 map !exists $section{$_} ? () : do {
532 my $attr = delete $section{$_};
533
534 [
535 $_,
536 map exists $attr->{$_} && !$ignore{$_}
537 ? [$_ => delete $attr->{$_}] : (),
538 @attr_order
539 ]
314 } 540 },
315 } 541
542 exists $section{$_} ? [$_ => delete $section{$_}] : (),
543 @section_order
544 ];
316 545
317 use PApp::Util; 546 $attr
318 warn PApp::Util::dumpval $attr;
319} 547}
320 548
321sub arch_edit_sections { 549sub arch_edit_sections {
322# if (edit_type == IGUIConstants.TILE_EDIT_NONE) 550# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
323# edit_type = 0; 551# edit_type = 0;
… …
377# return(edit_type); 605# return(edit_type);
378# 606#
379# 607#
380} 608}
381 609
382$CACHEDIR ||= "$ENV{HOME}/.crossfire"; 610sub cache_file($$&&) {
611 my ($src, $cache, $load, $create) = @_;
383 612
384init $CACHEDIR; 613 my ($size, $mtime) = (stat $src)[7,9]
614 or Carp::croak "$src: $!";
615
616 if (-e $cache) {
617 my $ref = eval { load_ref $cache };
618
619 if ($ref->{version} == 1
620 && $ref->{size} == $size
621 && $ref->{mtime} == $mtime
622 && eval { $load->($ref->{data}); 1 }) {
623 return;
624 }
625 }
626
627 my $ref = {
628 version => 1,
629 size => $size,
630 mtime => $mtime,
631 data => $create->(),
632 };
633
634 $load->($ref->{data});
635
636 save_ref $ref, $cache;
637}
638
639=item set_libdir $path
640
641Sets the library directory to the given path
642(default: $ENV{CROSSFIRE_LIBDIR}).
643
644You have to (re-)load the archetypes and tilecache manually after steting
645the library path.
646
647=cut
648
649sub set_libdir($) {
650 $LIB = $_[0];
651}
652
653=item load_archetypes
654
655(Re-)Load archetypes into %ARCH.
656
657=cut
658
659sub load_archetypes() {
660 cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
661 *ARCH = $_[0];
662 }, sub {
663 read_arch "$LIB/archetypes"
664 };
665}
666
667=item load_tilecache
668
669(Re-)Load %TILE and %FACE.
670
671=cut
672
673sub load_tilecache() {
674 require Gtk2;
675
676 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
677 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
678 or die "$VARDIR/tilecache.png: $!";
679 *FACE = $_[0];
680 }, sub {
681 my $tile = read_pak "$LIB/crossfire.0";
682
683 my %cache;
684
685 my $idx = 0;
686
687 for my $name (sort keys %$tile) {
688 my $pb = new Gtk2::Gdk::PixbufLoader;
689 $pb->write ($tile->{$name});
690 $pb->close;
691 my $pb = $pb->get_pixbuf;
692
693 my $tile = $cache{$name} = {
694 pb => $pb,
695 idx => $idx,
696 w => int $pb->get_width / TILESIZE,
697 h => int $pb->get_height / TILESIZE,
698 };
699
700
701 $idx += $tile->{w} * $tile->{h};
702 }
703
704 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
705
706 while (my ($name, $tile) = each %cache) {
707 my $tpb = delete $tile->{pb};
708 my $ofs = $tile->{idx};
709
710 for my $x (0 .. $tile->{w} - 1) {
711 for my $y (0 .. $tile->{h} - 1) {
712 my $idx = $ofs + $x + $y * $tile->{w};
713 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
714 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
715 }
716 }
717 }
718
719 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
720
721 \%cache
722 };
723}
385 724
386=head1 AUTHOR 725=head1 AUTHOR
387 726
388 Marc Lehmann <schmorp@schmorp.de> 727 Marc Lehmann <schmorp@schmorp.de>
389 http://home.schmorp.de/ 728 http://home.schmorp.de/

Diff Legend

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