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.45 by root, Thu Mar 16 01:13:02 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#XXX: The map_* procedures scream for a map-object
20 19
21our @EXPORT = 20our @EXPORT =
22 qw(read_pak read_arch %ARCH TILESIZE $TILE %FACE editor_archs arch_extents); 21 qw(read_pak read_arch %ARCH TILESIZE $TILE %FACE editor_archs arch_extents);
23 22
24our $LIB = $ENV{CROSSFIRE_LIBDIR} 23our $LIB = $ENV{CROSSFIRE_LIBDIR}
25 or Carp::croak "\$CROSSFIRE_LIBDIR must be set\n"; 24 or Carp::croak "\$CROSSFIRE_LIBDIR must be set\n";
26 25
27sub TILESIZE (){ 32 } 26sub TILESIZE (){ 32 }
28 27
29our $CACHEDIR; 28our $VARDIR;
30our %ARCH; 29our %ARCH;
31our %FACE; 30our %FACE;
32our $TILE; 31our $TILE;
33 32
34our %FIELD_MULTILINE = ( 33our %FIELD_MULTILINE = (
… …
43sub MOVE_FLY_LOW (){ 0x2 } 42sub MOVE_FLY_LOW (){ 0x2 }
44sub MOVE_FLY_HIGH (){ 0x4 } 43sub MOVE_FLY_HIGH (){ 0x4 }
45sub MOVE_FLYING (){ 0x6 } 44sub MOVE_FLYING (){ 0x6 }
46sub MOVE_SWIM (){ 0x8 } 45sub MOVE_SWIM (){ 0x8 }
47sub MOVE_ALL (){ 0xf } 46sub MOVE_ALL (){ 0xf }
47
48sub load_ref($) {
49 my ($path) = @_;
50
51 open my $fh, "<", $path
52 or die "$path: $!";
53 binmode $fh;
54 local $/;
55
56 Storable::thaw <$fh>
57}
58
59sub save_ref($$) {
60 my ($ref, $path) = @_;
61
62 open my $fh, ">", "$path~"
63 or die "$path~: $!";
64 binmode $fh;
65 print $fh Storable::freeze $ref;
66 close $fh;
67 rename "$path~", $path
68 or die "$path: $!";
69}
48 70
49sub normalize_arch($) { 71sub normalize_arch($) {
50 my ($ob) = @_; 72 my ($ob) = @_;
51 73
52 my $arch = $ARCH{$ob->{_name}} 74 my $arch = $ARCH{$ob->{_name}}
… …
113 my ($path, $cache) = @_; 135 my ($path, $cache) = @_;
114 136
115 eval { 137 eval {
116 defined $cache 138 defined $cache
117 && -M $cache < -M $path 139 && -M $cache < -M $path
118 && Storable::retrieve $cache 140 && load_ref $cache
119 } or do { 141 } or do {
120 my %pak; 142 my %pak;
121 143
122 open my $fh, "<:raw", $path 144 open my $fh, "<", $path
123 or Carp::croak "$_[0]: $!"; 145 or Carp::croak "$_[0]: $!";
146 binmode $fh;
124 while (<$fh>) { 147 while (<$fh>) {
125 my ($type, $id, $len, $path) = split; 148 my ($type, $id, $len, $path) = split;
126 $path =~ s/.*\///; 149 $path =~ s/.*\///;
127 read $fh, $pak{$path}, $len; 150 read $fh, $pak{$path}, $len;
128 } 151 }
129 152
130 Storable::nstore \%pak, $cache 153 save_ref \%pak, $cache
131 if defined $cache; 154 if defined $cache;
132 155
133 \%pak 156 \%pak
134 } 157 }
135} 158}
… …
138 my ($path, $cache) = @_; 161 my ($path, $cache) = @_;
139 162
140 eval { 163 eval {
141 defined $cache 164 defined $cache
142 && -M $cache < -M $path 165 && -M $cache < -M $path
143 && Storable::retrieve $cache 166 && load_ref $cache
144 } or do { 167 } or do {
145 my %arc; 168 my %arc;
146 my ($more, $prev); 169 my ($more, $prev);
147 170
148 open my $fh, "<:raw", $path 171 open my $fh, "<", $path
149 or Carp::croak "$path: $!"; 172 or Carp::croak "$path: $!";
173
174 binmode $fh;
150 175
151 my $parse_block; $parse_block = sub { 176 my $parse_block; $parse_block = sub {
152 my %arc = @_; 177 my %arc = @_;
153 178
154 while (<$fh>) { 179 while (<$fh>) {
… …
203 } 228 }
204 } 229 }
205 230
206 undef $parse_block; # work around bug in perl not freeing $fh etc. 231 undef $parse_block; # work around bug in perl not freeing $fh etc.
207 232
208 Storable::nstore \%arc, $cache 233 save_ref \%arc, $cache
209 if defined $cache; 234 if defined $cache;
210 235
211 \%arc 236 \%arc
212 } 237 }
213} 238}
… …
238 my ($a) = @_; 263 my ($a) = @_;
239 264
240 my $o = $ARCH{$a->{_name}} 265 my $o = $ARCH{$a->{_name}}
241 or return; 266 or return;
242 267
243 my $face = $FACE{$a->{face} || $o->{face}} 268 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"}
244 or (warn "no face data found for arch '$a->{_name}'"), return; 269 or (warn "no face data found for arch '$a->{_name}'"), return;
245 270
246 if ($face->{w} > 1 || $face->{h} > 1) { 271 if ($face->{w} > 1 || $face->{h} > 1) {
247 # bigface 272 # bigface
248 return (0, 0, $face->{w} - 1, $face->{h} - 1); 273 return (0, 0, $face->{w} - 1, $face->{h} - 1);
… …
264 # single face 289 # single face
265 return (0, 0, 0, 0); 290 return (0, 0, 0, 0);
266 } 291 }
267} 292}
268 293
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 294=item $type = arch_attr $arch
278 295
279Returns a hashref describing the object and its attributes. It can contain 296Returns a hashref describing the object and its attributes. It can contain
280the following keys: 297the following keys:
281 298
282 name the name, suitable for display purposes 299 name the name, suitable for display purposes
283 ignore 300 ignore
284 attr 301 attr
285 desc 302 desc
286 use 303 use
287 section => [name => \%attr, name => \%attr] 304 section => [name => \%attr, name => \%attr]
305 import
288 306
289=cut 307=cut
290 308
291sub arch_attr($) { 309sub arch_attr($) {
292 my ($arch) = @_; 310 my ($arch) = @_;
293 311
294 require Crossfire::Data; 312 require Crossfire::Data;
295 313
296 my $attr; 314 my $root;
297 315
298 if ($arch->{type} > 0) { 316 if ($arch->{type} > 0) {
299 $attr = $Crossfire::Data::ATTR{$arch->{type}+0}; 317 $root = $Crossfire::Data::ATTR{$arch->{type}+0};
300 } else { 318 } else {
301 $attr = $Crossfire::Data::TYPE{Misc}; 319 $root = $Crossfire::Data::TYPE{Misc};
302 320
303 type: 321 type:
304 for (@Crossfire::Data::ATTR0) { 322 for (@Crossfire::Data::ATTR0) {
305 my $req = $_->{required} 323 my $req = $_->{required}
306 or die "internal error: ATTR0 without 'required'"; 324 or die "internal error: ATTR0 without 'required'";
307 325
326 keys %$req;
308 while (my ($k, $v) = each %$req) { 327 while (my ($k, $v) = each %$req) {
309 next type 328 next type
310 unless $arch->{$k} == $v; 329 unless $arch->{$k} == $v;
311 } 330 }
312 331
313 $attr = $_; 332 $root = $_;
333 }
334 }
335
336 my $attr = { };
337
338 my @import = (\%Crossfire::Data::DEFAULT_ATTR, $root);
339 my (%ignore);
340 my (@section_order, %section, @attr_order);
341
342 while (my $type = shift @import) {
343 push @import, @{$type->{import} || []};
344
345 $attr->{$_} ||= $type->{$_}
346 for qw(name desc use);
347
348 for (@{$type->{ignore} || []}) {
349 $ignore{$_}++ for ref $_ ? @$_ : $_;
350 }
351
352 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
353 my ($name, $attr) = @$_;
354 push @section_order, $name;
355 for (@$attr) {
356 my ($k, $v) = @$_;
357 push @attr_order, $k;
358 $section{$name}{$k} ||= $v;
314 } 359 }
360 }
315 } 361 }
316 362
317 use PApp::Util; 363 $attr->{section} = [
318 warn PApp::Util::dumpval $attr; 364 map !exists $section{$_} ? () : do {
365 my $attr = delete $section{$_};
366
367 [
368 $_,
369 map exists $attr->{$_} && !$ignore{$_}
370 ? [$_ => delete $attr->{$_}] : (),
371 @attr_order
372 ]
373 },
374
375 exists $section{$_} ? [$_ => delete $section{$_}] : (),
376 @section_order
377 ];
378
379 $attr
319} 380}
320 381
321sub arch_edit_sections { 382sub arch_edit_sections {
322# if (edit_type == IGUIConstants.TILE_EDIT_NONE) 383# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
323# edit_type = 0; 384# edit_type = 0;
… …
377# return(edit_type); 438# return(edit_type);
378# 439#
379# 440#
380} 441}
381 442
382$CACHEDIR ||= "$ENV{HOME}/.crossfire"; 443sub init($) {
444 my ($cachedir) = @_;
383 445
446 return if %ARCH;
447
448 mkdir $cachedir, 0777;
449 *ARCH = read_arch "$LIB/archetypes", "$cachedir/archetypes.pst";
450}
451
452$VARDIR ||= $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire";
453
384init $CACHEDIR; 454init $VARDIR;
385 455
386=head1 AUTHOR 456=head1 AUTHOR
387 457
388 Marc Lehmann <schmorp@schmorp.de> 458 Marc Lehmann <schmorp@schmorp.de>
389 http://home.schmorp.de/ 459 http://home.schmorp.de/

Diff Legend

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