[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.22 by root, Thu Apr 5 13:50:49 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 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 "installing '$path' to '$DATADIR/maps'\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 %FACEINFO;
57	my @ARC;	88	our @ARC;
		89	our $TRS;
		90	our $NFILE;
		91	our %ANIM;
58		92
		93	our $QUANTIZE = "+dither -colorspace RGB -colors 256";
		94
		95	our (@png, @trs, @arc); # files we are interested in
		96
59	sub commit_png {	97	sub commit_png($$$) {
60	my ($name, $data) = @_;	98	my ($name, $data, $T) = @_;
61	#warn "$name: commited\n";
62	}
63		99
64	sub add_png($) {	100	$FACEINFO{$name}{"data$T"} = $data;
		101	}
		102
		103	sub process_png {
		104	while (@png) {
		105	my ($path, $delete) = @{pop @png};
		106
		107	my $png;
		108	aio_lstat $path;
		109	my ($size, $mtime) = (stat _)[7,9];
		110
		111	if (0 > aio_load $path, $png) {
		112	warn "$path: $!, skipping.\n";
		113	next;
		114	}
		115
		116	my $stem = $path;
		117	my $T;
		118
		119	if ($stem =~ s/\.32x32\.png~?$//) {
		120	$T = 32;
		121	} elsif ($stem =~ s/\.64x64\.png~?$//) {
		122	$T = 64;
		123	} else {
		124	warn "$path: weird filename, skipping.\n";
		125	next;
		126	}
		127
		128	# quickly extract width and height of the (necessarily PNG) image
		129	unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
		130	warn "$path: not a recognized png file, skipping.\n";
		131	next;
		132	}
		133
		134	my ($w, $h) = unpack "NN", $1;
		135
		136	if ($w < $T \|\| $h < $T) {
		137	warn "$path: too small ($w $h), skipping.\n";
		138	next;
		139	}
		140
		141	if ($w % $T \|\| $h % $T) {
		142	warn "$path: weird png size ($w $h), skipping.\n";
		143	next;
		144	}
		145
		146	unless ($path =~ /~$/) {
		147	# possibly enlarge
		148	if (0 > aio_stat "$stem.64x64.png") {
		149	my $other = "$stem.64x64.png~";
		150
		151	if (0 > aio_lstat $other or (-M _) > (-M $path)) {
		152	my $wrap = 0; # for the time being
		153	fork_sub {
		154	system "convert png:\Q$path\E -depth 8 rgba:-"
		155	. "\| $exec_prefix/bin/cfhq2xa $w $h $wrap"
		156	. "\| convert -depth 8 -size ".($w * 2)."x".($h * 2)." rgba:- $QUANTIZE -quality 00 png32:\Q$other\E~"
		157	and die "convert/hq2xa pipeline error: status $? ($!)";
		158	system $OPTIPNG, "-o5", "-i0", "-q", "$other~";
		159	die "$other~ has zero size, aborting." unless -s "$other~";
		160	rename "$other~", $other;
		161	};
		162	}
		163
		164	push @png, [$other, !$CACHE];
		165	}
		166
		167	# possibly scale down
		168	if (0 > aio_stat "$stem.32x32.png") {
		169	my $other = "$stem.32x32.png~";
		170
		171	if (0 > aio_lstat $other or (-M _) > (-M $path)) {
		172	fork_sub {
		173	system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~";
		174	system $OPTIPNG, "-o5", "-i0", "-q", "$other~";
		175	die "$other~ has zero size, aborting." unless -s "$other~";
		176	rename "$other~", $other;
		177	};
		178	}
		179
		180	#warn "scaled down $path to $other\n";#d#
		181	push @png, [$other, !$CACHE];
		182	}
		183	}
		184
		185	(my $face = $stem) =~ s/^.*\///;
		186
		187	if (($w > $T \|\| $h > $T) && $face !~ /_S\./) {
		188	# split
		189	my @tile;
		190	for my $x (0 .. (int $w / $T) - 1) {
		191	for my $y (0 .. (int $h / $T) - 1) {
		192	my $file = "$path+$x+$y~";
		193	aio_lstat $file;
		194	push @tile, [$x, $y, $file, (stat _)[9]];
		195	}
		196	}
		197
		198	my $mtime = (lstat $path)[9];
		199	my @todo = grep { $_->[3] <= $mtime } @tile;
		200	if (@todo) {
		201	fork_sub {
		202	open my $convert, "\|-", $CONVERT,
		203	"png:-",
		204	(map {
		205	(
		206	"(",
		207	"+clone",
		208	-crop => (sprintf "%dx%d+%d+%d", $T, $T, $_->[0] * $T, $_->[1] * $T),
		209	"+repage",
		210	-quality => "00",
		211	-write => "png32:$_->[2]~",
		212	"+delete",
		213	")",
		214	)
		215	} @todo),
		216	"null:";
		217
		218	binmode $convert;
		219	print $convert $png;
		220	close $convert;
		221
		222	# pass 2, optimise, and rename
		223	for (@todo) {
		224	system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~";
		225	die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
		226	rename "$_->[2]~", $_->[2];
		227	}
		228	};
		229	}
		230
		231	for (@tile) {
		232	my ($x, $y, $file) = @$_;
		233	my $tile;
		234
		235	if (0 > aio_load $file, $tile) {
		236	die "$path: unable to read tile +$x+$y, aborting.\n";
		237	}
		238	IO::AIO::aio_unlink $file unless $CACHE;
		239	commit_png $x\|$y ? "$face+$x+$y" : $face, $tile, $T;
		240	}
		241	} else {
		242	# use as-is (either small, use smooth)
		243	commit_png $face, $png, $T;
		244	}
		245
		246	aio_unlink $path if $delete;
		247	}
		248	}
		249
		250	sub process_arc {
		251	while (@arc) {
		252	my ($dir, $file) = @{pop @arc};
		253
		254	my $arc;
		255	aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/
		256
		257	my $arc = read_arch "$dir/$file";
		258	for my $o (values %$arc) {
		259	push @ARC, $o;
		260
		261	$o->{editor_folder} = $dir;
		262
		263	my $visibility = delete $o->{visibility};
		264	my $magicmap = delete $o->{magicmap};
		265
		266	# find upper left corner :/
		267	# omg, this is sooo broken
		268	my ($dx, $dy);
		269	for (my $o = $o; $o; $o = $o->{more}) {
		270	$dx = $o->{x} if $o->{x} < $dx;
		271	$dy = $o->{y} if $o->{y} < $dy;
		272	}
		273
		274	for (my $o = $o; $o; $o = $o->{more}) {
		275	my $x = $o->{x} - $dx;
		276	my $y = $o->{y} - $dy;
		277
		278	my $ext = $x\|$y ? "+$x+$y" : "";
		279
		280	$o->{face} .= $ext unless /^blank.x11$\|^empty.x11$/;
		281
		282	my $visibility = delete $o->{visibility} if exists $o->{visibility};
		283	my $magicmap = delete $o->{magicmap} if exists $o->{magicmap};
		284
		285	my $anim = delete $o->{anim};
		286
		287	if ($anim) {
		288	$o->{animation} = "$o->{_name}";
		289
		290	for (@$anim) {
		291	$_ .= $ext unless /^facings\s\|^blank.x11$\|^empty.x11$/;
		292	}
		293
		294	$ANIM{"$o->{_name}$ext"} =
		295	join "", map "$_\n",
		296	"anim $o->{_name}",
		297	@$anim,
		298	"mina";
		299	}
		300
		301	for my $face ($o->{face} \|\| (), @{$anim \|\| []}) {
		302	next if $face =~ /^facings\s\|^blank.x11$\|^empty.x11$/;
		303
		304	my $info = $FACEINFO{$face} \|\|= {};
		305
		306	$info->{visibility} = $visibility if defined $visibility;
		307	$info->{magicmap} = $magicmap if defined $magicmap;
		308	}
		309
		310	if (my $smooth = delete $o->{smoothface}) {
		311	my ($face, $smooth) = split /\s+/, $smooth;
		312	# skip empty_S.x11, it seems to server no purpose whatsoever
		313	# but increases bandwidth demands and worse.
		314	unless ($smooth eq "empty_S.x11") {
		315	$FACEINFO{$face}{smooth} = $smooth;
		316	}
		317	}
		318	}
		319	}
		320	}
		321	}
		322
		323	sub process_trs {
		324	while (@trs) {
		325	my ($dir, $file) = @{pop @trs};
		326	my $path = "$dir/$file";
		327
		328	my $trs;
		329	if (0 > aio_load $path, $trs) {
		330	warn "$path: $!, skipping.\n";
		331	next;
		332	}
		333
		334	$TRS .= $trs;
		335	}
		336	}
		337
		338	sub find_files;
		339	sub find_files {
65	my ($path) = @_;	340	my ($path) = @_;
66		341
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;	342	IO::AIO::aioreq_pri 4;
134	aio_scandir $path, 4, sub {	343	IO::AIO::aio_scandir $path, 4, sub {
135	my ($dirs, $nondirs) = @_;	344	my ($dirs, $nondirs) = @_;
136		345
137	collect_arch "$path/$_"	346	find_files "$path/$_"
138	for grep $_ !~ /^(?:CVS\|dev)$/, @$dirs;	347	for grep $_ !~ /^(?:CVS\|dev)$/, @$dirs;
139		348
140	for my $file (@$nondirs) {	349	for my $file (@$nondirs) {
141	if ($file =~ /\.png$/) {	350	if ($file =~ /\.png$/) {
142	add_png "$path/$file";	351	push @png, ["$path/$file", 0];
143	} elsif ($file =~ /\.trs$/) {	352	} elsif ($file =~ /\.trs$/) {
144	add_trs $path, $file;	353	push @trs, [$path, $file];
145	} elsif ($file =~ /\.arc$/) {	354	} elsif ($file =~ /\.arc$/) {
146	add_arc $path, $file;	355	push @arc, [$path, $file];
147	} else {	356	} else {
148	warn "ignoring $path/$file\n" if $VERBOSE >= 2;	357	warn "ignoring $path/$file\n" if $VERBOSE >= 2;
149	}	358	}
150	}	359	}
151	};	360	};
152	}	361	}
153		362
154	sub inst_arch($) {	363	sub inst_arch($) {
155	my (undef, $path) = @_;	364	my (undef, $path) = @_;
156		365
157	print "installing '$path' to '$DATADIR'\n\n";	366	print "installing '$path' to '$DATADIR'\n",
		367	"(this can take a long time if you run this\n",
		368	"for the first time or do not use --cache).\n";
158		369
159	if (!-d "$path/treasures") {	370	if (!-d "$path/treasures") {
160	warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";	371	warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";
161	exit 1 unless $FORCE;	372	exit 1 unless $FORCE;
162	}	373	}
163		374
164	collect_arch $path;	375	find_files $path;
165	IO::AIO::flush;	376	IO::AIO::flush;
166		377
167	die "--install-arch not yet implemented\n";	378	$_->join for (
		379	# four png crunchers work fine for my 2x smp machine
		380	(async \&process_png), (async \&process_png), (async \&process_png), (async \&process_png),
		381	(async \&process_trs), (async \&process_trs),
		382	(async \&process_arc), (async \&process_arc),
		383	);
		384
		385	{
		386	open my $fh, ">:utf8", "$DATADIR/animations~"
		387	or die "$DATADIR/animations~: $!";
		388	print $fh join "", map $ANIM{$_}, sort keys %ANIM
		389	}
		390
		391	{
		392	open my $fh, ">:utf8", "$DATADIR/archetypes~"
		393	or die "$DATADIR/archetypes~: $!";
		394	substr $_->{editor_folder}, 0, 1 + length $path, "" for @ARC;
		395	print $fh Crossfire::archlist_to_string \@ARC;
		396	}
		397
		398	{
		399	open my $fh, ">:utf8", "$DATADIR/treasures~"
		400	or die "$DATADIR/treasures~: $!";
		401	print $fh $TRS;
		402	}
		403
		404	{
		405	while (my ($k, $v) = each %FACEINFO) {
		406	length $v->{data32} or warn "$k: face has no png32. this will not work (shoddy gcfclient will crash of course).\n";
		407	length $v->{data64} or warn "$k: face has no png64. this will not work very well.\n";
		408
		409	length $v->{data32} <= 10000 or warn "$k: face32 larger than 10000 bytes, will not work with crossfire client.\n";
		410	#length $v->{data64} <= 10000 or warn "$k: face64 larger than 10000 bytes.\n";
		411
		412	$v->{chksum32} = Digest::MD5::md5 $v->{data32};
		413	$v->{chksum64} = Digest::MD5::md5 $v->{data64};
		414	}
		415
		416	open my $fh, ">:perlio", "$DATADIR/facedata~"
		417	or die "$DATADIR/facedata~: $!";
		418
		419	$FACEINFO{""} = { version => 1};
		420	print $fh Storable::nfreeze \%FACEINFO;
		421	}
		422
		423	for (qw(archetypes facedata animations treasures)) {
		424	chmod 0644, "$DATADIR/$_~";
		425	rename "$DATADIR/$_~", "$DATADIR/$_"
		426	or die "$DATADIR/$_: $!";
		427	}
		428
		429	print "archetype data installed successfully.\n";
168	}	430	}
169	}	431	}
170		432
171	Getopt::Long::Configure ("bundling", "no_ignore_case");	433	Getopt::Long::Configure ("bundling", "no_ignore_case");
172	GetOptions (	434	GetOptions (
173	"verbose\|v:+" => \$VERBOSE,	435	"verbose\|v:+" => \$VERBOSE,
		436	"cache" => \$CACHE,
174	"quiet\|q" => sub { $VERBOSE = 0 },	437	"quiet\|q" => sub { $VERBOSE = 0 },
175	"force" => sub { $FORCE = 1 },	438	"force" => sub { $FORCE = 1 },
176	"install-arch=s" => \&inst_arch,	439	"install-arch=s" => \&inst_arch,
177	"install-maps=s" => \&inst_maps,	440	"install-maps=s" => \&inst_maps,
178	"print-statedir" => sub { print "@pkgstatedir@\n" },	441	"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.22 by root, Thu Apr 5 13:50:49 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.22 by root, Thu Apr 5 13:50:49 2007 UTC