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

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.61 by root, Mon Mar 27 17:38:18 2006 UTC vs.
Revision 1.91 by root, Sat Mar 3 19:06:03 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	'""' => \&as_string,
		163	'>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
		164	'+=' => sub { $_[0][0] \|= $MOVE_TYPE{$_[1]}; $_[0][1] \|= $MOVE_TYPE{$_[1]}; &normalise },
		165	'-=' => sub { $_[0][0] \|= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
		166	'/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
		167	'x=' => sub {
		168	my $cur = $_[0] >= $_[1];
		169	if (!defined $cur) {
		170	$_[0] += $_[1];
		171	} elsif ($cur) {
		172	$_[0] -= $_[1];
		173	} else {
		174	$_[0] /= $_[1];
		175	}
		176
		177	$_[0]
		178	},
		179	'eq' => sub { "$_[0]" eq "$_[1]" },
		180	'ne' => sub { "$_[0]" ne "$_[1]" },
		181	;
		182	}
		183
		184	sub Crossfire::MoveType::new {
		185	my ($class, $string) = @_;
		186
		187	my $mask;
		188	my $value;
		189
		190	for (split /\s+/, lc $string) {
		191	if (s/^-//) {
		192	$mask \|= $MOVE_TYPE{$_};
		193	$value &= ~$MOVE_TYPE{$_};
		194	} else {
		195	$mask \|= $MOVE_TYPE{$_};
		196	$value \|= $MOVE_TYPE{$_};
		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	}
116		234
117	sub load_ref($) {	235	sub load_ref($) {
118	my ($path) = @_;	236	my ($path) = @_;
119		237
120	open my $fh, "<", $path	238	open my $fh, "<:raw:perlio", $path
121	or die "$path: $!";	239	or die "$path: $!";
122	binmode $fh;
123	local $/;	240	local $/;
124		241
125	thaw <$fh>	242	thaw <$fh>
126	}	243	}
127		244
128	sub save_ref($$) {	245	sub save_ref($$) {
129	my ($ref, $path) = @_;	246	my ($ref, $path) = @_;
130		247
131	open my $fh, ">", "$path~"	248	open my $fh, ">:raw:perlio", "$path~"
132	or die "$path~: $!";	249	or die "$path~: $!";
133	binmode $fh;
134	print $fh freeze $ref;	250	print $fh freeze $ref;
135	close $fh;	251	close $fh;
136	rename "$path~", $path	252	rename "$path~", $path
137	or die "$path: $!";	253	or die "$path: $!";
138	}	254	}
139		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
		324	# object as in "Object xxx", i.e. archetypes
140	sub normalize_object($) {	325	sub normalize_object($) {
141	my ($ob) = @_;	326	my ($ob) = @_;
142		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	# nuke outdated or never supported fields
143	delete $ob->{$_} for qw(	348	delete @$ob{qw(
144	can_knockback can_parry can_impale can_cut can_dam_armour	349	can_knockback can_parry can_impale can_cut can_dam_armour
145	can_apply pass_thru can_pass_thru	350	can_apply pass_thru can_pass_thru
146	);	351	)};
147		352
		353	if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
		354	if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
		355	if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
		356
		357	# convert movement strings to bitsets
148	for my $attr (keys %FIELD_MOVEMENT) {	358	for my $attr (keys %FIELD_MOVEMENT) {
149	next unless exists $ob->{$attr};	359	next unless exists $ob->{$attr};
150		360
151	$ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility	361	$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	}	362	}
178		363
		364	# convert outdated movement flags to new movement sets
179	if (defined (my $v = delete $ob->{no_pass})) {	365	if (defined (my $v = delete $ob->{no_pass})) {
180	$ob->{move_block} = $v ? MOVE_ALL : 0;	366	$ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
181	}	367	}
182	if (defined (my $v = delete $ob->{slow_move})) {	368	if (defined (my $v = delete $ob->{slow_move})) {
183	$ob->{move_slow} \|= MOVE_WALK;	369	$ob->{move_slow} += "walk";
184	$ob->{move_slow_penalty} = $v;	370	$ob->{move_slow_penalty} = $v;
185	}	371	}
186	if (defined (my $v = delete $ob->{walk_on})) {	372	if (defined (my $v = delete $ob->{walk_on})) {
187	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK	373	$ob->{move_on} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
188	: $ob->{move_on} & ~MOVE_WALK;
189	}	374	}
190	if (defined (my $v = delete $ob->{walk_off})) {	375	if (defined (my $v = delete $ob->{walk_off})) {
191	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK	376	$ob->{move_off} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
192	: $ob->{move_off} & ~MOVE_WALK;
193	}	377	}
194	if (defined (my $v = delete $ob->{fly_on})) {	378	if (defined (my $v = delete $ob->{fly_on})) {
195	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW	379	$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	}	380	}
198	if (defined (my $v = delete $ob->{fly_off})) {	381	if (defined (my $v = delete $ob->{fly_off})) {
199	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW	382	$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	}	383	}
202	if (defined (my $v = delete $ob->{flying})) {	384	if (defined (my $v = delete $ob->{flying})) {
203	$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW	385	$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	}	386	}
		387
		388	# convert idiotic event_xxx things into objects
		389	while (my ($event, $subtype) = each %EVENT_TYPE) {
		390	if (exists $ob->{"event_${event}_plugin"}) {
		391	push @{$ob->{inventory}}, {
		392	_name => "event_$event",
		393	title => delete $ob->{"event_${event}_plugin"},
		394	slaying => delete $ob->{"event_${event}"},
		395	name => delete $ob->{"event_${event}_options"},
		396	};
		397	}
		398	}
		399
		400	# some archetypes had "+3" instead of the canonical "3", so fix
		401	$ob->{dam} *= 1 if exists $ob->{dam};
206		402
207	$ob	403	$ob
208	}	404	}
209		405
		406	# arch as in "arch xxx", ie.. objects
210	sub normalize_arch($) {	407	sub normalize_arch($) {
211	my ($ob) = @_;	408	my ($ob) = @_;
212		409
213	normalize_object $ob;	410	normalize_object $ob;
214		411
…		…
251	}	448	}
252		449
253	$ob	450	$ob
254	}	451	}
255		452
		453	sub attr_thaw($) {
		454	my ($ob) = @_;
		455
		456	$ob->{attach} = from_json $ob->{attach}
		457	if exists $ob->{attach};
		458
		459	$ob
		460	}
		461
		462	sub attr_freeze($) {
		463	my ($ob) = @_;
		464
		465	$ob->{attach} = Crossfire::to_json $ob->{attach}
		466	if exists $ob->{attach};
		467
		468	$ob
		469	}
		470
256	sub read_pak($) {	471	sub read_pak($) {
257	my ($path) = @_;	472	my ($path) = @_;
258		473
259	my %pak;	474	my %pak;
260		475
261	open my $fh, "<", $path	476	open my $fh, "<:raw:perlio", $path
262	or Carp::croak "$_[0]: $!";	477	or Carp::croak "$_[0]: $!";
263	binmode $fh;	478	binmode $fh;
264	while (<$fh>) {	479	while (<$fh>) {
265	my ($type, $id, $len, $path) = split;	480	my ($type, $id, $len, $path) = split;
266	$path =~ s/.*\///;	481	$path =~ s/.*\///;
…		…
268	}	483	}
269		484
270	\%pak	485	\%pak
271	}	486	}
272		487
273	sub read_arch($) {	488	sub read_arch($;$) {
274	my ($path) = @_;	489	my ($path, $toplevel) = @_;
275		490
276	my %arc;	491	my %arc;
277	my ($more, $prev);	492	my ($more, $prev);
		493	my $comment;
278		494
279	open my $fh, "<", $path	495	open my $fh, "<:raw:perlio:utf8", $path
280	or Carp::croak "$path: $!";	496	or Carp::croak "$path: $!";
281		497
282	binmode $fh;	498	# binmode $fh;
283		499
284	my $parse_block; $parse_block = sub {	500	my $parse_block; $parse_block = sub {
285	my %arc = @_;	501	my %arc = @_;
286		502
287	while (<$fh>) {	503	while (<$fh>) {
288	s/\s+$//;	504	s/\s+$//;
289	if (/^end$/i) {	505	if (/^end$/i) {
290	last;	506	last;
		507
291	} elsif (/^arch (\S+)$/i) {	508	} elsif (/^arch (\S+)$/i) {
292	push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);	509	push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
		510
293	} elsif (/^lore$/i) {	511	} elsif (/^lore$/i) {
294	while (<$fh>) {	512	while (<$fh>) {
295	last if /^endlore\s*$/i;	513	last if /^endlore\s*$/i;
296	$arc{lore} .= $_;	514	$arc{lore} .= $_;
297	}	515	}
298	} elsif (/^msg$/i) {	516	} elsif (/^msg$/i) {
299	while (<$fh>) {	517	while (<$fh>) {
300	last if /^endmsg\s*$/i;	518	last if /^endmsg\s*$/i;
301	$arc{msg} .= $_;	519	$arc{msg} .= $_;
302	}	520	}
		521	} elsif (/^anim$/i) {
		522	while (<$fh>) {
		523	last if /^mina\s*$/i;
		524	chomp;
		525	push @{ $arc{anim} }, $_;
		526	}
303	} elsif (/^(\S+)\s(.)$/) {	527	} elsif (/^(\S+)\s(.)$/) {
304	$arc{lc $1} = $2;	528	$arc{lc $1} = $2;
305	} elsif (/^\s*($\|#)/) {	529	} elsif (/^\s*#/) {
		530	$arc{_comment} .= "$_\n";
		531
		532	} elsif (/^\s*$/) {
306	#	533	#
307	} else {	534	} else {
308	warn "$path: unparsable line '$_' in arch $arc{_name}";	535	warn "$path: unparsable line '$_' in arch $arc{_name}";
309	}	536	}
310	}	537	}
…		…
316	s/\s+$//;	543	s/\s+$//;
317	if (/^more$/i) {	544	if (/^more$/i) {
318	$more = $prev;	545	$more = $prev;
319	} elsif (/^object (\S+)$/i) {	546	} elsif (/^object (\S+)$/i) {
320	my $name = $1;	547	my $name = $1;
321	my $arc = normalize_object $parse_block->(_name => $name);	548	my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
		549	undef $comment;
		550	delete $arc{_comment} unless length $arc{_comment};
		551	$arc->{_atype} = 'object';
322		552
323	if ($more) {	553	if ($more) {
324	$more->{more} = $arc;	554	$more->{more} = $arc;
325	} else {	555	} else {
326	$arc{$name} = $arc;	556	$arc{$name} = $arc;
327	}	557	}
328	$prev = $arc;	558	$prev = $arc;
329	$more = undef;	559	$more = undef;
330	} elsif (/^arch (\S+)$/i) {	560	} elsif (/^arch (\S+)$/i) {
331	my $name = $1;	561	my $name = $1;
332	my $arc = normalize_arch $parse_block->(_name => $name);	562	my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
		563	undef $comment;
		564	delete $arc{_comment} unless length $arc{_comment};
		565	$arc->{_atype} = 'arch';
333		566
334	if ($more) {	567	if ($more) {
335	$more->{more} = $arc;	568	$more->{more} = $arc;
336	} else {	569	} else {
337	push @{ $arc{arch} }, $arc;	570	push @{ $arc{arch} }, $arc;
338	}	571	}
339	$prev = $arc;	572	$prev = $arc;
340	$more = undef;	573	$more = undef;
		574	} elsif ($toplevel && /^(\S+)\s+(.*)$/) {
		575	if ($1 eq "lev_array") {
		576	while (<$fh>) {
		577	last if /^endplst\s*$/;
		578	push @{$toplevel->{lev_array}}, $_+0;
		579	}
		580	} else {
		581	$toplevel->{$1} = $2;
		582	}
		583	} elsif (/^\s*#/) {
		584	$comment .= "$_\n";
341	} elsif (/^\s*($\|#)/) {	585	} elsif (/^\s*($\|#)/) {
342	#	586	#
343	} else {	587	} else {
344	warn "$path: unparseable top-level line '$_'";	588	die "$path: unparseable top-level line '$_'";
345	}	589	}
346	}	590	}
347		591
348	undef $parse_block; # work around bug in perl not freeing $fh etc.	592	undef $parse_block; # work around bug in perl not freeing $fh etc.
349		593
350	\%arc	594	\%arc
		595	}
		596
		597	sub archlist_to_string {
		598	my ($arch) = @_;
		599
		600	my $str;
		601
		602	my $append; $append = sub {
		603	my %a = %{$_[0]};
		604
		605	Crossfire::attr_freeze \%a;
		606	Crossfire::normalize_arch \%a;
		607
		608	# undo the bit-split we did before
		609	if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
		610	$a{attack_movement} = (delete $a{attack_movement_bits_0_3})
		611	\| (delete $a{attack_movement_bits_4_7});
		612	}
		613
		614	if (my $comment = delete $a{_comment}) {
		615	if ($comment =~ /[^\n\s#]/) {
		616	$str .= $comment;
		617	}
		618	}
		619
		620	$str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
		621
		622	my $inv = delete $a{inventory};
		623	my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
		624	my $anim = delete $a{anim};
		625
		626	if ($a{_atype} eq 'object') {
		627	$str .= join "\n", "anim", @$anim, "mina\n"
		628	if $anim;
		629	}
		630
		631	my @kv;
		632
		633	for ($a{_name} eq "map"
		634	? @Crossfire::FIELD_ORDER_MAP
		635	: @Crossfire::FIELD_ORDER) {
		636	push @kv, [$_, delete $a{$_}]
		637	if exists $a{$_};
		638	}
		639
		640	for (sort keys %a) {
		641	next if /^_/; # ignore our _-keys
		642	push @kv, [$_, delete $a{$_}];
		643	}
		644
		645	for (@kv) {
		646	my ($k, $v) = @$_;
		647
		648	if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
		649	$v =~ s/\n$//;
		650	$str .= "$k\n$v\n$end\n";
		651	} else {
		652	$str .= "$k $v\n";
		653	}
		654	}
		655
		656	if ($inv) {
		657	$append->($_) for @$inv;
		658	}
		659
		660	$str .= "end\n";
		661
		662	if ($a{_atype} eq 'object') {
		663	if ($more) {
		664	$str .= "more\n";
		665	$append->($more) if $more;
		666	} else {
		667	$str .= "\n";
		668	}
		669	}
		670	};
		671
		672	for (@$arch) {
		673	$append->($_);
		674	}
		675
		676	$str
351	}	677	}
352		678
353	# put all archs into a hash with editor_face as it's key	679	# put all archs into a hash with editor_face as it's key
354	# NOTE: the arrays in the hash values are references to	680	# NOTE: the arrays in the hash values are references to
355	# the archs from $ARCH	681	# the archs from $ARCH
356	sub editor_archs {	682	sub editor_archs {
357	my %paths;	683	my %paths;
358		684
359	for (keys %ARCH) {	685	for (keys %ARCH) {
360	my $arch = $ARCH{$_};	686	my $arch = $ARCH{$_};
361	push @{$paths{$arch->{editor_folder}}}, \$arch;	687	push @{$paths{$arch->{editor_folder}}}, $arch;
362	}	688	}
363		689
364	\%paths	690	\%paths
365	}	691	}
366		692
…		…
376	my ($a) = @_;	702	my ($a) = @_;
377		703
378	my $o = $ARCH{$a->{_name}}	704	my $o = $ARCH{$a->{_name}}
379	or return;	705	or return;
380		706
381	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"}	707	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"};
		708	unless ($face) {
		709	$face = $FACE{"blank.x11"}
382	or (warn "no face data found for arch '$a->{_name}'"), return;	710	or (warn "no face data found for arch '$a->{_name}'"), return;
		711	}
383		712
384	if ($face->{w} > 1 \|\| $face->{h} > 1) {	713	if ($face->{w} > 1 \|\| $face->{h} > 1) {
385	# bigface	714	# bigface
386	return (0, 0, $face->{w} - 1, $face->{h} - 1);	715	return (0, 0, $face->{w} - 1, $face->{h} - 1);
387		716
…		…
494	];	823	];
495		824
496	$attr	825	$attr
497	}	826	}
498		827
499	sub arch_edit_sections {
500	# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
501	# edit_type = 0;
502	# else if (edit_type != 0) {
503	# // all flags from 'check_type' must be unset in this arch because they get recalculated now
504	# edit_type &= ~check_type;
505	# }
506	#
507	# }
508	# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
509	# getAttributeValue("alive", defarch) == 1 &&
510	# (getAttributeValue("monster", defarch) == 1 \|\|
511	# getAttributeValue("generator", defarch) == 1)) {
512	# // Monster: monsters/npcs/generators
513	# edit_type \|= IGUIConstants.TILE_EDIT_MONSTER;
514	# }
515	# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
516	# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
517	# // Walls
518	# edit_type \|= IGUIConstants.TILE_EDIT_WALL;
519	# }
520	# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
521	# getAttributeValue("connected", defarch) != 0) {
522	# // Connected Objects
523	# edit_type \|= IGUIConstants.TILE_EDIT_CONNECTED;
524	# }
525	# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
526	# arch_type == 66 \|\| arch_type == 41 \|\| arch_type == 95) {
527	# // Exit: teleporter/exit/trapdoors
528	# edit_type \|= IGUIConstants.TILE_EDIT_EXIT;
529	# }
530	# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
531	# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 \|\|
532	# arch_type == 5 \|\| arch_type == 36 \|\| arch_type == 60 \|\|
533	# arch_type == 85 \|\| arch_type == 111 \|\| arch_type == 123 \|\|
534	# arch_type == 124 \|\| arch_type == 130)) {
535	# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
536	# edit_type \|= IGUIConstants.TILE_EDIT_TREASURE;
537	# }
538	# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
539	# arch_type == 20 \|\| arch_type == 23 \|\| arch_type == 26 \|\|
540	# arch_type == 91 \|\| arch_type == 21 \|\| arch_type == 24) {
541	# // Door: door/special door/gates + keys
542	# edit_type \|= IGUIConstants.TILE_EDIT_DOOR;
543	# }
544	# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
545	# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
546	# arch_type <= 16) \|\| arch_type == 33 \|\| arch_type == 34 \|\|
547	# arch_type == 35 \|\| arch_type == 39 \|\| arch_type == 70 \|\|
548	# arch_type == 87 \|\| arch_type == 99 \|\| arch_type == 100 \|\|
549	# arch_type == 104 \|\| arch_type == 109 \|\| arch_type == 113 \|\|
550	# arch_type == 122 \|\| arch_type == 3)) {
551	# // Equipment: weapons/armour/wands/rods
552	# edit_type \|= IGUIConstants.TILE_EDIT_EQUIP;
553	# }
554	#
555	# return(edit_type);
556	#
557	#
558	}
559
560	sub cache_file($$&&) {	828	sub cache_file($$&&) {
561	my ($src, $cache, $load, $create) = @_;	829	my ($src, $cache, $load, $create) = @_;
562		830
563	my ($size, $mtime) = (stat $src)[7,9]	831	my ($size, $mtime) = (stat $src)[7,9]
564	or Carp::croak "$src: $!";	832	or Carp::croak "$src: $!";

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing deliantra/Deliantra/Deliantra.pm (file contents): Revision 1.61 by root, Mon Mar 27 17:38:18 2006 UTC vs. Revision 1.91 by root, Sat Mar 3 19:06:03 2007 UTC

Diff Legend

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.61 by root, Mon Mar 27 17:38:18 2006 UTC vs.
Revision 1.91 by root, Sat Mar 3 19:06:03 2007 UTC