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

Diff Legend

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