[ViewVC] Diff of: cvs/deliantra/server/utils/cfutil.in

Comparing deliantra/server/utils/cfutil.in (file contents):
Revision 1.2 by root, Wed Mar 7 01:23:37 2007 UTC vs.
Revision 1.30 by root, Sat Apr 21 11:55:36 2007 UTC

…		…
7	my $datarootdir = "@datarootdir@";	7	my $datarootdir = "@datarootdir@";
8	my $DATADIR = "@datadir@/@PACKAGE@";	8	my $DATADIR = "@datadir@/@PACKAGE@";
9		9
10	my $CONVERT = "@CONVERT@";	10	my $CONVERT = "@CONVERT@";
11	my $IDENTIFY = "@IDENTIFY@";	11	my $IDENTIFY = "@IDENTIFY@";
		12	my $OPTIPNG = "@OPTIPNG@";
12	my $RSYNC = "@RSYNC@";	13	my $RSYNC = "@RSYNC@";
13		14
14	use Getopt::Long;	15	use Getopt::Long;
		16	use Coro::Event;
		17	use AnyEvent;
15	use IO::AIO;	18	use IO::AIO ();
16	use File::Temp;	19	use File::Temp;
17	use Crossfire;	20	use Crossfire;
		21	use Coro;
		22	use Coro::AIO;
		23	use POSIX ();
		24	use Digest::MD5;
		25	use Coro::Storable; $Storable::canonical = 1;
18		26
19	sub usage {	27	sub usage {
20	warn <<EOF;	28	warn <<EOF;
21	Usage: cfutil [-v] [-q] [--force]	29	Usage: cfutil [-v] [-q] [--force] [--cache]
22	[--install-arch path]	30	[--install-arch path]
23	[--install-maps maps]	31	[--install-maps maps]
24	[--print-statedir]	32	[--print-statedir]
25	[--print-confdir]	33	[--print-confdir]
26	[--print-datadir]	34	[--print-datadir]
…		…
29	EOF	37	EOF
30	exit 1;	38	exit 1;
31	}	39	}
32		40
33	my $VERBOSE = 1;	41	my $VERBOSE = 1;
		42	my $CACHE = 0;
34	my $FORCE;	43	my $FORCE;
35	my $TMPDIR = "/tmp/cfutil$$~";	44	my $TMPDIR = "/tmp/cfutil$$~";
		45	my $TMPFILE = "aaaa0";
36		46
37	END { system "rm", "-rf", $TMPDIR }	47	END { system "rm", "-rf", $TMPDIR }
		48
		49	Event->signal (signal => "INT", cb => sub { exit 1 });
		50	Event->signal (signal => "TERM", cb => sub { exit 1 });
38		51
39	mkdir $TMPDIR, 0700	52	mkdir $TMPDIR, 0700
40	or die "$TMPDIR: $!";	53	or die "$TMPDIR: $!";
41		54
		55	sub fork_sub(&) {
		56	my ($cb) = @_;
		57
		58	if (my $pid = fork) {
		59	my $current = $Coro::current;
		60	my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });
		61	Coro::schedule;
		62	} else {
		63	eval { $cb->() };
		64	POSIX::_exit 0 unless $@;
		65	warn $@;
		66	POSIX::_exit 1;
		67	}
		68	}
		69
42	sub inst_maps($) {	70	sub inst_maps($) {
43	my (undef, $path) = @_;	71	my (undef, $path) = @_;
44		72
45	print "installing '$path' to '$DATADIR/maps'\n\n";	73	print "\nInstalling '$path' to '$DATADIR/maps'\n\n";
46		74
47	if (!-f "$path/regions") {	75	if (!-f "$path/regions") {
48	warn "'$path' does not look like a maps directory ('regions' file is missing).\n";	76	warn "'$path' does not look like a maps directory ('regions' file is missing).\n";
49	exit 1 unless $FORCE;	77	exit 1 unless $FORCE;
50	}	78	}
51		79
52	system $RSYNC, "-av", "$path/.", "$DATADIR/maps/.", "--delete", "--exclude", "CVS", "--delete-excluded";	80	system $RSYNC, "-av", "$path/.", "$DATADIR/maps/.", "--delete", "--exclude", "CVS", "--delete-excluded"
		81	and die "map installation failed.\n";
		82
		83	print "maps installed successfully.\n";
53	}	84	}
54		85
55	{	86	{
56	my @PNG;	87	our %ANIMINFO;
		88	our %FACEINFO;
57	my @ARC;	89	our @ARC;
		90	our %ARC;
		91	our $TRS;
		92	our $NFILE;
58		93
		94	our $QUANTIZE = "+dither -colorspace RGB -colors 256";
		95
		96	our (@png, @trs, @arc); # files we are interested in
		97
59	sub commit_png {	98	sub commit_png($$$) {
60	my ($name, $data) = @_;	99	my ($name, $data, $T) = @_;
61	#warn "$name: commited\n";
62	}
63		100
64	sub add_png($) {	101	$FACEINFO{$name}{"data$T"} = $data;
		102	}
		103
		104	sub process_png {
		105	while (@png) {
		106	my ($path, $delete) = @{pop @png};
		107
		108	my $png;
		109	aio_lstat $path;
		110	my ($size, $mtime) = (stat _)[7,9];
		111
		112	if (0 > aio_load $path, $png) {
		113	warn "$path: $!, skipping.\n";
		114	next;
		115	}
		116
		117	my $stem = $path;
		118	my $T;
		119
		120	if ($stem =~ s/\.32x32\.png~?$//) {
		121	$T = 32;
		122	} elsif ($stem =~ s/\.64x64\.png~?$//) {
		123	$T = 64;
		124	} else {
		125	warn "$path: weird filename, skipping.\n";
		126	next;
		127	}
		128
		129	# quickly extract width and height of the (necessarily PNG) image
		130	unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
		131	warn "$path: not a recognized png file, skipping.\n";
		132	next;
		133	}
		134
		135	my ($w, $h) = unpack "NN", $1;
		136
		137	if ($w < $T \|\| $h < $T) {
		138	warn "$path: too small ($w $h), skipping.\n";
		139	next;
		140	}
		141
		142	if ($w % $T \|\| $h % $T) {
		143	warn "$path: weird png size ($w $h), skipping.\n";
		144	next;
		145	}
		146
		147	unless ($path =~ /~$/) {
		148	# possibly enlarge
		149	if (0 > aio_stat "$stem.64x64.png") {
		150	my $other = "$stem.64x64.png~";
		151
		152	if (0 > aio_lstat $other or (-M _) > (-M $path)) {
		153	my $wrap = 0; # for the time being
		154	fork_sub {
		155	system "convert png:\Q$path\E -depth 8 rgba:-"
		156	. "\| $exec_prefix/bin/cfhq2xa $w $h $wrap"
		157	. "\| convert -depth 8 -size ".($w * 2)."x".($h * 2)." rgba:- $QUANTIZE -quality 00 png32:\Q$other\E~"
		158	and die "convert/hq2xa pipeline error: status $? ($!)";
		159	system $OPTIPNG, "-o5", "-i0", "-q", "$other~";
		160	die "$other~ has zero size, aborting." unless -s "$other~";
		161	rename "$other~", $other;
		162	};
		163	}
		164
		165	push @png, [$other, !$CACHE];
		166	}
		167
		168	# possibly scale down
		169	if (0 > aio_stat "$stem.32x32.png") {
		170	my $other = "$stem.32x32.png~";
		171
		172	if (0 > aio_lstat $other or (-M _) > (-M $path)) {
		173	fork_sub {
		174	system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~";
		175	system $OPTIPNG, "-o5", "-i0", "-q", "$other~";
		176	die "$other~ has zero size, aborting." unless -s "$other~";
		177	rename "$other~", $other;
		178	};
		179	}
		180
		181	#warn "scaled down $path to $other\n";#d#
		182	push @png, [$other, !$CACHE];
		183	}
		184	}
		185
		186	(my $face = $stem) =~ s/^.*\///;
		187
		188	# split all bigfaces, but avoid smoothfaces (*_S)
		189	if (($w > $T \|\| $h > $T) && $face !~ /_S\./) {
		190	# split
		191	my @tile;
		192	for my $x (0 .. (int $w / $T) - 1) {
		193	for my $y (0 .. (int $h / $T) - 1) {
		194	my $file = "$path+$x+$y~";
		195	aio_lstat $file;
		196	push @tile, [$x, $y, $file, (stat _)[9]];
		197	}
		198	}
		199
		200	my $mtime = (lstat $path)[9];
		201	my @todo = grep { $_->[3] <= $mtime } @tile;
		202	if (@todo) {
		203	fork_sub {
		204	open my $convert, "\|-", $CONVERT,
		205	"png:-",
		206	(map {
		207	(
		208	"(",
		209	"+clone",
		210	-crop => (sprintf "%dx%d+%d+%d", $T, $T, $_->[0] * $T, $_->[1] * $T),
		211	"+repage",
		212	-quality => "00",
		213	-write => "png32:$_->[2]~",
		214	"+delete",
		215	")",
		216	)
		217	} @todo),
		218	"null:";
		219
		220	binmode $convert;
		221	print $convert $png;
		222	close $convert;
		223
		224	# pass 2, optimise, and rename
		225	for (@todo) {
		226	system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~";
		227	die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
		228	rename "$_->[2]~", $_->[2];
		229	}
		230	};
		231	}
		232
		233	for (@tile) {
		234	my ($x, $y, $file) = @$_;
		235	my $tile;
		236
		237	if (0 > aio_load $file, $tile) {
		238	die "$path: unable to read tile +$x+$y, aborting.\n";
		239	}
		240	IO::AIO::aio_unlink $file unless $CACHE;
		241	commit_png $x\|$y ? "$face+$x+$y" : $face, $tile, $T;
		242	}
		243	} else {
		244	# use as-is (either small, use smooth)
		245	commit_png $face, $png, $T;
		246	}
		247
		248	aio_unlink $path if $delete;
		249	}
		250	}
		251
		252	sub process_arc {
		253	while (@arc) {
		254	my ($dir, $file) = @{pop @arc};
		255
		256	my $arc;
		257	aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/
		258
		259	my $arc = read_arch "$dir/$file";
		260	for my $o (values %$arc) {
		261	push @ARC, $o;
		262	for (my $m = $o; $m; $m = $m->{more}) {
		263	$ARC{$m->{_name}} = $m;
		264	}
		265
		266	$o->{editor_folder} = $dir;
		267
		268	my $visibility = delete $o->{visibility};
		269	my $magicmap = delete $o->{magicmap};
		270
		271	# find upper left corner :/
		272	# omg, this is sooo broken
		273	my ($dx, $dy);
		274	for (my $o = $o; $o; $o = $o->{more}) {
		275	$dx = $o->{x} if $o->{x} < $dx;
		276	$dy = $o->{y} if $o->{y} < $dy;
		277	}
		278
		279	for (my $o = $o; $o; $o = $o->{more}) {
		280	my $x = $o->{x} - $dx;
		281	my $y = $o->{y} - $dy;
		282
		283	my $ext = $x\|$y ? "+$x+$y" : "";
		284
		285	$o->{face} .= $ext unless /^blank.x11$\|^empty.x11$/ \|\| !$o->{face};
		286
		287	my $visibility = delete $o->{visibility} if exists $o->{visibility};
		288	my $magicmap = delete $o->{magicmap} if exists $o->{magicmap};
		289
		290	my $anim = delete $o->{anim};
		291
		292	if ($anim) {
		293	# possibly add $ext to the animation name to avoid
		294	# the need to specify archnames for all parts
		295	# of a multipart archetype.
		296	$o->{animation} = "$o->{_name}";
		297	my $facings = 1;
		298	my @frames;
		299
		300	for (@$anim) {
		301	if (/^facings\s+(\d+)/) {
		302	$facings = $1*1;
		303	} elsif (/^blank.x11$\|^empty.x11$/) {
		304	push @frames, $_;
		305	} else {
		306	push @frames, "$_$ext";
		307	}
		308	}
		309
		310	$ANIMINFO{$o->{animation}} = {
		311	facings => $facings,
		312	frames => \@frames,
		313	};
		314	}
		315
		316	for my $face ($o->{face} \|\| (), @{$anim \|\| []}) {
		317	next if $face =~ /^facings\s\|^blank.x11$\|^empty.x11$/;
		318
		319	my $info = $FACEINFO{$face} \|\|= {};
		320
		321	$info->{visibility} = $visibility if defined $visibility;
		322	$info->{magicmap} = $magicmap if defined $magicmap;
		323	}
		324
		325	if (my $smooth = delete $o->{smoothface}) {
		326	my %kv =split /\s+/, $smooth;
		327	my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
		328	while (my ($face, $smooth) = each %kv) {
		329	$FACEINFO{$face}{smooth} = $smooth;
		330	$FACEINFO{$face}{smoothlevel} = $level;
		331	}
		332	}
		333	}
		334	}
		335	}
		336	}
		337
		338	sub process_trs {
		339	while (@trs) {
		340	my ($dir, $file) = @{pop @trs};
		341	my $path = "$dir/$file";
		342
		343	my $trs;
		344	if (0 > aio_load $path, $trs) {
		345	warn "$path: $!, skipping.\n";
		346	next;
		347	}
		348
		349	$TRS .= $trs;
		350	}
		351	}
		352
		353	sub find_files;
		354	sub find_files {
65	my ($path) = @_;	355	my ($path) = @_;
66		356
67	my $png;
68	aio_lstat $path, sub {
69	my ($size, $mtime) = (stat _)[7,9];
70
71	aio_load $path, $png, sub {
72	if ($_[0] < 0) {
73	warn "$path: $!, skipping.\n";
74	return;
75	}
76
77	unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
78	warn "$path: not a recongized png file, skipping.\n";
79	return;
80	}
81
82	my ($w, $h) = unpack "NN", $1;
83
84	(my $face = $path) =~ s/^.*\///;
85	my $T = 32;
86
87	unless ($face =~ s/\.base\.(...)\.png$/.$1/) {
88	warn "$path: weird filename, skipping.\n";
89	return;
90	}
91
92	if ($w < $T \|\| $h < $T) {
93	warn "$path: too small ($w $h), skipping.\n";
94	return;
95	}
96
97	if ($w % $T \|\| $h % $T) {
98	warn "$path: weird png size ($w $h), skipping.\n";
99	return;
100	}
101
102	if ($w > $T \|\| $h > $T) {
103	# split
104	} else {
105	# use as-is
106	commit_png $face, $png;
107	}
108
109	#warn "$path: $w, $h\n";
110	};
111	};
112
113	IO::AIO::poll; # reduce file-handle pressure
114	}
115
116	sub add_arc($$) {
117	my ($dir, $file) = @_;
118
119	my $arc;
120	aio_load "$dir/$file", $arc, sub { # simply pre-cache, as read_arch wants a file :/
121	my $arc = read_arch "$dir/$file";
122	};
123	}
124
125	sub add_trs($$) {
126	my ($dir, $file) = @_;
127	}
128
129	sub collect_arch;
130	sub collect_arch {
131	my ($path) = @_;
132
133	aioreq_pri 4;	357	IO::AIO::aioreq_pri 4;
134	aio_scandir $path, 4, sub {	358	IO::AIO::aio_scandir $path, 4, sub {
135	my ($dirs, $nondirs) = @_;	359	my ($dirs, $nondirs) = @_;
136		360
137	collect_arch "$path/$_"	361	find_files "$path/$_"
138	for grep $_ !~ /^(?:CVS\|dev)$/, @$dirs;	362	for grep $_ !~ /^(?:CVS\|dev)$/, @$dirs;
139		363
140	for my $file (@$nondirs) {	364	for my $file (@$nondirs) {
141	if ($file =~ /\.png$/) {	365	if ($file =~ /\.png$/) {
142	add_png "$path/$file";	366	push @png, ["$path/$file", 0];
143	} elsif ($file =~ /\.trs$/) {	367	} elsif ($file =~ /\.trs$/) {
144	add_trs $path, $file;	368	push @trs, [$path, $file];
145	} elsif ($file =~ /\.arc$/) {	369	} elsif ($file =~ /\.arc$/) {
146	add_arc $path, $file;	370	push @arc, [$path, $file];
147	} else {	371	} else {
148	warn "ignoring $path/$file\n" if $VERBOSE >= 2;	372	warn "ignoring $path/$file\n" if $VERBOSE >= 2;
149	}	373	}
150	}	374	}
151	};	375	};
152	}	376	}
153		377
154	sub inst_arch($) {	378	sub inst_arch($) {
155	my (undef, $path) = @_;	379	my (undef, $path) = @_;
156		380
		381	print "\n",
157	print "installing '$path' to '$DATADIR'\n\n";	382	"Installing '$path' to '$DATADIR'\n",
		383	"\n",
		384	"This can take a long time if you run this\n",
		385	"for the first time or do not use --cache.\n",
		386	"\n",
		387	"Unless you run verbosely, all following warning\n",
		388	"or error messages indicate serious problems.\n",
		389	"\n";
158		390
159	if (!-d "$path/treasures") {	391	if (!-d "$path/treasures") {
160	warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";	392	warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";
161	exit 1 unless $FORCE;	393	exit 1 unless $FORCE;
162	}	394	}
163		395
164	collect_arch $path;	396	find_files $path;
165	IO::AIO::flush;	397	IO::AIO::flush;
166		398
167	die "--install-arch not yet implemented\n";	399	$_->join for (
		400	# four png crunchers work fine for my 2x smp machine
		401	(async \&process_png), (async \&process_png), (async \&process_png), (async \&process_png),
		402	(async \&process_trs), (async \&process_trs),
		403	(async \&process_arc), (async \&process_arc),
		404	);
		405
		406	{
		407	# remove path prefix from editor_folder
		408	substr $_->{editor_folder}, 0, 1 + length $path, ""
		409	for values %ARC;
		410
		411	# resolve inherit
		412	while () {
		413	my $progress;
		414	my $loop;
		415
		416	for my $o (values %ARC) {
		417	if (my $other = $o->{inherit}) {
		418	if (my $s = $ARC{$other}) {
		419	if ($s->{inherit}) {
		420	$loop = $s;
		421	} else {
		422	delete $o->{inherit};
		423	my %s = %$s;
		424	delete @s{qw(_name more name name_pl)};
		425	%$o = ( %s, %$o );
		426	++$progress;
		427	}
		428	} else {
		429	warn "'$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";
		430	delete $ARC{$o->{_name}};
		431	}
		432	}
		433	}
		434
		435	unless ($progress) {
		436	die "inheritance loop detected starting at archetype '$loop->{_name}', aborting.\n"
		437	if $loop;
		438
		439	last;
		440	}
		441	}
		442
		443	open my $fh, ">:utf8", "$DATADIR/archetypes~"
		444	or die "$DATADIR/archetypes~: $!";
		445	print $fh Crossfire::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
		446	}
		447
		448	{
		449	open my $fh, ">:utf8", "$DATADIR/treasures~"
		450	or die "$DATADIR/treasures~: $!";
		451	print $fh $TRS;
		452	}
		453
		454	{
		455	while (my ($k, $v) = each %FACEINFO) {
		456	length $v->{data32} or warn "$k: face has no png32. this will not work (shoddy gcfclient will crash of course).\n";
		457	length $v->{data64} or warn "$k: face has no png64. this will not work very well.\n";
		458
		459	length $v->{data32} <= 10000 or warn "$k: face32 larger than 10000 bytes, will not work with crossfire client.\n";
		460	#length $v->{data64} <= 10000 or warn "$k: face64 larger than 10000 bytes.\n";
		461
		462	$v->{chksum32} = Digest::MD5::md5 $v->{data32};
		463	$v->{chksum64} = Digest::MD5::md5 $v->{data64};
		464	}
		465
		466	open my $fh, ">:perlio", "$DATADIR/facedata~"
		467	or die "$DATADIR/facedata~: $!";
		468
		469	print $fh freeze {
		470	version => 2,
		471	faceinfo => \%FACEINFO,
		472	animinfo => \%ANIMINFO,
		473	};
		474	}
		475
		476	for (qw(archetypes facedata treasures)) {
		477	chmod 0644, "$DATADIR/$_~";
		478	rename "$DATADIR/$_~", "$DATADIR/$_"
		479	or die "$DATADIR/$_: $!";
		480	}
		481
		482	print "archetype data installed successfully.\n";
168	}	483	}
169	}	484	}
170		485
171	Getopt::Long::Configure ("bundling", "no_ignore_case");	486	Getopt::Long::Configure ("bundling", "no_ignore_case");
172	GetOptions (	487	GetOptions (
173	"verbose\|v:+" => \$VERBOSE,	488	"verbose\|v:+" => \$VERBOSE,
		489	"cache" => \$CACHE,
174	"quiet\|q" => sub { $VERBOSE = 0 },	490	"quiet\|q" => sub { $VERBOSE = 0 },
175	"force" => sub { $FORCE = 1 },	491	"force" => sub { $FORCE = 1 },
176	"install-arch=s" => \&inst_arch,	492	"install-arch=s" => \&inst_arch,
177	"install-maps=s" => \&inst_maps,	493	"install-maps=s" => \&inst_maps,
178	"print-statedir" => sub { print "@pkgstatedir@\n" },	494	"print-statedir" => sub { print "@pkgstatedir@\n" },

Diff Legend

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

Comparing deliantra/server/utils/cfutil.in (file contents): Revision 1.2 by root, Wed Mar 7 01:23:37 2007 UTC vs. Revision 1.30 by root, Sat Apr 21 11:55:36 2007 UTC

Diff Legend

Comparing deliantra/server/utils/cfutil.in (file contents):
Revision 1.2 by root, Wed Mar 7 01:23:37 2007 UTC vs.
Revision 1.30 by root, Sat Apr 21 11:55:36 2007 UTC