[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.95 by root, Mon Mar 5 01:10:30 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.97';
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	'=' => sub { bless [@{$_[0]}], ref $_[0] },
		163	'""' => \&as_string,
		164	'>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
		165	'+=' => sub { $_[0][0] \|= $MOVE_TYPE{$_[1]}; $_[0][1] \|= $MOVE_TYPE{$_[1]}; &normalise },
		166	'-=' => sub { $_[0][0] \|= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
		167	'/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
		168	'x=' => sub {
		169	my $cur = $_[0] >= $_[1];
		170	if (!defined $cur) {
		171	if ($_[0] >= "all") {
		172	$_[0] -= $_[1];
		173	} else {
		174	$_[0] += $_[1];
		175	}
		176	} elsif ($cur) {
		177	$_[0] -= $_[1];
		178	} else {
		179	$_[0] /= $_[1];
		180	}
		181
		182	$_[0]
		183	},
		184	'eq' => sub { "$_[0]" eq "$_[1]" },
		185	'ne' => sub { "$_[0]" ne "$_[1]" },
		186	;
		187	}
		188
		189	sub Crossfire::MoveType::new {
		190	my ($class, $string) = @_;
		191
		192	my $mask;
		193	my $value;
		194
		195	if ($string =~ /^\s\d+\s$/) {
		196	$mask = MOVE_ALL;
		197	$value = $string+0;
		198	} else {
		199	for (split /\s+/, lc $string) {
		200	if (s/^-//) {
		201	$mask \|= $MOVE_TYPE{$_};
		202	$value &= ~$MOVE_TYPE{$_};
		203	} else {
		204	$mask \|= $MOVE_TYPE{$_};
		205	$value \|= $MOVE_TYPE{$_};
		206	}
		207	}
		208	}
		209
		210	(bless [$mask, $value], $class)->normalise
		211	}
		212
		213	sub Crossfire::MoveType::normalise {
		214	my ($self) = @_;
		215
		216	if ($self->[0] & MOVE_ALL) {
		217	my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
		218	$self->[0] &= $mask;
		219	$self->[1] &= $mask;
		220	}
		221
		222	$self->[1] &= $self->[0];
		223
		224	$self
		225	}
		226
		227	sub Crossfire::MoveType::as_string {
		228	my ($self) = @_;
		229
		230	my @res;
		231
		232	my ($mask, $value) = @$self;
		233
		234	for (@Crossfire::MOVE_TYPE) {
		235	my $bit = $Crossfire::MOVE_TYPE{$_};
		236	if (($mask & $bit) == $bit && (($value & $bit) == $bit \|\| ($value & $bit) == 0)) {
		237	$mask &= ~$bit;
		238	push @res, $value & $bit ? $_ : "-$_";
		239	}
		240	}
		241
		242	join " ", @res
		243	}
131		244
132	sub load_ref($) {	245	sub load_ref($) {
133	my ($path) = @_;	246	my ($path) = @_;
134		247
135	open my $fh, "<:raw:perlio", $path	248	open my $fh, "<:raw:perlio", $path
…		…
148	close $fh;	261	close $fh;
149	rename "$path~", $path	262	rename "$path~", $path
150	or die "$path: $!";	263	or die "$path: $!";
151	}	264	}
152		265
		266	my %attack_mask = (
		267	physical => 0x00000001,
		268	magic => 0x00000002,
		269	fire => 0x00000004,
		270	electricity => 0x00000008,
		271	cold => 0x00000010,
		272	confusion => 0x00000020,
		273	acid => 0x00000040,
		274	drain => 0x00000080,
		275	weaponmagic => 0x00000100,
		276	ghosthit => 0x00000200,
		277	poison => 0x00000400,
		278	slow => 0x00000800,
		279	paralyze => 0x00001000,
		280	turn_undead => 0x00002000,
		281	fear => 0x00004000,
		282	cancellation => 0x00008000,
		283	deplete => 0x00010000,
		284	death => 0x00020000,
		285	chaos => 0x00040000,
		286	counterspell => 0x00080000,
		287	godpower => 0x00100000,
		288	holyword => 0x00200000,
		289	blind => 0x00400000,
		290	internal => 0x00800000,
		291	life_stealing => 0x01000000,
		292	disease => 0x02000000,
		293	);
		294
		295	sub _add_resist($$$) {
		296	my ($ob, $mask, $value) = @_;
		297
		298	while (my ($k, $v) = each %attack_mask) {
		299	$ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
		300	}
		301	}
		302
		303	my %MATERIAL = reverse
		304	paper => 1,
		305	iron => 2,
		306	glass => 4,
		307	leather => 8,
		308	wood => 16,
		309	organic => 32,
		310	stone => 64,
		311	cloth => 128,
		312	adamant => 256,
		313	liquid => 512,
		314	tin => 1024,
		315	bone => 2048,
		316	ice => 4096,
		317
		318	# guesses
		319	runestone => 12,
		320	bronze => 18,
		321	"ancient wood" => 20,
		322	glass => 36,
		323	marble => 66,
		324	ice => 68,
		325	stone => 70,
		326	stone => 80,
		327	cloth => 136,
		328	ironwood => 144,
		329	adamantium => 258,
		330	glacium => 260,
		331	blood => 544,
		332	;
		333
153	# object as in "Object xxx", i.e. archetypes	334	# object as in "Object xxx", i.e. archetypes
154	sub normalize_object($) {	335	sub normalize_object($) {
155	my ($ob) = @_;	336	my ($ob) = @_;
156		337
		338	# convert material bitset to materialname, if possible
		339	if (exists $ob->{material}) {
		340	if (!$ob->{material}) {
		341	delete $ob->{material};
		342	} elsif (exists $ob->{materialname}) {
		343	if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
		344	delete $ob->{material};
		345	} else {
		346	warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
		347	delete $ob->{material}; # assume materilname is more specific and nuke material
		348	}
		349	} elsif (my $name = $MATERIAL{$ob->{material}}) {
		350	delete $ob->{material};
		351	$ob->{materialname} = $name;
		352	} else {
		353	warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
		354	}
		355	}
		356
157	# nuke outdated or never supported fields	357	# nuke outdated or never supported fields
158	delete $ob->{$_} for qw(	358	delete @$ob{qw(
159	can_knockback can_parry can_impale can_cut can_dam_armour	359	can_knockback can_parry can_impale can_cut can_dam_armour
160	can_apply pass_thru can_pass_thru	360	can_apply pass_thru can_pass_thru
161	);	361	)};
		362
		363	if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
		364	if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
		365	if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
162		366
163	# convert movement strings to bitsets	367	# convert movement strings to bitsets
164	for my $attr (keys %FIELD_MOVEMENT) {	368	for my $attr (keys %FIELD_MOVEMENT) {
165	next unless exists $ob->{$attr};	369	next unless exists $ob->{$attr};
166		370
167	$ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility	371	$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	}	372	}
194		373
195	# convert outdated movement flags to new movement sets	374	# convert outdated movement flags to new movement sets
196	if (defined (my $v = delete $ob->{no_pass})) {	375	if (defined (my $v = delete $ob->{no_pass})) {
197	$ob->{move_block} = $v ? MOVE_ALL : 0;	376	$ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
198	}	377	}
199	if (defined (my $v = delete $ob->{slow_move})) {	378	if (defined (my $v = delete $ob->{slow_move})) {
200	$ob->{move_slow} \|= MOVE_WALK;	379	$ob->{move_slow} += "walk";
201	$ob->{move_slow_penalty} = $v;	380	$ob->{move_slow_penalty} = $v;
202	}	381	}
203	if (defined (my $v = delete $ob->{walk_on})) {	382	if (defined (my $v = delete $ob->{walk_on})) {
204	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK	383	$ob->{move_on} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
205	: $ob->{move_on} & ~MOVE_WALK;
206	}	384	}
207	if (defined (my $v = delete $ob->{walk_off})) {	385	if (defined (my $v = delete $ob->{walk_off})) {
208	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK	386	$ob->{move_off} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
209	: $ob->{move_off} & ~MOVE_WALK;
210	}	387	}
211	if (defined (my $v = delete $ob->{fly_on})) {	388	if (defined (my $v = delete $ob->{fly_on})) {
212	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW	389	$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	}	390	}
215	if (defined (my $v = delete $ob->{fly_off})) {	391	if (defined (my $v = delete $ob->{fly_off})) {
216	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW	392	$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	}	393	}
219	if (defined (my $v = delete $ob->{flying})) {	394	if (defined (my $v = delete $ob->{flying})) {
220	$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW	395	$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	}	396	}
223		397
224	# convert idiotic event_xxx things into objects	398	# convert idiotic event_xxx things into objects
225	while (my ($event, $subtype) = each %EVENT_TYPE) {	399	while (my ($event, $subtype) = each %EVENT_TYPE) {
226	if (exists $ob->{"event_${event}_plugin"}) {	400	if (exists $ob->{"event_${event}_plugin"}) {
…		…
230	slaying => delete $ob->{"event_${event}"},	404	slaying => delete $ob->{"event_${event}"},
231	name => delete $ob->{"event_${event}_options"},	405	name => delete $ob->{"event_${event}_options"},
232	};	406	};
233	}	407	}
234	}	408	}
		409
		410	# some archetypes had "+3" instead of the canonical "3", so fix
		411	$ob->{dam} *= 1 if exists $ob->{dam};
235		412
236	$ob	413	$ob
237	}	414	}
238		415
239	# arch as in "arch xxx", ie.. objects	416	# arch as in "arch xxx", ie.. objects
…		…
281	}	458	}
282		459
283	$ob	460	$ob
284	}	461	}
285		462
		463	sub attr_thaw($) {
		464	my ($ob) = @_;
		465
		466	$ob->{attach} = from_json $ob->{attach}
		467	if exists $ob->{attach};
		468
		469	$ob
		470	}
		471
		472	sub attr_freeze($) {
		473	my ($ob) = @_;
		474
		475	$ob->{attach} = Crossfire::to_json $ob->{attach}
		476	if exists $ob->{attach};
		477
		478	$ob
		479	}
		480
286	sub read_pak($) {	481	sub read_pak($) {
287	my ($path) = @_;	482	my ($path) = @_;
288		483
289	my %pak;	484	my %pak;
290		485
…		…
298	}	493	}
299		494
300	\%pak	495	\%pak
301	}	496	}
302		497
303	sub read_arch($) {	498	sub read_arch($;$) {
304	my ($path) = @_;	499	my ($path, $toplevel) = @_;
305		500
306	my %arc;	501	my %arc;
307	my ($more, $prev);	502	my ($more, $prev);
		503	my $comment;
308		504
309	open my $fh, "<:raw:perlio:utf8", $path	505	open my $fh, "<:raw:perlio:utf8", $path
310	or Carp::croak "$path: $!";	506	or Carp::croak "$path: $!";
311		507
312	binmode $fh;	508	# binmode $fh;
313		509
314	my $parse_block; $parse_block = sub {	510	my $parse_block; $parse_block = sub {
315	my %arc = @_;	511	my %arc = @_;
316		512
317	while (<$fh>) {	513	while (<$fh>) {
318	s/\s+$//;	514	s/\s+$//;
319	if (/^end$/i) {	515	if (/^end$/i) {
320	last;	516	last;
		517
321	} elsif (/^arch (\S+)$/i) {	518	} elsif (/^arch (\S+)$/i) {
322	push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);	519	push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
		520
323	} elsif (/^lore$/i) {	521	} elsif (/^lore$/i) {
324	while (<$fh>) {	522	while (<$fh>) {
325	last if /^endlore\s*$/i;	523	last if /^endlore\s*$/i;
326	$arc{lore} .= $_;	524	$arc{lore} .= $_;
327	}	525	}
328	} elsif (/^msg$/i) {	526	} elsif (/^msg$/i) {
329	while (<$fh>) {	527	while (<$fh>) {
330	last if /^endmsg\s*$/i;	528	last if /^endmsg\s*$/i;
331	$arc{msg} .= $_;	529	$arc{msg} .= $_;
332	}	530	}
		531	} elsif (/^anim$/i) {
		532	while (<$fh>) {
		533	last if /^mina\s*$/i;
		534	chomp;
		535	push @{ $arc{anim} }, $_;
		536	}
333	} elsif (/^(\S+)\s(.)$/) {	537	} elsif (/^(\S+)\s(.)$/) {
334	$arc{lc $1} = $2;	538	$arc{lc $1} = $2;
335	} elsif (/^\s*($\|#)/) {	539	} elsif (/^\s*#/) {
		540	$arc{_comment} .= "$_\n";
		541
		542	} elsif (/^\s*$/) {
336	#	543	#
337	} else {	544	} else {
338	warn "$path: unparsable line '$_' in arch $arc{_name}";	545	warn "$path: unparsable line '$_' in arch $arc{_name}";
339	}	546	}
340	}	547	}
…		…
346	s/\s+$//;	553	s/\s+$//;
347	if (/^more$/i) {	554	if (/^more$/i) {
348	$more = $prev;	555	$more = $prev;
349	} elsif (/^object (\S+)$/i) {	556	} elsif (/^object (\S+)$/i) {
350	my $name = $1;	557	my $name = $1;
351	my $arc = normalize_object $parse_block->(_name => $name);	558	my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
		559	undef $comment;
		560	delete $arc{_comment} unless length $arc{_comment};
		561	$arc->{_atype} = 'object';
352		562
353	if ($more) {	563	if ($more) {
354	$more->{more} = $arc;	564	$more->{more} = $arc;
355	} else {	565	} else {
356	$arc{$name} = $arc;	566	$arc{$name} = $arc;
357	}	567	}
358	$prev = $arc;	568	$prev = $arc;
359	$more = undef;	569	$more = undef;
360	} elsif (/^arch (\S+)$/i) {	570	} elsif (/^arch (\S+)$/i) {
361	my $name = $1;	571	my $name = $1;
362	my $arc = normalize_arch $parse_block->(_name => $name);	572	my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
		573	undef $comment;
		574	delete $arc{_comment} unless length $arc{_comment};
		575	$arc->{_atype} = 'arch';
363		576
364	if ($more) {	577	if ($more) {
365	$more->{more} = $arc;	578	$more->{more} = $arc;
366	} else {	579	} else {
367	push @{ $arc{arch} }, $arc;	580	push @{ $arc{arch} }, $arc;
368	}	581	}
369	$prev = $arc;	582	$prev = $arc;
370	$more = undef;	583	$more = undef;
		584	} elsif ($toplevel && /^(\S+)\s+(.*)$/) {
		585	if ($1 eq "lev_array") {
		586	while (<$fh>) {
		587	last if /^endplst\s*$/;
		588	push @{$toplevel->{lev_array}}, $_+0;
		589	}
		590	} else {
		591	$toplevel->{$1} = $2;
		592	}
		593	} elsif (/^\s*#/) {
		594	$comment .= "$_\n";
371	} elsif (/^\s*($\|#)/) {	595	} elsif (/^\s*($\|#)/) {
372	#	596	#
373	} else {	597	} else {
374	warn "$path: unparseable top-level line '$_'";	598	die "$path: unparseable top-level line '$_'";
375	}	599	}
376	}	600	}
377		601
378	undef $parse_block; # work around bug in perl not freeing $fh etc.	602	undef $parse_block; # work around bug in perl not freeing $fh etc.
379		603
380	\%arc	604	\%arc
		605	}
		606
		607	sub archlist_to_string {
		608	my ($arch) = @_;
		609
		610	my $str;
		611
		612	my $append; $append = sub {
		613	my %a = %{$_[0]};
		614
		615	Crossfire::attr_freeze \%a;
		616	Crossfire::normalize_arch \%a;
		617
		618	# undo the bit-split we did before
		619	if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
		620	$a{attack_movement} = (delete $a{attack_movement_bits_0_3})
		621	\| (delete $a{attack_movement_bits_4_7});
		622	}
		623
		624	if (my $comment = delete $a{_comment}) {
		625	if ($comment =~ /[^\n\s#]/) {
		626	$str .= $comment;
		627	}
		628	}
		629
		630	$str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
		631
		632	my $inv = delete $a{inventory};
		633	my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
		634	my $anim = delete $a{anim};
		635
		636	if ($a{_atype} eq 'object') {
		637	$str .= join "\n", "anim", @$anim, "mina\n"
		638	if $anim;
		639	}
		640
		641	my @kv;
		642
		643	for ($a{_name} eq "map"
		644	? @Crossfire::FIELD_ORDER_MAP
		645	: @Crossfire::FIELD_ORDER) {
		646	push @kv, [$_, delete $a{$_}]
		647	if exists $a{$_};
		648	}
		649
		650	for (sort keys %a) {
		651	next if /^_/; # ignore our _-keys
		652	push @kv, [$_, delete $a{$_}];
		653	}
		654
		655	for (@kv) {
		656	my ($k, $v) = @$_;
		657
		658	if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
		659	$v =~ s/\n$//;
		660	$str .= "$k\n$v\n$end\n";
		661	} else {
		662	$str .= "$k $v\n";
		663	}
		664	}
		665
		666	if ($inv) {
		667	$append->($_) for @$inv;
		668	}
		669
		670	$str .= "end\n";
		671
		672	if ($a{_atype} eq 'object') {
		673	if ($more) {
		674	$str .= "more\n";
		675	$append->($more) if $more;
		676	} else {
		677	$str .= "\n";
		678	}
		679	}
		680	};
		681
		682	for (@$arch) {
		683	$append->($_);
		684	}
		685
		686	$str
381	}	687	}
382		688
383	# put all archs into a hash with editor_face as it's key	689	# put all archs into a hash with editor_face as it's key
384	# NOTE: the arrays in the hash values are references to	690	# NOTE: the arrays in the hash values are references to
385	# the archs from $ARCH	691	# the archs from $ARCH
…		…
406	my ($a) = @_;	712	my ($a) = @_;
407		713
408	my $o = $ARCH{$a->{_name}}	714	my $o = $ARCH{$a->{_name}}
409	or return;	715	or return;
410		716
411	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"}	717	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"};
		718	unless ($face) {
		719	$face = $FACE{"blank.x11"}
412	or (warn "no face data found for arch '$a->{_name}'"), return;	720	or (warn "no face data found for arch '$a->{_name}'"), return;
		721	}
413		722
414	if ($face->{w} > 1 \|\| $face->{h} > 1) {	723	if ($face->{w} > 1 \|\| $face->{h} > 1) {
415	# bigface	724	# bigface
416	return (0, 0, $face->{w} - 1, $face->{h} - 1);	725	return (0, 0, $face->{w} - 1, $face->{h} - 1);
417		726
…		…
524	];	833	];
525		834
526	$attr	835	$attr
527	}	836	}
528		837
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($$&&) {	838	sub cache_file($$&&) {
591	my ($src, $cache, $load, $create) = @_;	839	my ($src, $cache, $load, $create) = @_;
592		840
593	my ($size, $mtime) = (stat $src)[7,9]	841	my ($size, $mtime) = (stat $src)[7,9]
594	or Carp::croak "$src: $!";	842	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.95 by root, Mon Mar 5 01:10:30 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.95 by root, Mon Mar 5 01:10:30 2007 UTC