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.63 by root, Fri Mar 31 21:06:47 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) = @_;
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 }
197 } elsif (/^arch (\S+)$/i) { 333 } elsif (/^(\S+)\s*(.*)$/) {
198 push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1); 334 $arc{lc $1} = $2;
199 } elsif (/^\s*($|#)/) { 335 } elsif (/^\s*($|#)/) {
200 # 336 #
201 } else { 337 } else {
202 warn "$path: unparseable top-level line '$_'"; 338 warn "$path: unparsable line '$_' in arch $arc{_name}";
203 } 339 }
204 } 340 }
205 341
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 342 \%arc
212 } 343 };
344
345 while (<$fh>) {
346 s/\s+$//;
347 if (/^more$/i) {
348 $more = $prev;
349 } elsif (/^object (\S+)$/i) {
350 my $name = $1;
351 my $arc = normalize_object $parse_block->(_name => $name);
352
353 if ($more) {
354 $more->{more} = $arc;
355 } else {
356 $arc{$name} = $arc;
357 }
358 $prev = $arc;
359 $more = undef;
360 } elsif (/^arch (\S+)$/i) {
361 my $name = $1;
362 my $arc = normalize_arch $parse_block->(_name => $name);
363
364 if ($more) {
365 $more->{more} = $arc;
366 } else {
367 push @{ $arc{arch} }, $arc;
368 }
369 $prev = $arc;
370 $more = undef;
371 } elsif (/^\s*($|#)/) {
372 #
373 } else {
374 warn "$path: unparseable top-level line '$_'";
375 }
376 }
377
378 undef $parse_block; # work around bug in perl not freeing $fh etc.
379
380 \%arc
213} 381}
214 382
215# put all archs into a hash with editor_face as it's key 383# put all archs into a hash with editor_face as it's key
216# NOTE: the arrays in the hash values are references to 384# NOTE: the arrays in the hash values are references to
217# the archs from $ARCH 385# the archs from $ARCH
218sub editor_archs { 386sub editor_archs {
219 my %paths; 387 my %paths;
220 388
221 for (keys %ARCH) { 389 for (keys %ARCH) {
222 my $arch = $ARCH{$_}; 390 my $arch = $ARCH{$_};
223 push @{$paths{$arch->{editor_folder}}}, \$arch; 391 push @{$paths{$arch->{editor_folder}}}, $arch;
224 } 392 }
225 393
226 \%paths 394 \%paths
227} 395}
228 396
238 my ($a) = @_; 406 my ($a) = @_;
239 407
240 my $o = $ARCH{$a->{_name}} 408 my $o = $ARCH{$a->{_name}}
241 or return; 409 or return;
242 410
243 my $face = $FACE{$a->{face} || $o->{face}} 411 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"}
244 or (warn "no face data found for arch '$a->{_name}'"), return; 412 or (warn "no face data found for arch '$a->{_name}'"), return;
245 413
246 if ($face->{w} > 1 || $face->{h} > 1) { 414 if ($face->{w} > 1 || $face->{h} > 1) {
247 # bigface 415 # bigface
248 return (0, 0, $face->{w} - 1, $face->{h} - 1); 416 return (0, 0, $face->{w} - 1, $face->{h} - 1);
264 # single face 432 # single face
265 return (0, 0, 0, 0); 433 return (0, 0, 0, 0);
266 } 434 }
267} 435}
268 436
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 437=item $type = arch_attr $arch
278 438
279Returns a hashref describing the object and its attributes. It can contain 439Returns a hashref describing the object and its attributes. It can contain
280the following keys: 440the following keys:
281 441
282 name the name, suitable for display purposes 442 name the name, suitable for display purposes
283 ignore 443 ignore
284 attr 444 attr
285 desc 445 desc
286 use 446 use
287 section => [name => \%attr, name => \%attr] 447 section => [name => \%attr, name => \%attr]
448 import
288 449
289=cut 450=cut
290 451
291sub arch_attr($) { 452sub arch_attr($) {
292 my ($arch) = @_; 453 my ($obj) = @_;
293 454
294 require Crossfire::Data; 455 require Crossfire::Data;
295 456
457 my $root;
296 my $attr; 458 my $attr = { };
459
460 my $arch = $ARCH{ $obj->{_name} };
461 my $type = $obj->{type} || $arch->{type};
297 462
298 if ($arch->{type} > 0) { 463 if ($type > 0) {
299 $attr = $Crossfire::Data::ATTR{$arch->{type}+0}; 464 $root = $Crossfire::Data::ATTR{$type};
300 } else { 465 } else {
466 my %a = (%$arch, %$obj);
467
468 if ($a{is_floor} && !$a{alive}) {
469 $root = $Crossfire::Data::TYPE{Floor};
470 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
471 $root = $Crossfire::Data::TYPE{"Monster & NPC"};
472 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
473 $root = $Crossfire::Data::TYPE{Wall};
474 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
475 $root = $Crossfire::Data::TYPE{"Weak Wall"};
476 } else {
301 $attr = $Crossfire::Data::TYPE{Misc}; 477 $root = $Crossfire::Data::TYPE{Misc};
478 }
479 }
302 480
303 type: 481 my @import = ($root);
304 for (@Crossfire::Data::ATTR0) { 482
305 my $req = $_->{required} 483 unshift @import, \%Crossfire::Data::DEFAULT_ATTR
306 or die "internal error: ATTR0 without 'required'"; 484 unless $type == 116;
307 485
308 while (my ($k, $v) = each %$req) { 486 my (%ignore);
309 next type 487 my (@section_order, %section, @attr_order);
310 unless $arch->{$k} == $v; 488
489 while (my $type = shift @import) {
490 push @import, @{$type->{import} || []};
491
492 $attr->{$_} ||= $type->{$_}
493 for qw(name desc use);
494
495 for (@{$type->{ignore} || []}) {
496 $ignore{$_}++ for ref $_ ? @$_ : $_;
497 }
498
499 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
500 my ($name, $attr) = @$_;
501 push @section_order, $name;
502 for (@$attr) {
503 my ($k, $v) = @$_;
504 push @attr_order, $k;
505 $section{$name}{$k} ||= $v;
311 } 506 }
507 }
508 }
312 509
313 $attr = $_; 510 $attr->{section} = [
511 map !exists $section{$_} ? () : do {
512 my $attr = delete $section{$_};
513
514 [
515 $_,
516 map exists $attr->{$_} && !$ignore{$_}
517 ? [$_ => delete $attr->{$_}] : (),
518 @attr_order
519 ]
314 } 520 },
315 } 521
522 exists $section{$_} ? [$_ => delete $section{$_}] : (),
523 @section_order
524 ];
316 525
317 use PApp::Util; 526 $attr
318 warn PApp::Util::dumpval $attr;
319} 527}
320 528
321sub arch_edit_sections { 529sub arch_edit_sections {
322# if (edit_type == IGUIConstants.TILE_EDIT_NONE) 530# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
323# edit_type = 0; 531# edit_type = 0;
377# return(edit_type); 585# return(edit_type);
378# 586#
379# 587#
380} 588}
381 589
382$CACHEDIR ||= "$ENV{HOME}/.crossfire"; 590sub cache_file($$&&) {
591 my ($src, $cache, $load, $create) = @_;
383 592
384init $CACHEDIR; 593 my ($size, $mtime) = (stat $src)[7,9]
594 or Carp::croak "$src: $!";
595
596 if (-e $cache) {
597 my $ref = eval { load_ref $cache };
598
599 if ($ref->{version} == 1
600 && $ref->{size} == $size
601 && $ref->{mtime} == $mtime
602 && eval { $load->($ref->{data}); 1 }) {
603 return;
604 }
605 }
606
607 my $ref = {
608 version => 1,
609 size => $size,
610 mtime => $mtime,
611 data => $create->(),
612 };
613
614 $load->($ref->{data});
615
616 save_ref $ref, $cache;
617}
618
619=item set_libdir $path
620
621Sets the library directory to the given path
622(default: $ENV{CROSSFIRE_LIBDIR}).
623
624You have to (re-)load the archetypes and tilecache manually after steting
625the library path.
626
627=cut
628
629sub set_libdir($) {
630 $LIB = $_[0];
631}
632
633=item load_archetypes
634
635(Re-)Load archetypes into %ARCH.
636
637=cut
638
639sub load_archetypes() {
640 cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
641 *ARCH = $_[0];
642 }, sub {
643 read_arch "$LIB/archetypes"
644 };
645}
646
647=item load_tilecache
648
649(Re-)Load %TILE and %FACE.
650
651=cut
652
653sub load_tilecache() {
654 require Gtk2;
655
656 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
657 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
658 or die "$VARDIR/tilecache.png: $!";
659 *FACE = $_[0];
660 }, sub {
661 my $tile = read_pak "$LIB/crossfire.0";
662
663 my %cache;
664
665 my $idx = 0;
666
667 for my $name (sort keys %$tile) {
668 my $pb = new Gtk2::Gdk::PixbufLoader;
669 $pb->write ($tile->{$name});
670 $pb->close;
671 my $pb = $pb->get_pixbuf;
672
673 my $tile = $cache{$name} = {
674 pb => $pb,
675 idx => $idx,
676 w => int $pb->get_width / TILESIZE,
677 h => int $pb->get_height / TILESIZE,
678 };
679
680
681 $idx += $tile->{w} * $tile->{h};
682 }
683
684 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
685
686 while (my ($name, $tile) = each %cache) {
687 my $tpb = delete $tile->{pb};
688 my $ofs = $tile->{idx};
689
690 for my $x (0 .. $tile->{w} - 1) {
691 for my $y (0 .. $tile->{h} - 1) {
692 my $idx = $ofs + $x + $y * $tile->{w};
693 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
694 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
695 }
696 }
697 }
698
699 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
700
701 \%cache
702 };
703}
385 704
386=head1 AUTHOR 705=head1 AUTHOR
387 706
388 Marc Lehmann <schmorp@schmorp.de> 707 Marc Lehmann <schmorp@schmorp.de>
389 http://home.schmorp.de/ 708 http://home.schmorp.de/

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines