ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra-Client/DC.pm
(Generate patch)

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.21 by root, Tue Apr 11 13:05:11 2006 UTC vs.
Revision 1.76 by root, Mon May 29 21:20:15 2006 UTC

1=head1 NAME 1=head1 NAME
2 2
3Crossfire::Client - undocumented utility garbage for our crossfire client 3CFClient - undocumented utility garbage for our crossfire client
4 4
5=head1 SYNOPSIS 5=head1 SYNOPSIS
6 6
7 use Crossfire::Client; 7 use CFClient;
8 8
9=head1 DESCRIPTION 9=head1 DESCRIPTION
10 10
11=over 4 11=over 4
12 12
13=cut 13=cut
14 14
15package Crossfire::Client; 15package CFClient;
16 16
17BEGIN { 17BEGIN {
18 $VERSION = '0.1'; 18 $VERSION = '0.1';
19 19
20 use XSLoader; 20 use XSLoader;
21 XSLoader::load "Crossfire::Client", $VERSION; 21 XSLoader::load "CFClient", $VERSION;
22} 22}
23 23
24our %GL_EXT; 24use utf8;
25our $GL_VERSION;
26 25
27our $GL_NPOT; 26use Carp ();
28 27use AnyEvent ();
29sub gl_init { 28use BerkeleyDB;
30 $GL_VERSION = gl_version * 1;
31 %GL_EXT = map +($_ => 1), split /\s+/, gl_extensions;
32
33 $GL_NPOT = $GL_EXT{GL_ARB_texture_non_power_of_two} || $GL_VERSION >= 2;
34
35 Crossfire::Client::Texture::restore_state ();
36}
37 29
38sub find_rcfile($) { 30sub find_rcfile($) {
39 my $path; 31 my $path;
40 32
41 for (@INC) { 33 for (grep !ref, @INC) {
42 $path = "$_/Crossfire/resources/$_[0]"; 34 $path = "$_/CFClient/resources/$_[0]";
43 return $path if -r $path; 35 return $path if -r $path;
44 } 36 }
45 37
46 die "FATAL: can't find required file $_[0]\n"; 38 die "FATAL: can't find required file $_[0]\n";
47} 39}
… …
76 } 68 }
77 69
78 close CFG; 70 close CFG;
79} 71}
80 72
81package Crossfire::Client::Texture; 73mkdir "$Crossfire::VARDIR/cfplus", 0777;
82 74
83use Scalar::Util; 75{
76 use strict;
84 77
85use SDL::OpenGL; 78 our $DB_ENV = new BerkeleyDB::Env
79 -Home => "$Crossfire::VARDIR/cfplus",
80 -Cachesize => 1_000_000,
81 -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
82# -ErrPrefix => "DATABASE",
83 -Verbose => 1,
84 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN,
85 -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE | DB_TXN_WRITE_NOSYNC,
86 or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
87}
86 88
87my @textures; 89sub db_table($) {
90 my ($table) = @_;
88 91
89sub new { 92 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
90 my ($class, %data) = @_;
91 93
92 my $self = bless { 94 new CFClient::Database
93 internalformat => GL_RGBA, 95 -Env => $DB_ENV,
94 format => GL_RGBA, 96 -Filename => $table,
97# -Filename => "database",
98# -Subname => $table,
99 -Property => DB_CHKSUM,
100 -Flags => DB_CREATE | DB_UPGRADE,
101 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
102}
103
104sub pod_to_pango($) {
105 my ($pom) = @_;
106
107 $pom->present ("CFClient::PodToPango")
108}
109
110sub pod_to_pango_list($) {
111 my ($pom) = @_;
112
113 [
114 map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "],
115 split /\n/, $pom->present ("CFClient::PodToPango")
116 ]
117}
118
119package CFClient::PodToPango;
120
121use base Pod::POM::View::Text;
122
123our $indent = 0;
124
125*view_seq_code =
126*view_seq_bold = sub { "<b>$_[1]</b>" };
127*view_seq_italic = sub { "<i>$_[1]</i>" };
128*view_seq_space =
129*view_seq_link =
130*view_seq_index = sub { CFClient::UI::Label::escape ($_[1]) };
131
132sub view_seq_text {
133 my $text = $_[1];
134 $text =~ s/\s+/ /g;
135 CFClient::UI::Label::escape ($text)
136}
137
138sub view_item {
139 ("\t" x ($indent / 4))
140 . $_[1]->title->present ($_[0])
141 . "\n"
142 . $_[1]->content->present ($_[0])
143}
144
145sub view_verbatim {
146 (join "",
147 map +("\t" x ($indent / 2)) . "<tt>$_</tt>\n",
148 split /\n/, CFClient::UI::Label::escape ($_[1]))
149 . "\n"
150}
151
152sub view_textblock {
153 ("\t" x ($indent / 2)) . "$_[1]\n\n"
154}
155
156sub view_head1 {
157 "\n\n<span foreground='#ffff00' size='x-large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
158 . $_[1]->content->present ($_[0])
159};
160
161sub view_head2 {
162 "\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
163 . $_[1]->content->present ($_[0])
164};
165
166sub view_head3 {
167 "\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
168 . $_[1]->content->present ($_[0])
169};
170
171sub view_over {
172 local $indent = $indent + $_[1]->indent;
173 $_[1]->content->present ($_[0])
174}
175
176package CFClient::Database;
177
178our @ISA = BerkeleyDB::Btree::;
179
180sub get($$) {
181 my $data;
182
183 $_[0]->db_get ($_[1], $data) == 0
95 %data, 184 ? $data
96 }, $class; 185 : ()
97
98 push @textures, $self;
99 Scalar::Util::weaken $textures[-1];
100
101 $self->upload;
102
103 $self
104} 186}
105 187
106sub new_from_image { 188my %DB_SYNC;
107 my ($class, $image) = @_;
108 189
109 $class->new (image => $image) 190sub put($$$) {
110} 191 my ($db, $key, $data) = @_;
111 192
112sub new_from_file { 193 $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });
113 my ($class, $path) = @_;
114 194
115 open my $fh, "<:raw", $path 195 $db->db_put ($key => $data)
116 or die "$path: $!";
117
118 local $/;
119 $class->new_from_image (<$fh>)
120} 196}
121 197
122#sub new_from_surface { 198package CFClient::Item;
123# my ($class, $surface) = @_;
124#
125# $surface->rgba;
126#
127# $class->new (
128# data => $surface->pixels,
129# width => $surface->width,
130# height => $surface->height,
131# )
132#}
133 199
134sub new_from_layout { 200use strict;
135 my ($class, $layout) = @_; 201use Crossfire::Protocol::Constants;
136 202
137 my ($w, $h, $data) = $layout->render; 203sub desc_string {
138
139 $class->new (
140 width => $w,
141 height => $h,
142 data => $data,
143 internalformat => GL_ALPHA4,
144 format => GL_ALPHA,
145 )
146}
147
148sub new_from_opengl {
149 my ($class, $w, $h, $cb) = @_;
150
151 $class->new (width => $w, height => $h, rendercb => $cb)
152}
153
154sub topot {
155 (grep $_ >= $_[0], 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048, 4096, 8192, 16384, 32768)[0]
156}
157
158sub upload {
159 my ($self) = @_; 204 my ($self) = @_;
160 205
161 return unless $SDL::App::USING_OPENGL; 206 my $desc =
207 $self->{nrof} < 2
208 ? $self->{name}
209 : "$self->{nrof} × $self->{name_pl}";
162 210
163 my $data; 211 $self->{flags} & F_OPEN
212 and $desc .= " (open)";
213 $self->{flags} & F_APPLIED
214 and $desc .= " (applied)";
215 $self->{flags} & F_UNPAID
216 and $desc .= " (unpaid)";
217 $self->{flags} & F_MAGIC
218 and $desc .= " (magic)";
219 $self->{flags} & F_CURSED
220 and $desc .= " (cursed)";
221 $self->{flags} & F_DAMNED
222 and $desc .= " (damned)";
223 $self->{flags} & F_LOCKED
224 and $desc .= " *";
164 225
165 if (exists $self->{data}) { 226 $desc
166 $data = $self->{data}; 227}
167 } elsif (exists $self->{rendercb}) {
168 glViewport 0, 0, $self->{width}, $self->{height};
169 glMatrixMode GL_PROJECTION;
170 glLoadIdentity;
171 glOrtho 0, $self->{width}, 0, $self->{height}, -10000, 10000;
172 glMatrixMode GL_MODELVIEW;
173 glPushmatrix;
174 glLoadIdentity;
175 glClear GL_COLOR_BUFFER_BIT;
176 228
177 $self->{rendercb}->($self, $self->{width}, $self->{height}); 229sub weight_string {
178 } else { 230 my ($self) = @_;
179 my $pb = new Gtk2::Gdk::PixbufLoader;
180 $pb->write ($self->{image});
181 $pb->close;
182 231
183 $pb = $pb->get_pixbuf; 232 my $weight = ($self->{nrof} || 1) * $self->{weight};
184 $pb = $pb->add_alpha (0, 0, 0, 0);
185 233
186 $self->{width} = $pb->get_width; 234 $weight < 0 ? "?" : $weight * 0.001
187 $self->{height} = $pb->get_height; 235}
188 236
189 $data = $pb->get_pixels; 237sub update_widgets {
238 my ($self) = @_;
239
240 my $button_cb = sub {
241 my (undef, $ev, $x, $y) = @_;
242
243 if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
244 my $targ = $::CONN->{player}{tag};
245
246 if ($self->{container} == $::CONN->{player}{tag}) {
247 $targ = $::CONN->{open_container};
248 }
249
250 $::CONN->send ("move $targ $self->{tag} 0");
251 } elsif ($ev->{button} == 1) {
252 $::CONN->send ("examine $self->{tag}");
253 } elsif ($ev->{button} == 2) {
254 $::CONN->send ("apply $self->{tag}");
255 } elsif ($ev->{button} == 3) {
256 my @menu_items = (
257 ["examine", sub { $::CONN->send ("examine $self->{tag}") }],
258 ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
259 ["apply", sub { $::CONN->send ("apply $self->{tag}") }],
260 (
261 $self->{flags} & F_LOCKED
262 ? (
263 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
264 )
265 : (
266 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
267 ["drop", sub { $::CONN->send ("move $::CONN->{open_container} $self->{tag} 0") }],
268 )
269 ),
270 );
271
272 CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
273 }
274
275 1
276 };
277
278 my $tooltip_std = "<small>"
279 . "Left click - examine item\n"
280 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
281 . "Middle click - apply\n"
282 . "Right click - further options"
283 . "</small>\n";
284
285 $self->{face_widget} ||= new CFClient::UI::Face
286 can_events => 1,
287 can_hover => 1,
288 anim => $self->{anim},
289 animspeed => $self->{animspeed}, # TODO# must be set at creation time
290 on_button_down => $button_cb,
291 ;
292 $self->{face_widget}{face} = $self->{face};
293 $self->{face_widget}{anim} = $self->{anim};
294 $self->{face_widget}{animspeed} = $self->{animspeed};
295 $self->{face_widget}->set_tooltip (
296 "<b>Face/Animation.</b>\n"
297 . "Item uses face #$self->{face}. "
298 . ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
299 . "\n\n$tooltip_std"
300 );
301
302 $self->{desc_widget} ||= new CFClient::UI::Label
303 can_events => 1,
304 can_hover => 1,
305 ellipsise => 2,
306 align => -1,
307 on_button_down => $button_cb,
308 ;
309 my $desc = CFClient::Item::desc_string $self;
310 $self->{desc_widget}->set_text ($desc);
311 $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
312
313 $self->{weight_widget} ||= new CFClient::UI::Label
314 can_events => 1,
315 can_hover => 1,
316 ellipsise => 0,
317 align => 0,
318 on_button_down => $button_cb,
319 ;
320 $self->{weight_widget}->set_text (CFClient::Item::weight_string $self);
321
322 $self->{weight_widget}->set_tooltip (
323 "<b>Weight</b>.\n"
324 . ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
325 . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
326 . "\n\n$tooltip_std"
327 );
328}
329
330package CFClient::Recorder;
331
332our $RECORD_WINDOW;
333
334my $CMDBOX;
335my $CURRENT_CMDS;
336my $REC_BTN;
337
338my @ALLOWED_MODIFIER_KEYS = (
339 (CFClient::SDLK_LSHIFT) => "LSHIFT",
340 (CFClient::SDLK_LCTRL ) => "LCTRL",
341 (CFClient::SDLK_LALT ) => "LALT",
342 (CFClient::SDLK_LMETA ) => "LMETA",
343
344 (CFClient::SDLK_RSHIFT) => "RSHIFT",
345 (CFClient::SDLK_RCTRL ) => "RCTRL",
346 (CFClient::SDLK_RALT ) => "RALT",
347 (CFClient::SDLK_RMETA ) => "RMETA",
348);
349
350my %ALLOWED_MODIFIERS = (
351 (CFClient::KMOD_LSHIFT) => "LSHIFT",
352 (CFClient::KMOD_LCTRL ) => "LCTRL",
353 (CFClient::KMOD_LALT ) => "LALT",
354 (CFClient::KMOD_LMETA ) => "LMETA",
355
356 (CFClient::KMOD_RSHIFT) => "RSHIFT",
357 (CFClient::KMOD_RCTRL ) => "RCTRL",
358 (CFClient::KMOD_RALT ) => "RALT",
359 (CFClient::KMOD_RMETA ) => "RMETA",
360);
361
362my %DIRECT_BIND_CHARS = map { $_ => 1 } qw/0 1 2 3 4 5 6 7 8 9/;
363my @DIRECT_BIND_KEYS = (
364 CFClient::SDLK_F1,
365 CFClient::SDLK_F2,
366 CFClient::SDLK_F3,
367 CFClient::SDLK_F4,
368 CFClient::SDLK_F5,
369 CFClient::SDLK_F6,
370 CFClient::SDLK_F7,
371 CFClient::SDLK_F8,
372 CFClient::SDLK_F9,
373 CFClient::SDLK_F10,
374 CFClient::SDLK_F11,
375 CFClient::SDLK_F12,
376 CFClient::SDLK_F13,
377 CFClient::SDLK_F14,
378 CFClient::SDLK_F15,
379);
380
381# this binding dialog asks for a key-combo to be pressed
382# and if successful it binds the modifier+symbol to the
383# supplied actions in $cmd.
384# (Bindings are stored in $::CFG->{bindings}->{$mod}->{$sym})
385sub open_binding_dialog {
386 my ($cmd) = @_;
387
388 my $w = new CFClient::UI::FancyFrame
389 title => "Bind Action";
390
391 $w->add (my $vb = new CFClient::UI::VBox);
392 $vb->add (new CFClient::UI::Label
393 text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key."
394 ."You can only bind 0-9 and F1-F15 without modifiers."
395 );
396 $vb->add (my $entry = new CFClient::UI::Entry
397 text => "",
398 on_key_down => sub {
399 my ($entry, $ev) = @_;
400
401 my $mod = $ev->{mod};
402 my $sym = $ev->{sym};
403
404 # XXX: This seems a little bit hackisch to me, but i have to ignore them
405 if (grep { $_ == $sym } @ALLOWED_MODIFIER_KEYS) {
406 return;
407 }
408
409 if ($mod == CFClient::KMOD_NONE
410 and not $DIRECT_BIND_CHARS{chr ($ev->{unicode})}
411 and not grep { $sym == $_ } @DIRECT_BIND_KEYS)
412 {
413 $::STATUSBOX->add (
414 "Can't bind key ".CFClient::SDL_GetKeyName ($sym)
415 ." directly without modifier! It would damage the completer handling."
416 );
417 return;
418 }
419
420 $entry->focus_out;
421
422 $::CFG->{bindings}->{$mod}->{$sym} = $cmd;
423 $::STATUSBOX->add ("Bound actions to '".keycombo_to_name ($mod, $sym)."'. Don't forget 'Save Config'!");
424
425 $w->destroy
426 });
427
428 $entry->focus_in;
429 $w->center;
430 $w->show;
431}
432
433sub keycombo_to_name {
434 my ($mod, $sym) = @_;
435
436 my $mods = join '+',
437 map { $ALLOWED_MODIFIERS{$_} }
438 grep { $_ & $mod }
439 keys %ALLOWED_MODIFIERS;
440 $mods .= "+" if $mods ne '';
441
442 return $mods . CFClient::SDL_GetKeyName ($sym);
443}
444
445sub clear_command_list {
446 $CMDBOX->clear () if $CMDBOX;
447}
448
449sub set_command_list {
450 my ($list) = @_;
451
452 return unless $CMDBOX;
453
454 $CMDBOX->clear ();
455 $CURRENT_CMDS = $list;
456
457 my $idx = 0;
458
459 for (@$list) {
460 $CMDBOX->add (my $hb = new CFClient::UI::HBox);
461
462 my $i = $idx;
463 $hb->add (new CFClient::UI::Button
464 text => "delete",
465 tooltip => "Deletes the action from the record",
466 on_activate => sub {
467 $CMDBOX->remove ($hb);
468 $list->[$i] = undef;
469 });
470
471 $hb->add (new CFClient::UI::Label text => $_);
472
473 $idx++
190 } 474 }
475}
191 476
192 my ($tw, $th) = @$self{qw(width height)}; 477# if $show is 1 the recorder will be shown
478sub start {
479 my ($show) = @_;
193 480
194 unless ($GL_NPOT) { 481 $RECORD_WINDOW->show if $show;
195 $tw = topot $tw;
196 $th = topot $th;
197 482
198 if (defined $data) { 483 $REC_BTN->set_text ("stop recording");
199 my $bpp = (length $data) / ($self->{width} * $self->{height}); 484 $REC_BTN->{recording} = 1;
200 $data = pack "(a" . ($tw * $bpp) . ")*", 485 clear_command_list;
201 unpack "(a" . ($self->{width} * $bpp) . ")*", $data; 486 $::CONN->start_record;
202 $data .= ("\x00" x ($tw * $bpp)) x ($th - $self->{height}); 487}
203 } 488
489# if $autobind is 1 the recorder will be automatically
490# jump into the binding query and hide the recorder window
491sub stop {
492 my ($autobind) = @_;
493
494 $REC_BTN->set_text ("start recording");
495 $REC_BTN->{recording} = 0;
496
497 my $rec = $::CONN->stop_record;
498 return unless ref $rec eq 'ARRAY';
499 set_command_list ($rec);
500
501 if ($autobind) {
502 open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
503 $RECORD_WINDOW->hide;
204 } 504 }
505}
205 506
206 $self->{s} = $self->{width} / $tw; 507sub make_window {
207 $self->{t} = $self->{height} / $th; 508 $RECORD_WINDOW = new CFClient::UI::FancyFrame
509 req_y => 1,
510 req_x => -1,
511 title => "Action Recorder";
208 512
209 $self->{name} ||= (glGenTextures 1)->[0]; 513 $RECORD_WINDOW->add (my $vb = new CFClient::UI::VBox);
514 $vb->add ($REC_BTN = new CFClient::UI::Button
515 text => "start recording",
516 tooltip => "Start/Stops recording of actions."
517 ."(CTRL+Insert Starts the recorder, Insert Stops recorder and binds automatically)"
518 ."All subsequent actions after the recording started will be captured."
519 ."The actions are displayed after the record was stopped."
520 ."To bind the action you have to click on the 'Bind' button",
521 on_activate => sub {
522 my ($btn) = @_;
210 523
211 glBindTexture GL_TEXTURE_2D, $self->{name}; 524 unless ($btn->{recording}) {
212 525 start;
213 glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR;
214 glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR;#_MIPMAP_LINEAR;
215 glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP;
216 glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP;
217
218 glGetError;
219 if (defined $data) {
220 glTexImage2D GL_TEXTURE_2D, 0,
221 $self->{internalformat},
222 $tw, $th, # need to pad texture first
223 0,
224 $self->{format},
225 GL_UNSIGNED_BYTE,
226 $data;
227 glGetError and die;
228 } else { 526 } else {
229 glCopyTexImage2D GL_TEXTURE_2D, 0, 527 stop;
230 $self->{internalformat}, 528 }
231 0, 0, 529 });
232 $tw, $th, 530 $vb->add ($CMDBOX = new CFClient::UI::VBox);
233 0; 531 $vb->add (new CFClient::UI::Button
234 glPopmatrix; 532 text => "bind",
235 } 533 tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
236} 534 on_activate => sub {
535 open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
536 });
237 537
238sub DESTROY { 538 $RECORD_WINDOW
239 my ($self) = @_;
240
241 return unless exists $self->{name};
242
243 glDeleteTextures delete $self->{name};
244} 539}
245
246sub restore_state{
247 $_->upload
248 for grep $_, @textures;
249};
250 540
2511; 5411;
252 542
253=back 543=back
254 544

Diff Legend

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