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.76 by root, Mon May 29 21:20:15 2006 UTC vs.
Revision 1.217 by root, Wed Nov 21 13:23:10 2012 UTC

1=head1 NAME 1=head1 NAME
2 2
3CFClient - undocumented utility garbage for our crossfire client 3DC - undocumented utility garbage for our deliantra client
4 4
5=head1 SYNOPSIS 5=head1 SYNOPSIS
6 6
7 use CFClient; 7 use DC;
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 DC;
16
17use Carp ();
18
19our $VERSION;
16 20
17BEGIN { 21BEGIN {
18 $VERSION = '0.1'; 22 $VERSION = '3.0';
19 23
20 use XSLoader; 24 use XSLoader;
21 XSLoader::load "CFClient", $VERSION; 25 XSLoader::load "Deliantra::Client", $VERSION;
22} 26}
23 27
24use utf8; 28use utf8;
29use strict qw(vars subs);
25 30
26use Carp (); 31use Socket ();
27use AnyEvent (); 32use AnyEvent ();
28use BerkeleyDB; 33use AnyEvent::Util ();
34use Pod::POM ();
35use File::Path ();
36use Storable (); # finally
37use Fcntl ();
38use JSON::XS qw(encode_json decode_json);
39use Guard qw(guard);
40
41# modules to support other DC::* packages
42use List::Util ();
43use IO::AIO ();
44use Coro::AIO ();
45use AnyEvent::AIO ();
46
47use Deliantra::Util ();
48use Deliantra::Protocol::Constants ();
49
50=item shorten $string[, $maxlength]
51
52=cut
53
54sub shorten($;$) {
55 my ($str, $len) = @_;
56 substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
57 $str
58}
59
60sub asxml($) {
61 local $_ = $_[0];
62
63 s/&/&amp;/g;
64 s/>/&gt;/g;
65 s/</&lt;/g;
66
67 $_
68}
69
70sub sanitise_cfxml($) {
71 local $_ = shift;
72
73 # we now weed out all tags we do not support
74 s{ <(?! /?i> | /?u> | /?b> | /?big | /?small | /?s | /?tt | fg\ | /fg>)
75 }{
76 "&lt;"
77 }gex;
78
79 # now all entities
80 s/&(?!amp;|lt;|gt;|apos;|quot;|#[0-9]+;|#x[0-9a-fA-F]+;)/&amp;/g;
81
82 # handle some elements
83 s/<fg name='([^']*)'>(.*?)<\/fg>/<span foreground='$1'>$2<\/span>/gs;
84 s/<fg name="([^"]*)">(.*?)<\/fg>/<span foreground="$1">$2<\/span>/gs;
85
86 s/\s+$//;
87
88 $_
89}
90
91sub background(&;&) {
92 my ($bg, $cb) = @_;
93
94 my ($fh_r, $fh_w) = AnyEvent::Util::portable_socketpair
95 or die "unable to create background socketpair: $!";
96
97 my $pid = fork;
98
99 if (defined $pid && !$pid) {
100 local $SIG{__DIE__};
101
102 open STDOUT, ">&", $fh_w;
103 open STDERR, ">&", $fh_w;
104 close $fh_r;
105 close $fh_w;
106
107 $| = 1;
108
109 eval { $bg->() };
110
111 if ($@) {
112 my $msg = $@;
113 $msg =~ s/\n+/\n/;
114 warn "FATAL: $msg";
115 DC::_exit 1;
116 }
117
118 # win32 is fucked up, of course. exit will clean stuff up,
119 # which destroys our database etc. _exit will exit ALL
120 # forked processes, because of the dreaded fork emulation.
121 DC::_exit 0;
122 }
123
124 close $fh_w;
125
126 my $buffer;
127
128 my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
129 unless (sysread $fh_r, $buffer, 4096, length $buffer) {
130 undef $w;
131 $cb->();
132 return;
133 }
134
135 while ($buffer =~ s/^(.*)\n//) {
136 my $line = $1;
137 $line =~ s/\s+$//;
138 utf8::decode $line;
139 if ($line =~ /^\x{e877}json_msg (.*)$/s) {
140 $cb->(JSON::XS->new->allow_nonref->decode ($1));
141 } else {
142 ::message ({
143 markup => "background($pid): " . DC::asxml $line,
144 });
145 }
146 }
147 });
148}
149
150sub background_msg {
151 my ($msg) = @_;
152
153 $msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
154 $msg =~ s/\n//g;
155 utf8::encode $msg;
156 print $msg, "\n";
157}
158
159package DC;
160
161our $RC_THEME;
162our %THEME;
163our @RC_PATH;
164our $RC_BASE;
165
166for (grep !ref, @INC) {
167 $RC_BASE = "$_/Deliantra/Client/private/resources";
168 last if -d $RC_BASE;
169}
29 170
30sub find_rcfile($) { 171sub find_rcfile($) {
31 my $path; 172 my $path;
32 173
33 for (grep !ref, @INC) { 174 for (@RC_PATH, "") {
34 $path = "$_/CFClient/resources/$_[0]"; 175 $path = "$RC_BASE/$_/$_[0]";
35 return $path if -r $path; 176 return $path if -e $path;
36 } 177 }
37 178
38 die "FATAL: can't find required file $_[0]\n"; 179 die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
39} 180}
40 181
41sub read_cfg { 182sub load_json($) {
42 my ($file) = @_; 183 my ($file) = @_;
43 184
44 open CFG, $file 185 open my $fh, $file
45 or return; 186 or return;
46 187
47 my $CFG;
48
49 local $/; 188 local $/;
50 $CFG = eval <CFG>; 189 eval { JSON::XS->new->utf8->relaxed->decode (<$fh>) }
51
52 $::CFG = $CFG;
53
54 close CFG;
55} 190}
56 191
192sub set_theme($) {
193 return if $RC_THEME eq $_[0];
194 $RC_THEME = $_[0];
195
196 # kind of hacky, find the main theme file, then load all theme files and merge them
197
198 %THEME = ();
199 @RC_PATH = "theme-$RC_THEME";
200
201 my $theme = load_json find_rcfile "theme.json"
202 or die "FATAL: theme resource file not found";
203
204 @RC_PATH = @{ $theme->{path} } if $theme->{path};
205
206 for (@RC_PATH, "") {
207 my $theme = load_json "$RC_BASE/$_/theme.json"
208 or next;
209
210 %THEME = ( %$theme, %THEME );
211 }
212}
213
57sub write_cfg { 214sub read_cfg($) {
58 my ($file) = @_; 215 my ($file) = @_;
59 216
60 open CFG, ">$file" 217 $::CFG = (load_json $file) || (load_json "$file.bak");
218}
219
220sub write_cfg($) {
221 my $file = "$Deliantra::VARDIR/client.cf";
222
223 $::CFG->{VERSION} = $::VERSION;
224 $::CFG->{layout} = DC::UI::get_layout ();
225
226 open my $fh, ">:utf8", "$file~"
61 or return; 227 or return;
228 print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
229 close $fh;
62 230
231 rename $file, "$file.bak";
232 rename "$file~", $file;
233}
234
235sub load_cfg() {
236 if (-e "$Deliantra::VARDIR/client.cf") {
237 DC::read_cfg "$Deliantra::VARDIR/client.cf";
238 } else {
239 $::CFG = { cfg_schema => 1, db_schema => 1 };
240 }
241}
242
243sub save_cfg() {
244 write_cfg "$Deliantra::VARDIR/client.cf";
245}
246
247sub upgrade_cfg() {
248 my %DEF_CFG = (
249 config_autosave => 1,
250 sdl_mode => undef,
251 fullscreen => 1,
252 fast => 0,
253 force_opengl11 => undef,
254 disable_alpha => 0,
255 smooth_movement => 1,
256 smooth_transitions => 1,
257 texture_compression => 1,
258 map_scale => 1,
259 fow_enable => 1,
260 fow_intensity => 0,
261 fow_texture => 0,
262 map_smoothing => 1,
263 gui_fontsize => 1,
264 log_fontsize => 0.7,
265 gauge_fontsize => 1,
266 gauge_size => 0.35,
267 stat_fontsize => 0.7,
268 mapsize => 100,
269 audio_enable => 1,
270 audio_hw_channels => 0,
271 audio_hw_frequency => 0,
272 audio_hw_chunksize => 0,
273 audio_mix_channels => 8,
274 effects_enable => 1,
275 effects_volume => 1,
276 bgm_enable => 1,
277 bgm_volume => 0.5,
278 output_rate => "",
279 pickup => Deliantra::Protocol::Constants::PICKUP_SPELLBOOK
280 | Deliantra::Protocol::Constants::PICKUP_SKILLSCROLL
281 | Deliantra::Protocol::Constants::PICKUP_VALUABLES,
282 inv_sort => "mtime",
283 default => "profile", # default profile
284 show_tips => 1,
285 logview_max_par => 1000,
286 shift_fire_stop => 0,
287 uitheme => "wood",
288 map_shift_x => -24, # arbitrary
289 map_shift_y => +24, # arbitrary
290 );
291
292 while (my ($k, $v) = each %DEF_CFG) {
293 $::CFG->{$k} = $v unless exists $::CFG->{$k};
294 }
295
296 if ($::CFG->{cfg_schema} < 1) {
297 for my $profile (values %{ $::CFG->{profile} }) {
298 $profile->{password} = unpack "H*", Deliantra::Util::hash_pw $profile->{password};
299 }
300 $::CFG->{cfg_schema} = 1;
301 }
302}
303
304sub http_proxy {
305 my @proxy = win32_proxy_info;
306
307 if (@proxy) {
308 "http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
309 } elsif (exists $ENV{http_proxy}) {
310 $ENV{http_proxy}
311 } else {
312 ()
313 }
314}
315
316sub set_proxy {
317 my $proxy = http_proxy
318 or return;
319
320 $ENV{http_proxy} = $proxy;
321}
322
323sub lwp_useragent {
324 require LWP::UserAgent;
63 { 325
64 require Data::Dumper; 326 DC::set_proxy;
65 local $Data::Dumper::Purity = 1;
66 $::CFG->{VERSION} = $::VERSION;
67 print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]);
68 }
69 327
70 close CFG; 328 my $ua = LWP::UserAgent->new (
329 agent => "deliantra $VERSION",
330 keep_alive => 1,
331 env_proxy => 1,
332 timeout => 30,
333 );
71} 334}
72 335
73mkdir "$Crossfire::VARDIR/cfplus", 0777; 336sub lwp_check($) {
74
75{
76 use strict;
77
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}
88
89sub db_table($) {
90 my ($table) = @_; 337 my ($res) = @_;
91 338
92 $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; 339 $res->is_error
340 and die $res->status_line;
93 341
94 new CFClient::Database 342 $res
95 -Env => $DB_ENV,
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} 343}
103 344
104sub pod_to_pango($) { 345sub fh_nonblocking($$) {
105 my ($pom) = @_; 346 my ($fh, $nb) = @_;
106 347
107 $pom->present ("CFClient::PodToPango") 348 if ($^O eq "MSWin32") {
108} 349 $nb = (! ! $nb) + 0;
109 350 ioctl $fh, 0x8004667e, \$nb; # FIONBIO
110sub pod_to_pango_list($) { 351 } else {
111 my ($pom) = @_; 352 fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
112
113 [ 353 }
114 map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "],
115 split /\n/, $pom->present ("CFClient::PodToPango")
116 ]
117} 354}
118 355
119package CFClient::PodToPango; 356package DC::Layout;
120 357
121use base Pod::POM::View::Text; 358$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
122 359 glyph_cache_restore;
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}; 360};
160 361
161sub view_head2 { 362$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
162 "\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n" 363 glyph_cache_backup;
163 . $_[1]->content->present ($_[0])
164}; 364};
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 {
204 my ($self) = @_;
205
206 my $desc =
207 $self->{nrof} < 2
208 ? $self->{name}
209 : "$self->{nrof} × $self->{name_pl}";
210
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 .= " *";
225
226 $desc
227}
228
229sub weight_string {
230 my ($self) = @_;
231
232 my $weight = ($self->{nrof} || 1) * $self->{weight};
233
234 $weight < 0 ? "?" : $weight * 0.001
235}
236
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++
474 }
475}
476
477# if $show is 1 the recorder will be shown
478sub start {
479 my ($show) = @_;
480
481 $RECORD_WINDOW->show if $show;
482
483 $REC_BTN->set_text ("stop recording");
484 $REC_BTN->{recording} = 1;
485 clear_command_list;
486 $::CONN->start_record;
487}
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;
504 }
505}
506
507sub make_window {
508 $RECORD_WINDOW = new CFClient::UI::FancyFrame
509 req_y => 1,
510 req_x => -1,
511 title => "Action Recorder";
512
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) = @_;
523
524 unless ($btn->{recording}) {
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 });
537
538 $RECORD_WINDOW
539}
540 365
5411; 3661;
542 367
543=back 368=back
544 369

Diff Legend

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