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.65 by root, Wed May 3 19:34:31 2006 UTC

… …
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} = $v ? $ob->{move_on} | MOVE_WALK
205 : $ob->{move_on} & ~MOVE_WALK;
206 }
207 if (defined (my $v = delete $ob->{walk_off})) {
208 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK
209 : $ob->{move_off} & ~MOVE_WALK;
210 }
211 if (defined (my $v = delete $ob->{fly_on})) {
212 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW
213 : $ob->{move_on} & ~MOVE_FLY_LOW;
214 }
215 if (defined (my $v = delete $ob->{fly_off})) {
216 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW
217 : $ob->{move_off} & ~MOVE_FLY_LOW;
218 }
219 if (defined (my $v = delete $ob->{flying})) {
220 $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW
221 : $ob->{move_type} & ~MOVE_FLY_LOW;
222 }
223
224 # convert idiotic event_xxx things into objects
225 while (my ($event, $subtype) = each %EVENT_TYPE) {
226 if (exists $ob->{"event_${event}_plugin"}) {
227 push @{$ob->{inventory}}, {
228 _name => "event_$event",
229 title => delete $ob->{"event_${event}_plugin"},
230 slaying => delete $ob->{"event_${event}"},
231 name => delete $ob->{"event_${event}_options"},
232 };
233 }
234 }
235
236 $ob
237}
238
239# arch as in "arch xxx", ie.. objects
49sub normalize_arch($) { 240sub normalize_arch($) {
50 my ($ob) = @_; 241 my ($ob) = @_;
51 242
243 normalize_object $ob;
244
52 my $arch = $ARCH{$ob->{_name}} 245 my $arch = $ARCH{$ob->{_name}}
53 or (warn "$ob->{_name}: no such archetype", return $ob); 246 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 247
57 if ($arch->{type} == 22) { # map 248 if ($arch->{type} == 22) { # map
58 my %normalize = ( 249 my %normalize = (
59 "enter_x" => "hp", 250 "enter_x" => "hp",
60 "enter_y" => "sp", 251 "enter_y" => "sp",
… …
70 while (my ($k2, $k1) = each %normalize) { 261 while (my ($k2, $k1) = each %normalize) {
71 if (defined (my $v = delete $ob->{$k1})) { 262 if (defined (my $v = delete $ob->{$k1})) {
72 $ob->{$k2} = $v; 263 $ob->{$k2} = $v;
73 } 264 }
74 } 265 }
75 } 266 } 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 267 # if value matches archetype default, delete
102 while (my ($k, $v) = each %$ob) { 268 while (my ($k, $v) = each %$ob) {
103 if (exists $arch->{$k} and $arch->{$k} eq $v) { 269 if (exists $arch->{$k} and $arch->{$k} eq $v) {
104 next if $k eq "_name"; 270 next if $k eq "_name";
105 delete $ob->{$k}; 271 delete $ob->{$k};
106 } 272 }
273 }
274 }
275
276 # a speciality for the editor
277 if (exists $ob->{attack_movement}) {
278 my $am = delete $ob->{attack_movement};
279 $ob->{attack_movement_bits_0_3} = $am & 15;
280 $ob->{attack_movement_bits_4_7} = $am & 240;
107 } 281 }
108 282
109 $ob 283 $ob
110} 284}
111 285
112sub read_pak($;$) { 286sub read_pak($) {
113 my ($path, $cache) = @_; 287 my ($path) = @_;
114 288
115 eval {
116 defined $cache
117 && -M $cache < -M $path
118 && Storable::retrieve $cache
119 } or do {
120 my %pak; 289 my %pak;
121 290
122 open my $fh, "<:raw", $path 291 open my $fh, "<:raw:perlio", $path
123 or Carp::croak "$_[0]: $!"; 292 or Carp::croak "$_[0]: $!";
293 binmode $fh;
124 while (<$fh>) { 294 while (<$fh>) {
125 my ($type, $id, $len, $path) = split; 295 my ($type, $id, $len, $path) = split;
126 $path =~ s/.*\///; 296 $path =~ s/.*\///;
127 read $fh, $pak{$path}, $len; 297 read $fh, $pak{$path}, $len;
128 } 298 }
129 299
130 Storable::nstore \%pak, $cache
131 if defined $cache;
132
133 \%pak 300 \%pak
134 }
135} 301}
136 302
137sub read_arch($;$) { 303sub read_arch($;$) {
138 my ($path, $cache) = @_; 304 my ($path, $toplevel) = @_;
139 305
140 eval {
141 defined $cache
142 && -M $cache < -M $path
143 && Storable::retrieve $cache
144 } or do {
145 my %arc; 306 my %arc;
146 my ($more, $prev); 307 my ($more, $prev);
147 308
148 open my $fh, "<:raw", $path 309 open my $fh, "<:raw:perlio:utf8", $path
149 or Carp::croak "$path: $!"; 310 or Carp::croak "$path: $!";
150 311
312 binmode $fh;
313
151 my $parse_block; $parse_block = sub { 314 my $parse_block; $parse_block = sub {
152 my %arc = @_; 315 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 316
182 while (<$fh>) { 317 while (<$fh>) {
183 s/\s+$//; 318 s/\s+$//;
184 if (/^more$/i) { 319 if (/^end$/i) {
185 $more = $prev; 320 last;
186 } elsif (/^object (\S+)$/i) { 321 } elsif (/^arch (\S+)$/i) {
187 my $name = $1; 322 push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);
188 my $arc = $parse_block->(_name => $name); 323 } elsif (/^lore$/i) {
189 324 while (<$fh>) {
190 if ($more) { 325 last if /^endlore\s*$/i;
191 $more->{more} = $arc;
192 } else {
193 $arc{$name} = $arc; 326 $arc{lore} .= $_;
194 } 327 }
195 $prev = $arc; 328 } elsif (/^msg$/i) {
196 $more = undef; 329 while (<$fh>) {
330 last if /^endmsg\s*$/i;
331 $arc{msg} .= $_;
332 }
333 } elsif (/^anim$/i) {
334 while (<$fh>) {
335 last if /^mina\s*$/i;
336 chomp;
337 push @{ $arc{anim} }, $_;
338 }
197 } elsif (/^arch (\S+)$/i) { 339 } elsif (/^(\S+)\s*(.*)$/) {
198 push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1); 340 $arc{lc $1} = $2;
199 } elsif (/^\s*($|#)/) { 341 } elsif (/^\s*($|#)/) {
200 # 342 #
201 } else { 343 } else {
202 warn "$path: unparseable top-level line '$_'"; 344 warn "$path: unparsable line '$_' in arch $arc{_name}";
203 } 345 }
204 } 346 }
205 347
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 348 \%arc
212 } 349 };
350
351 while (<$fh>) {
352 s/\s+$//;
353 if (/^more$/i) {
354 $more = $prev;
355 } elsif (/^object (\S+)$/i) {
356 my $name = $1;
357 my $arc = normalize_object $parse_block->(_name => $name);
358
359 if ($more) {
360 $more->{more} = $arc;
361 } else {
362 $arc{$name} = $arc;
363 }
364 $prev = $arc;
365 $more = undef;
366 } elsif (/^arch (\S+)$/i) {
367 my $name = $1;
368 my $arc = normalize_arch $parse_block->(_name => $name);
369
370 if ($more) {
371 $more->{more} = $arc;
372 } else {
373 push @{ $arc{arch} }, $arc;
374 }
375 $prev = $arc;
376 $more = undef;
377 } elsif ($toplevel && /^(\S+)\s+(.*)$/) {
378 if ($1 eq "lev_array") {
379 while (<$fh>) {
380 last if /^endplst\s*$/;
381 push @{$toplevel->{lev_array}}, $_+0;
382 }
383 } else {
384 $toplevel->{$1} = $2;
385 }
386 } elsif (/^\s*($|#)/) {
387 #
388 } else {
389 die "$path: unparseable top-level line '$_'";
390 }
391 }
392
393 undef $parse_block; # work around bug in perl not freeing $fh etc.
394
395 \%arc
213} 396}
214 397
215# put all archs into a hash with editor_face as it's key 398# put all archs into a hash with editor_face as it's key
216# NOTE: the arrays in the hash values are references to 399# NOTE: the arrays in the hash values are references to
217# the archs from $ARCH 400# the archs from $ARCH
218sub editor_archs { 401sub editor_archs {
219 my %paths; 402 my %paths;
220 403
221 for (keys %ARCH) { 404 for (keys %ARCH) {
222 my $arch = $ARCH{$_}; 405 my $arch = $ARCH{$_};
223 push @{$paths{$arch->{editor_folder}}}, \$arch; 406 push @{$paths{$arch->{editor_folder}}}, $arch;
224 } 407 }
225 408
226 \%paths 409 \%paths
227} 410}
228 411
… …
238 my ($a) = @_; 421 my ($a) = @_;
239 422
240 my $o = $ARCH{$a->{_name}} 423 my $o = $ARCH{$a->{_name}}
241 or return; 424 or return;
242 425
243 my $face = $FACE{$a->{face} || $o->{face}} 426 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"}
244 or (warn "no face data found for arch '$a->{_name}'"), return; 427 or (warn "no face data found for arch '$a->{_name}'"), return;
245 428
246 if ($face->{w} > 1 || $face->{h} > 1) { 429 if ($face->{w} > 1 || $face->{h} > 1) {
247 # bigface 430 # bigface
248 return (0, 0, $face->{w} - 1, $face->{h} - 1); 431 return (0, 0, $face->{w} - 1, $face->{h} - 1);
… …
264 # single face 447 # single face
265 return (0, 0, 0, 0); 448 return (0, 0, 0, 0);
266 } 449 }
267} 450}
268 451
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 452=item $type = arch_attr $arch
278 453
279Returns a hashref describing the object and its attributes. It can contain 454Returns a hashref describing the object and its attributes. It can contain
280the following keys: 455the following keys:
281 456
282 name the name, suitable for display purposes 457 name the name, suitable for display purposes
283 ignore 458 ignore
284 attr 459 attr
285 desc 460 desc
286 use 461 use
287 section => [name => \%attr, name => \%attr] 462 section => [name => \%attr, name => \%attr]
463 import
288 464
289=cut 465=cut
290 466
291sub arch_attr($) { 467sub arch_attr($) {
292 my ($arch) = @_; 468 my ($obj) = @_;
293 469
294 require Crossfire::Data; 470 require Crossfire::Data;
295 471
472 my $root;
296 my $attr; 473 my $attr = { };
474
475 my $arch = $ARCH{ $obj->{_name} };
476 my $type = $obj->{type} || $arch->{type};
297 477
298 if ($arch->{type} > 0) { 478 if ($type > 0) {
299 $attr = $Crossfire::Data::ATTR{$arch->{type}+0}; 479 $root = $Crossfire::Data::ATTR{$type};
300 } else { 480 } else {
481 my %a = (%$arch, %$obj);
482
483 if ($a{is_floor} && !$a{alive}) {
484 $root = $Crossfire::Data::TYPE{Floor};
485 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
486 $root = $Crossfire::Data::TYPE{"Monster & NPC"};
487 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
488 $root = $Crossfire::Data::TYPE{Wall};
489 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
490 $root = $Crossfire::Data::TYPE{"Weak Wall"};
491 } else {
301 $attr = $Crossfire::Data::TYPE{Misc}; 492 $root = $Crossfire::Data::TYPE{Misc};
493 }
494 }
302 495
303 type: 496 my @import = ($root);
304 for (@Crossfire::Data::ATTR0) { 497
305 my $req = $_->{required} 498 unshift @import, \%Crossfire::Data::DEFAULT_ATTR
306 or die "internal error: ATTR0 without 'required'"; 499 unless $type == 116;
307 500
308 while (my ($k, $v) = each %$req) { 501 my (%ignore);
309 next type 502 my (@section_order, %section, @attr_order);
310 unless $arch->{$k} == $v; 503
504 while (my $type = shift @import) {
505 push @import, @{$type->{import} || []};
506
507 $attr->{$_} ||= $type->{$_}
508 for qw(name desc use);
509
510 for (@{$type->{ignore} || []}) {
511 $ignore{$_}++ for ref $_ ? @$_ : $_;
512 }
513
514 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
515 my ($name, $attr) = @$_;
516 push @section_order, $name;
517 for (@$attr) {
518 my ($k, $v) = @$_;
519 push @attr_order, $k;
520 $section{$name}{$k} ||= $v;
311 } 521 }
522 }
523 }
312 524
313 $attr = $_; 525 $attr->{section} = [
526 map !exists $section{$_} ? () : do {
527 my $attr = delete $section{$_};
528
529 [
530 $_,
531 map exists $attr->{$_} && !$ignore{$_}
532 ? [$_ => delete $attr->{$_}] : (),
533 @attr_order
534 ]
314 } 535 },
315 } 536
537 exists $section{$_} ? [$_ => delete $section{$_}] : (),
538 @section_order
539 ];
316 540
317 use PApp::Util; 541 $attr
318 warn PApp::Util::dumpval $attr;
319} 542}
320 543
321sub arch_edit_sections { 544sub arch_edit_sections {
322# if (edit_type == IGUIConstants.TILE_EDIT_NONE) 545# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
323# edit_type = 0; 546# edit_type = 0;
… …
377# return(edit_type); 600# return(edit_type);
378# 601#
379# 602#
380} 603}
381 604
382$CACHEDIR ||= "$ENV{HOME}/.crossfire"; 605sub cache_file($$&&) {
606 my ($src, $cache, $load, $create) = @_;
383 607
384init $CACHEDIR; 608 my ($size, $mtime) = (stat $src)[7,9]
609 or Carp::croak "$src: $!";
610
611 if (-e $cache) {
612 my $ref = eval { load_ref $cache };
613
614 if ($ref->{version} == 1
615 && $ref->{size} == $size
616 && $ref->{mtime} == $mtime
617 && eval { $load->($ref->{data}); 1 }) {
618 return;
619 }
620 }
621
622 my $ref = {
623 version => 1,
624 size => $size,
625 mtime => $mtime,
626 data => $create->(),
627 };
628
629 $load->($ref->{data});
630
631 save_ref $ref, $cache;
632}
633
634=item set_libdir $path
635
636Sets the library directory to the given path
637(default: $ENV{CROSSFIRE_LIBDIR}).
638
639You have to (re-)load the archetypes and tilecache manually after steting
640the library path.
641
642=cut
643
644sub set_libdir($) {
645 $LIB = $_[0];
646}
647
648=item load_archetypes
649
650(Re-)Load archetypes into %ARCH.
651
652=cut
653
654sub load_archetypes() {
655 cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
656 *ARCH = $_[0];
657 }, sub {
658 read_arch "$LIB/archetypes"
659 };
660}
661
662=item load_tilecache
663
664(Re-)Load %TILE and %FACE.
665
666=cut
667
668sub load_tilecache() {
669 require Gtk2;
670
671 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
672 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
673 or die "$VARDIR/tilecache.png: $!";
674 *FACE = $_[0];
675 }, sub {
676 my $tile = read_pak "$LIB/crossfire.0";
677
678 my %cache;
679
680 my $idx = 0;
681
682 for my $name (sort keys %$tile) {
683 my $pb = new Gtk2::Gdk::PixbufLoader;
684 $pb->write ($tile->{$name});
685 $pb->close;
686 my $pb = $pb->get_pixbuf;
687
688 my $tile = $cache{$name} = {
689 pb => $pb,
690 idx => $idx,
691 w => int $pb->get_width / TILESIZE,
692 h => int $pb->get_height / TILESIZE,
693 };
694
695
696 $idx += $tile->{w} * $tile->{h};
697 }
698
699 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
700
701 while (my ($name, $tile) = each %cache) {
702 my $tpb = delete $tile->{pb};
703 my $ofs = $tile->{idx};
704
705 for my $x (0 .. $tile->{w} - 1) {
706 for my $y (0 .. $tile->{h} - 1) {
707 my $idx = $ofs + $x + $y * $tile->{w};
708 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
709 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
710 }
711 }
712 }
713
714 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
715
716 \%cache
717 };
718}
385 719
386=head1 AUTHOR 720=head1 AUTHOR
387 721
388 Marc Lehmann <schmorp@schmorp.de> 722 Marc Lehmann <schmorp@schmorp.de>
389 http://home.schmorp.de/ 723 http://home.schmorp.de/

Diff Legend

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