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

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

Diff Legend

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

Comparing deliantra/Deliantra-Client/DC.pm (file contents): Revision 1.34 by root, Sat Apr 15 21:16:49 2006 UTC vs. Revision 1.58 by root, Tue May 23 00:26:17 2006 UTC

Diff Legend

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.34 by root, Sat Apr 15 21:16:49 2006 UTC vs.
Revision 1.58 by root, Tue May 23 00:26:17 2006 UTC