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.64 by root, Sun Apr 2 20:17:23 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 }
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 ($toplevel && /^(\S+)\s+(.*)$/) {
372 if ($1 eq "lev_array") {
373 while (<$fh>) {
374 last if /^endplst\s*$/;
375 push @{$toplevel->{lev_array}}, $_+0;
376 }
377 } else {
378 $toplevel->{$1} = $2;
379 }
380 } elsif (/^\s*($|#)/) {
381 #
382 } else {
383 die "$path: unparseable top-level line '$_'";
384 }
385 }
386
387 undef $parse_block; # work around bug in perl not freeing $fh etc.
388
389 \%arc
213} 390}
214 391
215# put all archs into a hash with editor_face as it's key 392# put all archs into a hash with editor_face as it's key
216# NOTE: the arrays in the hash values are references to 393# NOTE: the arrays in the hash values are references to
217# the archs from $ARCH 394# the archs from $ARCH
218sub editor_archs { 395sub editor_archs {
219 my %paths; 396 my %paths;
220 397
221 for (keys %ARCH) { 398 for (keys %ARCH) {
222 my $arch = $ARCH{$_}; 399 my $arch = $ARCH{$_};
223 push @{$paths{$arch->{editor_folder}}}, \$arch; 400 push @{$paths{$arch->{editor_folder}}}, $arch;
224 } 401 }
225 402
226 \%paths 403 \%paths
227} 404}
228 405
… …
238 my ($a) = @_; 415 my ($a) = @_;
239 416
240 my $o = $ARCH{$a->{_name}} 417 my $o = $ARCH{$a->{_name}}
241 or return; 418 or return;
242 419
243 my $face = $FACE{$a->{face} || $o->{face}} 420 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"}
244 or (warn "no face data found for arch '$a->{_name}'"), return; 421 or (warn "no face data found for arch '$a->{_name}'"), return;
245 422
246 if ($face->{w} > 1 || $face->{h} > 1) { 423 if ($face->{w} > 1 || $face->{h} > 1) {
247 # bigface 424 # bigface
248 return (0, 0, $face->{w} - 1, $face->{h} - 1); 425 return (0, 0, $face->{w} - 1, $face->{h} - 1);
… …
264 # single face 441 # single face
265 return (0, 0, 0, 0); 442 return (0, 0, 0, 0);
266 } 443 }
267} 444}
268 445
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 446=item $type = arch_attr $arch
278 447
279Returns a hashref describing the object and its attributes. It can contain 448Returns a hashref describing the object and its attributes. It can contain
280the following keys: 449the following keys:
281 450
282 name the name, suitable for display purposes 451 name the name, suitable for display purposes
283 ignore 452 ignore
284 attr 453 attr
285 desc 454 desc
286 use 455 use
287 section => [name => \%attr, name => \%attr] 456 section => [name => \%attr, name => \%attr]
457 import
288 458
289=cut 459=cut
290 460
291sub arch_attr($) { 461sub arch_attr($) {
292 my ($arch) = @_; 462 my ($obj) = @_;
293 463
294 require Crossfire::Data; 464 require Crossfire::Data;
295 465
296 my %attr; 466 my $root;
467 my $attr = { };
468
469 my $arch = $ARCH{ $obj->{_name} };
470 my $type = $obj->{type} || $arch->{type};
297 471
298 if ($arch->{type} > 0) { 472 if ($type > 0) {
299 %attr = %{ $Crossfire::Data::ATTR{$arch->{type}+0} || {} }; 473 $root = $Crossfire::Data::ATTR{$type};
300 } else { 474 } else {
301 die; 475 my %a = (%$arch, %$obj);
476
477 if ($a{is_floor} && !$a{alive}) {
478 $root = $Crossfire::Data::TYPE{Floor};
479 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
480 $root = $Crossfire::Data::TYPE{"Monster & NPC"};
481 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
482 $root = $Crossfire::Data::TYPE{Wall};
483 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
484 $root = $Crossfire::Data::TYPE{"Weak Wall"};
485 } else {
486 $root = $Crossfire::Data::TYPE{Misc};
487 }
488 }
489
490 my @import = ($root);
302 } 491
492 unshift @import, \%Crossfire::Data::DEFAULT_ATTR
493 unless $type == 116;
303 494
304 use PApp::Util; 495 my (%ignore);
305 warn PApp::Util::dumpval \%attr; 496 my (@section_order, %section, @attr_order);
497
498 while (my $type = shift @import) {
499 push @import, @{$type->{import} || []};
500
501 $attr->{$_} ||= $type->{$_}
502 for qw(name desc use);
503
504 for (@{$type->{ignore} || []}) {
505 $ignore{$_}++ for ref $_ ? @$_ : $_;
506 }
507
508 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
509 my ($name, $attr) = @$_;
510 push @section_order, $name;
511 for (@$attr) {
512 my ($k, $v) = @$_;
513 push @attr_order, $k;
514 $section{$name}{$k} ||= $v;
515 }
516 }
517 }
518
519 $attr->{section} = [
520 map !exists $section{$_} ? () : do {
521 my $attr = delete $section{$_};
522
523 [
524 $_,
525 map exists $attr->{$_} && !$ignore{$_}
526 ? [$_ => delete $attr->{$_}] : (),
527 @attr_order
528 ]
529 },
530
531 exists $section{$_} ? [$_ => delete $section{$_}] : (),
532 @section_order
533 ];
534
535 $attr
306} 536}
307 537
308sub arch_edit_sections { 538sub arch_edit_sections {
309# if (edit_type == IGUIConstants.TILE_EDIT_NONE) 539# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
310# edit_type = 0; 540# edit_type = 0;
… …
364# return(edit_type); 594# return(edit_type);
365# 595#
366# 596#
367} 597}
368 598
369$CACHEDIR ||= "$ENV{HOME}/.crossfire"; 599sub cache_file($$&&) {
600 my ($src, $cache, $load, $create) = @_;
370 601
371init $CACHEDIR; 602 my ($size, $mtime) = (stat $src)[7,9]
603 or Carp::croak "$src: $!";
604
605 if (-e $cache) {
606 my $ref = eval { load_ref $cache };
607
608 if ($ref->{version} == 1
609 && $ref->{size} == $size
610 && $ref->{mtime} == $mtime
611 && eval { $load->($ref->{data}); 1 }) {
612 return;
613 }
614 }
615
616 my $ref = {
617 version => 1,
618 size => $size,
619 mtime => $mtime,
620 data => $create->(),
621 };
622
623 $load->($ref->{data});
624
625 save_ref $ref, $cache;
626}
627
628=item set_libdir $path
629
630Sets the library directory to the given path
631(default: $ENV{CROSSFIRE_LIBDIR}).
632
633You have to (re-)load the archetypes and tilecache manually after steting
634the library path.
635
636=cut
637
638sub set_libdir($) {
639 $LIB = $_[0];
640}
641
642=item load_archetypes
643
644(Re-)Load archetypes into %ARCH.
645
646=cut
647
648sub load_archetypes() {
649 cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
650 *ARCH = $_[0];
651 }, sub {
652 read_arch "$LIB/archetypes"
653 };
654}
655
656=item load_tilecache
657
658(Re-)Load %TILE and %FACE.
659
660=cut
661
662sub load_tilecache() {
663 require Gtk2;
664
665 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
666 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
667 or die "$VARDIR/tilecache.png: $!";
668 *FACE = $_[0];
669 }, sub {
670 my $tile = read_pak "$LIB/crossfire.0";
671
672 my %cache;
673
674 my $idx = 0;
675
676 for my $name (sort keys %$tile) {
677 my $pb = new Gtk2::Gdk::PixbufLoader;
678 $pb->write ($tile->{$name});
679 $pb->close;
680 my $pb = $pb->get_pixbuf;
681
682 my $tile = $cache{$name} = {
683 pb => $pb,
684 idx => $idx,
685 w => int $pb->get_width / TILESIZE,
686 h => int $pb->get_height / TILESIZE,
687 };
688
689
690 $idx += $tile->{w} * $tile->{h};
691 }
692
693 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
694
695 while (my ($name, $tile) = each %cache) {
696 my $tpb = delete $tile->{pb};
697 my $ofs = $tile->{idx};
698
699 for my $x (0 .. $tile->{w} - 1) {
700 for my $y (0 .. $tile->{h} - 1) {
701 my $idx = $ofs + $x + $y * $tile->{w};
702 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
703 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
704 }
705 }
706 }
707
708 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
709
710 \%cache
711 };
712}
372 713
373=head1 AUTHOR 714=head1 AUTHOR
374 715
375 Marc Lehmann <schmorp@schmorp.de> 716 Marc Lehmann <schmorp@schmorp.de>
376 http://home.schmorp.de/ 717 http://home.schmorp.de/

Diff Legend

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