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.50 by root, Mon Mar 20 01:12:23 2006 UTC

… …
11use strict; 11use strict;
12 12
13use base 'Exporter'; 13use base 'Exporter';
14 14
15use Carp (); 15use Carp ();
16use File::Spec;
17use List::Util qw(min max);
16use Storable; 18use Storable;
17use List::Util qw(min max);
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# not used yet, maybe alphabetical is ok
40our @FIELD_ORDER = (qw(name name_pl)); 43our @FIELD_ORDER = (qw(name name_pl));
41 44
42sub MOVE_WALK (){ 0x1 } 45sub MOVE_WALK (){ 0x01 }
43sub MOVE_FLY_LOW (){ 0x2 } 46sub MOVE_FLY_LOW (){ 0x02 }
44sub MOVE_FLY_HIGH (){ 0x4 } 47sub MOVE_FLY_HIGH (){ 0x04 }
45sub MOVE_FLYING (){ 0x6 } 48sub MOVE_FLYING (){ 0x06 }
46sub MOVE_SWIM (){ 0x8 } 49sub MOVE_SWIM (){ 0x08 }
50sub MOVE_BOAT (){ 0x10 }
47sub MOVE_ALL (){ 0xf } 51sub MOVE_ALL (){ 0xff }
52
53sub load_ref($) {
54 my ($path) = @_;
55
56 open my $fh, "<", $path
57 or die "$path: $!";
58 binmode $fh;
59 local $/;
60
61 Storable::thaw <$fh>
62}
63
64sub save_ref($$) {
65 my ($ref, $path) = @_;
66
67 open my $fh, ">", "$path~"
68 or die "$path~: $!";
69 binmode $fh;
70 print $fh Storable::freeze $ref;
71 close $fh;
72 rename "$path~", $path
73 or die "$path: $!";
74}
48 75
49sub normalize_arch($) { 76sub normalize_arch($) {
50 my ($ob) = @_; 77 my ($ob) = @_;
51 78
52 my $arch = $ARCH{$ob->{_name}} 79 my $arch = $ARCH{$ob->{_name}}
53 or (warn "$ob->{_name}: no such archetype", return $ob); 80 or (warn "$ob->{_name}: no such archetype", return $ob);
54 81
82 delete $ob->{$_} for qw(
55 delete $ob->{$_} for qw(can_knockback can_parry can_impale can_cut can_dam_armour can_apply); 83 can_knockback can_parry can_impale can_cut can_dam_armour
84 can_apply pass_thru can_pass_thru
85 );
56 86
57 if ($arch->{type} == 22) { # map 87 if ($arch->{type} == 22) { # map
58 my %normalize = ( 88 my %normalize = (
59 "enter_x" => "hp", 89 "enter_x" => "hp",
60 "enter_y" => "sp", 90 "enter_y" => "sp",
… …
72 $ob->{$k2} = $v; 102 $ob->{$k2} = $v;
73 } 103 }
74 } 104 }
75 } 105 }
76 106
107 for my $attr (qw(move_type move_block move_allow move_on move_off move_slow)) {
108 next unless exists $ob->{$attr};
109 next if $ob->{$attr} =~ /^\d+$/;
110
111 my $flags = 0;
112
113 # assume list
114 for my $flag (map lc, split /\s+/, $ob->{$attr}) {
115 $flags |= MOVE_WALK if $flag eq "walk";
116 $flags |= MOVE_FLY_LOW if $flag eq "fly_low";
117 $flags |= MOVE_FLY_HIGH if $flag eq "fly_high";
118 $flags |= MOVE_FLYING if $flag eq "flying";
119 $flags |= MOVE_SWIM if $flag eq "swim";
120 $flags |= MOVE_BOAT if $flag eq "boat";
121 $flags |= MOVE_ALL if $flag eq "all";
122
123 $flags &= ~MOVE_WALK if $flag eq "-walk";
124 $flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
125 $flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
126 $flags &= ~MOVE_FLYING if $flag eq "-flying";
127 $flags &= ~MOVE_SWIM if $flag eq "-swim";
128 $flags &= ~MOVE_BOAT if $flag eq "-boat";
129 $flags &= ~MOVE_ALL if $flag eq "-all";
130 }
131
132 $ob->{$attr} = $flags;
133 }
134
77 if (defined (my $v = delete $ob->{no_pass})) { 135 if (defined (my $v = delete $ob->{no_pass})) {
78 $ob->{move_block} = $v ? MOVE_ALL : 0; 136 $ob->{move_block} = $v ? MOVE_ALL : 0;
137 }
138 if (defined (my $v = delete $ob->{slow_move})) {
139 $ob->{move_slow} |= MOVE_WALK;
140 $ob->{move_slow_penalty} = $v;
79 } 141 }
80 if (defined (my $v = delete $ob->{walk_on})) { 142 if (defined (my $v = delete $ob->{walk_on})) {
81 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK 143 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK
82 : $ob->{move_on} & ~MOVE_WALK; 144 : $ob->{move_on} & ~MOVE_WALK;
83 } 145 }
… …
107 } 169 }
108 170
109 $ob 171 $ob
110} 172}
111 173
112sub read_pak($;$) { 174sub read_pak($) {
113 my ($path, $cache) = @_; 175 my ($path) = @_;
114 176
115 eval {
116 defined $cache
117 && -M $cache < -M $path
118 && Storable::retrieve $cache
119 } or do {
120 my %pak; 177 my %pak;
121 178
122 open my $fh, "<:raw", $path 179 open my $fh, "<", $path
123 or Carp::croak "$_[0]: $!"; 180 or Carp::croak "$_[0]: $!";
181 binmode $fh;
124 while (<$fh>) { 182 while (<$fh>) {
125 my ($type, $id, $len, $path) = split; 183 my ($type, $id, $len, $path) = split;
126 $path =~ s/.*\///; 184 $path =~ s/.*\///;
127 read $fh, $pak{$path}, $len; 185 read $fh, $pak{$path}, $len;
128 } 186 }
129 187
130 Storable::nstore \%pak, $cache
131 if defined $cache;
132
133 \%pak 188 \%pak
134 }
135} 189}
136 190
137sub read_arch($;$) { 191sub read_arch($) {
138 my ($path, $cache) = @_; 192 my ($path) = @_;
139 193
140 eval {
141 defined $cache
142 && -M $cache < -M $path
143 && Storable::retrieve $cache
144 } or do {
145 my %arc; 194 my %arc;
146 my ($more, $prev); 195 my ($more, $prev);
147 196
148 open my $fh, "<:raw", $path 197 open my $fh, "<", $path
149 or Carp::croak "$path: $!"; 198 or Carp::croak "$path: $!";
150 199
200 binmode $fh;
201
151 my $parse_block; $parse_block = sub { 202 my $parse_block; $parse_block = sub {
152 my %arc = @_; 203 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 204
182 while (<$fh>) { 205 while (<$fh>) {
183 s/\s+$//; 206 s/\s+$//;
184 if (/^more$/i) { 207 if (/^end$/i) {
185 $more = $prev; 208 last;
186 } elsif (/^object (\S+)$/i) { 209 } elsif (/^arch (\S+)$/) {
187 my $name = $1; 210 push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);
188 my $arc = $parse_block->(_name => $name); 211 } elsif (/^lore$/) {
189 212 while (<$fh>) {
190 if ($more) { 213 last if /^endlore\s*$/i;
191 $more->{more} = $arc;
192 } else {
193 $arc{$name} = $arc; 214 $arc{lore} .= $_;
194 } 215 }
195 $prev = $arc; 216 } elsif (/^msg$/) {
196 $more = undef; 217 while (<$fh>) {
218 last if /^endmsg\s*$/i;
219 $arc{msg} .= $_;
220 }
197 } elsif (/^arch (\S+)$/i) { 221 } elsif (/^(\S+)\s*(.*)$/) {
198 push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1); 222 $arc{lc $1} = $2;
199 } elsif (/^\s*($|#)/) { 223 } elsif (/^\s*($|#)/) {
200 # 224 #
201 } else { 225 } else {
202 warn "$path: unparseable top-level line '$_'"; 226 warn "$path: unparsable line '$_' in arch $arc{_name}";
203 } 227 }
204 } 228 }
205 229
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 230 \%arc
212 } 231 };
232
233 while (<$fh>) {
234 s/\s+$//;
235 if (/^more$/i) {
236 $more = $prev;
237 } elsif (/^object (\S+)$/i) {
238 my $name = $1;
239 my $arc = $parse_block->(_name => $name);
240
241 if ($more) {
242 $more->{more} = $arc;
243 } else {
244 $arc{$name} = $arc;
245 }
246 $prev = $arc;
247 $more = undef;
248 } elsif (/^arch (\S+)$/i) {
249 push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1);
250 } elsif (/^\s*($|#)/) {
251 #
252 } else {
253 warn "$path: unparseable top-level line '$_'";
254 }
255 }
256
257 undef $parse_block; # work around bug in perl not freeing $fh etc.
258
259 \%arc
213} 260}
214 261
215# put all archs into a hash with editor_face as it's key 262# put all archs into a hash with editor_face as it's key
216# NOTE: the arrays in the hash values are references to 263# NOTE: the arrays in the hash values are references to
217# the archs from $ARCH 264# the archs from $ARCH
… …
238 my ($a) = @_; 285 my ($a) = @_;
239 286
240 my $o = $ARCH{$a->{_name}} 287 my $o = $ARCH{$a->{_name}}
241 or return; 288 or return;
242 289
243 my $face = $FACE{$a->{face} || $o->{face}} 290 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"}
244 or (warn "no face data found for arch '$a->{_name}'"), return; 291 or (warn "no face data found for arch '$a->{_name}'"), return;
245 292
246 if ($face->{w} > 1 || $face->{h} > 1) { 293 if ($face->{w} > 1 || $face->{h} > 1) {
247 # bigface 294 # bigface
248 return (0, 0, $face->{w} - 1, $face->{h} - 1); 295 return (0, 0, $face->{w} - 1, $face->{h} - 1);
… …
264 # single face 311 # single face
265 return (0, 0, 0, 0); 312 return (0, 0, 0, 0);
266 } 313 }
267} 314}
268 315
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 316=item $type = arch_attr $arch
278 317
279Returns a hashref describing the object and its attributes. It can contain 318Returns a hashref describing the object and its attributes. It can contain
280the following keys: 319the following keys:
281 320
282 name the name, suitable for display purposes 321 name the name, suitable for display purposes
283 ignore 322 ignore
284 attr 323 attr
285 desc 324 desc
286 use 325 use
287 section => [name => \%attr, name => \%attr] 326 section => [name => \%attr, name => \%attr]
327 import
288 328
289=cut 329=cut
290 330
291sub arch_attr($) { 331sub arch_attr($) {
292 my ($arch) = @_; 332 my ($obj) = @_;
293 333
294 require Crossfire::Data; 334 require Crossfire::Data;
295 335
296 my %attr; 336 my $root;
337 my $attr = { };
338
339 my $arch = $ARCH{ $obj->{_name} };
340 my $type = $obj->{type} || $arch->{type};
297 341
298 if ($arch->{type} > 0) { 342 if ($type > 0) {
299 %attr = %{ $Crossfire::Data::ATTR{$arch->{type}+0} || {} }; 343 $root = $Crossfire::Data::ATTR{$type};
300 } else { 344 } else {
301 die; 345 $root = $Crossfire::Data::TYPE{Misc};
346
347 type:
348 for (@Crossfire::Data::ATTR0) {
349 my $req = $_->{required}
350 or die "internal error: ATTR0 without 'required'";
351
352 keys %$req;
353 while (my ($k, $v) = each %$req) {
354 next type
355 unless $obj->{$k} == $v || $arch->{$k} == $v;
356 }
357
358 $root = $_;
359 }
360 }
361
362 my @import = ($root);
302 } 363
364 unshift @import, \%Crossfire::Data::DEFAULT_ATTR
365 unless $type == 116;
303 366
304 use PApp::Util; 367 my (%ignore);
305 warn PApp::Util::dumpval \%attr; 368 my (@section_order, %section, @attr_order);
369
370 while (my $type = shift @import) {
371 push @import, @{$type->{import} || []};
372
373 $attr->{$_} ||= $type->{$_}
374 for qw(name desc use);
375
376 for (@{$type->{ignore} || []}) {
377 $ignore{$_}++ for ref $_ ? @$_ : $_;
378 }
379
380 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
381 my ($name, $attr) = @$_;
382 push @section_order, $name;
383 for (@$attr) {
384 my ($k, $v) = @$_;
385 push @attr_order, $k;
386 $section{$name}{$k} ||= $v;
387 }
388 }
389 }
390
391 $attr->{section} = [
392 map !exists $section{$_} ? () : do {
393 my $attr = delete $section{$_};
394
395 [
396 $_,
397 map exists $attr->{$_} && !$ignore{$_}
398 ? [$_ => delete $attr->{$_}] : (),
399 @attr_order
400 ]
401 },
402
403 exists $section{$_} ? [$_ => delete $section{$_}] : (),
404 @section_order
405 ];
406
407 $attr
306} 408}
307 409
308sub arch_edit_sections { 410sub arch_edit_sections {
309# if (edit_type == IGUIConstants.TILE_EDIT_NONE) 411# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
310# edit_type = 0; 412# edit_type = 0;
… …
364# return(edit_type); 466# return(edit_type);
365# 467#
366# 468#
367} 469}
368 470
369$CACHEDIR ||= "$ENV{HOME}/.crossfire"; 471sub cache_file($$&&) {
472 my ($src, $cache, $load, $create) = @_;
370 473
371init $CACHEDIR; 474 warn "<@_>\n";#d#
475
476 my ($size, $mtime) = (stat $src)[7,9]
477 or Carp::croak "$src: $!";
478
479 if (-e $cache) {
480 my $ref = eval { load_ref $cache };
481
482 if ($ref->{version} == 1
483 && $ref->{size} == $size
484 && $ref->{mtime} == $mtime
485 && eval { $load->($ref->{data}); 1 }) {
486 return;
487 }
488 }
489
490 my $ref = {
491 version => 1,
492 size => $size,
493 mtime => $mtime,
494 data => $create->(),
495 };
496
497 $load->($ref->{data});
498
499 save_ref $ref, $cache;
500}
501
502=item set_libdir $path
503
504Sets the library directory to the given path
505(default: $ENV{CROSSFIRE_LIBDIR}).
506
507You have to (re-)load the archetypes and tilecache manually after steting
508the library path.
509
510=cut
511
512sub set_libdir($) {
513 $LIB = $_[0];
514}
515
516=item load_archetypes
517
518(Re-)Load archetypes into %ARCH.
519
520=cut
521
522sub load_archetypes() {
523 cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
524 *ARCH = $_[0];
525 }, sub {
526 read_arch "$LIB/archetypes"
527 };
528}
529
530=item load_tilecache
531
532(Re-)Load %TILE and %FACE.
533
534=cut
535
536sub load_tilecache() {
537 require Gtk2;
538
539 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
540 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
541 or die "$VARDIR/tilecache.png: $!";
542 *FACE = $_[0];
543 }, sub {
544 require File::Temp;
545
546 my $tile = read_pak "$LIB/crossfire.0";
547
548 my %cache;
549
550 my $idx = 0;
551
552 for my $name (sort keys %$tile) {
553 my ($fh, $filename) = File::Temp::tempfile ();
554 print $fh $tile->{$name};
555 close $fh;
556 my $pb = new_from_file Gtk2::Gdk::Pixbuf $filename;
557 unlink $filename;
558
559 my $tile = $cache{$name} = {
560 pb => $pb,
561 idx => $idx,
562 w => int $pb->get_width / TILESIZE,
563 h => int $pb->get_height / TILESIZE,
564 };
565
566
567 $idx += $tile->{w} * $tile->{h};
568 }
569
570 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
571
572 while (my ($name, $tile) = each %cache) {
573 my $tpb = delete $tile->{pb};
574 my $ofs = $tile->{idx};
575
576 for my $x (0 .. $tile->{w} - 1) {
577 for my $y (0 .. $tile->{h} - 1) {
578 my $idx = $ofs + $x + $y * $tile->{w};
579 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
580 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
581 }
582 }
583 }
584
585 $pb->save ("$VARDIR/tilecache.png", "png");
586
587 \%cache
588 };
589}
372 590
373=head1 AUTHOR 591=head1 AUTHOR
374 592
375 Marc Lehmann <schmorp@schmorp.de> 593 Marc Lehmann <schmorp@schmorp.de>
376 http://home.schmorp.de/ 594 http://home.schmorp.de/

Diff Legend

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