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

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.64 by root, Sun Apr 2 20:17:23 2006 UTC vs.
Revision 1.85 by root, Wed Feb 7 00:44:18 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(
49	name swap_time reset_timeout fixed_resettime difficulty region	63	name attach swap_time reset_timeout fixed_resettime difficulty region
50	shopitems shopgreed shopmin shopmax shoprace	64	shopitems shopgreed shopmin shopmax shoprace
51	darkness width height enter_x enter_y msg maplore	65	darkness width height enter_x enter_y msg maplore
52	unique template	66	unique template
53	outdoor temp pressure humid windspeed winddir sky nosmooth	67	outdoor temp pressure humid windspeed winddir sky nosmooth
54	tile_path_1 tile_path_2 tile_path_3 tile_path_4	68	tile_path_1 tile_path_2 tile_path_3 tile_path_4
55	));	69	));
56		70
57	our @FIELD_ORDER = (qw(	71	our @FIELD_ORDER = (qw(
58	elevation	72	elevation
59		73
60	name name_pl custom_name title race	74	name name_pl custom_name attach title race
61	slaying skill msg lore other_arch face	75	slaying skill msg lore other_arch face
62	#todo-events	76	#todo-events
63	animation is_animated	77	animation is_animated
64	str dex con wis pow cha int	78	str dex con wis pow cha int
65	hp maxhp sp maxsp grace maxgrace	79	hp maxhp sp maxsp grace maxgrace
…		…
148	close $fh;	162	close $fh;
149	rename "$path~", $path	163	rename "$path~", $path
150	or die "$path: $!";	164	or die "$path: $!";
151	}	165	}
152		166
		167	my %attack_mask = (
		168	physical => 0x00000001,
		169	magic => 0x00000002,
		170	fire => 0x00000004,
		171	electricity => 0x00000008,
		172	cold => 0x00000010,
		173	confusion => 0x00000020,
		174	acid => 0x00000040,
		175	drain => 0x00000080,
		176	weaponmagic => 0x00000100,
		177	ghosthit => 0x00000200,
		178	poison => 0x00000400,
		179	slow => 0x00000800,
		180	paralyze => 0x00001000,
		181	turn_undead => 0x00002000,
		182	fear => 0x00004000,
		183	cancellation => 0x00008000,
		184	deplete => 0x00010000,
		185	death => 0x00020000,
		186	chaos => 0x00040000,
		187	counterspell => 0x00080000,
		188	godpower => 0x00100000,
		189	holyword => 0x00200000,
		190	blind => 0x00400000,
		191	internal => 0x00800000,
		192	life_stealing => 0x01000000,
		193	disease => 0x02000000,
		194	);
		195
		196	sub _add_resist($$$) {
		197	my ($ob, $mask, $value) = @_;
		198
		199	while (my ($k, $v) = each %attack_mask) {
		200	$ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
		201	}
		202	}
		203
		204	my %MATERIAL = reverse
		205	paper => 1,
		206	iron => 2,
		207	glass => 4,
		208	leather => 8,
		209	wood => 16,
		210	organic => 32,
		211	stone => 64,
		212	cloth => 128,
		213	adamant => 256,
		214	liquid => 512,
		215	tin => 1024,
		216	bone => 2048,
		217	ice => 4096,
		218
		219	# guesses
		220	runestone => 12,
		221	bronze => 18,
		222	"ancient wood" => 20,
		223	glass => 36,
		224	marble => 66,
		225	ice => 68,
		226	stone => 70,
		227	stone => 80,
		228	cloth => 136,
		229	ironwood => 144,
		230	adamantium => 258,
		231	glacium => 260,
		232	blood => 544,
		233	;
		234
153	# object as in "Object xxx", i.e. archetypes	235	# object as in "Object xxx", i.e. archetypes
154	sub normalize_object($) {	236	sub normalize_object($) {
155	my ($ob) = @_;	237	my ($ob) = @_;
156		238
		239	# convert material bitset to materialname, if possible
		240	if (exists $ob->{material}) {
		241	if (!$ob->{material}) {
		242	delete $ob->{material};
		243	} elsif (exists $ob->{materialname}) {
		244	if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
		245	delete $ob->{material};
		246	} else {
		247	warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
		248	delete $ob->{material}; # assume materilname is more specific and nuke material
		249	}
		250	} elsif (my $name = $MATERIAL{$ob->{material}}) {
		251	delete $ob->{material};
		252	$ob->{materialname} = $name;
		253	} else {
		254	warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
		255	}
		256	}
		257
157	# nuke outdated or never supported fields	258	# nuke outdated or never supported fields
158	delete $ob->{$_} for qw(	259	delete @$ob{qw(
159	can_knockback can_parry can_impale can_cut can_dam_armour	260	can_knockback can_parry can_impale can_cut can_dam_armour
160	can_apply pass_thru can_pass_thru	261	can_apply pass_thru can_pass_thru
161	);	262	)};
		263
		264	if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
		265	if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
		266	if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
162		267
163	# convert movement strings to bitsets	268	# convert movement strings to bitsets
164	for my $attr (keys %FIELD_MOVEMENT) {	269	for my $attr (keys %FIELD_MOVEMENT) {
165	next unless exists $ob->{$attr};	270	next unless exists $ob->{$attr};
166		271
…		…
199	if (defined (my $v = delete $ob->{slow_move})) {	304	if (defined (my $v = delete $ob->{slow_move})) {
200	$ob->{move_slow} \|= MOVE_WALK;	305	$ob->{move_slow} \|= MOVE_WALK;
201	$ob->{move_slow_penalty} = $v;	306	$ob->{move_slow_penalty} = $v;
202	}	307	}
203	if (defined (my $v = delete $ob->{walk_on})) {	308	if (defined (my $v = delete $ob->{walk_on})) {
		309	$ob->{move_on} = MOVE_ALL unless exists $ob->{move_on};
204	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK	310	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK
205	: $ob->{move_on} & ~MOVE_WALK;	311	: $ob->{move_on} & ~MOVE_WALK;
206	}	312	}
207	if (defined (my $v = delete $ob->{walk_off})) {	313	if (defined (my $v = delete $ob->{walk_off})) {
		314	$ob->{move_off} = MOVE_ALL unless exists $ob->{move_off};
208	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK	315	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK
209	: $ob->{move_off} & ~MOVE_WALK;	316	: $ob->{move_off} & ~MOVE_WALK;
210	}	317	}
211	if (defined (my $v = delete $ob->{fly_on})) {	318	if (defined (my $v = delete $ob->{fly_on})) {
		319	$ob->{move_on} = MOVE_ALL unless exists $ob->{move_on};
212	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW	320	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW
213	: $ob->{move_on} & ~MOVE_FLY_LOW;	321	: $ob->{move_on} & ~MOVE_FLY_LOW;
214	}	322	}
215	if (defined (my $v = delete $ob->{fly_off})) {	323	if (defined (my $v = delete $ob->{fly_off})) {
		324	$ob->{move_off} = MOVE_ALL unless exists $ob->{move_off};
216	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW	325	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW
217	: $ob->{move_off} & ~MOVE_FLY_LOW;	326	: $ob->{move_off} & ~MOVE_FLY_LOW;
218	}	327	}
219	if (defined (my $v = delete $ob->{flying})) {	328	if (defined (my $v = delete $ob->{flying})) {
		329	$ob->{move_type} = MOVE_ALL unless exists $ob->{move_type};
220	$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW	330	$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW
221	: $ob->{move_type} & ~MOVE_FLY_LOW;	331	: $ob->{move_type} & ~MOVE_FLY_LOW;
222	}	332	}
223		333
224	# convert idiotic event_xxx things into objects	334	# convert idiotic event_xxx things into objects
…		…
230	slaying => delete $ob->{"event_${event}"},	340	slaying => delete $ob->{"event_${event}"},
231	name => delete $ob->{"event_${event}_options"},	341	name => delete $ob->{"event_${event}_options"},
232	};	342	};
233	}	343	}
234	}	344	}
		345
		346	# some archetypes had "+3" instead of the canonical "3", so fix
		347	$ob->{dam} *= 1 if exists $ob->{dam};
235		348
236	$ob	349	$ob
237	}	350	}
238		351
239	# arch as in "arch xxx", ie.. objects	352	# arch as in "arch xxx", ie.. objects
…		…
281	}	394	}
282		395
283	$ob	396	$ob
284	}	397	}
285		398
		399	sub attr_thaw($) {
		400	my ($ob) = @_;
		401
		402	$ob->{attach} = from_json $ob->{attach}
		403	if exists $ob->{attach};
		404
		405	$ob
		406	}
		407
		408	sub attr_freeze($) {
		409	my ($ob) = @_;
		410
		411	$ob->{attach} = Crossfire::to_json $ob->{attach}
		412	if exists $ob->{attach};
		413
		414	$ob
		415	}
		416
286	sub read_pak($) {	417	sub read_pak($) {
287	my ($path) = @_;	418	my ($path) = @_;
288		419
289	my %pak;	420	my %pak;
290		421
…		…
303	sub read_arch($;$) {	434	sub read_arch($;$) {
304	my ($path, $toplevel) = @_;	435	my ($path, $toplevel) = @_;
305		436
306	my %arc;	437	my %arc;
307	my ($more, $prev);	438	my ($more, $prev);
		439	my $comment;
308		440
309	open my $fh, "<:raw:perlio:utf8", $path	441	open my $fh, "<:raw:perlio:utf8", $path
310	or Carp::croak "$path: $!";	442	or Carp::croak "$path: $!";
311		443
312	binmode $fh;	444	# binmode $fh;
313		445
314	my $parse_block; $parse_block = sub {	446	my $parse_block; $parse_block = sub {
315	my %arc = @_;	447	my %arc = @_;
316		448
317	while (<$fh>) {	449	while (<$fh>) {
318	s/\s+$//;	450	s/\s+$//;
319	if (/^end$/i) {	451	if (/^end$/i) {
320	last;	452	last;
		453
321	} elsif (/^arch (\S+)$/i) {	454	} elsif (/^arch (\S+)$/i) {
322	push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);	455	push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
		456
323	} elsif (/^lore$/i) {	457	} elsif (/^lore$/i) {
324	while (<$fh>) {	458	while (<$fh>) {
325	last if /^endlore\s*$/i;	459	last if /^endlore\s*$/i;
326	$arc{lore} .= $_;	460	$arc{lore} .= $_;
327	}	461	}
328	} elsif (/^msg$/i) {	462	} elsif (/^msg$/i) {
329	while (<$fh>) {	463	while (<$fh>) {
330	last if /^endmsg\s*$/i;	464	last if /^endmsg\s*$/i;
331	$arc{msg} .= $_;	465	$arc{msg} .= $_;
332	}	466	}
		467	} elsif (/^anim$/i) {
		468	while (<$fh>) {
		469	last if /^mina\s*$/i;
		470	chomp;
		471	push @{ $arc{anim} }, $_;
		472	}
333	} elsif (/^(\S+)\s(.)$/) {	473	} elsif (/^(\S+)\s(.)$/) {
334	$arc{lc $1} = $2;	474	$arc{lc $1} = $2;
335	} elsif (/^\s*($\|#)/) {	475	} elsif (/^\s*#/) {
		476	$arc{_comment} .= "$_\n";
		477
		478	} elsif (/^\s*$/) {
336	#	479	#
337	} else {	480	} else {
338	warn "$path: unparsable line '$_' in arch $arc{_name}";	481	warn "$path: unparsable line '$_' in arch $arc{_name}";
339	}	482	}
340	}	483	}
…		…
346	s/\s+$//;	489	s/\s+$//;
347	if (/^more$/i) {	490	if (/^more$/i) {
348	$more = $prev;	491	$more = $prev;
349	} elsif (/^object (\S+)$/i) {	492	} elsif (/^object (\S+)$/i) {
350	my $name = $1;	493	my $name = $1;
351	my $arc = normalize_object $parse_block->(_name => $name);	494	my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
		495	undef $comment;
		496	delete $arc{_comment} unless length $arc{_comment};
		497	$arc->{_atype} = 'object';
352		498
353	if ($more) {	499	if ($more) {
354	$more->{more} = $arc;	500	$more->{more} = $arc;
355	} else {	501	} else {
356	$arc{$name} = $arc;	502	$arc{$name} = $arc;
357	}	503	}
358	$prev = $arc;	504	$prev = $arc;
359	$more = undef;	505	$more = undef;
360	} elsif (/^arch (\S+)$/i) {	506	} elsif (/^arch (\S+)$/i) {
361	my $name = $1;	507	my $name = $1;
362	my $arc = normalize_arch $parse_block->(_name => $name);	508	my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
		509	undef $comment;
		510	delete $arc{_comment} unless length $arc{_comment};
		511	$arc->{_atype} = 'arch';
363		512
364	if ($more) {	513	if ($more) {
365	$more->{more} = $arc;	514	$more->{more} = $arc;
366	} else {	515	} else {
367	push @{ $arc{arch} }, $arc;	516	push @{ $arc{arch} }, $arc;
…		…
375	push @{$toplevel->{lev_array}}, $_+0;	524	push @{$toplevel->{lev_array}}, $_+0;
376	}	525	}
377	} else {	526	} else {
378	$toplevel->{$1} = $2;	527	$toplevel->{$1} = $2;
379	}	528	}
		529	} elsif (/^\s*#/) {
		530	$comment .= "$_\n";
380	} elsif (/^\s*($\|#)/) {	531	} elsif (/^\s*($\|#)/) {
381	#	532	#
382	} else {	533	} else {
383	die "$path: unparseable top-level line '$_'";	534	die "$path: unparseable top-level line '$_'";
384	}	535	}
385	}	536	}
386		537
387	undef $parse_block; # work around bug in perl not freeing $fh etc.	538	undef $parse_block; # work around bug in perl not freeing $fh etc.
388		539
389	\%arc	540	\%arc
		541	}
		542
		543	sub archlist_to_string {
		544	my ($arch) = @_;
		545
		546	my $str;
		547
		548	my $append; $append = sub {
		549	my %a = %{$_[0]};
		550
		551	Crossfire::attr_freeze \%a;
		552	Crossfire::normalize_arch \%a;
		553
		554	# undo the bit-split we did before
		555	if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
		556	$a{attack_movement} = (delete $a{attack_movement_bits_0_3})
		557	\| (delete $a{attack_movement_bits_4_7});
		558	}
		559
		560	if (my $comment = delete $a{_comment}) {
		561	if ($comment =~ /[^\n\s#]/) {
		562	$str .= $comment;
		563	}
		564	}
		565
		566	$str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
		567
		568	my $inv = delete $a{inventory};
		569	my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
		570	my $anim = delete $a{anim};
		571
		572	my @kv;
		573
		574	for ($a{_name} eq "map"
		575	? @Crossfire::FIELD_ORDER_MAP
		576	: @Crossfire::FIELD_ORDER) {
		577	push @kv, [$_, delete $a{$_}]
		578	if exists $a{$_};
		579	}
		580
		581	for (sort keys %a) {
		582	next if /^_/; # ignore our _-keys
		583	push @kv, [$_, delete $a{$_}];
		584	}
		585
		586	for (@kv) {
		587	my ($k, $v) = @$_;
		588
		589	if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
		590	$v =~ s/\n$//;
		591	$str .= "$k\n$v\n$end\n";
		592	} elsif (exists $Crossfire::FIELD_MOVEMENT{$k}) {
		593	if ($v & ~Crossfire::MOVE_ALL or !$v) {
		594	$str .= "$k $v\n";
		595
		596	} elsif ($v & Crossfire::MOVE_ALLBIT) {
		597	$str .= "$k all";
		598
		599	$str .= " -walk" unless $v & Crossfire::MOVE_WALK;
		600	$str .= " -fly_low" unless $v & Crossfire::MOVE_FLY_LOW;
		601	$str .= " -fly_high" unless $v & Crossfire::MOVE_FLY_HIGH;
		602	$str .= " -swim" unless $v & Crossfire::MOVE_SWIM;
		603	$str .= " -boat" unless $v & Crossfire::MOVE_BOAT;
		604
		605	$str .= "\n";
		606
		607	} else {
		608	$str .= $k;
		609
		610	$str .= " walk" if $v & Crossfire::MOVE_WALK;
		611	$str .= " fly_low" if $v & Crossfire::MOVE_FLY_LOW;
		612	$str .= " fly_high" if $v & Crossfire::MOVE_FLY_HIGH;
		613	$str .= " swim" if $v & Crossfire::MOVE_SWIM;
		614	$str .= " boat" if $v & Crossfire::MOVE_BOAT;
		615
		616	$str .= "\n";
		617	}
		618	} else {
		619	$str .= "$k $v\n";
		620	}
		621	}
		622
		623	if ($inv) {
		624	$append->($_) for @$inv;
		625	}
		626
		627	if ($a{_atype} eq 'object') {
		628	$str .= join "\n", "anim", @$anim, "mina\n"
		629	if $anim;
		630	}
		631
		632	$str .= "end\n";
		633
		634	if ($a{_atype} eq 'object') {
		635	if ($more) {
		636	$str .= "more\n";
		637	$append->($more) if $more;
		638	} else {
		639	$str .= "\n";
		640	}
		641	}
		642	};
		643
		644	for (@$arch) {
		645	$append->($_);
		646	}
		647
		648	$str
390	}	649	}
391		650
392	# put all archs into a hash with editor_face as it's key	651	# put all archs into a hash with editor_face as it's key
393	# NOTE: the arrays in the hash values are references to	652	# NOTE: the arrays in the hash values are references to
394	# the archs from $ARCH	653	# the archs from $ARCH
…		…
415	my ($a) = @_;	674	my ($a) = @_;
416		675
417	my $o = $ARCH{$a->{_name}}	676	my $o = $ARCH{$a->{_name}}
418	or return;	677	or return;
419		678
420	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"}	679	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"};
		680	unless ($face) {
		681	$face = $FACE{"blank.x11"}
421	or (warn "no face data found for arch '$a->{_name}'"), return;	682	or (warn "no face data found for arch '$a->{_name}'"), return;
		683	}
422		684
423	if ($face->{w} > 1 \|\| $face->{h} > 1) {	685	if ($face->{w} > 1 \|\| $face->{h} > 1) {
424	# bigface	686	# bigface
425	return (0, 0, $face->{w} - 1, $face->{h} - 1);	687	return (0, 0, $face->{w} - 1, $face->{h} - 1);
426		688

Diff Legend

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

Comparing deliantra/Deliantra/Deliantra.pm (file contents): Revision 1.64 by root, Sun Apr 2 20:17:23 2006 UTC vs. Revision 1.85 by root, Wed Feb 7 00:44:18 2007 UTC

Diff Legend

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.64 by root, Sun Apr 2 20:17:23 2006 UTC vs.
Revision 1.85 by root, Wed Feb 7 00:44:18 2007 UTC