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.8 by root, Sat Apr 8 13:36:25 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
24use utf8;
25
26use Carp ();
27use AnyEvent ();
28use BerkeleyDB;
23 29
24sub find_rcfile($) { 30sub find_rcfile($) {
25 my $path; 31 my $path;
26 32
27 for (@INC) { 33 for (grep !ref, @INC) {
28 $path = "$_/Crossfire/resources/$_[0]"; 34 $path = "$_/CFClient/resources/$_[0]";
29 return $path if -r $path; 35 return $path if -r $path;
30 } 36 }
31 37
32 die "FATAL: can't find required file $_[0]\n"; 38 die "FATAL: can't find required file $_[0]\n";
33} 39}
… …
53 59
54 open CFG, ">$file" 60 open CFG, ">$file"
55 or return; 61 or return;
56 62
57 { 63 {
64 require Data::Dumper;
58 local $Data::Dumper::Purity = 1; 65 local $Data::Dumper::Purity = 1;
59 $::CFG->{VERSION} = $::VERSION; 66 $::CFG->{VERSION} = $::VERSION;
60 print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]); 67 print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]);
61 } 68 }
62 69
63 close CFG; 70 close CFG;
64} 71}
65 72
66package Crossfire::Client::Texture; 73mkdir "$Crossfire::VARDIR/cfplus", 0777;
67 74
68use Scalar::Util; 75{
76 use strict;
69 77
70use SDL::OpenGL; 78 our $DB_ENV = new BerkeleyDB::Env
71 79 -Home => "$Crossfire::VARDIR/cfplus",
72my @textures; 80 -Cachesize => 1_000_000,
73 81 -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
74sub _new { 82# -ErrPrefix => "DATABASE",
75 my ($class, %data) = @_; 83 -Verbose => 1,
76 84 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN,
77 my $self = bless \%data, $class; 85 -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE | DB_TXN_WRITE_NOSYNC,
78 86 or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
79 push @textures, $self;
80 Scalar::Util::weaken $textures[-1];
81
82 $self->upload;
83
84 $self
85} 87}
86 88
87sub new_from_image { 89sub db_table($) {
88 my ($class, $image) = @_; 90 my ($table) = @_;
89 91
90 $class->_new (image => $image) 92 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
91}
92 93
93sub new_from_file { 94 new CFClient::Database
94 my ($class, $path) = @_; 95 -Env => $DB_ENV,
95 96 -Filename => $table,
96 open my $fh, "<:raw", $path 97# -Filename => "database",
97 or die "$path: $!"; 98# -Subname => $table,
98 99 -Property => DB_CHKSUM,
99 local $/; 100 -Flags => DB_CREATE | DB_UPGRADE,
100 $class->new_from_image (<$fh>) 101 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
101} 102}
102 103
103sub new_from_surface { 104sub pod_to_pango($) {
104 my ($class, $surface) = @_; 105 my ($pom) = @_;
105 106
106 $surface->rgba; 107 $pom->present ("CFClient::PodToPango")
108}
107 109
108 $class->_new ( 110sub pod_to_pango_list($) {
109 data => $surface->pixels, 111 my ($pom) = @_;
110 width => $surface->width, 112
111 height => $surface->height,
112 ) 113 [
114 map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "],
115 split /\n/, $pom->present ("CFClient::PodToPango")
116 ]
113} 117}
114 118
115sub new_from_ttf { 119package CFClient::PodToPango;
116 my ($class, $ttf, $text) = @_;
117 120
118 utf8::encode $text; 121use base Pod::POM::View::Text;
119 122
120 my $surface = SDL::TTFRenderUTF8Blended $ttf, $text, 123our $indent = 0;
121 (new SDL::Color -r => 255, -g => 255, -b => 255);
122 124
123 $class->new_from_surface (bless \$surface, SDL::Surface::) 125*view_seq_code =
124} 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]) };
125 131
126sub new_from_opengl { 132sub view_seq_text {
127 my ($class, $w, $h, $cb) = @_; 133 my $text = $_[1];
128 134 $text =~ s/\s+/ /g;
129 $class->_new (width => $w, height => $h, render => $cb) 135 CFClient::UI::Label::escape ($text)
130} 136}
131 137
132sub upload { 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
184 ? $data
185 : ()
186}
187
188my %DB_SYNC;
189
190sub put($$$) {
191 my ($db, $key, $data) = @_;
192
193 $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });
194
195 $db->db_put ($key => $data)
196}
197
198package CFClient::Item;
199
200use strict;
201use Crossfire::Protocol::Constants;
202
203sub desc_string {
133 my ($self) = @_; 204 my ($self) = @_;
134 205
135 return unless $SDL::App::USING_OPENGL; 206 my $desc =
207 $self->{nrof} < 2
208 ? $self->{name}
209 : "$self->{nrof} × $self->{name_pl}";
136 210
137 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 .= " *";
138 225
139 if (exists $self->{data}) { 226 $desc
140 $data = $self->{data}; 227}
141 } elsif (exists $self->{rendercb}) {
142 glViewport 0, 0, $self->{width}, $self->{height};
143 glClear GL_COLOR_BUFFER_BIT;
144 228
145 $self->{rendercb}->($self, $self->{width}, $self->{height}); 229sub weight_string {
146 } else { 230 my ($self) = @_;
147 my $pb = new Gtk2::Gdk::PixbufLoader;
148 $pb->write ($self->{image});
149 $pb->close;
150 231
151 $pb = $pb->get_pixbuf; 232 my $weight = ($self->{nrof} || 1) * $self->{weight};
152 $pb = $pb->add_alpha (0, 0, 0, 0);
153 233
154 $self->{width} = $pb->get_width; 234 $weight < 0 ? "?" : $weight * 0.001
155 $self->{height} = $pb->get_height; 235}
156 236
157 $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++
158 } 474 }
475}
159 476
160 ($self->{name}) = @{glGenTextures 1}; 477# if $show is 1 the recorder will be shown
478sub start {
479 my ($show) = @_;
161 480
162 glBindTexture GL_TEXTURE_2D, $self->{name}; 481 $RECORD_WINDOW->show if $show;
163 482
164 glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR; 483 $REC_BTN->set_text ("stop recording");
165 glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR;#_MIPMAP_LINEAR; 484 $REC_BTN->{recording} = 1;
166 glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP; 485 clear_command_list;
167 glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP; 486 $::CONN->start_record;
168 487}
169 if (defined $data) { 488
170 glTexImage2D GL_TEXTURE_2D, 0, 489# if $autobind is 1 the recorder will be automatically
171 GL_RGBA8, 490# jump into the binding query and hide the recorder window
172 $self->{width}, $self->{height}, 491sub stop {
173 0, 492 my ($autobind) = @_;
174 GL_RGBA, 493
175 GL_UNSIGNED_BYTE, 494 $REC_BTN->set_text ("start recording");
176 $data; 495 $REC_BTN->{recording} = 0;
177 } else { 496
178 glCopyTexImage2D GL_TEXTURE_2D, 0, 497 my $rec = $::CONN->stop_record;
179 GL_RGBA8, 498 return unless ref $rec eq 'ARRAY';
180 0, 0, 499 set_command_list ($rec);
181 $self->{width}, $self->{height}, 500
182 0; 501 if ($autobind) {
502 open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
503 $RECORD_WINDOW->hide;
183 } 504 }
184} 505}
185 506
186sub DESTROY { 507sub make_window {
187 my ($self) = @_; 508 $RECORD_WINDOW = new CFClient::UI::FancyFrame
509 req_y => 1,
510 req_x => -1,
511 title => "Action Recorder";
188 512
189 return unless exists $self->{name}; 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) = @_;
190 523
191 glDeleteTextures delete $self->{name}; 524 unless ($btn->{recording}) {
192} 525 start;
526 } else {
527 stop;
528 }
529 });
530 $vb->add ($CMDBOX = new CFClient::UI::VBox);
531 $vb->add (new CFClient::UI::Button
532 text => "bind",
533 tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
534 on_activate => sub {
535 open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
536 });
193 537
194push @::GLINIT, sub { 538 $RECORD_WINDOW
195 $_->upload 539}
196 for grep $_, @textures;
197};
198 540
1991; 5411;
200 542
201=back 543=back
202 544

Diff Legend

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