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.54 by root, Thu Mar 23 06:45: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# same as in server save routine, to (hopefully) be compatible
43# to the other editors.
40our @FIELD_ORDER = (qw(name name_pl)); 44our @FIELD_ORDER = (qw(
45 name name_pl custom_name title race
46 slaying skill msg lore other_arch face
47 #events
48 animation is_animated
49 Str Dex Con Wis Pow Cha Int
50 hp maxhp sp maxsp grace maxgrace
51 exp perm_exp expmul
52 food dam luck wc ac x y speed speed_left move_state attack_movement
53 nrof level direction type subtype
41 54
55 resist_physical resist_magic resist_fire resist_electricity
56 resist_cold resist_confusion resist_acid resist_drain
57 resist_weaponmagic resist_ghosthit resist_poison resist_slow
58 resist_paralyze resist_turn_undead resist_fear resist_cancellation
59 resist_deplete resist_death resist_chaos resist_counterspell
60 resist_godpower resist_holyword resist_blind resist_internal
61 resist_life_stealing resist_disease
62
63 path_attuned path_repelled path_denied material materialname
64 value carrying weight invisible state magic
65 last_heal last_sp last_grace last_eat
66 connected glow_radius randomitems npx_status npc_program
67 run_away pick_up container will_apply smoothlevel
68 current_weapon_script weapontype tooltype elevation client_type
69 item_power duration range
70 range_modifier duration_modifier dam_modifier gen_sp_armour
71 move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty
72
73 alive wiz was_wiz applied unpaid can_use_shield no_pick is_animated monster
74 friendly generator is_thrown auto_apply treasure player sold see_invisible
75 can_roll overlay_floor is_turnable is_used_up identified reflecting changing
76 splitting hitback startequip blocksview undead scared unaggressive
77 reflect_missile reflect_spell no_magic no_fix_player is_lightable tear_down
78 run_away pick_up unique no_drop can_cast_spell can_use_scroll can_use_range
79 can_use_bow can_use_armour can_use_weapon can_use_ring has_ready_range
80 has_ready_bow xrays is_floor lifesave no_strength sleep stand_still
81 random_move only_attack confused stealth cursed damned see_anywhere
82 known_magical known_cursed can_use_skill been_applied has_ready_scroll
83 can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly
84 has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark
85 is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage
86 activate_on_push activate_on_release is_water use_content_on_gen is_buildable
87
88 body_range body_arm body_torso body_head body_neck body_skill
89 body_finger body_shoulder body_foot body_hand body_wrist body_waist
90));
91
42sub MOVE_WALK (){ 0x1 } 92sub MOVE_WALK (){ 0x01 }
43sub MOVE_FLY_LOW (){ 0x2 } 93sub MOVE_FLY_LOW (){ 0x02 }
44sub MOVE_FLY_HIGH (){ 0x4 } 94sub MOVE_FLY_HIGH (){ 0x04 }
45sub MOVE_FLYING (){ 0x6 } 95sub MOVE_FLYING (){ 0x06 }
46sub MOVE_SWIM (){ 0x8 } 96sub MOVE_SWIM (){ 0x08 }
97sub MOVE_BOAT (){ 0x10 }
47sub MOVE_ALL (){ 0xf } 98sub MOVE_ALL (){ 0xff }
99
100sub load_ref($) {
101 my ($path) = @_;
102
103 open my $fh, "<", $path
104 or die "$path: $!";
105 binmode $fh;
106 local $/;
107
108 thaw <$fh>
109}
110
111sub save_ref($$) {
112 my ($ref, $path) = @_;
113
114 open my $fh, ">", "$path~"
115 or die "$path~: $!";
116 binmode $fh;
117 print $fh freeze $ref;
118 close $fh;
119 rename "$path~", $path
120 or die "$path: $!";
121}
122
123sub normalize_object($) {
124 my ($ob) = @_;
125
126 delete $ob->{$_} for qw(
127 can_knockback can_parry can_impale can_cut can_dam_armour
128 can_apply pass_thru can_pass_thru
129 );
130
131 for my $attr (qw(move_type move_block move_allow move_on move_off move_slow)) {
132 next unless exists $ob->{$attr};
133 next if $ob->{$attr} =~ /^\d+$/;
134
135 my $flags = 0;
136
137 # assume list
138 for my $flag (map lc, split /\s+/, $ob->{$attr}) {
139 $flags |= MOVE_WALK if $flag eq "walk";
140 $flags |= MOVE_FLY_LOW if $flag eq "fly_low";
141 $flags |= MOVE_FLY_HIGH if $flag eq "fly_high";
142 $flags |= MOVE_FLYING if $flag eq "flying";
143 $flags |= MOVE_SWIM if $flag eq "swim";
144 $flags |= MOVE_BOAT if $flag eq "boat";
145 $flags |= MOVE_ALL if $flag eq "all";
146
147 $flags &= ~MOVE_WALK if $flag eq "-walk";
148 $flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
149 $flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
150 $flags &= ~MOVE_FLYING if $flag eq "-flying";
151 $flags &= ~MOVE_SWIM if $flag eq "-swim";
152 $flags &= ~MOVE_BOAT if $flag eq "-boat";
153 $flags &= ~MOVE_ALL if $flag eq "-all";
154 }
155
156 $ob->{$attr} = $flags;
157 }
158
159 if (defined (my $v = delete $ob->{no_pass})) {
160 $ob->{move_block} = $v ? MOVE_ALL : 0;
161 }
162 if (defined (my $v = delete $ob->{slow_move})) {
163 $ob->{move_slow} |= MOVE_WALK;
164 $ob->{move_slow_penalty} = $v;
165 }
166 if (defined (my $v = delete $ob->{walk_on})) {
167 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK
168 : $ob->{move_on} & ~MOVE_WALK;
169 }
170 if (defined (my $v = delete $ob->{walk_off})) {
171 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK
172 : $ob->{move_off} & ~MOVE_WALK;
173 }
174 if (defined (my $v = delete $ob->{fly_on})) {
175 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW
176 : $ob->{move_on} & ~MOVE_FLY_LOW;
177 }
178 if (defined (my $v = delete $ob->{fly_off})) {
179 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW
180 : $ob->{move_off} & ~MOVE_FLY_LOW;
181 }
182 if (defined (my $v = delete $ob->{flying})) {
183 $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW
184 : $ob->{move_type} & ~MOVE_FLY_LOW;
185 }
186
187 $ob
188}
48 189
49sub normalize_arch($) { 190sub normalize_arch($) {
50 my ($ob) = @_; 191 my ($ob) = @_;
51 192
193 normalize_object $ob;
194
52 my $arch = $ARCH{$ob->{_name}} 195 my $arch = $ARCH{$ob->{_name}}
53 or (warn "$ob->{_name}: no such archetype", return $ob); 196 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 197
57 if ($arch->{type} == 22) { # map 198 if ($arch->{type} == 22) { # map
58 my %normalize = ( 199 my %normalize = (
59 "enter_x" => "hp", 200 "enter_x" => "hp",
60 "enter_y" => "sp", 201 "enter_y" => "sp",
… …
70 while (my ($k2, $k1) = each %normalize) { 211 while (my ($k2, $k1) = each %normalize) {
71 if (defined (my $v = delete $ob->{$k1})) { 212 if (defined (my $v = delete $ob->{$k1})) {
72 $ob->{$k2} = $v; 213 $ob->{$k2} = $v;
73 } 214 }
74 } 215 }
75 } 216 } 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 217 # if value matches archetype default, delete
102 while (my ($k, $v) = each %$ob) { 218 while (my ($k, $v) = each %$ob) {
103 if (exists $arch->{$k} and $arch->{$k} eq $v) { 219 if (exists $arch->{$k} and $arch->{$k} eq $v) {
104 next if $k eq "_name"; 220 next if $k eq "_name";
105 delete $ob->{$k}; 221 delete $ob->{$k};
222 }
106 } 223 }
107 } 224 }
108 225
109 $ob 226 $ob
110} 227}
111 228
112sub read_pak($;$) { 229sub read_pak($) {
113 my ($path, $cache) = @_; 230 my ($path) = @_;
114 231
115 eval {
116 defined $cache
117 && -M $cache < -M $path
118 && Storable::retrieve $cache
119 } or do {
120 my %pak; 232 my %pak;
121 233
122 open my $fh, "<:raw", $path 234 open my $fh, "<", $path
123 or Carp::croak "$_[0]: $!"; 235 or Carp::croak "$_[0]: $!";
236 binmode $fh;
124 while (<$fh>) { 237 while (<$fh>) {
125 my ($type, $id, $len, $path) = split; 238 my ($type, $id, $len, $path) = split;
126 $path =~ s/.*\///; 239 $path =~ s/.*\///;
127 read $fh, $pak{$path}, $len; 240 read $fh, $pak{$path}, $len;
128 } 241 }
129 242
130 Storable::nstore \%pak, $cache
131 if defined $cache;
132
133 \%pak 243 \%pak
134 }
135} 244}
136 245
137sub read_arch($;$) { 246sub read_arch($) {
138 my ($path, $cache) = @_; 247 my ($path) = @_;
139 248
140 eval {
141 defined $cache
142 && -M $cache < -M $path
143 && Storable::retrieve $cache
144 } or do {
145 my %arc; 249 my %arc;
146 my ($more, $prev); 250 my ($more, $prev);
147 251
148 open my $fh, "<:raw", $path 252 open my $fh, "<", $path
149 or Carp::croak "$path: $!"; 253 or Carp::croak "$path: $!";
150 254
255 binmode $fh;
256
151 my $parse_block; $parse_block = sub { 257 my $parse_block; $parse_block = sub {
152 my %arc = @_; 258 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 259
182 while (<$fh>) { 260 while (<$fh>) {
183 s/\s+$//; 261 s/\s+$//;
184 if (/^more$/i) { 262 if (/^end$/i) {
185 $more = $prev; 263 last;
186 } elsif (/^object (\S+)$/i) { 264 } elsif (/^arch (\S+)$/) {
187 my $name = $1; 265 push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);
188 my $arc = $parse_block->(_name => $name); 266 } elsif (/^lore$/) {
189 267 while (<$fh>) {
190 if ($more) { 268 last if /^endlore\s*$/i;
191 $more->{more} = $arc;
192 } else {
193 $arc{$name} = $arc; 269 $arc{lore} .= $_;
194 } 270 }
195 $prev = $arc; 271 } elsif (/^msg$/) {
196 $more = undef; 272 while (<$fh>) {
273 last if /^endmsg\s*$/i;
274 $arc{msg} .= $_;
275 }
197 } elsif (/^arch (\S+)$/i) { 276 } elsif (/^(\S+)\s*(.*)$/) {
198 push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1); 277 $arc{lc $1} = $2;
199 } elsif (/^\s*($|#)/) { 278 } elsif (/^\s*($|#)/) {
200 # 279 #
201 } else { 280 } else {
202 warn "$path: unparseable top-level line '$_'"; 281 warn "$path: unparsable line '$_' in arch $arc{_name}";
203 } 282 }
204 } 283 }
205 284
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 285 \%arc
212 } 286 };
287
288 while (<$fh>) {
289 s/\s+$//;
290 if (/^more$/i) {
291 $more = $prev;
292 } elsif (/^object (\S+)$/i) {
293 my $name = $1;
294 my $arc = normalize_object $parse_block->(_name => $name);
295
296 if ($more) {
297 $more->{more} = $arc;
298 } else {
299 $arc{$name} = $arc;
300 }
301 $prev = $arc;
302 $more = undef;
303 } elsif (/^arch (\S+)$/i) {
304 push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1);
305 } elsif (/^\s*($|#)/) {
306 #
307 } else {
308 warn "$path: unparseable top-level line '$_'";
309 }
310 }
311
312 undef $parse_block; # work around bug in perl not freeing $fh etc.
313
314 \%arc
213} 315}
214 316
215# put all archs into a hash with editor_face as it's key 317# put all archs into a hash with editor_face as it's key
216# NOTE: the arrays in the hash values are references to 318# NOTE: the arrays in the hash values are references to
217# the archs from $ARCH 319# the archs from $ARCH
… …
238 my ($a) = @_; 340 my ($a) = @_;
239 341
240 my $o = $ARCH{$a->{_name}} 342 my $o = $ARCH{$a->{_name}}
241 or return; 343 or return;
242 344
243 my $face = $FACE{$a->{face} || $o->{face}} 345 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"}
244 or (warn "no face data found for arch '$a->{_name}'"), return; 346 or (warn "no face data found for arch '$a->{_name}'"), return;
245 347
246 if ($face->{w} > 1 || $face->{h} > 1) { 348 if ($face->{w} > 1 || $face->{h} > 1) {
247 # bigface 349 # bigface
248 return (0, 0, $face->{w} - 1, $face->{h} - 1); 350 return (0, 0, $face->{w} - 1, $face->{h} - 1);
… …
264 # single face 366 # single face
265 return (0, 0, 0, 0); 367 return (0, 0, 0, 0);
266 } 368 }
267} 369}
268 370
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 371=item $type = arch_attr $arch
278 372
279Returns a hashref describing the object and its attributes. It can contain 373Returns a hashref describing the object and its attributes. It can contain
280the following keys: 374the following keys:
281 375
282 name the name, suitable for display purposes 376 name the name, suitable for display purposes
283 ignore 377 ignore
284 attr 378 attr
285 desc 379 desc
286 use 380 use
287 section => [name => \%attr, name => \%attr] 381 section => [name => \%attr, name => \%attr]
382 import
288 383
289=cut 384=cut
290 385
291sub arch_attr($) { 386sub arch_attr($) {
292 my ($arch) = @_; 387 my ($obj) = @_;
293 388
294 require Crossfire::Data; 389 require Crossfire::Data;
295 390
296 my %attr; 391 my $root;
392 my $attr = { };
393
394 my $arch = $ARCH{ $obj->{_name} };
395 my $type = $obj->{type} || $arch->{type};
297 396
298 if ($arch->{type} > 0) { 397 if ($type > 0) {
299 %attr = %{ $Crossfire::Data::ATTR{$arch->{type}+0} || {} }; 398 $root = $Crossfire::Data::ATTR{$type};
300 } else { 399 } else {
301 die; 400 $root = $Crossfire::Data::TYPE{Misc};
401
402 type:
403 for (@Crossfire::Data::ATTR0) {
404 my $req = $_->{required}
405 or die "internal error: ATTR0 without 'required'";
406
407 keys %$req;
408 while (my ($k, $v) = each %$req) {
409 next type
410 unless $obj->{$k} == $v || $arch->{$k} == $v;
411 }
412
413 $root = $_;
414 }
415 }
416
417 my @import = ($root);
302 } 418
419 unshift @import, \%Crossfire::Data::DEFAULT_ATTR
420 unless $type == 116;
303 421
304 use PApp::Util; 422 my (%ignore);
305 warn PApp::Util::dumpval \%attr; 423 my (@section_order, %section, @attr_order);
424
425 while (my $type = shift @import) {
426 push @import, @{$type->{import} || []};
427
428 $attr->{$_} ||= $type->{$_}
429 for qw(name desc use);
430
431 for (@{$type->{ignore} || []}) {
432 $ignore{$_}++ for ref $_ ? @$_ : $_;
433 }
434
435 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
436 my ($name, $attr) = @$_;
437 push @section_order, $name;
438 for (@$attr) {
439 my ($k, $v) = @$_;
440 push @attr_order, $k;
441 $section{$name}{$k} ||= $v;
442 }
443 }
444 }
445
446 $attr->{section} = [
447 map !exists $section{$_} ? () : do {
448 my $attr = delete $section{$_};
449
450 [
451 $_,
452 map exists $attr->{$_} && !$ignore{$_}
453 ? [$_ => delete $attr->{$_}] : (),
454 @attr_order
455 ]
456 },
457
458 exists $section{$_} ? [$_ => delete $section{$_}] : (),
459 @section_order
460 ];
461
462 $attr
306} 463}
307 464
308sub arch_edit_sections { 465sub arch_edit_sections {
309# if (edit_type == IGUIConstants.TILE_EDIT_NONE) 466# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
310# edit_type = 0; 467# edit_type = 0;
… …
364# return(edit_type); 521# return(edit_type);
365# 522#
366# 523#
367} 524}
368 525
369$CACHEDIR ||= "$ENV{HOME}/.crossfire"; 526sub cache_file($$&&) {
527 my ($src, $cache, $load, $create) = @_;
370 528
371init $CACHEDIR; 529 my ($size, $mtime) = (stat $src)[7,9]
530 or Carp::croak "$src: $!";
531
532 if (-e $cache) {
533 my $ref = eval { load_ref $cache };
534
535 if ($ref->{version} == 1
536 && $ref->{size} == $size
537 && $ref->{mtime} == $mtime
538 && eval { $load->($ref->{data}); 1 }) {
539 return;
540 }
541 }
542
543 my $ref = {
544 version => 1,
545 size => $size,
546 mtime => $mtime,
547 data => $create->(),
548 };
549
550 $load->($ref->{data});
551
552 save_ref $ref, $cache;
553}
554
555=item set_libdir $path
556
557Sets the library directory to the given path
558(default: $ENV{CROSSFIRE_LIBDIR}).
559
560You have to (re-)load the archetypes and tilecache manually after steting
561the library path.
562
563=cut
564
565sub set_libdir($) {
566 $LIB = $_[0];
567}
568
569=item load_archetypes
570
571(Re-)Load archetypes into %ARCH.
572
573=cut
574
575sub load_archetypes() {
576 cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
577 *ARCH = $_[0];
578 }, sub {
579 read_arch "$LIB/archetypes"
580 };
581}
582
583=item load_tilecache
584
585(Re-)Load %TILE and %FACE.
586
587=cut
588
589sub load_tilecache() {
590 require Gtk2;
591
592 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
593 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
594 or die "$VARDIR/tilecache.png: $!";
595 *FACE = $_[0];
596 }, sub {
597 require File::Temp;
598
599 my $tile = read_pak "$LIB/crossfire.0";
600
601 my %cache;
602
603 my $idx = 0;
604
605 for my $name (sort keys %$tile) {
606 my ($fh, $filename) = File::Temp::tempfile ();
607 print $fh $tile->{$name};
608 close $fh;
609 my $pb = new_from_file Gtk2::Gdk::Pixbuf $filename;
610 unlink $filename;
611
612 my $tile = $cache{$name} = {
613 pb => $pb,
614 idx => $idx,
615 w => int $pb->get_width / TILESIZE,
616 h => int $pb->get_height / TILESIZE,
617 };
618
619
620 $idx += $tile->{w} * $tile->{h};
621 }
622
623 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
624
625 while (my ($name, $tile) = each %cache) {
626 my $tpb = delete $tile->{pb};
627 my $ofs = $tile->{idx};
628
629 for my $x (0 .. $tile->{w} - 1) {
630 for my $y (0 .. $tile->{h} - 1) {
631 my $idx = $ofs + $x + $y * $tile->{w};
632 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
633 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
634 }
635 }
636 }
637
638 $pb->save ("$VARDIR/tilecache.png", "png");
639
640 \%cache
641 };
642}
372 643
373=head1 AUTHOR 644=head1 AUTHOR
374 645
375 Marc Lehmann <schmorp@schmorp.de> 646 Marc Lehmann <schmorp@schmorp.de>
376 http://home.schmorp.de/ 647 http://home.schmorp.de/

Diff Legend

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