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

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.63 by root, Fri Mar 31 21:06:47 2006 UTC vs.
Revision 1.92 by root, Sat Mar 3 19:32:00 2007 UTC

…		…
4		4
5	=cut	5	=cut
6		6
7	package Crossfire;	7	package Crossfire;
8		8
9	our $VERSION = '0.1';	9	our $VERSION = '0.96';
10		10
11	use strict;	11	use strict;
12		12
13	use base 'Exporter';	13	use base 'Exporter';
14		14
…		…
19		19
20	our @EXPORT = qw(	20	our @EXPORT = qw(
21	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	);	22	);
23		23
		24	use JSON::Syck (); #TODO#d# replace by JSON::PC when it becomes available == working
		25
		26	sub from_json($) {
		27	$JSON::Syck::ImplicitUnicode = 1;
		28	JSON::Syck::Load $_[0]
		29	}
		30
		31	sub to_json($) {
		32	$JSON::Syck::ImplicitUnicode = 0;
		33	JSON::Syck::Dump $_[0]
		34	}
		35
24	our $LIB = $ENV{CROSSFIRE_LIBDIR};	36	our $LIB = $ENV{CROSSFIRE_LIBDIR};
25		37
26	our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire";	38	our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire"
		39	: $ENV{AppData} ? "$ENV{APPDATA}/crossfire"
		40	: File::Spec->tmpdir . "/crossfire";
27		41
28	mkdir $VARDIR, 0777;	42	mkdir $VARDIR, 0777;
29		43
30	sub TILESIZE (){ 32 }	44	sub TILESIZE (){ 32 }
31		45
…		…
44	qw(move_type move_block move_allow move_on move_off move_slow);	58	qw(move_type move_block move_allow move_on move_off move_slow);
45		59
46	# same as in server save routine, to (hopefully) be compatible	60	# same as in server save routine, to (hopefully) be compatible
47	# to the other editors.	61	# to the other editors.
48	our @FIELD_ORDER_MAP = (qw(	62	our @FIELD_ORDER_MAP = (qw(
		63	file_format_version
49	name swap_time reset_timeout fixed_resettime difficulty region	64	name attach swap_time reset_timeout fixed_resettime difficulty region
50	shopitems shopgreed shopmin shopmax shoprace	65	shopitems shopgreed shopmin shopmax shoprace
51	darkness width height enter_x enter_y msg maplore	66	darkness width height enter_x enter_y msg maplore
52	unique template	67	unique template
53	outdoor temp pressure humid windspeed winddir sky nosmooth	68	outdoor temp pressure humid windspeed winddir sky nosmooth
54	tile_path_1 tile_path_2 tile_path_3 tile_path_4	69	tile_path_1 tile_path_2 tile_path_3 tile_path_4
55	));	70	));
56		71
57	our @FIELD_ORDER = (qw(	72	our @FIELD_ORDER = (qw(
58	elevation	73	elevation
59		74
60	name name_pl custom_name title race	75	name name_pl custom_name attach title race
61	slaying skill msg lore other_arch face	76	slaying skill msg lore other_arch face
62	#todo-events	77	#todo-events
63	animation is_animated	78	animation is_animated
64	str dex con wis pow cha int	79	str dex con wis pow cha int
65	hp maxhp sp maxsp grace maxgrace	80	hp maxhp sp maxsp grace maxgrace
…		…
124	sub MOVE_FLY_HIGH (){ 0x04 }	139	sub MOVE_FLY_HIGH (){ 0x04 }
125	sub MOVE_FLYING (){ 0x06 }	140	sub MOVE_FLYING (){ 0x06 }
126	sub MOVE_SWIM (){ 0x08 }	141	sub MOVE_SWIM (){ 0x08 }
127	sub MOVE_BOAT (){ 0x10 }	142	sub MOVE_BOAT (){ 0x10 }
128	sub MOVE_KNOWN (){ 0x1f } # all of above	143	sub MOVE_KNOWN (){ 0x1f } # all of above
129	sub MOVE_ALLBIT (){ 0x10000 }
130	sub MOVE_ALL (){ 0x1001f } # very special value, more PITA	144	sub MOVE_ALL (){ 0x10000 } # very special value
		145
		146	our %MOVE_TYPE = (
		147	walk => MOVE_WALK,
		148	fly_low => MOVE_FLY_LOW,
		149	fly_high => MOVE_FLY_HIGH,
		150	flying => MOVE_FLYING,
		151	swim => MOVE_SWIM,
		152	boat => MOVE_BOAT,
		153	all => MOVE_ALL,
		154	);
		155
		156	our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat);
		157
		158	{
		159	package Crossfire::MoveType;
		160
		161	use overload
		162	'""' => \&as_string,
		163	'>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
		164	'+=' => sub { $_[0][0] \|= $MOVE_TYPE{$_[1]}; $_[0][1] \|= $MOVE_TYPE{$_[1]}; &normalise },
		165	'-=' => sub { $_[0][0] \|= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
		166	'/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
		167	'x=' => sub {
		168	my $cur = $_[0] >= $_[1];
		169	if (!defined $cur) {
		170	$_[0] += $_[1];
		171	} elsif ($cur) {
		172	$_[0] -= $_[1];
		173	} else {
		174	$_[0] /= $_[1];
		175	}
		176
		177	$_[0]
		178	},
		179	'eq' => sub { "$_[0]" eq "$_[1]" },
		180	'ne' => sub { "$_[0]" ne "$_[1]" },
		181	;
		182	}
		183
		184	sub Crossfire::MoveType::new {
		185	my ($class, $string) = @_;
		186
		187	my $mask;
		188	my $value;
		189
		190	if ($string =~ /^\s\d+\s$/) {
		191	$mask = MOVE_ALL;
		192	$value = $string+0;
		193	} else {
		194	for (split /\s+/, lc $string) {
		195	if (s/^-//) {
		196	$mask \|= $MOVE_TYPE{$_};
		197	$value &= ~$MOVE_TYPE{$_};
		198	} else {
		199	$mask \|= $MOVE_TYPE{$_};
		200	$value \|= $MOVE_TYPE{$_};
		201	}
		202	}
		203	}
		204
		205	(bless [$mask, $value], $class)->normalise
		206	}
		207
		208	sub Crossfire::MoveType::normalise {
		209	my ($self) = @_;
		210
		211	if ($self->[0] & MOVE_ALL) {
		212	my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
		213	$self->[0] &= $mask;
		214	$self->[1] &= $mask;
		215	}
		216
		217	$self->[1] &= $self->[0];
		218
		219	$self
		220	}
		221
		222	sub Crossfire::MoveType::as_string {
		223	my ($self) = @_;
		224
		225	my @res;
		226
		227	my ($mask, $value) = @$self;
		228
		229	for (@Crossfire::MOVE_TYPE) {
		230	my $bit = $Crossfire::MOVE_TYPE{$_};
		231	if (($mask & $bit) == $bit && (($value & $bit) == $bit \|\| ($value & $bit) == 0)) {
		232	$mask &= ~$bit;
		233	push @res, $value & $bit ? $_ : "-$_";
		234	}
		235	}
		236
		237	join " ", @res
		238	}
131		239
132	sub load_ref($) {	240	sub load_ref($) {
133	my ($path) = @_;	241	my ($path) = @_;
134		242
135	open my $fh, "<:raw:perlio", $path	243	open my $fh, "<:raw:perlio", $path
…		…
148	close $fh;	256	close $fh;
149	rename "$path~", $path	257	rename "$path~", $path
150	or die "$path: $!";	258	or die "$path: $!";
151	}	259	}
152		260
		261	my %attack_mask = (
		262	physical => 0x00000001,
		263	magic => 0x00000002,
		264	fire => 0x00000004,
		265	electricity => 0x00000008,
		266	cold => 0x00000010,
		267	confusion => 0x00000020,
		268	acid => 0x00000040,
		269	drain => 0x00000080,
		270	weaponmagic => 0x00000100,
		271	ghosthit => 0x00000200,
		272	poison => 0x00000400,
		273	slow => 0x00000800,
		274	paralyze => 0x00001000,
		275	turn_undead => 0x00002000,
		276	fear => 0x00004000,
		277	cancellation => 0x00008000,
		278	deplete => 0x00010000,
		279	death => 0x00020000,
		280	chaos => 0x00040000,
		281	counterspell => 0x00080000,
		282	godpower => 0x00100000,
		283	holyword => 0x00200000,
		284	blind => 0x00400000,
		285	internal => 0x00800000,
		286	life_stealing => 0x01000000,
		287	disease => 0x02000000,
		288	);
		289
		290	sub _add_resist($$$) {
		291	my ($ob, $mask, $value) = @_;
		292
		293	while (my ($k, $v) = each %attack_mask) {
		294	$ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
		295	}
		296	}
		297
		298	my %MATERIAL = reverse
		299	paper => 1,
		300	iron => 2,
		301	glass => 4,
		302	leather => 8,
		303	wood => 16,
		304	organic => 32,
		305	stone => 64,
		306	cloth => 128,
		307	adamant => 256,
		308	liquid => 512,
		309	tin => 1024,
		310	bone => 2048,
		311	ice => 4096,
		312
		313	# guesses
		314	runestone => 12,
		315	bronze => 18,
		316	"ancient wood" => 20,
		317	glass => 36,
		318	marble => 66,
		319	ice => 68,
		320	stone => 70,
		321	stone => 80,
		322	cloth => 136,
		323	ironwood => 144,
		324	adamantium => 258,
		325	glacium => 260,
		326	blood => 544,
		327	;
		328
153	# object as in "Object xxx", i.e. archetypes	329	# object as in "Object xxx", i.e. archetypes
154	sub normalize_object($) {	330	sub normalize_object($) {
155	my ($ob) = @_;	331	my ($ob) = @_;
156		332
		333	# convert material bitset to materialname, if possible
		334	if (exists $ob->{material}) {
		335	if (!$ob->{material}) {
		336	delete $ob->{material};
		337	} elsif (exists $ob->{materialname}) {
		338	if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
		339	delete $ob->{material};
		340	} else {
		341	warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
		342	delete $ob->{material}; # assume materilname is more specific and nuke material
		343	}
		344	} elsif (my $name = $MATERIAL{$ob->{material}}) {
		345	delete $ob->{material};
		346	$ob->{materialname} = $name;
		347	} else {
		348	warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
		349	}
		350	}
		351
157	# nuke outdated or never supported fields	352	# nuke outdated or never supported fields
158	delete $ob->{$_} for qw(	353	delete @$ob{qw(
159	can_knockback can_parry can_impale can_cut can_dam_armour	354	can_knockback can_parry can_impale can_cut can_dam_armour
160	can_apply pass_thru can_pass_thru	355	can_apply pass_thru can_pass_thru
161	);	356	)};
		357
		358	if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
		359	if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
		360	if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
162		361
163	# convert movement strings to bitsets	362	# convert movement strings to bitsets
164	for my $attr (keys %FIELD_MOVEMENT) {	363	for my $attr (keys %FIELD_MOVEMENT) {
165	next unless exists $ob->{$attr};	364	next unless exists $ob->{$attr};
166		365
167	$ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility	366	$ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
168
169	next if $ob->{$attr} =~ /^\d+$/;
170
171	my $flags = 0;
172
173	# assume list
174	for my $flag (map lc, split /\s+/, $ob->{$attr}) {
175	$flags \|= MOVE_WALK if $flag eq "walk";
176	$flags \|= MOVE_FLY_LOW if $flag eq "fly_low";
177	$flags \|= MOVE_FLY_HIGH if $flag eq "fly_high";
178	$flags \|= MOVE_FLYING if $flag eq "flying";
179	$flags \|= MOVE_SWIM if $flag eq "swim";
180	$flags \|= MOVE_BOAT if $flag eq "boat";
181	$flags \|= MOVE_ALL if $flag eq "all";
182
183	$flags &= ~MOVE_WALK if $flag eq "-walk";
184	$flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
185	$flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
186	$flags &= ~MOVE_FLYING if $flag eq "-flying";
187	$flags &= ~MOVE_SWIM if $flag eq "-swim";
188	$flags &= ~MOVE_BOAT if $flag eq "-boat";
189	$flags &= ~MOVE_ALL if $flag eq "-all";
190	}
191
192	$ob->{$attr} = $flags;
193	}	367	}
194		368
195	# convert outdated movement flags to new movement sets	369	# convert outdated movement flags to new movement sets
196	if (defined (my $v = delete $ob->{no_pass})) {	370	if (defined (my $v = delete $ob->{no_pass})) {
197	$ob->{move_block} = $v ? MOVE_ALL : 0;	371	$ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
198	}	372	}
199	if (defined (my $v = delete $ob->{slow_move})) {	373	if (defined (my $v = delete $ob->{slow_move})) {
200	$ob->{move_slow} \|= MOVE_WALK;	374	$ob->{move_slow} += "walk";
201	$ob->{move_slow_penalty} = $v;	375	$ob->{move_slow_penalty} = $v;
202	}	376	}
203	if (defined (my $v = delete $ob->{walk_on})) {	377	if (defined (my $v = delete $ob->{walk_on})) {
204	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK	378	$ob->{move_on} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
205	: $ob->{move_on} & ~MOVE_WALK;
206	}	379	}
207	if (defined (my $v = delete $ob->{walk_off})) {	380	if (defined (my $v = delete $ob->{walk_off})) {
208	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK	381	$ob->{move_off} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
209	: $ob->{move_off} & ~MOVE_WALK;
210	}	382	}
211	if (defined (my $v = delete $ob->{fly_on})) {	383	if (defined (my $v = delete $ob->{fly_on})) {
212	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW	384	$ob->{move_on} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
213	: $ob->{move_on} & ~MOVE_FLY_LOW;
214	}	385	}
215	if (defined (my $v = delete $ob->{fly_off})) {	386	if (defined (my $v = delete $ob->{fly_off})) {
216	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW	387	$ob->{move_off} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
217	: $ob->{move_off} & ~MOVE_FLY_LOW;
218	}	388	}
219	if (defined (my $v = delete $ob->{flying})) {	389	if (defined (my $v = delete $ob->{flying})) {
220	$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW	390	$ob->{move_type} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
221	: $ob->{move_type} & ~MOVE_FLY_LOW;
222	}	391	}
223		392
224	# convert idiotic event_xxx things into objects	393	# convert idiotic event_xxx things into objects
225	while (my ($event, $subtype) = each %EVENT_TYPE) {	394	while (my ($event, $subtype) = each %EVENT_TYPE) {
226	if (exists $ob->{"event_${event}_plugin"}) {	395	if (exists $ob->{"event_${event}_plugin"}) {
…		…
230	slaying => delete $ob->{"event_${event}"},	399	slaying => delete $ob->{"event_${event}"},
231	name => delete $ob->{"event_${event}_options"},	400	name => delete $ob->{"event_${event}_options"},
232	};	401	};
233	}	402	}
234	}	403	}
		404
		405	# some archetypes had "+3" instead of the canonical "3", so fix
		406	$ob->{dam} *= 1 if exists $ob->{dam};
235		407
236	$ob	408	$ob
237	}	409	}
238		410
239	# arch as in "arch xxx", ie.. objects	411	# arch as in "arch xxx", ie.. objects
…		…
281	}	453	}
282		454
283	$ob	455	$ob
284	}	456	}
285		457
		458	sub attr_thaw($) {
		459	my ($ob) = @_;
		460
		461	$ob->{attach} = from_json $ob->{attach}
		462	if exists $ob->{attach};
		463
		464	$ob
		465	}
		466
		467	sub attr_freeze($) {
		468	my ($ob) = @_;
		469
		470	$ob->{attach} = Crossfire::to_json $ob->{attach}
		471	if exists $ob->{attach};
		472
		473	$ob
		474	}
		475
286	sub read_pak($) {	476	sub read_pak($) {
287	my ($path) = @_;	477	my ($path) = @_;
288		478
289	my %pak;	479	my %pak;
290		480
…		…
298	}	488	}
299		489
300	\%pak	490	\%pak
301	}	491	}
302		492
303	sub read_arch($) {	493	sub read_arch($;$) {
304	my ($path) = @_;	494	my ($path, $toplevel) = @_;
305		495
306	my %arc;	496	my %arc;
307	my ($more, $prev);	497	my ($more, $prev);
		498	my $comment;
308		499
309	open my $fh, "<:raw:perlio:utf8", $path	500	open my $fh, "<:raw:perlio:utf8", $path
310	or Carp::croak "$path: $!";	501	or Carp::croak "$path: $!";
311		502
312	binmode $fh;	503	# binmode $fh;
313		504
314	my $parse_block; $parse_block = sub {	505	my $parse_block; $parse_block = sub {
315	my %arc = @_;	506	my %arc = @_;
316		507
317	while (<$fh>) {	508	while (<$fh>) {
318	s/\s+$//;	509	s/\s+$//;
319	if (/^end$/i) {	510	if (/^end$/i) {
320	last;	511	last;
		512
321	} elsif (/^arch (\S+)$/i) {	513	} elsif (/^arch (\S+)$/i) {
322	push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);	514	push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
		515
323	} elsif (/^lore$/i) {	516	} elsif (/^lore$/i) {
324	while (<$fh>) {	517	while (<$fh>) {
325	last if /^endlore\s*$/i;	518	last if /^endlore\s*$/i;
326	$arc{lore} .= $_;	519	$arc{lore} .= $_;
327	}	520	}
328	} elsif (/^msg$/i) {	521	} elsif (/^msg$/i) {
329	while (<$fh>) {	522	while (<$fh>) {
330	last if /^endmsg\s*$/i;	523	last if /^endmsg\s*$/i;
331	$arc{msg} .= $_;	524	$arc{msg} .= $_;
332	}	525	}
		526	} elsif (/^anim$/i) {
		527	while (<$fh>) {
		528	last if /^mina\s*$/i;
		529	chomp;
		530	push @{ $arc{anim} }, $_;
		531	}
333	} elsif (/^(\S+)\s(.)$/) {	532	} elsif (/^(\S+)\s(.)$/) {
334	$arc{lc $1} = $2;	533	$arc{lc $1} = $2;
335	} elsif (/^\s*($\|#)/) {	534	} elsif (/^\s*#/) {
		535	$arc{_comment} .= "$_\n";
		536
		537	} elsif (/^\s*$/) {
336	#	538	#
337	} else {	539	} else {
338	warn "$path: unparsable line '$_' in arch $arc{_name}";	540	warn "$path: unparsable line '$_' in arch $arc{_name}";
339	}	541	}
340	}	542	}
…		…
346	s/\s+$//;	548	s/\s+$//;
347	if (/^more$/i) {	549	if (/^more$/i) {
348	$more = $prev;	550	$more = $prev;
349	} elsif (/^object (\S+)$/i) {	551	} elsif (/^object (\S+)$/i) {
350	my $name = $1;	552	my $name = $1;
351	my $arc = normalize_object $parse_block->(_name => $name);	553	my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
		554	undef $comment;
		555	delete $arc{_comment} unless length $arc{_comment};
		556	$arc->{_atype} = 'object';
352		557
353	if ($more) {	558	if ($more) {
354	$more->{more} = $arc;	559	$more->{more} = $arc;
355	} else {	560	} else {
356	$arc{$name} = $arc;	561	$arc{$name} = $arc;
357	}	562	}
358	$prev = $arc;	563	$prev = $arc;
359	$more = undef;	564	$more = undef;
360	} elsif (/^arch (\S+)$/i) {	565	} elsif (/^arch (\S+)$/i) {
361	my $name = $1;	566	my $name = $1;
362	my $arc = normalize_arch $parse_block->(_name => $name);	567	my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
		568	undef $comment;
		569	delete $arc{_comment} unless length $arc{_comment};
		570	$arc->{_atype} = 'arch';
363		571
364	if ($more) {	572	if ($more) {
365	$more->{more} = $arc;	573	$more->{more} = $arc;
366	} else {	574	} else {
367	push @{ $arc{arch} }, $arc;	575	push @{ $arc{arch} }, $arc;
368	}	576	}
369	$prev = $arc;	577	$prev = $arc;
370	$more = undef;	578	$more = undef;
		579	} elsif ($toplevel && /^(\S+)\s+(.*)$/) {
		580	if ($1 eq "lev_array") {
		581	while (<$fh>) {
		582	last if /^endplst\s*$/;
		583	push @{$toplevel->{lev_array}}, $_+0;
		584	}
		585	} else {
		586	$toplevel->{$1} = $2;
		587	}
		588	} elsif (/^\s*#/) {
		589	$comment .= "$_\n";
371	} elsif (/^\s*($\|#)/) {	590	} elsif (/^\s*($\|#)/) {
372	#	591	#
373	} else {	592	} else {
374	warn "$path: unparseable top-level line '$_'";	593	die "$path: unparseable top-level line '$_'";
375	}	594	}
376	}	595	}
377		596
378	undef $parse_block; # work around bug in perl not freeing $fh etc.	597	undef $parse_block; # work around bug in perl not freeing $fh etc.
379		598
380	\%arc	599	\%arc
		600	}
		601
		602	sub archlist_to_string {
		603	my ($arch) = @_;
		604
		605	my $str;
		606
		607	my $append; $append = sub {
		608	my %a = %{$_[0]};
		609
		610	Crossfire::attr_freeze \%a;
		611	Crossfire::normalize_arch \%a;
		612
		613	# undo the bit-split we did before
		614	if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
		615	$a{attack_movement} = (delete $a{attack_movement_bits_0_3})
		616	\| (delete $a{attack_movement_bits_4_7});
		617	}
		618
		619	if (my $comment = delete $a{_comment}) {
		620	if ($comment =~ /[^\n\s#]/) {
		621	$str .= $comment;
		622	}
		623	}
		624
		625	$str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
		626
		627	my $inv = delete $a{inventory};
		628	my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
		629	my $anim = delete $a{anim};
		630
		631	if ($a{_atype} eq 'object') {
		632	$str .= join "\n", "anim", @$anim, "mina\n"
		633	if $anim;
		634	}
		635
		636	my @kv;
		637
		638	for ($a{_name} eq "map"
		639	? @Crossfire::FIELD_ORDER_MAP
		640	: @Crossfire::FIELD_ORDER) {
		641	push @kv, [$_, delete $a{$_}]
		642	if exists $a{$_};
		643	}
		644
		645	for (sort keys %a) {
		646	next if /^_/; # ignore our _-keys
		647	push @kv, [$_, delete $a{$_}];
		648	}
		649
		650	for (@kv) {
		651	my ($k, $v) = @$_;
		652
		653	if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
		654	$v =~ s/\n$//;
		655	$str .= "$k\n$v\n$end\n";
		656	} else {
		657	$str .= "$k $v\n";
		658	}
		659	}
		660
		661	if ($inv) {
		662	$append->($_) for @$inv;
		663	}
		664
		665	$str .= "end\n";
		666
		667	if ($a{_atype} eq 'object') {
		668	if ($more) {
		669	$str .= "more\n";
		670	$append->($more) if $more;
		671	} else {
		672	$str .= "\n";
		673	}
		674	}
		675	};
		676
		677	for (@$arch) {
		678	$append->($_);
		679	}
		680
		681	$str
381	}	682	}
382		683
383	# put all archs into a hash with editor_face as it's key	684	# put all archs into a hash with editor_face as it's key
384	# NOTE: the arrays in the hash values are references to	685	# NOTE: the arrays in the hash values are references to
385	# the archs from $ARCH	686	# the archs from $ARCH
…		…
406	my ($a) = @_;	707	my ($a) = @_;
407		708
408	my $o = $ARCH{$a->{_name}}	709	my $o = $ARCH{$a->{_name}}
409	or return;	710	or return;
410		711
411	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"}	712	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"};
		713	unless ($face) {
		714	$face = $FACE{"blank.x11"}
412	or (warn "no face data found for arch '$a->{_name}'"), return;	715	or (warn "no face data found for arch '$a->{_name}'"), return;
		716	}
413		717
414	if ($face->{w} > 1 \|\| $face->{h} > 1) {	718	if ($face->{w} > 1 \|\| $face->{h} > 1) {
415	# bigface	719	# bigface
416	return (0, 0, $face->{w} - 1, $face->{h} - 1);	720	return (0, 0, $face->{w} - 1, $face->{h} - 1);
417		721
…		…
524	];	828	];
525		829
526	$attr	830	$attr
527	}	831	}
528		832
529	sub arch_edit_sections {
530	# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
531	# edit_type = 0;
532	# else if (edit_type != 0) {
533	# // all flags from 'check_type' must be unset in this arch because they get recalculated now
534	# edit_type &= ~check_type;
535	# }
536	#
537	# }
538	# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
539	# getAttributeValue("alive", defarch) == 1 &&
540	# (getAttributeValue("monster", defarch) == 1 \|\|
541	# getAttributeValue("generator", defarch) == 1)) {
542	# // Monster: monsters/npcs/generators
543	# edit_type \|= IGUIConstants.TILE_EDIT_MONSTER;
544	# }
545	# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
546	# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
547	# // Walls
548	# edit_type \|= IGUIConstants.TILE_EDIT_WALL;
549	# }
550	# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
551	# getAttributeValue("connected", defarch) != 0) {
552	# // Connected Objects
553	# edit_type \|= IGUIConstants.TILE_EDIT_CONNECTED;
554	# }
555	# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
556	# arch_type == 66 \|\| arch_type == 41 \|\| arch_type == 95) {
557	# // Exit: teleporter/exit/trapdoors
558	# edit_type \|= IGUIConstants.TILE_EDIT_EXIT;
559	# }
560	# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
561	# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 \|\|
562	# arch_type == 5 \|\| arch_type == 36 \|\| arch_type == 60 \|\|
563	# arch_type == 85 \|\| arch_type == 111 \|\| arch_type == 123 \|\|
564	# arch_type == 124 \|\| arch_type == 130)) {
565	# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
566	# edit_type \|= IGUIConstants.TILE_EDIT_TREASURE;
567	# }
568	# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
569	# arch_type == 20 \|\| arch_type == 23 \|\| arch_type == 26 \|\|
570	# arch_type == 91 \|\| arch_type == 21 \|\| arch_type == 24) {
571	# // Door: door/special door/gates + keys
572	# edit_type \|= IGUIConstants.TILE_EDIT_DOOR;
573	# }
574	# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
575	# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
576	# arch_type <= 16) \|\| arch_type == 33 \|\| arch_type == 34 \|\|
577	# arch_type == 35 \|\| arch_type == 39 \|\| arch_type == 70 \|\|
578	# arch_type == 87 \|\| arch_type == 99 \|\| arch_type == 100 \|\|
579	# arch_type == 104 \|\| arch_type == 109 \|\| arch_type == 113 \|\|
580	# arch_type == 122 \|\| arch_type == 3)) {
581	# // Equipment: weapons/armour/wands/rods
582	# edit_type \|= IGUIConstants.TILE_EDIT_EQUIP;
583	# }
584	#
585	# return(edit_type);
586	#
587	#
588	}
589
590	sub cache_file($$&&) {	833	sub cache_file($$&&) {
591	my ($src, $cache, $load, $create) = @_;	834	my ($src, $cache, $load, $create) = @_;
592		835
593	my ($size, $mtime) = (stat $src)[7,9]	836	my ($size, $mtime) = (stat $src)[7,9]
594	or Carp::croak "$src: $!";	837	or Carp::croak "$src: $!";

Diff Legend

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

Comparing deliantra/Deliantra/Deliantra.pm (file contents): Revision 1.63 by root, Fri Mar 31 21:06:47 2006 UTC vs. Revision 1.92 by root, Sat Mar 3 19:32:00 2007 UTC

Diff Legend

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.63 by root, Fri Mar 31 21:06:47 2006 UTC vs.
Revision 1.92 by root, Sat Mar 3 19:32:00 2007 UTC