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

Diff Legend

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