[ViewVC] Diff of: cvs/deliantra/Deliantra/Deliantra.pm

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.15 by root, Sun Feb 12 04:50:24 2006 UTC vs.
Revision 1.38 by root, Sun Mar 12 23:22:48 2006 UTC

…		…
11	use strict;	11	use strict;
12		12
13	use base 'Exporter';	13	use base 'Exporter';
14		14
15	use Carp ();	15	use Carp ();
		16	use File::Spec;
		17	use List::Util qw(min max);
16	use Storable;	18	use Storable;
17	use List::Util qw(min max);
18
19	#XXX: The map_* procedures scream for a map-object
20		19
21	our @EXPORT =	20	our @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
24	our $LIB = $ENV{CROSSFIRE_LIBDIR}	23	our $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
27	sub TILESIZE (){ 32 }	26	sub TILESIZE (){ 32 }
28		27
29	our $CACHEDIR;	28	our $VARDIR;
30	our %ARCH;	29	our %ARCH;
31	our %FACE;	30	our %FACE;
32	our $TILE;	31	our $TILE;
33		32
34	our %FIELD_MULTILINE = (	33	our %FIELD_MULTILINE = (
…		…
43	sub MOVE_FLY_LOW (){ 0x2 }	42	sub MOVE_FLY_LOW (){ 0x2 }
44	sub MOVE_FLY_HIGH (){ 0x4 }	43	sub MOVE_FLY_HIGH (){ 0x4 }
45	sub MOVE_FLYING (){ 0x6 }	44	sub MOVE_FLYING (){ 0x6 }
46	sub MOVE_SWIM (){ 0x8 }	45	sub MOVE_SWIM (){ 0x8 }
47	sub MOVE_ALL (){ 0xf }	46	sub MOVE_ALL (){ 0xf }
		47
		48	sub 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
		59	sub 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
49	sub normalize_arch($) {	71	sub 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	}
…		…
224	}	249	}
225		250
226	\%paths	251	\%paths
227	}	252	}
228		253
		254	=item ($minx, $miny, $maxx, $maxy) = arch_extents $arch
		255
229	# arch_extents determines the extents of a given arch	256	arch_extents determines the extents of the given arch's face(s), linked
230	# bigfaces, linked faces and single faces are handled here	257	faces and single faces are handled here it returns (minx, miny, maxx,
231	# it returns (minx, miny, maxx, maxy)	258	maxy)
		259
		260	=cut
		261
232	sub arch_extents {	262	sub arch_extents {
233	my ($a) = @_;	263	my ($a) = @_;
234		264
235	my $o = $ARCH{$a->{_name}}	265	my $o = $ARCH{$a->{_name}}
236	or return;	266	or return;
…		…
259	# single face	289	# single face
260	return (0, 0, 0, 0);	290	return (0, 0, 0, 0);
261	}	291	}
262	}	292	}
263		293
		294	=item $type = arch_attr $arch
		295
		296	Returns a hashref describing the object and its attributes. It can contain
		297	the following keys:
		298
		299	name the name, suitable for display purposes
		300	ignore
		301	attr
		302	desc
		303	use
		304	section => [name => \%attr, name => \%attr]
		305	import
		306
		307	=cut
		308
		309	sub arch_attr($) {
		310	my ($arch) = @_;
		311
		312	require Crossfire::Data;
		313
		314	my $root;
		315
		316	if ($arch->{type} > 0) {
		317	$root = $Crossfire::Data::ATTR{$arch->{type}+0};
		318	} else {
		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	}
		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{$_}
		370	? [$_ => delete $attr->{$_}] : (),
		371	@attr_order
		372	]
		373	},
		374
		375	exists $section{$_} ? [$_ => delete $section{$_}] : (),
		376	@section_order
		377	];
		378
		379	use PApp::Util;
		380	warn PApp::Util::dumpval $attr;
		381
		382	$attr
		383	}
		384
		385	sub arch_edit_sections {
		386	# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
		387	# edit_type = 0;
		388	# else if (edit_type != 0) {
		389	# // all flags from 'check_type' must be unset in this arch because they get recalculated now
		390	# edit_type &= ~check_type;
		391	# }
		392	#
		393	# }
		394	# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
		395	# getAttributeValue("alive", defarch) == 1 &&
		396	# (getAttributeValue("monster", defarch) == 1 \|\|
		397	# getAttributeValue("generator", defarch) == 1)) {
		398	# // Monster: monsters/npcs/generators
		399	# edit_type \|= IGUIConstants.TILE_EDIT_MONSTER;
		400	# }
		401	# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
		402	# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
		403	# // Walls
		404	# edit_type \|= IGUIConstants.TILE_EDIT_WALL;
		405	# }
		406	# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
		407	# getAttributeValue("connected", defarch) != 0) {
		408	# // Connected Objects
		409	# edit_type \|= IGUIConstants.TILE_EDIT_CONNECTED;
		410	# }
		411	# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
		412	# arch_type == 66 \|\| arch_type == 41 \|\| arch_type == 95) {
		413	# // Exit: teleporter/exit/trapdoors
		414	# edit_type \|= IGUIConstants.TILE_EDIT_EXIT;
		415	# }
		416	# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
		417	# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 \|\|
		418	# arch_type == 5 \|\| arch_type == 36 \|\| arch_type == 60 \|\|
		419	# arch_type == 85 \|\| arch_type == 111 \|\| arch_type == 123 \|\|
		420	# arch_type == 124 \|\| arch_type == 130)) {
		421	# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
		422	# edit_type \|= IGUIConstants.TILE_EDIT_TREASURE;
		423	# }
		424	# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
		425	# arch_type == 20 \|\| arch_type == 23 \|\| arch_type == 26 \|\|
		426	# arch_type == 91 \|\| arch_type == 21 \|\| arch_type == 24) {
		427	# // Door: door/special door/gates + keys
		428	# edit_type \|= IGUIConstants.TILE_EDIT_DOOR;
		429	# }
		430	# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
		431	# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
		432	# arch_type <= 16) \|\| arch_type == 33 \|\| arch_type == 34 \|\|
		433	# arch_type == 35 \|\| arch_type == 39 \|\| arch_type == 70 \|\|
		434	# arch_type == 87 \|\| arch_type == 99 \|\| arch_type == 100 \|\|
		435	# arch_type == 104 \|\| arch_type == 109 \|\| arch_type == 113 \|\|
		436	# arch_type == 122 \|\| arch_type == 3)) {
		437	# // Equipment: weapons/armour/wands/rods
		438	# edit_type \|= IGUIConstants.TILE_EDIT_EQUIP;
		439	# }
		440	#
		441	# return(edit_type);
		442	#
		443	#
		444	}
		445
264	sub init($) {	446	sub init($) {
265	my ($cachedir) = @_;	447	my ($cachedir) = @_;
266		448
267	return if %ARCH;	449	return if %ARCH;
268		450
		451	mkdir $cachedir, 0777;
269	*ARCH = read_arch "$LIB/archetypes", "$cachedir/archetypes.pst";	452	*ARCH = read_arch "$LIB/archetypes", "$cachedir/archetypes.pst";
270	}	453	}
271		454
272	$CACHEDIR \|\|= "$ENV{HOME}/.crossfire";	455	$VARDIR \|\|= $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire";
273		456
274	init $CACHEDIR;	457	init $VARDIR;
275		458
276	=head1 AUTHOR	459	=head1 AUTHOR
277		460
278	Marc Lehmann <schmorp@schmorp.de>	461	Marc Lehmann <schmorp@schmorp.de>
279	http://home.schmorp.de/	462	http://home.schmorp.de/

Diff Legend

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

Comparing deliantra/Deliantra/Deliantra.pm (file contents): Revision 1.15 by root, Sun Feb 12 04:50:24 2006 UTC vs. Revision 1.38 by root, Sun Mar 12 23:22:48 2006 UTC

Diff Legend

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.15 by root, Sun Feb 12 04:50:24 2006 UTC vs.
Revision 1.38 by root, Sun Mar 12 23:22:48 2006 UTC