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

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.35 by root, Sat Apr 15 22:55:59 2006 UTC vs.
Revision 1.61 by root, Wed May 24 21:49:58 2006 UTC

…		…
19		19
20	use XSLoader;	20	use XSLoader;
21	XSLoader::load "CFClient", $VERSION;	21	XSLoader::load "CFClient", $VERSION;
22	}	22	}
23		23
		24	use Carp ();
24	use AnyEvent;	25	use AnyEvent ();
25	use BerkeleyDB;	26	use BerkeleyDB;
26	use SDL::OpenGL;	27
		28	use CFClient::OpenGL;
27		29
28	our %GL_EXT;	30	our %GL_EXT;
29	our $GL_VERSION;	31	our $GL_VERSION;
30		32
31	our $GL_NPOT;	33	our $GL_NPOT;
		34	our $GL_DEBUG = 1;
32		35
33	sub gl_init {	36	sub gl_init {
34	$GL_VERSION = gl_version * 1;	37	$GL_VERSION = gl_version * 1;
35	%GL_EXT = map +($_ => 1), split /\s+/, gl_extensions;	38	%GL_EXT = map +($_ => 1), split /\s+/, gl_extensions;
36		39
37	$GL_NPOT = $GL_EXT{GL_ARB_texture_non_power_of_two} \|\| $GL_VERSION >= 2;	40	$GL_NPOT = $GL_EXT{GL_ARB_texture_non_power_of_two} \|\| $GL_VERSION >= 2;
		41	$GL_NPOT = 0 if gl_vendor =~ /ATI Technologies/; # ATI doesn't get it right...
38		42
39	glEnable GL_TEXTURE_2D;
40	glEnable GL_COLOR_MATERIAL;	43	glDisable GL_COLOR_MATERIAL;
41	glShadeModel GL_FLAT;	44	glShadeModel GL_FLAT;
		45	glDisable GL_DITHER;
42	glDisable GL_DEPTH_TEST;	46	glDisable GL_DEPTH_TEST;
43	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	47	glDepthMask 0;
44
45	glHint GL_PERSPECTIVE_CORRECTION_HINT, GL_FASTEST;	48	glHint GL_PERSPECTIVE_CORRECTION_HINT, GL_FASTEST;
46		49
47	CFClient::Texture::restore_state ();	50	CFClient::Texture::restore_state ();
		51	}
		52
		53	sub gl_check {
		54	return unless $GL_DEBUG;
		55
		56	if (my $error = glGetError) {
		57	my ($format, @args) = @_;
		58	Carp::cluck sprintf "opengl error %x while $format", $error, @args;
		59	}
48	}	60	}
49		61
50	sub find_rcfile($) {	62	sub find_rcfile($) {
51	my $path;	63	my $path;
52		64
53	for (@INC) {	65	for (grep !ref, @INC) {
54	$path = "$_/CFClient/resources/$_[0]";	66	$path = "$_/CFClient/resources/$_[0]";
55	return $path if -r $path;	67	return $path if -r $path;
56	}	68	}
57		69
58	die "FATAL: can't find required file $_[0]\n";	70	die "FATAL: can't find required file $_[0]\n";
…		…
93	mkdir "$Crossfire::VARDIR/pclient", 0777;	105	mkdir "$Crossfire::VARDIR/pclient", 0777;
94		106
95	our $DB_ENV = new BerkeleyDB::Env	107	our $DB_ENV = new BerkeleyDB::Env
96	-Home => "$Crossfire::VARDIR/pclient",	108	-Home => "$Crossfire::VARDIR/pclient",
97	-Cachesize => 1_000_000,	109	-Cachesize => 1_000_000,
98	-ErrFile => "/proc/self/fd/2",	110	-ErrFile => "$Crossfire::VARDIR/pclient/errorlog.txt",
99	-ErrPrefix => "DATABASE",	111	# -ErrPrefix => "DATABASE",
100	-Verbose => 1,	112	-Verbose => 1,
101	-Flags => DB_CREATE \| DB_JOINENV \| DB_RECOVER_FATAL \| DB_INIT_MPOOL \| DB_INIT_LOCK \| DB_INIT_TXN,	113	-Flags => DB_CREATE \| DB_RECOVER \| DB_INIT_MPOOL \| DB_INIT_LOCK \| DB_INIT_TXN,
102	or die "unable to create/open database home $Crossfire::VARDIR/pclient: $BerkeleyDB::Error";	114	or die "unable to create/open database home $Crossfire::VARDIR/pclient: $BerkeleyDB::Error";
103		115
104	sub db_table($) {	116	sub db_table($) {
		117	my ($table) = @_;
		118
		119	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
		120
105	new CFClient::Database	121	new CFClient::Database
106	-Env => $DB_ENV,	122	-Env => $DB_ENV,
		123	-Filename => $table,
107	-Filename => "database",	124	# -Filename => "database",
108	-Subname => $_[0],	125	# -Subname => $table,
		126	-Property => DB_CHKSUM,
109	-Flags => DB_CREATE \| DB_UPGRADE,	127	-Flags => DB_CREATE \| DB_UPGRADE,
110	or die "unable to create/open database table $_[0]: $BerkeleyDB::Error";	128	or die "unable to create/open database table $_[0]: $BerkeleyDB::Error";
111	}	129	}
112		130
		131	sub pod_to_pango($) {
		132	my ($pom) = @_;
		133
		134	$pom->present ("CFClient::PodToPango")
		135	}
		136
		137	sub pod_to_pango_list($) {
		138	my ($pom) = @_;
		139
		140	[
		141	map s/^(\s)// && [40 length $1, length $_ ? $_ : " "],
		142	split /\n/, $pom->present ("CFClient::PodToPango")
		143	]
		144	}
		145
		146	package CFClient::PodToPango;
		147
		148	use base Pod::POM::View::Text;
		149
		150	our $indent = 0;
		151
		152	*view_seq_code =
		153	*view_seq_bold = sub { "<b>$_[1]</b>" };
		154	*view_seq_italic = sub { "<i>$_[1]</i>" };
		155	*view_seq_space =
		156	*view_seq_link =
		157	*view_seq_index = sub { CFClient::UI::Label::escape ($_[1]) };
		158
		159	sub view_seq_text {
		160	my $text = $_[1];
		161	$text =~ s/\s+/ /g;
		162	CFClient::UI::Label::escape ($text)
		163	}
		164
		165	sub view_item {
		166	("\t" x ($indent / 4))
		167	. $_[1]->title->present ($_[0])
		168	. "\n"
		169	. $_[1]->content->present ($_[0])
		170	}
		171
		172	sub view_verbatim {
		173	(join "",
		174	map +("\t" x ($indent / 2)) . "$_\n",
		175	split /\n/, CFClient::UI::Label::escape ($_[1]))
		176	. "\n"
		177	}
		178
		179	sub view_textblock {
		180	("\t" x ($indent / 2)) . "$_[1]\n\n"
		181	}
		182
		183	sub view_head1 {
		184	"<span foreground='#ffff00' size='x-large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
		185	. $_[1]->content->present ($_[0])
		186	};
		187
		188	sub view_head2 {
		189	"<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
		190	. $_[1]->content->present ($_[0])
		191	};
		192
		193	sub view_over {
		194	local $indent = $indent + $_[1]->indent;
		195	$_[1]->content->present ($_[0])
		196	}
		197
113	package CFClient::Database;	198	package CFClient::Database;
114		199
115	our @ISA = BerkeleyDB::Btree::;	200	our @ISA = BerkeleyDB::Btree::;
116		201
117	sub get($$) {	202	sub get($$) {
118	my $data;	203	my $data;
119		204
120	$_[0]->db_get ($_[1], $data) == 0	205	$_[0]->db_get ($_[1], $data) == 0
121	? $data	206	? $data
122	: ();	207	: ()
123	}	208	}
124		209
125	my %DB_SYNC;	210	my %DB_SYNC;
126		211
127	sub put($$$) {	212	sub put($$$) {
128	my ($db, $key, $data) = @_;	213	my ($db, $key, $data) = @_;
129		214
130	$db->db_put ($key => $data);
131
132	$DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });	215	$DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });
133		216
		217	$db->db_put ($key => $data)
134	}	218	}
135		219
136	package CFClient::Texture;	220	package CFClient::Texture;
137		221
138	use strict;	222	use strict;
139		223
140	use Scalar::Util;	224	use Scalar::Util;
141		225
142	use SDL::OpenGL;	226	use CFClient::OpenGL;
143		227
144	my %TEXTURES;	228	my %TEXTURES;
145	my @NAMES;
146		229
147	sub new {	230	sub new {
148	my ($class, %data) = @_;	231	my ($class, %data) = @_;
149		232
150	my $self = bless {	233	my $self = bless {
…		…
166		249
167	$class->new (image => $image, %arg)	250	$class->new (image => $image, %arg)
168	}	251	}
169		252
170	sub new_from_file {	253	sub new_from_file {
171	my ($class, $path) = @_;	254	my ($class, $path, %arg) = @_;
172		255
173	open my $fh, "<:raw", $path	256	open my $fh, "<:raw", $path
174	or die "$path: $!";	257	or die "$path: $!";
175		258
176	local $/;	259	local $/;
177	$class->new_from_image (<$fh>)	260	$class->new_from_image (<$fh>, %arg)
178	}	261	}
179		262
180	#sub new_from_surface {	263	#sub new_from_surface {
181	# my ($class, $surface) = @_;	264	# my ($class, $surface) = @_;
182	#	265	#
…		…
188	# h => $surface->height,	271	# h => $surface->height,
189	# )	272	# )
190	#}	273	#}
191		274
192	sub new_from_layout {	275	sub new_from_layout {
193	my ($class, $layout) = @_;	276	my ($class, $layout, %arg) = @_;
194		277
195	my ($w, $h, $data) = $layout->render;	278	my ($w, $h, $data, $format, $internalformat) = $layout->render;
196		279
197	$class->new (	280	$class->new (
198	w => $w,	281	w => $w,
199	h => $h,	282	h => $h,
200	data => $data,	283	data => $data,
201	internalformat => GL_ALPHA4,
202	format => GL_ALPHA,	284	format => $format,
		285	internalformat => $format,
203	type => GL_UNSIGNED_BYTE,	286	type => GL_UNSIGNED_BYTE,
		287	%arg,
204	)	288	)
205	}	289	}
206		290
207	sub new_from_opengl {	291	sub new_from_opengl {
208	my ($class, $w, $h, $cb) = @_;	292	my ($class, $w, $h, $cb) = @_;
209		293
210	$class->new (w => $w, h => $h, render_cb => $cb)	294	$class->new (w => $w \|\| 1, h => $h \|\| 1, render_cb => $cb)
211	}	295	}
212		296
213	sub topot {	297	sub topot {
214	(grep $_ >= $_[0], 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048, 4096, 8192, 16384, 32768)[0]	298	(grep $_ >= $_[0], 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048, 4096, 8192, 16384, 32768)[0]
215	}	299	}
…		…
238	= CFClient::load_image_inline $self->{image};	322	= CFClient::load_image_inline $self->{image};
239	}	323	}
240		324
241	my ($tw, $th) = @$self{qw(w h)};	325	my ($tw, $th) = @$self{qw(w h)};
242		326
243	unless ($tw && $th) {	327	unless ($tw > 0 && $th > 0) {
244	$tw = $th = 1;	328	$tw = $th = 1;
245	$data = "\x00" x 64;	329	$data = "\x00" x 64;
246	}	330	}
247		331
248	$self->{minified} = [CFClient::average $tw, $th, $data]	332	$self->{minified} = [CFClient::average $tw, $th, $data]
…		…
251	unless ($GL_NPOT) {	335	unless ($GL_NPOT) {
252	# TODO: does not work for zero-sized textures	336	# TODO: does not work for zero-sized textures
253	$tw = topot $tw;	337	$tw = topot $tw;
254	$th = topot $th;	338	$th = topot $th;
255		339
256	if ($tw != $self->{w} \|\| $th != $self->{h} && defined $data) {	340	if (($tw != $self->{w} \|\| $th != $self->{h}) && defined $data) {
257	my $bpp = (length $data) / ($self->{w} * $self->{h});	341	my $bpp = (length $data) / ($self->{w} * $self->{h});
258	$data = pack "(a" . ($tw * $bpp) . ")*",	342	$data = pack "(a" . ($tw * $bpp) . ")*",
259	unpack "(a" . ($self->{w} * $bpp) . ")*", $data;	343	unpack "(a" . ($self->{w} * $bpp) . ")*", $data;
260	$data .= ("\x00" x ($tw * $bpp)) x ($th - $self->{h});	344	$data .= ("\x00" x ($tw * $bpp)) x ($th - $self->{h});
261	}	345	}
262	}	346	}
263		347
264	$self->{s} = $self->{w} / $tw;	348	$self->{s} = $self->{w} / $tw;
265	$self->{t} = $self->{h} / $th;	349	$self->{t} = $self->{h} / $th;
266		350
267	$self->{name} \|\|= (pop @NAMES) \|\| (glGenTextures 1)->[0];	351	$self->{name} \|\|= glGenTexture;
268		352
269	glBindTexture GL_TEXTURE_2D, $self->{name};	353	glBindTexture GL_TEXTURE_2D, $self->{name};
270		354
271	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, $::FAST ? GL_NEAREST : GL_LINEAR;
272	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, $::FAST ? GL_NEAREST : GL_LINEAR;
273	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP;	355	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP;
274	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP;	356	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP;
		357
		358	if ($::FAST) {
		359	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST;
		360	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST;
		361	} elsif ($self->{mipmap} && $GL_VERSION >= 1.4) {
		362	# alternatively check for 0x8191
		363	glTexParameter GL_TEXTURE_2D, GL_GENERATE_MIPMAP, 1;
		364	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR;
		365	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR;
		366	} else {
		367	glTexParameter GL_TEXTURE_2D, GL_GENERATE_MIPMAP, $self->{mipmap};
		368	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR;
		369	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR;
		370	}
275		371
		372	glGetError;
		373
276	if (defined $data) {	374	if (defined $data) {
277	glTexImage2D GL_TEXTURE_2D, 0,	375	glTexImage2D GL_TEXTURE_2D, 0,
278	$self->{internalformat},	376	$self->{internalformat},
279	$tw, $th, # need to pad texture first	377	$tw, $th,
280	0,	378	0,
281	$self->{format},	379	$self->{format},
282	$self->{type},	380	$self->{type},
283	$data;	381	$data;
284	glGetError and die;	382	CFClient::gl_check "uploading texture %dx%d if=%x f=%x t=%x",
		383	$tw, $th, $self->{internalformat}, $self->{format}, $self->{type};
285	} else {	384	} else {
286	glCopyTexImage2D GL_TEXTURE_2D, 0,	385	glCopyTexImage2D GL_TEXTURE_2D, 0,
287	$self->{internalformat},	386	$self->{internalformat},
288	0, 0,	387	0, 0,
289	$tw, $th,	388	$tw, $th,
290	0;	389	0;
291	glGetError and die "glCopyTexImage2D $tw,$th";	390	CFClient::gl_check "copying to texture %dx%d if=%x",
		391	$tw, $th, $self->{internalformat};
292	}	392	}
		393
		394	glBindTexture GL_TEXTURE_2D, 0; # just to be on the safe side
293	}	395	}
294		396
295	sub DESTROY {	397	sub DESTROY {
296	my ($self) = @_;	398	my ($self) = @_;
297		399
298	delete $TEXTURES{$self+0};	400	delete $TEXTURES{$self+0};
299		401
300	if (my $name = delete $self->{name}) {	402	glDeleteTexture delete $self->{name}
301	glDeleteTextures $name;	403	if $self->{name};
302	push @NAMES, $name;
303	}
304
305	}	404	}
306		405
307	sub restore_state{	406	sub restore_state {
308	$_->upload	407	$_->upload
309	for grep $_, values %TEXTURES;	408	for values %TEXTURES;
310	};	409	}
311		410
312	1;	411	1;
313		412
314	=back	413	=back
315		414

Diff Legend

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

Comparing deliantra/Deliantra-Client/DC.pm (file contents): Revision 1.35 by root, Sat Apr 15 22:55:59 2006 UTC vs. Revision 1.61 by root, Wed May 24 21:49:58 2006 UTC

Diff Legend

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.35 by root, Sat Apr 15 22:55:59 2006 UTC vs.
Revision 1.61 by root, Wed May 24 21:49:58 2006 UTC