[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.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
…		…
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	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	}
116		244
117	sub load_ref($) {	245	sub load_ref($) {
118	my ($path) = @_;	246	my ($path) = @_;
119		247
120	open my $fh, "<", $path	248	open my $fh, "<:raw:perlio", $path
121	or die "$path: $!";	249	or die "$path: $!";
122	binmode $fh;
123	local $/;	250	local $/;
124		251
125	thaw <$fh>	252	thaw <$fh>
126	}	253	}
127		254
128	sub save_ref($$) {	255	sub save_ref($$) {
129	my ($ref, $path) = @_;	256	my ($ref, $path) = @_;
130		257
131	open my $fh, ">", "$path~"	258	open my $fh, ">:raw:perlio", "$path~"
132	or die "$path~: $!";	259	or die "$path~: $!";
133	binmode $fh;
134	print $fh freeze $ref;	260	print $fh freeze $ref;
135	close $fh;	261	close $fh;
136	rename "$path~", $path	262	rename "$path~", $path
137	or die "$path: $!";	263	or die "$path: $!";
138	}	264	}
139		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
		334	# object as in "Object xxx", i.e. archetypes
140	sub normalize_object($) {	335	sub normalize_object($) {
141	my ($ob) = @_;	336	my ($ob) = @_;
142		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
		357	# nuke outdated or never supported fields
143	delete $ob->{$_} for qw(	358	delete @$ob{qw(
144	can_knockback can_parry can_impale can_cut can_dam_armour	359	can_knockback can_parry can_impale can_cut can_dam_armour
145	can_apply pass_thru can_pass_thru	360	can_apply pass_thru can_pass_thru
146	);	361	)};
147		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; }
		366
		367	# convert movement strings to bitsets
148	for my $attr (keys %FIELD_MOVEMENT) {	368	for my $attr (keys %FIELD_MOVEMENT) {
149	next unless exists $ob->{$attr};	369	next unless exists $ob->{$attr};
150		370
151	$ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility	371	$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	}	372	}
178		373
		374	# convert outdated movement flags to new movement sets
179	if (defined (my $v = delete $ob->{no_pass})) {	375	if (defined (my $v = delete $ob->{no_pass})) {
180	$ob->{move_block} = $v ? MOVE_ALL : 0;	376	$ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
181	}	377	}
182	if (defined (my $v = delete $ob->{slow_move})) {	378	if (defined (my $v = delete $ob->{slow_move})) {
183	$ob->{move_slow} \|= MOVE_WALK;	379	$ob->{move_slow} += "walk";
184	$ob->{move_slow_penalty} = $v;	380	$ob->{move_slow_penalty} = $v;
185	}	381	}
186	if (defined (my $v = delete $ob->{walk_on})) {	382	if (defined (my $v = delete $ob->{walk_on})) {
187	$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" }
188	: $ob->{move_on} & ~MOVE_WALK;
189	}	384	}
190	if (defined (my $v = delete $ob->{walk_off})) {	385	if (defined (my $v = delete $ob->{walk_off})) {
191	$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" }
192	: $ob->{move_off} & ~MOVE_WALK;
193	}	387	}
194	if (defined (my $v = delete $ob->{fly_on})) {	388	if (defined (my $v = delete $ob->{fly_on})) {
195	$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" }
196	: $ob->{move_on} & ~MOVE_FLY_LOW;
197	}	390	}
198	if (defined (my $v = delete $ob->{fly_off})) {	391	if (defined (my $v = delete $ob->{fly_off})) {
199	$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" }
200	: $ob->{move_off} & ~MOVE_FLY_LOW;
201	}	393	}
202	if (defined (my $v = delete $ob->{flying})) {	394	if (defined (my $v = delete $ob->{flying})) {
203	$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" }
204	: $ob->{move_type} & ~MOVE_FLY_LOW;
205	}	396	}
		397
		398	# convert idiotic event_xxx things into objects
		399	while (my ($event, $subtype) = each %EVENT_TYPE) {
		400	if (exists $ob->{"event_${event}_plugin"}) {
		401	push @{$ob->{inventory}}, {
		402	_name => "event_$event",
		403	title => delete $ob->{"event_${event}_plugin"},
		404	slaying => delete $ob->{"event_${event}"},
		405	name => delete $ob->{"event_${event}_options"},
		406	};
		407	}
		408	}
		409
		410	# some archetypes had "+3" instead of the canonical "3", so fix
		411	$ob->{dam} *= 1 if exists $ob->{dam};
206		412
207	$ob	413	$ob
208	}	414	}
209		415
		416	# arch as in "arch xxx", ie.. objects
210	sub normalize_arch($) {	417	sub normalize_arch($) {
211	my ($ob) = @_;	418	my ($ob) = @_;
212		419
213	normalize_object $ob;	420	normalize_object $ob;
214		421
…		…
251	}	458	}
252		459
253	$ob	460	$ob
254	}	461	}
255		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
256	sub read_pak($) {	481	sub read_pak($) {
257	my ($path) = @_;	482	my ($path) = @_;
258		483
259	my %pak;	484	my %pak;
260		485
261	open my $fh, "<", $path	486	open my $fh, "<:raw:perlio", $path
262	or Carp::croak "$_[0]: $!";	487	or Carp::croak "$_[0]: $!";
263	binmode $fh;	488	binmode $fh;
264	while (<$fh>) {	489	while (<$fh>) {
265	my ($type, $id, $len, $path) = split;	490	my ($type, $id, $len, $path) = split;
266	$path =~ s/.*\///;	491	$path =~ s/.*\///;
…		…
268	}	493	}
269		494
270	\%pak	495	\%pak
271	}	496	}
272		497
273	sub read_arch($) {	498	sub read_arch($;$) {
274	my ($path) = @_;	499	my ($path, $toplevel) = @_;
275		500
276	my %arc;	501	my %arc;
277	my ($more, $prev);	502	my ($more, $prev);
		503	my $comment;
278		504
279	open my $fh, "<", $path	505	open my $fh, "<:raw:perlio:utf8", $path
280	or Carp::croak "$path: $!";	506	or Carp::croak "$path: $!";
281		507
282	binmode $fh;	508	# binmode $fh;
283		509
284	my $parse_block; $parse_block = sub {	510	my $parse_block; $parse_block = sub {
285	my %arc = @_;	511	my %arc = @_;
286		512
287	while (<$fh>) {	513	while (<$fh>) {
288	s/\s+$//;	514	s/\s+$//;
289	if (/^end$/i) {	515	if (/^end$/i) {
290	last;	516	last;
		517
291	} elsif (/^arch (\S+)$/i) {	518	} elsif (/^arch (\S+)$/i) {
292	push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);	519	push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
		520
293	} elsif (/^lore$/i) {	521	} elsif (/^lore$/i) {
294	while (<$fh>) {	522	while (<$fh>) {
295	last if /^endlore\s*$/i;	523	last if /^endlore\s*$/i;
296	$arc{lore} .= $_;	524	$arc{lore} .= $_;
297	}	525	}
298	} elsif (/^msg$/i) {	526	} elsif (/^msg$/i) {
299	while (<$fh>) {	527	while (<$fh>) {
300	last if /^endmsg\s*$/i;	528	last if /^endmsg\s*$/i;
301	$arc{msg} .= $_;	529	$arc{msg} .= $_;
302	}	530	}
		531	} elsif (/^anim$/i) {
		532	while (<$fh>) {
		533	last if /^mina\s*$/i;
		534	chomp;
		535	push @{ $arc{anim} }, $_;
		536	}
303	} elsif (/^(\S+)\s(.)$/) {	537	} elsif (/^(\S+)\s(.)$/) {
304	$arc{lc $1} = $2;	538	$arc{lc $1} = $2;
305	} elsif (/^\s*($\|#)/) {	539	} elsif (/^\s*#/) {
		540	$arc{_comment} .= "$_\n";
		541
		542	} elsif (/^\s*$/) {
306	#	543	#
307	} else {	544	} else {
308	warn "$path: unparsable line '$_' in arch $arc{_name}";	545	warn "$path: unparsable line '$_' in arch $arc{_name}";
309	}	546	}
310	}	547	}
…		…
316	s/\s+$//;	553	s/\s+$//;
317	if (/^more$/i) {	554	if (/^more$/i) {
318	$more = $prev;	555	$more = $prev;
319	} elsif (/^object (\S+)$/i) {	556	} elsif (/^object (\S+)$/i) {
320	my $name = $1;	557	my $name = $1;
321	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';
322		562
323	if ($more) {	563	if ($more) {
324	$more->{more} = $arc;	564	$more->{more} = $arc;
325	} else {	565	} else {
326	$arc{$name} = $arc;	566	$arc{$name} = $arc;
327	}	567	}
328	$prev = $arc;	568	$prev = $arc;
329	$more = undef;	569	$more = undef;
330	} elsif (/^arch (\S+)$/i) {	570	} elsif (/^arch (\S+)$/i) {
331	my $name = $1;	571	my $name = $1;
332	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';
333		576
334	if ($more) {	577	if ($more) {
335	$more->{more} = $arc;	578	$more->{more} = $arc;
336	} else {	579	} else {
337	push @{ $arc{arch} }, $arc;	580	push @{ $arc{arch} }, $arc;
338	}	581	}
339	$prev = $arc;	582	$prev = $arc;
340	$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";
341	} elsif (/^\s*($\|#)/) {	595	} elsif (/^\s*($\|#)/) {
342	#	596	#
343	} else {	597	} else {
344	warn "$path: unparseable top-level line '$_'";	598	die "$path: unparseable top-level line '$_'";
345	}	599	}
346	}	600	}
347		601
348	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.
349		603
350	\%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
351	}	687	}
352		688
353	# 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
354	# NOTE: the arrays in the hash values are references to	690	# NOTE: the arrays in the hash values are references to
355	# the archs from $ARCH	691	# the archs from $ARCH
356	sub editor_archs {	692	sub editor_archs {
357	my %paths;	693	my %paths;
358		694
359	for (keys %ARCH) {	695	for (keys %ARCH) {
360	my $arch = $ARCH{$_};	696	my $arch = $ARCH{$_};
361	push @{$paths{$arch->{editor_folder}}}, \$arch;	697	push @{$paths{$arch->{editor_folder}}}, $arch;
362	}	698	}
363		699
364	\%paths	700	\%paths
365	}	701	}
366		702
…		…
376	my ($a) = @_;	712	my ($a) = @_;
377		713
378	my $o = $ARCH{$a->{_name}}	714	my $o = $ARCH{$a->{_name}}
379	or return;	715	or return;
380		716
381	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"}
382	or (warn "no face data found for arch '$a->{_name}'"), return;	720	or (warn "no face data found for arch '$a->{_name}'"), return;
		721	}
383		722
384	if ($face->{w} > 1 \|\| $face->{h} > 1) {	723	if ($face->{w} > 1 \|\| $face->{h} > 1) {
385	# bigface	724	# bigface
386	return (0, 0, $face->{w} - 1, $face->{h} - 1);	725	return (0, 0, $face->{w} - 1, $face->{h} - 1);
387		726
…		…
431	my $type = $obj->{type} \|\| $arch->{type};	770	my $type = $obj->{type} \|\| $arch->{type};
432		771
433	if ($type > 0) {	772	if ($type > 0) {
434	$root = $Crossfire::Data::ATTR{$type};	773	$root = $Crossfire::Data::ATTR{$type};
435	} else {	774	} else {
		775	my %a = (%$arch, %$obj);
		776
		777	if ($a{is_floor} && !$a{alive}) {
		778	$root = $Crossfire::Data::TYPE{Floor};
		779	} elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
		780	$root = $Crossfire::Data::TYPE{"Monster & NPC"};
		781	} elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
		782	$root = $Crossfire::Data::TYPE{Wall};
		783	} elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
		784	$root = $Crossfire::Data::TYPE{"Weak Wall"};
		785	} else {
436	$root = $Crossfire::Data::TYPE{Misc};	786	$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	}	787	}
451	}	788	}
452		789
453	my @import = ($root);	790	my @import = ($root);
454		791
…		…
496	];	833	];
497		834
498	$attr	835	$attr
499	}	836	}
500		837
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($$&&) {	838	sub cache_file($$&&) {
563	my ($src, $cache, $load, $create) = @_;	839	my ($src, $cache, $load, $create) = @_;
564		840
565	my ($size, $mtime) = (stat $src)[7,9]	841	my ($size, $mtime) = (stat $src)[7,9]
566	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.60 by root, Mon Mar 27 17:23:35 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.60 by root, Mon Mar 27 17:23:35 2006 UTC vs.
Revision 1.95 by root, Mon Mar 5 01:10:30 2007 UTC