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