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.46 by root, Thu Mar 16 01:34:01 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 ($obj) = @_;
293 311
294 require Crossfire::Data; 312 require Crossfire::Data;
295 313
296 my %attr; 314 my $root;
315
316 my $arch = $ARCH{ $obj->{_name} };
317 my $type = $obj->{type} || $arch->{type};
297 318
298 if ($arch->{type} > 0) { 319 if ($type > 0) {
299 %attr = %{ $Crossfire::Data::ATTR{$arch->{type}+0} || {} }; 320 $root = $Crossfire::Data::ATTR{$type};
300 } else { 321 } else {
301 die; 322 $root = $Crossfire::Data::TYPE{Misc};
302 }
303 323
304 use PApp::Util; 324 type:
305 warn PApp::Util::dumpval \%attr; 325 for (@Crossfire::Data::ATTR0) {
326 my $req = $_->{required}
327 or die "internal error: ATTR0 without 'required'";
328
329 keys %$req;
330 while (my ($k, $v) = each %$req) {
331 next type
332 unless $obj->{$k} eq $v || $arch->{$k} eq $v;
333 }
334
335 $root = $_;
336 }
337 }
338
339 my $attr = { };
340
341 my @import = (\%Crossfire::Data::DEFAULT_ATTR, $root);
342 my (%ignore);
343 my (@section_order, %section, @attr_order);
344
345 while (my $type = shift @import) {
346 push @import, @{$type->{import} || []};
347
348 $attr->{$_} ||= $type->{$_}
349 for qw(name desc use);
350
351 for (@{$type->{ignore} || []}) {
352 $ignore{$_}++ for ref $_ ? @$_ : $_;
353 }
354
355 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
356 my ($name, $attr) = @$_;
357 push @section_order, $name;
358 for (@$attr) {
359 my ($k, $v) = @$_;
360 push @attr_order, $k;
361 $section{$name}{$k} ||= $v;
362 }
363 }
364 }
365
366 $attr->{section} = [
367 map !exists $section{$_} ? () : do {
368 my $attr = delete $section{$_};
369
370 [
371 $_,
372 map exists $attr->{$_} && !$ignore{$_}
373 ? [$_ => delete $attr->{$_}] : (),
374 @attr_order
375 ]
376 },
377
378 exists $section{$_} ? [$_ => delete $section{$_}] : (),
379 @section_order
380 ];
381
382 $attr
306} 383}
307 384
308sub arch_edit_sections { 385sub arch_edit_sections {
309# if (edit_type == IGUIConstants.TILE_EDIT_NONE) 386# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
310# edit_type = 0; 387# edit_type = 0;
… …
364# return(edit_type); 441# return(edit_type);
365# 442#
366# 443#
367} 444}
368 445
369$CACHEDIR ||= "$ENV{HOME}/.crossfire"; 446sub init($) {
447 my ($cachedir) = @_;
370 448
449 return if %ARCH;
450
451 mkdir $cachedir, 0777;
452 *ARCH = read_arch "$LIB/archetypes", "$cachedir/archetypes.pst";
453}
454
455$VARDIR ||= $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire";
456
371init $CACHEDIR; 457init $VARDIR;
372 458
373=head1 AUTHOR 459=head1 AUTHOR
374 460
375 Marc Lehmann <schmorp@schmorp.de> 461 Marc Lehmann <schmorp@schmorp.de>
376 http://home.schmorp.de/ 462 http://home.schmorp.de/

Diff Legend

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