ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra-Client/DC.pm
Revision: 1.52
Committed: Wed May 17 15:18:57 2006 UTC (17 years, 11 months ago) by root
Branch: MAIN
Changes since 1.51: +48 -1 lines
Log Message:
better text layout, minor fixes

File Contents

# User Rev Content
1 root 1.1 =head1 NAME
2    
3 root 1.22 CFClient - undocumented utility garbage for our crossfire client
4 root 1.1
5     =head1 SYNOPSIS
6    
7 root 1.22 use CFClient;
8 root 1.1
9     =head1 DESCRIPTION
10    
11     =over 4
12    
13     =cut
14    
15 root 1.22 package CFClient;
16 root 1.1
17     BEGIN {
18     $VERSION = '0.1';
19    
20 root 1.2 use XSLoader;
21 root 1.22 XSLoader::load "CFClient", $VERSION;
22 root 1.1 }
23    
24 root 1.43 use Carp ();
25 root 1.52 use AnyEvent ();
26 root 1.34 use BerkeleyDB;
27 root 1.52
28 root 1.41 use CFClient::OpenGL;
29 root 1.26
30 root 1.19 our %GL_EXT;
31     our $GL_VERSION;
32    
33     our $GL_NPOT;
34 root 1.49 our $GL_DEBUG = 1;
35 root 1.19
36     sub gl_init {
37     $GL_VERSION = gl_version * 1;
38     %GL_EXT = map +($_ => 1), split /\s+/, gl_extensions;
39    
40     $GL_NPOT = $GL_EXT{GL_ARB_texture_non_power_of_two} || $GL_VERSION >= 2;
41    
42 root 1.49 glDisable GL_COLOR_MATERIAL;
43 root 1.26 glShadeModel GL_FLAT;
44 root 1.49 glDisable GL_DITHER;
45 root 1.26 glDisable GL_DEPTH_TEST;
46     glHint GL_PERSPECTIVE_CORRECTION_HINT, GL_FASTEST;
47    
48 root 1.22 CFClient::Texture::restore_state ();
49 root 1.19 }
50    
51 root 1.49 sub gl_check {
52     return unless $GL_DEBUG;
53    
54     if (my $error = glGetError) {
55     Carp::cluck sprintf "opengl error %x while %s", $error, sprintf @_;
56     }
57     }
58    
59 root 1.5 sub find_rcfile($) {
60     my $path;
61    
62 root 1.46 for (grep !ref, @INC) {
63 root 1.22 $path = "$_/CFClient/resources/$_[0]";
64 root 1.5 return $path if -r $path;
65     }
66    
67     die "FATAL: can't find required file $_[0]\n";
68     }
69    
70     sub read_cfg {
71     my ($file) = @_;
72    
73     open CFG, $file
74     or return;
75    
76     my $CFG;
77    
78     local $/;
79     $CFG = eval <CFG>;
80    
81     $::CFG = $CFG;
82    
83     close CFG;
84     }
85    
86     sub write_cfg {
87     my ($file) = @_;
88    
89     open CFG, ">$file"
90     or return;
91    
92     {
93 elmex 1.9 require Data::Dumper;
94 root 1.5 local $Data::Dumper::Purity = 1;
95     $::CFG->{VERSION} = $::VERSION;
96     print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]);
97     }
98    
99     close CFG;
100     }
101    
102 root 1.34 mkdir "$Crossfire::VARDIR/pclient", 0777;
103    
104     our $DB_ENV = new BerkeleyDB::Env
105     -Home => "$Crossfire::VARDIR/pclient",
106     -Cachesize => 1_000_000,
107 root 1.39 -ErrFile => "$Crossfire::VARDIR/pclient/errorlog.txt",
108     # -ErrPrefix => "DATABASE",
109 root 1.34 -Verbose => 1,
110 root 1.39 -Flags => DB_CREATE | DB_RECOVER_FATAL | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN,
111 root 1.34 or die "unable to create/open database home $Crossfire::VARDIR/pclient: $BerkeleyDB::Error";
112    
113     sub db_table($) {
114 root 1.38 my ($table) = @_;
115    
116     $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
117    
118 root 1.34 new CFClient::Database
119     -Env => $DB_ENV,
120 root 1.38 -Filename => $table,
121     # -Filename => "database",
122     # -Subname => $table,
123 root 1.51 -Property => DB_CHKSUM,
124 root 1.34 -Flags => DB_CREATE | DB_UPGRADE,
125     or die "unable to create/open database table $_[0]: $BerkeleyDB::Error";
126     }
127    
128 root 1.52 sub pod_to_pango($) {
129     my ($pom) = @_;
130    
131     $pom->present ("CFClient::PodToPango")
132     }
133    
134     package CFClient::PodToPango;
135    
136     use base Pod::POM::View::Text;
137    
138     our $indent = 0;
139    
140     *view_seq_code =
141     *view_seq_bold = sub { "<b>$_[1]</b>" };
142     *view_seq_italic = sub { "<i>$_[1]</i>" };
143     *view_seq_space =
144     *view_seq_link =
145     *view_seq_index = sub { CFClient::UI::Label::escape ($_[1]) };
146    
147     sub view_seq_text {
148     my $text = $_[1];
149     $text =~ s/\s+/ /g;
150     CFClient::UI::Label::escape ($text)
151     }
152    
153     sub view_item {
154     ("\t" x ($indent / 4))
155     . $_[1]->title->present ($_[0])
156     . "\n"
157     . $_[1]->content->present ($_[0])
158     }
159    
160     sub view_textblock {
161     ("\t" x ($indent / 2)) . "$_[1]\n\n"
162     }
163    
164     sub view_head2 {
165     "<big>" . $_[1]->title->present ($_[0]) . "</big>\n\n"
166     . $_[1]->content->present ($_[0])
167     };
168    
169     sub view_over {
170     local $indent = $indent + $_[1]->indent;
171     $_[1]->content->present ($_[0])
172     }
173    
174 root 1.34 package CFClient::Database;
175    
176     our @ISA = BerkeleyDB::Btree::;
177    
178     sub get($$) {
179     my $data;
180    
181     $_[0]->db_get ($_[1], $data) == 0
182     ? $data
183 root 1.37 : ()
184 root 1.34 }
185    
186     my %DB_SYNC;
187    
188     sub put($$$) {
189     my ($db, $key, $data) = @_;
190    
191 root 1.37 $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });
192 root 1.34
193 root 1.37 $db->db_put ($key => $data)
194 root 1.34 }
195    
196 root 1.22 package CFClient::Texture;
197 root 1.3
198 root 1.25 use strict;
199    
200 root 1.3 use Scalar::Util;
201    
202 root 1.41 use CFClient::OpenGL;
203 root 1.3
204 root 1.35 my %TEXTURES;
205 root 1.3
206 root 1.14 sub new {
207 root 1.4 my ($class, %data) = @_;
208    
209 root 1.14 my $self = bless {
210 root 1.15 internalformat => GL_RGBA,
211     format => GL_RGBA,
212 root 1.29 type => GL_UNSIGNED_BYTE,
213 root 1.14 %data,
214     }, $class;
215 root 1.4
216 root 1.35 Scalar::Util::weaken ($TEXTURES{$self+0} = $self);
217 root 1.4
218     $self->upload;
219    
220     $self
221     }
222    
223     sub new_from_image {
224 root 1.33 my ($class, $image, %arg) = @_;
225 root 1.4
226 root 1.33 $class->new (image => $image, %arg)
227 root 1.4 }
228    
229 root 1.3 sub new_from_file {
230 root 1.42 my ($class, $path, %arg) = @_;
231 root 1.3
232     open my $fh, "<:raw", $path
233     or die "$path: $!";
234    
235     local $/;
236 root 1.42 $class->new_from_image (<$fh>, %arg)
237 root 1.3 }
238    
239 root 1.14 #sub new_from_surface {
240     # my ($class, $surface) = @_;
241     #
242     # $surface->rgba;
243     #
244     # $class->new (
245     # data => $surface->pixels,
246 root 1.24 # w => $surface->width,
247     # h => $surface->height,
248 root 1.14 # )
249     #}
250    
251 root 1.21 sub new_from_layout {
252 root 1.42 my ($class, $layout, %arg) = @_;
253 root 1.14
254 root 1.50 my ($w, $h, $data, $format, $internalformat) = $layout->render;
255 root 1.14
256     $class->new (
257 root 1.24 w => $w,
258     h => $h,
259 root 1.14 data => $data,
260 root 1.50 format => $format,
261     internalformat => $format,
262 root 1.29 type => GL_UNSIGNED_BYTE,
263 root 1.42 %arg,
264 root 1.4 )
265 root 1.3 }
266    
267 root 1.8 sub new_from_opengl {
268     my ($class, $w, $h, $cb) = @_;
269    
270 root 1.48 $class->new (w => $w || 1, h => $h || 1, render_cb => $cb)
271 root 1.8 }
272    
273 root 1.19 sub topot {
274     (grep $_ >= $_[0], 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048, 4096, 8192, 16384, 32768)[0]
275     }
276    
277 root 1.3 sub upload {
278     my ($self) = @_;
279    
280 root 1.27 return unless $GL_VERSION;
281 root 1.3
282 root 1.6 my $data;
283 root 1.3
284     if (exists $self->{data}) {
285 root 1.6 $data = $self->{data};
286 root 1.25
287 root 1.24 } elsif (exists $self->{render_cb}) {
288     glViewport 0, 0, $self->{w}, $self->{h};
289 root 1.12 glMatrixMode GL_PROJECTION;
290     glLoadIdentity;
291 root 1.31 glOrtho 0, $self->{w}, 0, $self->{h}, -10000, 10000;
292 root 1.12 glMatrixMode GL_MODELVIEW;
293     glLoadIdentity;
294 root 1.25 $self->{render_cb}->($self, $self->{w}, $self->{h});
295 root 1.8
296 root 1.3 } else {
297 root 1.29 ($self->{w}, $self->{h}, $data, $self->{internalformat}, $self->{format}, $self->{type})
298     = CFClient::load_image_inline $self->{image};
299 root 1.3 }
300    
301 root 1.24 my ($tw, $th) = @$self{qw(w h)};
302 root 1.19
303 root 1.47 unless ($tw > 0 && $th > 0) {
304 root 1.24 $tw = $th = 1;
305     $data = "\x00" x 64;
306     }
307    
308 root 1.32 $self->{minified} = [CFClient::average $tw, $th, $data]
309 root 1.33 if $self->{minify};
310 root 1.32
311 root 1.24 unless ($GL_NPOT) {
312     # TODO: does not work for zero-sized textures
313 root 1.19 $tw = topot $tw;
314     $th = topot $th;
315    
316 root 1.43 if (($tw != $self->{w} || $th != $self->{h}) && defined $data) {
317 root 1.24 my $bpp = (length $data) / ($self->{w} * $self->{h});
318 root 1.20 $data = pack "(a" . ($tw * $bpp) . ")*",
319 root 1.24 unpack "(a" . ($self->{w} * $bpp) . ")*", $data;
320     $data .= ("\x00" x ($tw * $bpp)) x ($th - $self->{h});
321 root 1.19 }
322     }
323    
324 root 1.24 $self->{s} = $self->{w} / $tw;
325     $self->{t} = $self->{h} / $th;
326 root 1.19
327 root 1.41 $self->{name} ||= glGenTexture;
328 root 1.3
329     glBindTexture GL_TEXTURE_2D, $self->{name};
330    
331     glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP;
332     glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP;
333 root 1.42
334     if ($::FAST) {
335     glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST;
336     glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST;
337 root 1.45 } elsif ($self->{mipmap} && $GL_VERSION >= 1.4) {
338     # alternatively check for 0x8191
339     glTexParameter GL_TEXTURE_2D, GL_GENERATE_MIPMAP, 1;
340     glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR;
341     glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR;
342 root 1.42 } else {
343     glTexParameter GL_TEXTURE_2D, GL_GENERATE_MIPMAP, $self->{mipmap};
344     glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR;
345 root 1.45 glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR;
346 root 1.42 }
347 root 1.3
348 root 1.45 glGetError;
349    
350 root 1.8 if (defined $data) {
351     glTexImage2D GL_TEXTURE_2D, 0,
352 root 1.15 $self->{internalformat},
353 root 1.19 $tw, $th, # need to pad texture first
354 root 1.8 0,
355 root 1.14 $self->{format},
356 root 1.29 $self->{type},
357 root 1.8 $data;
358 root 1.49 CFClient::gl_check "uploading texture %dx%d if=%x f=%x t=%x",
359     $tw, $th, $self->{internalformat}, $self->{format}, $self->{type};
360 root 1.8 } else {
361     glCopyTexImage2D GL_TEXTURE_2D, 0,
362 root 1.15 $self->{internalformat},
363 root 1.8 0, 0,
364 root 1.19 $tw, $th,
365 root 1.8 0;
366 root 1.49 CFClient::gl_check "copying to texture %dx%d if=%x",
367     $tw, $th, $self->{internalformat};
368 root 1.8 }
369 root 1.3 }
370    
371     sub DESTROY {
372     my ($self) = @_;
373    
374 root 1.35 delete $TEXTURES{$self+0};
375    
376 root 1.41 glDeleteTexture delete $self->{name}
377 root 1.36 if $self->{name};
378 root 1.3 }
379    
380 root 1.19 sub restore_state{
381 root 1.3 $_->upload
382 root 1.36 for values %TEXTURES;
383 root 1.3 };
384    
385 root 1.1 1;
386    
387     =back
388    
389     =head1 AUTHOR
390    
391     Marc Lehmann <schmorp@schmorp.de>
392     http://home.schmorp.de/
393    
394     =cut
395