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

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.60 by root, Mon Mar 27 17:23:35 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
…		…
102		117
103	body_range body_arm body_torso body_head body_neck body_skill	118	body_range body_arm body_torso body_head body_neck body_skill
104	body_finger body_shoulder body_foot body_hand body_wrist body_waist	119	body_finger body_shoulder body_foot body_hand body_wrist body_waist
105	));	120	));
106		121
		122	our %EVENT_TYPE = (
		123	apply => 1,
		124	attack => 2,
		125	death => 3,
		126	drop => 4,
		127	pickup => 5,
		128	say => 6,
		129	stop => 7,
		130	time => 8,
		131	throw => 9,
		132	trigger => 10,
		133	close => 11,
		134	timer => 12,
		135	);
		136
107	sub MOVE_WALK (){ 0x01 }	137	sub MOVE_WALK (){ 0x01 }
108	sub MOVE_FLY_LOW (){ 0x02 }	138	sub MOVE_FLY_LOW (){ 0x02 }
109	sub MOVE_FLY_HIGH (){ 0x04 }	139	sub MOVE_FLY_HIGH (){ 0x04 }
110	sub MOVE_FLYING (){ 0x06 }	140	sub MOVE_FLYING (){ 0x06 }
111	sub MOVE_SWIM (){ 0x08 }	141	sub MOVE_SWIM (){ 0x08 }
112	sub MOVE_BOAT (){ 0x10 }	142	sub MOVE_BOAT (){ 0x10 }
113	sub MOVE_KNOWN (){ 0x1f } # all of above	143	sub MOVE_KNOWN (){ 0x1f } # all of above
114	sub MOVE_ALLBIT (){ 0x10000 }
115	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	}
116		240
117	sub load_ref($) {	241	sub load_ref($) {
118	my ($path) = @_;	242	my ($path) = @_;
119		243
120	open my $fh, "<", $path	244	open my $fh, "<:raw:perlio", $path
121	or die "$path: $!";	245	or die "$path: $!";
122	binmode $fh;
123	local $/;	246	local $/;
124		247
125	thaw <$fh>	248	thaw <$fh>
126	}	249	}
127		250
128	sub save_ref($$) {	251	sub save_ref($$) {
129	my ($ref, $path) = @_;	252	my ($ref, $path) = @_;
130		253
131	open my $fh, ">", "$path~"	254	open my $fh, ">:raw:perlio", "$path~"
132	or die "$path~: $!";	255	or die "$path~: $!";
133	binmode $fh;
134	print $fh freeze $ref;	256	print $fh freeze $ref;
135	close $fh;	257	close $fh;
136	rename "$path~", $path	258	rename "$path~", $path
137	or die "$path: $!";	259	or die "$path: $!";
138	}	260	}
139		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
		330	# object as in "Object xxx", i.e. archetypes
140	sub normalize_object($) {	331	sub normalize_object($) {
141	my ($ob) = @_;	332	my ($ob) = @_;
142		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
		353	# nuke outdated or never supported fields
143	delete $ob->{$_} for qw(	354	delete @$ob{qw(
144	can_knockback can_parry can_impale can_cut can_dam_armour	355	can_knockback can_parry can_impale can_cut can_dam_armour
145	can_apply pass_thru can_pass_thru	356	can_apply pass_thru can_pass_thru
146	);	357	)};
147		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; }
		362
		363	# convert movement strings to bitsets
148	for my $attr (keys %FIELD_MOVEMENT) {	364	for my $attr (keys %FIELD_MOVEMENT) {
149	next unless exists $ob->{$attr};	365	next unless exists $ob->{$attr};
150		366
151	$ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility	367	$ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
152
153	next if $ob->{$attr} =~ /^\d+$/;
154
155	my $flags = 0;
156
157	# assume list
158	for my $flag (map lc, split /\s+/, $ob->{$attr}) {
159	$flags \|= MOVE_WALK if $flag eq "walk";
160	$flags \|= MOVE_FLY_LOW if $flag eq "fly_low";
161	$flags \|= MOVE_FLY_HIGH if $flag eq "fly_high";
162	$flags \|= MOVE_FLYING if $flag eq "flying";
163	$flags \|= MOVE_SWIM if $flag eq "swim";
164	$flags \|= MOVE_BOAT if $flag eq "boat";
165	$flags \|= MOVE_ALL if $flag eq "all";
166
167	$flags &= ~MOVE_WALK if $flag eq "-walk";
168	$flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
169	$flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
170	$flags &= ~MOVE_FLYING if $flag eq "-flying";
171	$flags &= ~MOVE_SWIM if $flag eq "-swim";
172	$flags &= ~MOVE_BOAT if $flag eq "-boat";
173	$flags &= ~MOVE_ALL if $flag eq "-all";
174	}
175
176	$ob->{$attr} = $flags;
177	}	368	}
178		369
		370	# convert outdated movement flags to new movement sets
179	if (defined (my $v = delete $ob->{no_pass})) {	371	if (defined (my $v = delete $ob->{no_pass})) {
180	$ob->{move_block} = $v ? MOVE_ALL : 0;	372	$ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
181	}	373	}
182	if (defined (my $v = delete $ob->{slow_move})) {	374	if (defined (my $v = delete $ob->{slow_move})) {
183	$ob->{move_slow} \|= MOVE_WALK;	375	$ob->{move_slow} += "walk";
184	$ob->{move_slow_penalty} = $v;	376	$ob->{move_slow_penalty} = $v;
185	}	377	}
186	if (defined (my $v = delete $ob->{walk_on})) {	378	if (defined (my $v = delete $ob->{walk_on})) {
187	$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" }
188	: $ob->{move_on} & ~MOVE_WALK;
189	}	380	}
190	if (defined (my $v = delete $ob->{walk_off})) {	381	if (defined (my $v = delete $ob->{walk_off})) {
191	$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" }
192	: $ob->{move_off} & ~MOVE_WALK;
193	}	383	}
194	if (defined (my $v = delete $ob->{fly_on})) {	384	if (defined (my $v = delete $ob->{fly_on})) {
195	$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" }
196	: $ob->{move_on} & ~MOVE_FLY_LOW;
197	}	386	}
198	if (defined (my $v = delete $ob->{fly_off})) {	387	if (defined (my $v = delete $ob->{fly_off})) {
199	$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" }
200	: $ob->{move_off} & ~MOVE_FLY_LOW;
201	}	389	}
202	if (defined (my $v = delete $ob->{flying})) {	390	if (defined (my $v = delete $ob->{flying})) {
203	$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" }
204	: $ob->{move_type} & ~MOVE_FLY_LOW;
205	}	392	}
		393
		394	# convert idiotic event_xxx things into objects
		395	while (my ($event, $subtype) = each %EVENT_TYPE) {
		396	if (exists $ob->{"event_${event}_plugin"}) {
		397	push @{$ob->{inventory}}, {
		398	_name => "event_$event",
		399	title => delete $ob->{"event_${event}_plugin"},
		400	slaying => delete $ob->{"event_${event}"},
		401	name => delete $ob->{"event_${event}_options"},
		402	};
		403	}
		404	}
		405
		406	# some archetypes had "+3" instead of the canonical "3", so fix
		407	$ob->{dam} *= 1 if exists $ob->{dam};
206		408
207	$ob	409	$ob
208	}	410	}
209		411
		412	# arch as in "arch xxx", ie.. objects
210	sub normalize_arch($) {	413	sub normalize_arch($) {
211	my ($ob) = @_;	414	my ($ob) = @_;
212		415
213	normalize_object $ob;	416	normalize_object $ob;
214		417
…		…
251	}	454	}
252		455
253	$ob	456	$ob
254	}	457	}
255		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
256	sub read_pak($) {	477	sub read_pak($) {
257	my ($path) = @_;	478	my ($path) = @_;
258		479
259	my %pak;	480	my %pak;
260		481
261	open my $fh, "<", $path	482	open my $fh, "<:raw:perlio", $path
262	or Carp::croak "$_[0]: $!";	483	or Carp::croak "$_[0]: $!";
263	binmode $fh;	484	binmode $fh;
264	while (<$fh>) {	485	while (<$fh>) {
265	my ($type, $id, $len, $path) = split;	486	my ($type, $id, $len, $path) = split;
266	$path =~ s/.*\///;	487	$path =~ s/.*\///;
…		…
268	}	489	}
269		490
270	\%pak	491	\%pak
271	}	492	}
272		493
273	sub read_arch($) {	494	sub read_arch($;$) {
274	my ($path) = @_;	495	my ($path, $toplevel) = @_;
275		496
276	my %arc;	497	my %arc;
277	my ($more, $prev);	498	my ($more, $prev);
		499	my $comment;
278		500
279	open my $fh, "<", $path	501	open my $fh, "<:raw:perlio:utf8", $path
280	or Carp::croak "$path: $!";	502	or Carp::croak "$path: $!";
281		503
282	binmode $fh;	504	# binmode $fh;
283		505
284	my $parse_block; $parse_block = sub {	506	my $parse_block; $parse_block = sub {
285	my %arc = @_;	507	my %arc = @_;
286		508
287	while (<$fh>) {	509	while (<$fh>) {
288	s/\s+$//;	510	s/\s+$//;
289	if (/^end$/i) {	511	if (/^end$/i) {
290	last;	512	last;
		513
291	} elsif (/^arch (\S+)$/i) {	514	} elsif (/^arch (\S+)$/i) {
292	push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);	515	push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
		516
293	} elsif (/^lore$/i) {	517	} elsif (/^lore$/i) {
294	while (<$fh>) {	518	while (<$fh>) {
295	last if /^endlore\s*$/i;	519	last if /^endlore\s*$/i;
296	$arc{lore} .= $_;	520	$arc{lore} .= $_;
297	}	521	}
298	} elsif (/^msg$/i) {	522	} elsif (/^msg$/i) {
299	while (<$fh>) {	523	while (<$fh>) {
300	last if /^endmsg\s*$/i;	524	last if /^endmsg\s*$/i;
301	$arc{msg} .= $_;	525	$arc{msg} .= $_;
302	}	526	}
		527	} elsif (/^anim$/i) {
		528	while (<$fh>) {
		529	last if /^mina\s*$/i;
		530	chomp;
		531	push @{ $arc{anim} }, $_;
		532	}
303	} elsif (/^(\S+)\s(.)$/) {	533	} elsif (/^(\S+)\s(.)$/) {
304	$arc{lc $1} = $2;	534	$arc{lc $1} = $2;
305	} elsif (/^\s*($\|#)/) {	535	} elsif (/^\s*#/) {
		536	$arc{_comment} .= "$_\n";
		537
		538	} elsif (/^\s*$/) {
306	#	539	#
307	} else {	540	} else {
308	warn "$path: unparsable line '$_' in arch $arc{_name}";	541	warn "$path: unparsable line '$_' in arch $arc{_name}";
309	}	542	}
310	}	543	}
…		…
316	s/\s+$//;	549	s/\s+$//;
317	if (/^more$/i) {	550	if (/^more$/i) {
318	$more = $prev;	551	$more = $prev;
319	} elsif (/^object (\S+)$/i) {	552	} elsif (/^object (\S+)$/i) {
320	my $name = $1;	553	my $name = $1;
321	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';
322		558
323	if ($more) {	559	if ($more) {
324	$more->{more} = $arc;	560	$more->{more} = $arc;
325	} else {	561	} else {
326	$arc{$name} = $arc;	562	$arc{$name} = $arc;
327	}	563	}
328	$prev = $arc;	564	$prev = $arc;
329	$more = undef;	565	$more = undef;
330	} elsif (/^arch (\S+)$/i) {	566	} elsif (/^arch (\S+)$/i) {
331	my $name = $1;	567	my $name = $1;
332	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';
333		572
334	if ($more) {	573	if ($more) {
335	$more->{more} = $arc;	574	$more->{more} = $arc;
336	} else {	575	} else {
337	push @{ $arc{arch} }, $arc;	576	push @{ $arc{arch} }, $arc;
338	}	577	}
339	$prev = $arc;	578	$prev = $arc;
340	$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";
341	} elsif (/^\s*($\|#)/) {	591	} elsif (/^\s*($\|#)/) {
342	#	592	#
343	} else {	593	} else {
344	warn "$path: unparseable top-level line '$_'";	594	die "$path: unparseable top-level line '$_'";
345	}	595	}
346	}	596	}
347		597
348	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.
349		599
350	\%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
351	}	683	}
352		684
353	# 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
354	# NOTE: the arrays in the hash values are references to	686	# NOTE: the arrays in the hash values are references to
355	# the archs from $ARCH	687	# the archs from $ARCH
356	sub editor_archs {	688	sub editor_archs {
357	my %paths;	689	my %paths;
358		690
359	for (keys %ARCH) {	691	for (keys %ARCH) {
360	my $arch = $ARCH{$_};	692	my $arch = $ARCH{$_};
361	push @{$paths{$arch->{editor_folder}}}, \$arch;	693	push @{$paths{$arch->{editor_folder}}}, $arch;
362	}	694	}
363		695
364	\%paths	696	\%paths
365	}	697	}
366		698
…		…
376	my ($a) = @_;	708	my ($a) = @_;
377		709
378	my $o = $ARCH{$a->{_name}}	710	my $o = $ARCH{$a->{_name}}
379	or return;	711	or return;
380		712
381	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"}
382	or (warn "no face data found for arch '$a->{_name}'"), return;	716	or (warn "no face data found for arch '$a->{_name}'"), return;
		717	}
383		718
384	if ($face->{w} > 1 \|\| $face->{h} > 1) {	719	if ($face->{w} > 1 \|\| $face->{h} > 1) {
385	# bigface	720	# bigface
386	return (0, 0, $face->{w} - 1, $face->{h} - 1);	721	return (0, 0, $face->{w} - 1, $face->{h} - 1);
387		722
…		…
431	my $type = $obj->{type} \|\| $arch->{type};	766	my $type = $obj->{type} \|\| $arch->{type};
432		767
433	if ($type > 0) {	768	if ($type > 0) {
434	$root = $Crossfire::Data::ATTR{$type};	769	$root = $Crossfire::Data::ATTR{$type};
435	} else {	770	} else {
		771	my %a = (%$arch, %$obj);
		772
		773	if ($a{is_floor} && !$a{alive}) {
		774	$root = $Crossfire::Data::TYPE{Floor};
		775	} elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
		776	$root = $Crossfire::Data::TYPE{"Monster & NPC"};
		777	} elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
		778	$root = $Crossfire::Data::TYPE{Wall};
		779	} elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
		780	$root = $Crossfire::Data::TYPE{"Weak Wall"};
		781	} else {
436	$root = $Crossfire::Data::TYPE{Misc};	782	$root = $Crossfire::Data::TYPE{Misc};
437
438	type:
439	for (@Crossfire::Data::ATTR0) {
440	my $req = $_->{required}
441	or die "internal error: ATTR0 without 'required'";
442
443	keys %$req;
444	while (my ($k, $v) = each %$req) {
445	next type
446	unless $obj->{$k} == $v \|\| $arch->{$k} == $v;
447	}
448
449	$root = $_;
450	}	783	}
451	}	784	}
452		785
453	my @import = ($root);	786	my @import = ($root);
454		787
…		…
496	];	829	];
497		830
498	$attr	831	$attr
499	}	832	}
500		833
501	sub arch_edit_sections {
502	# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
503	# edit_type = 0;
504	# else if (edit_type != 0) {
505	# // all flags from 'check_type' must be unset in this arch because they get recalculated now
506	# edit_type &= ~check_type;
507	# }
508	#
509	# }
510	# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
511	# getAttributeValue("alive", defarch) == 1 &&
512	# (getAttributeValue("monster", defarch) == 1 \|\|
513	# getAttributeValue("generator", defarch) == 1)) {
514	# // Monster: monsters/npcs/generators
515	# edit_type \|= IGUIConstants.TILE_EDIT_MONSTER;
516	# }
517	# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
518	# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
519	# // Walls
520	# edit_type \|= IGUIConstants.TILE_EDIT_WALL;
521	# }
522	# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
523	# getAttributeValue("connected", defarch) != 0) {
524	# // Connected Objects
525	# edit_type \|= IGUIConstants.TILE_EDIT_CONNECTED;
526	# }
527	# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
528	# arch_type == 66 \|\| arch_type == 41 \|\| arch_type == 95) {
529	# // Exit: teleporter/exit/trapdoors
530	# edit_type \|= IGUIConstants.TILE_EDIT_EXIT;
531	# }
532	# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
533	# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 \|\|
534	# arch_type == 5 \|\| arch_type == 36 \|\| arch_type == 60 \|\|
535	# arch_type == 85 \|\| arch_type == 111 \|\| arch_type == 123 \|\|
536	# arch_type == 124 \|\| arch_type == 130)) {
537	# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
538	# edit_type \|= IGUIConstants.TILE_EDIT_TREASURE;
539	# }
540	# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
541	# arch_type == 20 \|\| arch_type == 23 \|\| arch_type == 26 \|\|
542	# arch_type == 91 \|\| arch_type == 21 \|\| arch_type == 24) {
543	# // Door: door/special door/gates + keys
544	# edit_type \|= IGUIConstants.TILE_EDIT_DOOR;
545	# }
546	# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
547	# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
548	# arch_type <= 16) \|\| arch_type == 33 \|\| arch_type == 34 \|\|
549	# arch_type == 35 \|\| arch_type == 39 \|\| arch_type == 70 \|\|
550	# arch_type == 87 \|\| arch_type == 99 \|\| arch_type == 100 \|\|
551	# arch_type == 104 \|\| arch_type == 109 \|\| arch_type == 113 \|\|
552	# arch_type == 122 \|\| arch_type == 3)) {
553	# // Equipment: weapons/armour/wands/rods
554	# edit_type \|= IGUIConstants.TILE_EDIT_EQUIP;
555	# }
556	#
557	# return(edit_type);
558	#
559	#
560	}
561
562	sub cache_file($$&&) {	834	sub cache_file($$&&) {
563	my ($src, $cache, $load, $create) = @_;	835	my ($src, $cache, $load, $create) = @_;
564		836
565	my ($size, $mtime) = (stat $src)[7,9]	837	my ($size, $mtime) = (stat $src)[7,9]
566	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.60 by root, Mon Mar 27 17:23:35 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.60 by root, Mon Mar 27 17:23:35 2006 UTC vs.
Revision 1.93 by root, Sat Mar 3 19:38:06 2007 UTC