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