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.37 by root, Sun Mar 12 23:21:53 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}
… …
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 die; 319 $root = $Crossfire::Data::TYPE{Misc};
320
321 type:
322 for (@Crossfire::Data::ATTR0) {
323 my $req = $_->{required}
324 or die "internal error: ATTR0 without 'required'";
325
326 keys %$req;
327 while (my ($k, $v) = each %$req) {
328 next type
329 unless $arch->{$k} == $v;
330 }
331
332 $root = $_;
333 }
302 } 334 }
335
336 my $attr = { };
337
338 my @import = $root || \%Crossfire::Data::DEFAULT_ATTR;
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;
359 }
360 }
361 }
362
363 $attr->{section} = [
364 map !exists $section{$_} ? () : do {
365 my $attr = delete $section{$_};
366
367 [
368 $_,
369 map exists $attr->{$_} && !ignore{$_} ? [$_ => delete $attr->{$_}] : (),
370 @attr_order
371 ]
372 },
373
374 exists $section{$_} ? [$_ => delete $section{$_}] : (),
375 @section_order
376 ];
303 377
304 use PApp::Util; 378 use PApp::Util;
305 warn PApp::Util::dumpval \%attr; 379 warn PApp::Util::dumpval $attr;
380
381 $attr
306} 382}
307 383
308sub arch_edit_sections { 384sub arch_edit_sections {
309# if (edit_type == IGUIConstants.TILE_EDIT_NONE) 385# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
310# edit_type = 0; 386# edit_type = 0;
… …
364# return(edit_type); 440# return(edit_type);
365# 441#
366# 442#
367} 443}
368 444
369$CACHEDIR ||= "$ENV{HOME}/.crossfire"; 445sub init($) {
446 my ($cachedir) = @_;
370 447
448 return if %ARCH;
449
450 mkdir $cachedir, 0777;
451 *ARCH = read_arch "$LIB/archetypes", "$cachedir/archetypes.pst";
452}
453
454$VARDIR ||= $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire";
455
371init $CACHEDIR; 456init $VARDIR;
372 457
373=head1 AUTHOR 458=head1 AUTHOR
374 459
375 Marc Lehmann <schmorp@schmorp.de> 460 Marc Lehmann <schmorp@schmorp.de>
376 http://home.schmorp.de/ 461 http://home.schmorp.de/

Diff Legend

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