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.75 by root, Mon May 29 21:10:47 2006 UTC vs.
Revision 1.135 by root, Thu Dec 7 15:57:13 2006 UTC

1=head1 NAME 1=head1 NAME
2 2
3CFClient - undocumented utility garbage for our crossfire client 3CFPlus - undocumented utility garbage for our crossfire client
4 4
5=head1 SYNOPSIS 5=head1 SYNOPSIS
6 6
7 use CFClient; 7 use CFPlus;
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 CFClient; 15package CFPlus;
16
17use Carp ();
16 18
17BEGIN { 19BEGIN {
18 $VERSION = '0.1'; 20 $VERSION = '0.97';
19 21
20 use XSLoader; 22 use XSLoader;
21 XSLoader::load "CFClient", $VERSION; 23 XSLoader::load "CFPlus", $VERSION;
22} 24}
23 25
24use utf8; 26use utf8;
25 27
26use Carp ();
27use AnyEvent (); 28use AnyEvent ();
28use BerkeleyDB; 29use BerkeleyDB;
30use Pod::POM ();
31use Scalar::Util ();
32use File::Path ();
33use Storable (); # finally
34
35BEGIN {
36 use Crossfire::Protocol::Base ();
37 *to_json = \&Crossfire::Protocol::Base::to_json;
38 *from_json = \&Crossfire::Protocol::Base::from_json;
39}
40
41=item guard { BLOCK }
42
43Returns an object that executes the given block as soon as it is destroyed.
44
45=cut
46
47sub guard(&) {
48 bless \(my $cb = $_[0]), "CFPlus::Guard"
49}
50
51sub CFPlus::Guard::DESTROY {
52 ${$_[0]}->()
53}
54
55=item shorten $string[, $maxlength]
56
57=cut
58
59sub shorten($;$) {
60 my ($str, $len) = @_;
61 substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
62 $str
63}
64
65sub asxml($) {
66 local $_ = $_[0];
67
68 s/&/&amp;/g;
69 s/>/&gt;/g;
70 s/</&lt;/g;
71
72 $_
73}
74
75sub socketpipe() {
76 socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
77 or die "cannot establish bidiretcional pipe: $!\n";
78
79 ($fh1, $fh2)
80}
81
82sub background(&;&) {
83 my ($bg, $cb) = @_;
84
85 my ($fh_r, $fh_w) = CFPlus::socketpipe;
86
87 my $pid = fork;
88
89 if (defined $pid && !$pid) {
90 local $SIG{__DIE__};
91
92 open STDOUT, ">&", $fh_w;
93 open STDERR, ">&", $fh_w;
94 close $fh_r;
95 close $fh_w;
96
97 $| = 1;
98
99 eval { $bg->() };
100
101 if ($@) {
102 my $msg = $@;
103 $msg =~ s/\n+/\n/;
104 warn "FATAL: $msg";
105 CFPlus::_exit 1;
106 }
107
108 # win32 is fucked up, of course. exit will clean stuff up,
109 # which destroys our database etc. _exit will exit ALL
110 # forked processes, because of the dreaded fork emulation.
111 CFPlus::_exit 0;
112 }
113
114 close $fh_w;
115
116 my $buffer;
117
118 my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
119 unless (sysread $fh_r, $buffer, 4096, length $buffer) {
120 undef $w;
121 $cb->();
122 return;
123 }
124
125 while ($buffer =~ s/^(.*)\n//) {
126 my $line = $1;
127 $line =~ s/\s+$//;
128 utf8::decode $line;
129 if ($line =~ /^\x{e877}json_msg (.*)$/s) {
130 $cb->(from_json $1);
131 } else {
132 ::message ({
133 markup => "background($pid): " . CFPlus::asxml $line,
134 });
135 }
136 }
137 });
138}
139
140sub background_msg {
141 my ($msg) = @_;
142
143 $msg = "\x{e877}json_msg " . to_json $msg;
144 $msg =~ s/\n//g;
145 utf8::encode $msg;
146 print $msg, "\n";
147}
148
149package CFPlus::Database;
150
151our @ISA = BerkeleyDB::Btree::;
152
153sub get($$) {
154 my $data;
155
156 $_[0]->db_get ($_[1], $data) == 0
157 ? $data
158 : ()
159}
160
161my %DB_SYNC;
162
163sub put($$$) {
164 my ($db, $key, $data) = @_;
165
166 my $hkey = $db + 0;
167 Scalar::Util::weaken $db;
168 $DB_SYNC{$hkey} ||= AnyEvent->timer (after => 5, cb => sub {
169 delete $DB_SYNC{$hkey};
170 $db->db_sync if $db;
171 });
172
173 $db->db_put ($key => $data)
174}
175
176package CFPlus;
29 177
30sub find_rcfile($) { 178sub find_rcfile($) {
31 my $path; 179 my $path;
32 180
33 for (grep !ref, @INC) { 181 for (grep !ref, @INC) {
34 $path = "$_/CFClient/resources/$_[0]"; 182 $path = "$_/CFPlus/resources/$_[0]";
35 return $path if -r $path; 183 return $path if -r $path;
36 } 184 }
37 185
38 die "FATAL: can't find required file $_[0]\n"; 186 die "FATAL: can't find required file $_[0]\n";
39} 187}
40 188
41sub read_cfg { 189sub read_cfg {
42 my ($file) = @_; 190 my ($file) = @_;
43 191
44 open CFG, $file 192 open my $fh, $file
45 or return; 193 or return;
46 194
47 my $CFG;
48
49 local $/; 195 local $/;
50 $CFG = eval <CFG>; 196 my $CFG = <$fh>;
51 197
52 $::CFG = $CFG; 198 if ($CFG =~ /^---/) { ## TODO compatibility cruft, remove
53 199 require YAML;
54 close CFG; 200 utf8::decode $CFG;
201 $::CFG = YAML::Load ($CFG);
202 } elsif ($CFG =~ /^\{/) {
203 $::CFG = from_json $CFG;
204 } else {
205 $::CFG = eval $CFG; ## todo comaptibility cruft
206 }
55} 207}
56 208
57sub write_cfg { 209sub write_cfg {
58 my ($file) = @_; 210 my ($file) = @_;
59 211
60 open CFG, ">$file" 212 $::CFG->{VERSION} = $::VERSION;
213
214 open my $fh, ">:utf8", $file
61 or return; 215 or return;
216 print $fh to_json $::CFG;
217}
62 218
63 { 219sub http_proxy {
64 require Data::Dumper; 220 my @proxy = win32_proxy_info;
65 local $Data::Dumper::Purity = 1; 221
66 $::CFG->{VERSION} = $::VERSION; 222 if (@proxy) {
67 print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]); 223 "http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
224 } elsif (exists $ENV{http_proxy}) {
225 $ENV{http_proxy}
226 } else {
227 ()
68 } 228 }
69
70 close CFG;
71} 229}
72 230
73mkdir "$Crossfire::VARDIR/cfplus", 0777; 231sub set_proxy {
232 my $proxy = http_proxy
233 or return;
74 234
75our $DB_ENV = new BerkeleyDB::Env 235 $ENV{http_proxy} = $proxy;
76 -Home => "$Crossfire::VARDIR/cfplus", 236}
77 -Cachesize => 1_000_000, 237
78 -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt", 238sub lwp_useragent {
79# -ErrPrefix => "DATABASE", 239 require LWP::UserAgent;
80 -Verbose => 1, 240
81 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN, 241 CFPlus::set_proxy;
82 or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error"; 242
243 my $ua = LWP::UserAgent->new (
244 agent => "cfplus $VERSION",
245 keep_alive => 1,
246 env_proxy => 1,
247 timeout => 30,
248 );
249}
250
251sub lwp_check($) {
252 my ($res) = @_;
253
254 $res->is_error
255 and die $res->status_line;
256
257 $res
258}
259
260our $DB_ENV;
261our $DB_STATE;
83 262
84sub db_table($) { 263sub db_table($) {
85 my ($table) = @_; 264 my ($table) = @_;
86 265
87 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 266 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
88 267
89 new CFClient::Database 268 new CFPlus::Database
90 -Env => $DB_ENV, 269 -Env => $DB_ENV,
91 -Filename => $table, 270 -Filename => $table,
92# -Filename => "database", 271# -Filename => "database",
93# -Subname => $table, 272# -Subname => $table,
94 -Property => DB_CHKSUM, 273 -Property => DB_CHKSUM,
95 -Flags => DB_CREATE | DB_UPGRADE, 274 -Flags => DB_CREATE | DB_UPGRADE,
96 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"; 275 or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
97} 276}
98 277
99sub pod_to_pango($) { 278our $DB_HOME = "$Crossfire::VARDIR/cfplus";
100 my ($pom) = @_;
101 279
102 $pom->present ("CFClient::PodToPango") 280sub open_db {
103} 281 use strict;
104 282
105sub pod_to_pango_list($) { 283 mkdir $DB_HOME, 0777;
106 my ($pom) = @_; 284 my $recover = $BerkeleyDB::db_version >= 4.4
285 ? eval "DB_REGISTER | DB_RECOVER"
286 : 0;
107 287
288 $DB_ENV = new BerkeleyDB::Env
289 -Home => $DB_HOME,
290 -Cachesize => 1_000_000,
291 -ErrFile => "$DB_HOME/errorlog.txt",
292# -ErrPrefix => "DATABASE",
293 -Verbose => 1,
294 -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN | $recover,
295 -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE,
296 or die "unable to create/open database home $DB_HOME: $BerkeleyDB::Error";
297
298 $DB_STATE = db_table "state";
299
108 [ 300 1
109 map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "],
110 split /\n/, $pom->present ("CFClient::PodToPango")
111 ]
112} 301}
113 302
114package CFClient::PodToPango; 303unless (eval { open_db }) {
115 304 File::Path::rmtree $DB_HOME;
116use base Pod::POM::View::Text; 305 open_db;
117
118our $indent = 0;
119
120*view_seq_code =
121*view_seq_bold = sub { "<b>$_[1]</b>" };
122*view_seq_italic = sub { "<i>$_[1]</i>" };
123*view_seq_space =
124*view_seq_link =
125*view_seq_index = sub { CFClient::UI::Label::escape ($_[1]) };
126
127sub view_seq_text {
128 my $text = $_[1];
129 $text =~ s/\s+/ /g;
130 CFClient::UI::Label::escape ($text)
131} 306}
132 307
133sub view_item { 308package CFPlus::Layout;
134 ("\t" x ($indent / 4))
135 . $_[1]->title->present ($_[0])
136 . "\n"
137 . $_[1]->content->present ($_[0])
138}
139 309
140sub view_verbatim { 310$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {
141 (join "", 311 reset_glyph_cache;
142 map +("\t" x ($indent / 2)) . "<tt>$_</tt>\n",
143 split /\n/, CFClient::UI::Label::escape ($_[1]))
144 . "\n"
145}
146
147sub view_textblock {
148 ("\t" x ($indent / 2)) . "$_[1]\n\n"
149}
150
151sub view_head1 {
152 "\n\n<span foreground='#ffff00' size='x-large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
153 . $_[1]->content->present ($_[0])
154}; 312};
155 313
156sub view_head2 {
157 "\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
158 . $_[1]->content->present ($_[0])
159};
160
161sub view_head3 {
162 "\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
163 . $_[1]->content->present ($_[0])
164};
165
166sub view_over {
167 local $indent = $indent + $_[1]->indent;
168 $_[1]->content->present ($_[0])
169}
170
171package CFClient::Database;
172
173our @ISA = BerkeleyDB::Btree::;
174
175sub get($$) {
176 my $data;
177
178 $_[0]->db_get ($_[1], $data) == 0
179 ? $data
180 : ()
181}
182
183my %DB_SYNC;
184
185sub put($$$) {
186 my ($db, $key, $data) = @_;
187
188 $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });
189
190 $db->db_put ($key => $data)
191}
192
193package CFClient::Item; 314package CFPlus::Item;
194 315
195use strict; 316use strict;
196use Crossfire::Protocol::Constants; 317use Crossfire::Protocol::Constants;
318
319my $last_enter_count = 1;
197 320
198sub desc_string { 321sub desc_string {
199 my ($self) = @_; 322 my ($self) = @_;
200 323
201 my $desc = 324 my $desc =
… …
227 my $weight = ($self->{nrof} || 1) * $self->{weight}; 350 my $weight = ($self->{nrof} || 1) * $self->{weight};
228 351
229 $weight < 0 ? "?" : $weight * 0.001 352 $weight < 0 ? "?" : $weight * 0.001
230} 353}
231 354
355sub do_n_dialog {
356 my ($cb) = @_;
357
358 my $w = new CFPlus::UI::Toplevel
359 on_delete => sub { $_[0]->destroy; 1 },
360 has_close_button => 1,
361 ;
362
363 $w->add (my $vb = new CFPlus::UI::VBox x => "center", y => "center");
364 $vb->add (new CFPlus::UI::Label text => "Enter item count:");
365 $vb->add (my $entry = new CFPlus::UI::Entry
366 text => $last_enter_count,
367 on_activate => sub {
368 my ($entry) = @_;
369 $last_enter_count = $entry->get_text;
370 $cb->($last_enter_count);
371 $w->hide;
372 $w->destroy;
373
374 0
375 },
376 on_escape => sub { $w->destroy; 1 },
377 );
378 $entry->grab_focus;
379 $w->show;
380}
381
232sub update_widgets { 382sub update_widgets {
233 my ($self) = @_; 383 my ($self) = @_;
234 384
385 # necessary to avoid cyclic references
386 Scalar::Util::weaken $self;
387
235 my $button_cb = sub { 388 my $button_cb = sub {
236 my (undef, $ev, $x, $y) = @_; 389 my (undef, $ev, $x, $y) = @_;
237 390
238 if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
239 my $targ = $::CONN->{player}{tag}; 391 my $targ = $::CONN->{player}{tag};
240 392
241 if ($self->{container} == $::CONN->{player}{tag}) { 393 if ($self->{container} == $::CONN->{player}{tag}) {
242 $targ = $::CONN->{open_container}; 394 $targ = $::CONN->{open_container};
243 } 395 }
244 396
397 if (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 1) {
245 $::CONN->send ("move $targ $self->{tag} 0"); 398 $::CONN->send ("move $targ $self->{tag} 0")
399 if $targ || !($self->{flags} & F_LOCKED);
400 } elsif (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 2) {
401 $self->{flags} & F_LOCKED
402 ? $::CONN->send ("lock " . pack "CN", 0, $self->{tag})
403 : $::CONN->send ("lock " . pack "CN", 1, $self->{tag})
246 } elsif ($ev->{button} == 1) { 404 } elsif ($ev->{button} == 1) {
247 $::CONN->send ("examine $self->{tag}"); 405 $::CONN->send ("examine $self->{tag}");
248 } elsif ($ev->{button} == 2) { 406 } elsif ($ev->{button} == 2) {
249 $::CONN->send ("apply $self->{tag}"); 407 $::CONN->send ("apply $self->{tag}");
250 } elsif ($ev->{button} == 3) { 408 } elsif ($ev->{button} == 3) {
409 my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';
410 if ($self->{container} == $::CONN->{open_container}) {
411 $move_prefix = "take";
412 }
413
414 my $shortname = CFPlus::shorten $self->{name}, 14;
415
251 my @menu_items = ( 416 my @menu_items = (
252 ["examine", sub { $::CONN->send ("examine $self->{tag}") }], 417 ["examine", sub { $::CONN->send ("examine $self->{tag}") }],
253 ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }], 418 ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
419 ["ignite/thaw", # first try of an easier use of flint&steel
420 sub {
421 $::CONN->send ("mark ". pack "N", $self->{tag});
422 $::CONN->send ("command apply flint and steel");
423 }
424 ],
425 ["inscribe", # first try of an easier use of flint&steel
426 sub {
427 &::open_string_query ("Text to inscribe", sub {
428 my ($entry, $txt) = @_;
429 $::CONN->send ("mark ". pack "N", $self->{tag});
430 $::CONN->send ("command use_skill inscription $txt");
431 });
432 }
433 ],
434 ["rename", # first try of an easier use of flint&steel
435 sub {
436 &::open_string_query ("Rename item to:", sub {
437 my ($entry, $txt) = @_;
438 $::CONN->send ("mark ". pack "N", $self->{tag});
439 $::CONN->send ("command rename to <$txt>");
440 }, $self->{name},
441 "If you input no name or erase the current custom name, the custom name will be unset");
442 }
443 ],
254 ["apply", sub { $::CONN->send ("apply $self->{tag}") }], 444 ["apply", sub { $::CONN->send ("apply $self->{tag}") }],
255 ( 445 (
256 $self->{flags} & F_LOCKED 446 $self->{flags} & F_LOCKED
257 ? ( 447 ? (
258 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }], 448 ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
259 ) 449 )
260 : ( 450 : (
261 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }], 451 ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
262 ["drop", sub { $::CONN->send ("move $::CONN->{open_container} $self->{tag} 0") }], 452 ["$move_prefix all", sub { $::CONN->send ("move $targ $self->{tag} 0") }],
453 ["$move_prefix &lt;n&gt;",
454 sub {
455 do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
456 }
457 ]
263 ) 458 )
264 ), 459 ),
460 ["bind <i>apply $shortname</i> to a key" => sub { $::BIND_EDITOR->do_quick_binding (["apply $self->{name}"]) }],
265 ); 461 );
266 462
267 CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev); 463 CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);
268 } 464 }
269 465
270 1 466 1
271 }; 467 };
272 468
273 my $tooltip_std = "<small>" 469 my $tooltip_std = "<small>"
274 . "Left click - examine item\n" 470 . "Left click - examine item\n"
275 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n" 471 . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
276 . "Middle click - apply\n" 472 . "Middle click - apply\n"
473 . "Shift-Middle click - lock/unlock\n"
277 . "Right click - further options" 474 . "Right click - further options"
278 . "</small>\n"; 475 . "</small>\n";
279 476
477 my $bg = $self->{flags} & F_CURSED ? [1 , 0 , 0, 0.5]
478 : $self->{flags} & F_MAGIC ? [0.2, 0.2, 1, 0.5]
479 : undef;
480
280 $self->{face_widget} ||= new CFClient::UI::Face 481 $self->{face_widget} ||= new CFPlus::UI::Face
281 can_events => 1, 482 can_events => 1,
282 can_hover => 1, 483 can_hover => 1,
283 anim => $self->{anim}, 484 anim => $self->{anim},
284 animspeed => $self->{animspeed}, # TODO# must be set at creation time 485 animspeed => $self->{animspeed}, # TODO# must be set at creation time
285 on_button_down => $button_cb, 486 on_button_down => $button_cb,
286 ; 487 ;
488 $self->{face_widget}{bg} = $bg;
287 $self->{face_widget}{face} = $self->{face}; 489 $self->{face_widget}{face} = $self->{face};
288 $self->{face_widget}{anim} = $self->{anim}; 490 $self->{face_widget}{anim} = $self->{anim};
289 $self->{face_widget}{animspeed} = $self->{animspeed}; 491 $self->{face_widget}{animspeed} = $self->{animspeed};
290 $self->{face_widget}->set_tooltip ( 492 $self->{face_widget}->set_tooltip (
291 "<b>Face/Animation.</b>\n" 493 "<b>Face/Animation.</b>\n"
292 . "Item uses face #$self->{face}. " 494 . "Item uses face #$self->{face}. "
293 . ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ") 495 . ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
294 . "\n\n$tooltip_std" 496 . "\n\n$tooltip_std"
295 ); 497 );
296 498
297 $self->{desc_widget} ||= new CFClient::UI::Label 499 $self->{desc_widget} ||= new CFPlus::UI::Label
298 can_events => 1, 500 can_events => 1,
299 can_hover => 1, 501 can_hover => 1,
300 ellipsise => 2, 502 ellipsise => 2,
301 align => -1, 503 align => -1,
302 on_button_down => $button_cb, 504 on_button_down => $button_cb,
303 ; 505 ;
304 my $desc = CFClient::Item::desc_string $self; 506 my $desc = CFPlus::Item::desc_string $self;
507 $self->{desc_widget}{bg} = $bg;
305 $self->{desc_widget}->set_text ($desc); 508 $self->{desc_widget}->set_text ($desc);
306 $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std"); 509 $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
307 510
308 $self->{weight_widget} ||= new CFClient::UI::Label 511 $self->{weight_widget} ||= new CFPlus::UI::Label
309 can_events => 1, 512 can_events => 1,
310 can_hover => 1, 513 can_hover => 1,
311 ellipsise => 0, 514 ellipsise => 0,
312 align => 0, 515 align => 0,
313 on_button_down => $button_cb, 516 on_button_down => $button_cb,
314 ; 517 ;
518 $self->{weight_widget}{bg} = $bg;
315 $self->{weight_widget}->set_text (CFClient::Item::weight_string $self); 519 $self->{weight_widget}->set_text (CFPlus::Item::weight_string $self);
316
317 $self->{weight_widget}->set_tooltip ( 520 $self->{weight_widget}->set_tooltip (
318 "<b>Weight</b>.\n" 521 "<b>Weight</b>.\n"
319 . ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ") 522 . ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
320 . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ") 523 . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
321 . "\n\n$tooltip_std" 524 . "\n\n$tooltip_std"
322 ); 525 );
323} 526}
324 527
325package CFClient::Recorder;
326
327our $RECORD_WINDOW;
328
329my $CMDBOX;
330my $CURRENT_CMDS;
331my $REC_BTN;
332
333my @ALLOWED_MODIFIER_KEYS = (
334 (CFClient::SDLK_LSHIFT) => "LSHIFT",
335 (CFClient::SDLK_LCTRL ) => "LCTRL",
336 (CFClient::SDLK_LALT ) => "LALT",
337 (CFClient::SDLK_LMETA ) => "LMETA",
338
339 (CFClient::SDLK_RSHIFT) => "RSHIFT",
340 (CFClient::SDLK_RCTRL ) => "RCTRL",
341 (CFClient::SDLK_RALT ) => "RALT",
342 (CFClient::SDLK_RMETA ) => "RMETA",
343);
344
345my %ALLOWED_MODIFIERS = (
346 (CFClient::KMOD_LSHIFT) => "LSHIFT",
347 (CFClient::KMOD_LCTRL ) => "LCTRL",
348 (CFClient::KMOD_LALT ) => "LALT",
349 (CFClient::KMOD_LMETA ) => "LMETA",
350
351 (CFClient::KMOD_RSHIFT) => "RSHIFT",
352 (CFClient::KMOD_RCTRL ) => "RCTRL",
353 (CFClient::KMOD_RALT ) => "RALT",
354 (CFClient::KMOD_RMETA ) => "RMETA",
355);
356
357my %DIRECT_BIND_CHARS = map { $_ => 1 } qw/0 1 2 3 4 5 6 7 8 9/;
358my @DIRECT_BIND_KEYS = (
359 CFClient::SDLK_F1,
360 CFClient::SDLK_F2,
361 CFClient::SDLK_F3,
362 CFClient::SDLK_F4,
363 CFClient::SDLK_F5,
364 CFClient::SDLK_F6,
365 CFClient::SDLK_F7,
366 CFClient::SDLK_F8,
367 CFClient::SDLK_F9,
368 CFClient::SDLK_F10,
369 CFClient::SDLK_F11,
370 CFClient::SDLK_F12,
371 CFClient::SDLK_F13,
372 CFClient::SDLK_F14,
373 CFClient::SDLK_F15,
374);
375
376# this binding dialog asks for a key-combo to be pressed
377# and if successful it binds the modifier+symbol to the
378# supplied actions in $cmd.
379# (Bindings are stored in $::CFG->{bindings}->{$mod}->{$sym})
380sub open_binding_dialog {
381 my ($cmd) = @_;
382
383 my $w = new CFClient::UI::FancyFrame
384 title => "Bind Action";
385
386 $w->add (my $vb = new CFClient::UI::VBox);
387 $vb->add (new CFClient::UI::Label
388 text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key."
389 ."You can only bind 0-9 and F1-F15 without modifiers."
390 );
391 $vb->add (my $entry = new CFClient::UI::Entry
392 text => "",
393 on_key_down => sub {
394 my ($entry, $ev) = @_;
395
396 my $mod = $ev->{mod};
397 my $sym = $ev->{sym};
398
399 # XXX: This seems a little bit hackisch to me, but i have to ignore them
400 if (grep { $_ == $sym } @ALLOWED_MODIFIER_KEYS) {
401 return;
402 }
403
404 if ($mod == CFClient::KMOD_NONE
405 and not $DIRECT_BIND_CHARS{chr ($ev->{unicode})}
406 and not grep { $sym == $_ } @DIRECT_BIND_KEYS)
407 {
408 $::STATUSBOX->add (
409 "Can't bind key ".CFClient::SDL_GetKeyName ($sym)
410 ." directly without modifier! It would damage the completer handling."
411 );
412 return;
413 }
414
415 $entry->focus_out;
416
417 $::CFG->{bindings}->{$mod}->{$sym} = $cmd;
418 $::STATUSBOX->add ("Bound actions to '".keycombo_to_name ($mod, $sym)."'. Don't forget 'Save Config'!");
419
420 $w->destroy
421 });
422
423 $entry->focus_in;
424 $w->center;
425 $w->show;
426}
427
428sub keycombo_to_name {
429 my ($mod, $sym) = @_;
430
431 my $mods = join '+',
432 map { $ALLOWED_MODIFIERS{$_} }
433 grep { $_ & $mod }
434 keys %ALLOWED_MODIFIERS;
435 $mods .= "+" if $mods ne '';
436
437 return $mods . CFClient::SDL_GetKeyName ($sym);
438}
439
440sub clear_command_list {
441 $CMDBOX->clear () if $CMDBOX;
442}
443
444sub set_command_list {
445 my ($list) = @_;
446
447 return unless $CMDBOX;
448
449 $CMDBOX->clear ();
450 $CURRENT_CMDS = $list;
451
452 my $idx = 0;
453
454 for (@$list) {
455 $CMDBOX->add (my $hb = new CFClient::UI::HBox);
456
457 my $i = $idx;
458 $hb->add (new CFClient::UI::Button
459 text => "delete",
460 tooltip => "Deletes the action from the record",
461 on_activate => sub {
462 $CMDBOX->remove ($hb);
463 $list->[$i] = undef;
464 });
465
466 $hb->add (new CFClient::UI::Label text => $_);
467
468 $idx++
469 }
470}
471
472# if $show is 1 the recorder will be shown
473sub start {
474 my ($show) = @_;
475
476 $RECORD_WINDOW->show if $show;
477
478 $REC_BTN->set_text ("stop recording");
479 $REC_BTN->{recording} = 1;
480 clear_command_list;
481 $::CONN->start_record;
482}
483
484# if $autobind is 1 the recorder will be automatically
485# jump into the binding query and hide the recorder window
486sub stop {
487 my ($autobind) = @_;
488
489 $REC_BTN->set_text ("start recording");
490 $REC_BTN->{recording} = 0;
491
492 my $rec = $::CONN->stop_record;
493 return unless ref $rec eq 'ARRAY';
494 set_command_list ($rec);
495
496 if ($autobind) {
497 open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
498 $RECORD_WINDOW->hide;
499 }
500}
501
502sub make_window {
503 $RECORD_WINDOW = new CFClient::UI::FancyFrame
504 req_y => 1,
505 req_x => -1,
506 title => "Action Recorder";
507
508 $RECORD_WINDOW->add (my $vb = new CFClient::UI::VBox);
509 $vb->add ($REC_BTN = new CFClient::UI::Button
510 text => "start recording",
511 tooltip => "Start/Stops recording of actions."
512 ."(CTRL+Insert Starts the recorder, Insert Stops recorder and binds automatically)"
513 ."All subsequent actions after the recording started will be captured."
514 ."The actions are displayed after the record was stopped."
515 ."To bind the action you have to click on the 'Bind' button",
516 on_activate => sub {
517 my ($btn) = @_;
518
519 unless ($btn->{recording}) {
520 start;
521 } else {
522 stop;
523 }
524 });
525 $vb->add ($CMDBOX = new CFClient::UI::VBox);
526 $vb->add (new CFClient::UI::Button
527 text => "bind",
528 tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
529 on_activate => sub {
530 open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
531 });
532
533 $RECORD_WINDOW
534}
535
5361; 5281;
537 529
538=back 530=back
539 531
540=head1 AUTHOR 532=head1 AUTHOR

Diff Legend

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