ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Net-Bummskraut/bin/bummskraut
Revision: 1.35
Committed: Mon Jul 9 07:31:47 2007 UTC (16 years, 11 months ago) by elmex
Branch: MAIN
CVS Tags: HEAD
Changes since 1.34: +5 -0 lines
Log Message:
fixed some bug in xmpp handling and adde multiline error/info hack to
frontend.

File Contents

# Content
1 #!/opt/perl/bin/perl
2 use strict;
3 use Event;
4 use AnyEvent;
5 use Net::Bummskraut::Connection;
6 use Net::Bummskraut::Util;
7 use POSIX qw/strftime/;
8 use Net::Bummskraut::CursesChatWindow;
9 use Digest::HMAC_SHA1 qw/hmac_sha1_hex/;
10 use JSON::XS;
11
12 our $JS;
13
14 our $TSFORMAT="%d %T";
15 our $CFG;
16 our $AUTH_KEY;
17 our $config_scheme = $ARGV[2] || 'default';
18 our @highlight;
19 our @buffer_history;
20 our @buffer_history_prev;
21 our $temporary_timer;
22 our %buffer_nicks;
23 our %buffer_states;
24 our %buffer_groups;
25 our %id_aliases;
26 our $is_scrolled;
27
28 our $HOST = $ARGV[0] || 'localhost';
29 our $PORT = $ARGV[1] || 16100;
30
31 #####################################################################################
32
33 sub read_auth_key {
34 open my $k, $ENV{HOME}."/.bummskraut_key"
35 or die "Couldn't open $ENV{HOME}/.bummskraut_key: $!.\n"
36 ."It is needed for authentication!\n"
37 ."Get it from the bummskraut_server output.\n";
38 $AUTH_KEY = do { local $/; <$k> };
39 $AUTH_KEY =~ s/\s+//g;
40 }
41
42 #####################################################################################
43
44 our %completion = map { $_ => 1 } qw{
45 /goto
46 /pop
47 /prev
48 /next
49 /kill
50 /buffers
51
52 /set_nick
53 /set_groups
54
55 /xa
56 /away
57 /dnd
58 /present
59
60 /alias
61 /unalias
62 /bind
63 /unbind
64 /list_subids
65
66 /help
67
68 /colors
69 /clear_temporaries
70 /toggle_inhibit_highlight
71 /toggle_highlight_activity
72 /config_scheme
73
74 /highlights_seen
75 /highlights_seen_global
76 /highlights_seen_local
77
78 /meta
79 /history
80 /subscribe
81 /unsubscribe
82
83 /reconnect
84 /exit
85 };
86
87 our @command_help = (
88 ['/goto <buffer>' , 'Swaps to another buffer'],
89 ['/pop' , 'Jumps to the first buffer displayed in the highlight line'],
90 ['/prev' , 'Jumps to the previous shown buffer'],
91 ['/next' , 'If you used /prev this command will jump back again'],
92 ['/buffers [-(t|p|g|i)+] [<regex>]' , 'List all buffers (also by <regex> optionally)'],
93 ['/alias [<newname> <command line>]',
94 'Creates a new alias for <command line> and makes it '
95 .'available as /<newname>. If called without parameters '
96 .'it lists all defined aliases.'],
97 ['/unalias <name>' , 'Removes an alias.'],
98 ['/bind <char> [(<buffer>|/<command> <args>)]',
99 'Binds META+<char> to jump to the buffer <buffer> or '
100 .'execute an command. If called without buffer or command '
101 .'argument the current buffer will be bound. If called '
102 .'without any argument the currently defined bindings '
103 .'will be listed.'],
104 ['/unbind <char>' , 'Removes a binding'],
105 ['/list_subids' , 'Lists all sub IDs of the current buffer (if any).'],
106
107 ['/help [<topic>]' , 'This text (without the <topic> argument).'],
108 ['/colors' , 'A debugging command to show all possible colors'],
109 ['/config_scheme <name>', 'Sets the scheme of the configuration.'],
110
111 ['/clear_temporaries' , 'Clears temporary text from your buffer, '
112 .'(for example completion guides or /buffers, and other stuff)'],
113 ['/highlights_seen' , 'Clears the highlight line (the listed highlights also in other frontends)'],
114 ['/xa' , 'Sets your presence to extended away'],
115 ['/dnd' , 'Sets your presence to do not disturb'],
116 ['/away' , 'Sets your presence to away'],
117 ['/present' , 'Sets your presence to present'],
118 ['/highlights_seen_local' , 'Clears the highlight line (only in this frontends)'],
119 ['/highlights_seen_global', 'Clears the highlight line in all frondends completly'],
120 ['/toggle_inhibit_highlight', 'Will inhibit any highlighting of the currently '
121 .'selected buffer'],
122 ['/toggle_highlight_activity', 'Will highlight any activity in the currently '
123 .'selected buffer'],
124 ['/subscribe [<uri>]' , 'Subscribes contact to <uri> (or current buffer) '
125 .'(eg. irc:*<channel>@<ircserver>, '
126 .'or irc:~<nickname>@<ircserver>)'],
127 ['/unsubscribe [<uri>]' , 'Unsubscribes contact to <uri> (or current buffer).'],
128 ['/set_nick <nickname>' , 'Sets the nickname/alias for the current buffer id.'],
129 ['/set_groups <group1>[,<group2>,...]', 'Sets the groups for the current buffer id.'],
130 ['/history [<lines>]' , 'The backend will send you <lines> of lines from the chat history. (<lines> is per default 20)'],
131 ['/meta <command>' , 'Sends a meta command to the connected id of the current '
132 .'buffer, the interpretation of the command depends on '
133 .'the id scheme.'],
134 ['/reconnect' , 'Reconnects to the backend.'],
135 ['/exit' , 'Forcefully exits this frontend, CTRL-C might work better'],
136 );
137
138 #####################################################################################
139
140 sub get_id_parts {
141 my ($id) = @_;
142 split_irc_uri ($id)
143 }
144
145 sub get_id_nickname {
146 my ($dest, $src) = @_;
147 my $nick;
148
149 if (exists $buffer_nicks{$dest}) {
150 $nick = exists $buffer_nicks{$dest}->{$src}
151 ? $buffer_nicks{$dest}->{$src}->[1]
152 : $src
153 } else {
154 $nick = $id_aliases{$src} || $src
155 }
156
157 $nick
158 }
159
160 #####################################################################################
161
162 sub start_temporary_killer {
163 my ($buffer, $timeout) = @_;
164
165 if (0) { # XXX: Disabled because this seems to be too annoying
166 $::temporary_timer = AnyEvent->timer (after => $timeout || 4, cb => sub {
167 clear_buffer_temporaries ($buffer);
168 undef $::temporary_timer;
169 });
170 }
171 }
172
173 sub print_temporary_line {
174 my ($buffer, $line, $timeout) = @_;
175 $buffer = current_buffer () unless defined $buffer;
176 unshift @$line, 't';
177 printline ($buffer, $line);
178 if ($timeout) {
179 start_temporary_killer ($buffer);
180 }
181 }
182
183 #####################################################################################
184
185 sub update_buffer_statusline {
186 my $buf = current_buffer ();
187
188 my @add_info;
189 #if ($buf =~ /^irc:/) {
190 # my ($p, $a) = split_irc_uri ($buf);
191 # push @add_info,
192 # 11, '{irc} ',
193 # 78, $p,
194 # 11, '@',
195 # 13, $a,
196 # 11, " | ";
197 #}
198
199 push @add_info, 75, $buf;
200
201 push @add_info, 76, " [inhib act]" if $::CFG->{buffer_attrs}->{$config_scheme}->{$buf}->{inhibit_highlight};
202 push @add_info, 12, " [highlight act]" if $::CFG->{buffer_attrs}->{$config_scheme}->{$buf}->{highlight_activity};
203 push @add_info, 75, " ", 103, "[scrolled window]" if $is_scrolled;
204 printline (statusline => [@add_info, 'f', 11, ""]);
205 }
206
207 sub get_buffer_attr_tags {
208 my ($buf) = @_;
209 my $at = $::CFG->{buffer_attrs}->{$config_scheme}->{$buf};
210 my $tags;
211 for ([qw/inhibit_highlight i/], [qw/highlight_activity h/]) {
212 $tags .= $_->[1] if $at->{$_->[0]};
213 }
214 $tags
215 }
216
217 sub set_buffer_attr {
218 my ($buf, $attr, $flag) = @_;
219 if (defined $flag) {
220 $::CFG->{buffer_attrs}->{$config_scheme}->{$buf}->{$attr} = $flag;
221 } else {
222 $::CFG->{buffer_attrs}->{$config_scheme}->{$buf}->{$attr} = not $::CFG->{buffer_attrs}->{$config_scheme}->{$buf}->{$attr};
223 }
224 update_buffer_statusline ($buf);
225 save_config ("Changed buffer attribute of '$buf' in config scheme '$config_scheme'");
226 }
227
228 sub change_buffer {
229 my ($new_buf) = @_;
230 my $old_buf = current_buffer;
231 maybe_pop_highlight ($new_buf);
232 select_buffer ($new_buf);
233 update_buffer_statusline ($new_buf);
234
235 $JS->cl_broadcast_relay (buffers_seen => bummskraut_1_0 => [$new_buf], time)
236 if $JS;
237 }
238
239 sub monitored_buffer {
240 my ($buf) = @_;
241 not (grep { $buf eq $_ } qw/status debug monitor/)
242 }
243
244 #####################################################################################
245
246 sub push_buf_history {
247 my ($next_buf) = @_;
248 my $cb = current_buffer;
249 return if $next_buf eq $cb;
250
251 push @buffer_history, $cb
252 if not (@buffer_history)
253 || $buffer_history[-1] ne $cb;
254 }
255
256 sub prev_buf_history {
257 my $next = pop @buffer_history;
258 if (defined $next) {
259 push @buffer_history_prev, current_buffer
260 }
261 $next
262 }
263
264 sub next_buf_history {
265 my $prev = pop @buffer_history_prev;
266 if (defined $prev) {
267 push @buffer_history, current_buffer
268 }
269 $prev
270 }
271
272 #####################################################################################
273
274 sub write_infoline_rec {
275 my ($buffer, $time, $rec, @msg) = @_;
276
277 @msg = (@msg > 1 ? @msg : (3, $msg[0]));
278
279 @msg = map { s/\n\r?//; $_ } @msg; # FIXME: make multiline infos!
280
281 my $ts = POSIX::strftime ($TSFORMAT, localtime ($time || time ()));
282 my (@chatline) = (("p".length $ts), 0, $ts, 0, " ", @msg);
283
284 if ($rec && $buffer eq current_buffer && $buffer ne 'status') {
285 print_temporary_line ($buffer, \@chatline);
286 } else {
287 printline ($buffer, \@chatline);
288 }
289
290 unless ($rec) {
291 printline ('monitor', ["p".(length ($ts) + 1), 0, $ts, 7, " [", 0, $buffer, 7, "] ", @msg])
292 if monitored_buffer $buffer;
293 }
294 }
295
296 sub write_infoline {
297 my ($buffer, $time, @msg) = @_;
298 if (defined $buffer) {
299 write_infoline_rec ($buffer, $time, 0, @msg);
300 } else {
301 write_infoline_rec (status => $time, 1, @msg);
302 write_infoline_rec (current_buffer () => $time, 1, @msg) if current_buffer () ne 'status';
303 }
304 }
305
306 sub write_errorline_rec {
307 my ($buffer, $time, $rec, $msg) = @_;
308
309 $msg =~ s/\n\r?//g; # FIXME: make multiline errors!
310
311 my $ts = POSIX::strftime ($TSFORMAT, localtime ($time || time ()));
312 my (@chatline) = (("p".length $ts), 0, $ts, 0, " ", 68, "ERROR: ", 4, $msg);
313
314 if ($rec && $buffer eq current_buffer && $buffer ne 'status') {
315 print_temporary_line ($buffer, \@chatline);
316 } else {
317 printline ($buffer, \@chatline);
318 }
319
320 unless ($rec) {
321 printline ('monitor', ["p".(length ($ts) + 1), 0, $ts, 7, " [", 0, $buffer, 7, "]", 68, " ERROR: ", 4, $msg])
322 if monitored_buffer $buffer;
323 }
324
325 }
326
327 sub write_errorline {
328 my ($buffer, $time, $msg) = @_;
329
330 if (defined $buffer) {
331 write_errorline_rec ($buffer, $time, 0, $msg);
332 } else {
333 write_errorline_rec (status => $time, 1, $msg);
334 write_errorline_rec (current_buffer () => $time, 1, $msg) if current_buffer () ne 'status';
335 return;
336 }
337
338 }
339
340 sub printmultiline {
341 my ($buffer, $pad, $msgcolor, $msg, @first) = @_;
342
343 my @msglines = split /\r?\n/, $msg;
344 my $first = shift @msglines;
345
346 printline ($buffer, ["p$pad", @first, $msgcolor, $first]);
347
348 for (@msglines) {
349 printline ($buffer, ["p$pad", 0, " " x $pad, 0, $_]);
350 }
351 }
352
353 sub write_chatline {
354 my ($buffer, $src, $time, $msg, $is_echo, $type, $msg_scope, $highlight) = @_;
355 my $nick = get_id_nickname ($buffer, $src);
356
357 my $nick_color =
358 $is_echo
359 ? 7
360 : (
361 $msg_scope eq 'private'
362 ? 4
363 : ($highlight ? 70 : 0)
364 );
365 my $ts = POSIX::strftime ($TSFORMAT, localtime ($time));
366
367 my $adel_color = 0;
368
369 my ($adel, $bdel) = ('<', '>');
370 if ($type eq 'notice') {
371 ($adel, $bdel) = ('{', '}');
372 } elsif ($type eq 'action') {
373 ($adel, $bdel) = ('* ', '');
374 $adel_color = 5;
375 }
376
377 my $pad = length ($ts) + 4 + length ($nick);
378 printmultiline (
379 $buffer, $pad,
380 0, $msg,
381 0, $ts, $adel_color, " $adel", $nick_color, "$nick", 0, "$bdel "
382 );
383
384 printmultiline (
385 'monitor', length ($ts) + 1, 0, $msg,
386 0, $ts, 7, " [", 0, $buffer, 7, "]",
387 $adel_color, " $adel", $nick_color, "$nick", 0, "$bdel "
388 ) if monitored_buffer $buffer;
389 }
390
391 sub write_metaline {
392 my ($buffer, $src, $time, $msg) = @_;
393 my $nick = get_id_nickname ($buffer, $src);
394
395 my $ts = POSIX::strftime ($TSFORMAT, localtime ($time));
396
397 my (@chatline) = (
398 ("p".(length ($ts) + 4 + length ($nick))),
399 0, $ts,
400 5, " $nick",
401 0, " | ",
402 69, $msg);
403
404 printline ($buffer, \@chatline);
405
406 printline (
407 'monitor', [
408 "p".(length ($ts) + 1), 0, $ts, 7, " [", 0, $buffer, 7, "]",
409 5, " $nick", 0, " | ", 69, $msg
410 ]
411 ) if monitored_buffer $buffer;
412 }
413
414 sub write_temp_error {
415 my (@error) = @_;
416 print_temporary_line (undef, (@error > 1 ? @error : [4, $error[0]]));
417 }
418
419 sub write_temp_info {
420 my (@error) = @_;
421 print_temporary_line (undef, (@error > 1 ? @error : [3, $error[0]]));
422 }
423
424 #####################################################################################
425
426 sub get_first_highlight {
427 return $highlight[0];
428 }
429
430 sub maybe_pop_highlight {
431 my ($buffer) = @_;
432 @highlight = grep { $buffer ne $_ } @highlight;
433 printline (msgline => [map { (103, $_, 0, ' ') } @highlight]);
434 }
435
436 sub push_highlight {
437 my ($id) = @_;
438
439 unless (grep { $_ eq $id } (@highlight, current_buffer ())) {
440 push @highlight, $id;
441 printline (msgline => [map { (103, $_, 0, ' ') } @highlight]);
442 }
443 }
444
445 sub check_highlight {
446 my ($dest, $scope, $type, $do_highlight) = @_;
447
448 my $highlight = $do_highlight;
449
450 if ($::CFG->{buffer_attrs}->{$config_scheme}->{$dest}->{highlight_activity}
451 or ($scope eq 'private' and $type ne 'notice'))
452 {
453 push_highlight ($dest)
454 unless $::CFG->{buffer_attrs}->{$config_scheme}->{$dest}->{inhibit_highlight};
455
456 } elsif ($do_highlight) {
457 push_highlight ($dest)
458 unless $::CFG->{buffer_attrs}->{$config_scheme}->{$dest}->{inhibit_highlight};
459 $highlight = 1;
460 }
461
462 $highlight
463 }
464
465 sub clear_highlights {
466 my ($local) = @_;
467
468 unless ($local) {
469 $JS->cl_broadcast_relay (buffers_seen => bummskraut_1_0 => [@highlight], time)
470 if $JS;
471 }
472
473 @highlight = ();
474 printline (msgline => []);
475 }
476
477 #####################################################################################
478
479 sub handle_message {
480 my ($JS, $package, $src, $id, $scope, $type,
481 $is_echo, $do_highlight, $ts, $content) = @_;
482
483 write_chatline (
484 $id, $src, $ts, $content, $is_echo,
485 $type, $scope, check_highlight ($id, $scope, $type, $do_highlight)
486 );
487
488 # clear any highlights if we answered in this buffer
489 if ($is_echo) { maybe_pop_highlight ($id) }
490
491 1;
492 }
493
494 sub handle_meta_message {
495 my ($JS, $packet, $src, $dest, $ts, $content) = @_;
496
497 write_metaline ($dest, $src, $ts, $content);
498
499 1
500 }
501
502 sub handle_state_change {
503 my ($JS, $packet, $id, $ts, $state, $desc, $alias) = @_;
504
505 $buffer_states{$id}->{state} = [$state, $desc];
506 $id_aliases{$id} = ($alias eq '' ? undef : $alias) if defined $alias;
507
508 write_infoline ($id, $ts,
509 2, $id,
510 ($id_aliases{$id} ? (2, " (aka $id_aliases{$id})") : ()),
511 3, " state: ",
512 0, $state . ($desc ? ", $desc" : "")
513 );
514
515 if ($state eq 'n/a') {
516 delete $buffer_nicks{$id};
517
518 } elsif ($state eq 'dead') {
519 delete $buffer_states{$id};
520 delete $buffer_nicks{$id};
521 delete $id_aliases{$id};
522 }
523
524 update_buffer_statusline ($id);
525
526 1
527 }
528
529 sub handle_set_group {
530 my ($JS, $packet, $id, $groups) = @_;
531
532 $buffer_groups{$id} = $groups;
533 update_buffer_statusline ($id);
534
535 1
536 }
537
538 sub handle_add_subid {
539 my ($JS, $packet, $id, $timestamp, $ids) = @_;
540
541 for (@$ids) {
542 $buffer_nicks{$id}->{$_->[0]} = $_;
543 write_infoline ($id, $timestamp,
544 66, "+ ", map { (2, (sprintf "%-30s", $_->[0]), 0, " as ", 3, $_->[1]) } ($_)
545 );
546 }
547
548 1;
549 }
550
551 sub handle_remove_subid {
552 my ($JS, $packet, $id, $timestamp, $ids) = @_;
553
554 for (@$ids) {
555 delete $buffer_nicks{$id}->{$_->[0]};
556 write_infoline ($id, $timestamp,
557 68, "- ", map { (2, (sprintf "%-30s", $_->[0]), 0, " was ", 3, $_->[1]) } ($_)
558 );
559 }
560
561 1;
562 }
563
564 sub handle_change_subid {
565 my ($JS, $packet, $id, $timestamp, $subid, $new_subid, $oldnick, $newnick) = @_;
566
567 delete $buffer_nicks{$id}->{$subid};
568 $buffer_nicks{$id}->{$new_subid} = [$new_subid, $newnick];
569
570 write_infoline ($id, $timestamp,
571 67, "% ", 2, $subid, 2, " was ", 3, $oldnick, 0, " => ", 2, $new_subid, 2, " is ", 3, $newnick
572 );
573
574 1;
575 }
576
577 sub handle_info {
578 my ($JS, $packet, $id, $type, $ts, $content) = @_;
579 write_infoline ($id, $ts => "$type: $content");
580
581 1;
582 }
583
584 sub handle_error {
585 my ($JS, $packet, $id, $type, $ts, $content) = @_;
586 write_errorline ($id, $ts => "$type: $content");
587
588 1;
589 }
590
591 sub handle_config_state {
592 my ($JS, $packet, $cfgname, $cfg) = @_;
593 $::CFG = $cfg;
594 write_infoline ('status', time, "Retrieved config update for '$cfgname' from server.");
595
596 1;
597 }
598
599 sub handle_broadcast_relay {
600 my ($JS, $packet, $command, $tag, $data, $ts) = @_;
601
602 unless (grep { $_ eq $tag } qw/bummskraut_1_0/) {
603 return 1
604 }
605
606 if ($command eq 'buffers_seen') {
607 maybe_pop_highlight ($_) for @$data;
608
609 } elsif ($command eq 'highlights_seen') {
610 clear_highlights ('local')
611 }
612
613 1;
614 }
615
616 #####################################################################################
617
618 sub find_common_prefix {
619 my (@words) = @_;
620 @words = sort { length ($a) <=> length ($b) } @words;
621 my $shortest = $words[0];
622
623 while ($shortest ne '') {
624 my $no_match = 0;
625 for (@words) {
626 unless (/^\Q$shortest\E/) {
627 $no_match = 1;
628 last;
629 }
630 }
631
632 return $shortest if not $no_match;
633 substr $shortest, -1, 1, '';
634 }
635
636 return '';
637 }
638
639 Net::Bummskraut::CursesChatWindow::register_complete_cb (sub {
640 my ($word, $idx, @line) = @_;
641
642 # TODO: make completion cycling with $first_compl
643 #d# printline (undef, [0, "[$idx] [$word]"]);
644
645 my @found;
646
647 my @nicks = map { $_->[1] } values %{$buffer_nicks{current_buffer ()} || {}};
648 my @commands = ((keys %completion), (map { "/$_" } keys %{$::CFG->{aliases}}));
649 my @buffers = map { $_ } list_buffers;
650
651 if ($idx == 0) {
652 for (@nicks) {
653 my $n = $_ . ":";
654 if ($n =~ /^\Q$word\E/) {
655 push @found, $n;
656 }
657 }
658
659 for (@commands) {
660 if (/^\Q$word\E/) {
661 push @found, $_;
662 }
663 }
664
665 } else {
666 for (@nicks) {
667 if (/^\Q$word\E/) {
668 push @found, $_;
669 }
670 }
671
672 for (@buffers) {
673 if (/^\Q$word\E/) {
674 push @found, $_;
675 }
676 }
677
678 for (@commands) {
679 if (/^\Q$word\E/) {
680 push @found, $_;
681 }
682 }
683 }
684
685 return "$found[0] " if @found == 1;
686
687 if (@found > 10) {
688 my $longest;
689 for (@found) { $longest = length $_ > $longest ? length $_ : $longest }
690
691 my %first_chars;
692 my $len = 1;
693 while ((keys %first_chars) <= 1 && $len < $longest) {
694 %first_chars = ();
695 for (@found) { $first_chars{(substr $_, 0, $len)} = 1 }
696 $len++;
697 }
698
699 print_temporary_line (undef, [t => 7, "$word: ", map { (3, "$_-", 0, ', ') } sort keys %first_chars], 1);
700 return find_common_prefix (keys %first_chars);
701
702 } elsif (@found) {
703 print_temporary_line (undef, [t => 7, "$word: ", map { (3, $_, 0, ', ') } @found], 1);
704 return find_common_prefix (@found);
705 }
706
707 return $word;
708 });
709
710 #####################################################################################
711
712 sub change_config_scheme {
713 my ($scheme) = @_;
714 $config_scheme = $scheme;
715 update_buffer_statusline;
716 }
717
718 sub load_config {
719 $JS->cl_config_get (bummskraut_1_0 => sub {
720 my ($JS, $ev, $packet, @arg) = @_;
721
722 if ($ev eq 'error') {
723 my ($src, $type, $ts, $content) = @arg;
724 write_errorline (undef, $ts, "Couldn't get config: ($type) $content");
725
726 } else {
727 my ($cfgname, $cfg) = @arg;
728 $CFG = $cfg;
729 change_config_scheme ($config_scheme); # just trigger an update
730 write_infoline ('status', time, "Retrieved config for '$cfgname' from server.");
731 }
732
733 1
734 });
735 }
736
737 sub save_config {
738 my ($act) = @_;
739
740 $JS->cl_config_set (bummskraut_1_0 => $CFG, sub {
741 my ($JS, $ev, $packet, @arg) = @_;
742 my ($id, $type, $ts, $content) = @arg;
743
744 if ($ev eq 'error') {
745 write_errorline (undef, $ts, "Couldn't save config: ($type) $content");
746 } else {
747 write_infoline (undef, $ts, "Saved config [$act]: ($type) $content");
748 }
749
750 1
751 });
752 }
753
754 #####################################################################################
755
756 sub disconnect_cleanup {
757 %buffer_nicks = ();
758 %buffer_states = ();
759 %id_aliases = ();
760 update_buffer_statusline;
761 }
762
763 sub connect_bummskraut {
764 if ($JS) { $JS->disconnect }
765
766 $JS = Net::Bummskraut::Connection->new;
767
768 $JS->reg_cb (
769 connect => sub {
770 my ($JS, $cl) = @_;
771 $JS->cl_hello;
772 1
773 },
774 auth_challenge => sub {
775 my ($JS, $packet, $challenge) = @_;
776 $JS->cl_auth_response (hmac_sha1_hex ($challenge, $AUTH_KEY));
777 0
778 },
779 hello => sub {
780 write_infoline (undef, undef, "Connected to bummskraut_server at $HOST:$PORT.");
781 load_config;
782 },
783 connect_error => sub {
784 my ($JS, $e) = @_;
785 write_errorline (undef, undef, "Error on connect to bummskraut_server at $HOST:$PORT: $e");
786 1
787 },
788 disconnect => sub {
789 write_errorline (undef, undef, "Lost connection to bummskraut_server at $HOST:$PORT: $_[1]");
790 disconnect_cleanup;
791
792 1
793 },
794 broadcast_relay => \&handle_broadcast_relay,
795 config_state => \&handle_config_state,
796 message => \&handle_message,
797 meta_message => \&handle_meta_message,
798 state_change => \&handle_state_change,
799 add_subid => \&handle_add_subid,
800 remove_subid => \&handle_remove_subid,
801 change_subid => \&handle_change_subid,
802 info => \&handle_info,
803 error => \&handle_error,
804 set_group => \&handle_set_group,
805 debug_recv => sub {
806 my ($JS, $packet) = @_;
807 printline (debug => [0, "<= $_"]) for split /\n/, JSON::XS->new->canonical (1)->encode ($packet);
808 1
809 },
810 debug_send => sub {
811 my ($JS, $packet) = @_;
812 printline (debug => [0, "=> $_"]) for split /\n/, JSON::XS->new->canonical (1)->encode ($packet);
813 1
814 }
815 );
816
817 $JS->connect ($HOST, $PORT);
818 }
819
820 #####################################################################################
821
822 Net::Bummskraut::CursesChatWindow::register_scroll_cb (sub {
823 my ($is_s) = @_;
824 $is_scrolled = $is_s;
825 update_buffer_statusline;
826 });
827
828 #####################################################################################
829
830 sub send_message {
831 my ($type, $content) = @_;
832 my $dest = "" . current_buffer ();
833 unless ($dest =~ m/^[^:]+:/) {
834 write_temp_error ("Can't send regular messages in this buffer: '$dest'.");
835 return;
836 }
837
838 $JS->cl_message ($dest, 'public', $type, $content, sub {
839 my ($JS, $ev, $packet, $src, $id, $ts) = @_;
840 return 0 if $ev eq 'message_sent';
841 write_errorline ($dest, $ts, "Couldn't send message to '$dest': '$content'");
842 });
843 }
844
845 my $input_cb;
846 Net::Bummskraut::CursesChatWindow::register_input_cb ($input_cb = sub {
847 my ($input, $escape) = @_;
848
849 unless (defined $input) {
850 my $cmd = $CFG->{buffers}->{$escape};
851 if ($cmd !~ m/^\//) {
852 push_buf_history ($cmd);
853 if (defined $cmd) {
854 change_buffer ($cmd || 'status');
855 } else {
856 change_buffer ('status');
857 }
858 return;
859 } else {
860 $input = $cmd;
861 }
862 }
863
864 if ($input =~ m/^\/goto\s*(\S+)/) {
865 push_buf_history ($1);
866 change_buffer ($1);
867
868 } elsif ($input =~ m/^\/next/) {
869 my $b = next_buf_history;
870 if (defined $b) {
871 change_buffer ($b) if defined $b;
872 } else {
873 write_temp_error ("There are no buffer histories left.");
874 }
875
876 } elsif ($input =~ m/^\/prev/) {
877 my $b = prev_buf_history;
878 if (defined $b) {
879 change_buffer ($b) if defined $b;
880 } else {
881 write_temp_error ("There are no buffer histories left.");
882 }
883
884 } elsif ($input =~ m/^\/pop/) {
885 if (my $buf = get_first_highlight ()) {
886 push_buf_history ($buf);
887 change_buffer ($buf);
888 } else {
889 write_temp_error ("There are no highlights to pop.");
890 }
891
892 } elsif ($input =~ m/^\/kill\s*(\S*)/) {
893 my $b = $1 ne '' ? $1 : current_buffer ();
894 change_buffer ('status')
895 if "$b" eq current_buffer ();
896 if (clear_buffer ($b) || "$b" eq current_buffer ()) {
897 write_temp_info ("Killed buffer '$b'.");
898 }
899
900 } elsif ($input =~ m/^\/bind\s*(\S)?(?:\s+(\S+))?/) {
901 if ($1 ne '') {
902 $CFG->{buffers}->{$1} = $2 ne '' ? $2 : current_buffer;
903 save_config ("added binding $1 => $2");
904 } else {
905 print_temporary_line (undef, [7, "bindings:"]);
906 for (sort keys %{$CFG->{buffers}}) {
907 print_temporary_line (undef,
908 [0, sprintf " '%1s' => %s", $_, $CFG->{buffers}->{$_}]
909 );
910 }
911 }
912
913 } elsif ($input =~ m/^\/unbind\s*(\S)/) {
914 delete $CFG->{buffers}->{$1};
915 save_config ("removed binding '$1'");
916
917 } elsif ($input =~ m/^\/list_subids/) {
918 my $id = current_buffer;
919
920 if (exists $buffer_nicks{$id}) {
921 my @subs = values %{$buffer_nicks{$id}};
922
923 for (sort { lc ($a->[1]) cmp lc ($b->[1]) } @subs) {
924 print_temporary_line ($id, [7, " *", 2, (sprintf " %-40s", $_->[0]), 0, " as ", 3, $_->[1]]);
925 }
926
927 print_temporary_line ($id, [7, scalar (@subs), 0, " sub IDs in ", 2, $id]);
928 } else {
929 write_temp_error ("This buffer has no sub IDs.");
930 }
931
932 } elsif ($input =~ m/^\/buffers\s*(?:-(\S+)\s*)?(.*?)\s*$/) {
933 my $rgx = $2 ne '' ? $2 : '';
934 my $opt = $1;
935 my %opts;
936 for (split //, $1) {
937 $opts{lc $_} = 1;
938 }
939
940 eval {
941 my @matches =
942 grep { $rgx ne '' ? ($opts{i} ? not ($_ =~ /$rgx/) : $_ =~ /$rgx/) : 1 }
943 (list_buffers ());
944
945 if ($opts{p}) {
946 @matches =
947 grep {
948 $buffer_states{$_} and $buffer_states{$_}->{state}->[0] ne 'n/a'
949 } @matches;
950 }
951
952 if ($opts{t}) {
953 @matches =
954 grep {
955 get_buffer_attr_tags ($_)
956 } @matches;
957 }
958
959 print_temporary_line (undef,
960 [7, scalar (@matches) . " "
961 . ($rgx ne ''
962 ? "buffers [opt: ".(join '', keys %opts)."] matching /$rgx/:"
963 : "buffers [opt: ".(join '', keys %opts)."]:")
964 ]
965 );
966
967 for my $id ( sort { lc ($a) cmp lc ($b) } @matches) {
968 my $tags = get_buffer_attr_tags ($id);
969 print_temporary_line (undef, ['p4',
970 67, (sprintf " %-40s ", $id),
971 5, (sprintf "%-5s",
972 ($tags ne '' ? "[$tags]" : "")),
973 0, sprintf " %s",
974 $id_aliases{$id} ? "(aka $id_aliases{$id})" : ''
975 ]);
976
977 if ($buffer_states{$id}) {
978 my $state = $buffer_states{$id}->{state}->[0];
979 my $color = $state eq 'present' ? 2 : 6;
980 print_temporary_line (undef, ['p6',
981 0, " - ",
982 $color, (sprintf "%-8s", $state),
983 0, ": " . $buffer_states{$id}->{state}->[1],
984 ]);
985 }
986
987 if ($opts{g}) {
988 if ($buffer_groups{$id} && @{$buffer_groups{$id}}) {
989 print_temporary_line (undef, ['p6', 0, " * ", 0, (join ", ", map { "'$_'" } @{$buffer_groups{$id}})]);
990 }
991 }
992 }
993 };
994 if ($@) {
995 write_temp_error ("Couldn't match buffers, bad regex?");
996 }
997
998 } elsif ($input =~ m/^\/colors/) {
999 Net::Bummskraut::CursesChatWindow::print_colors;
1000
1001 } elsif ($input =~ m/^\/clear_temporaries/) {
1002 clear_buffer_temporaries (current_buffer ());
1003
1004 } elsif ($input =~ m/^\/highlights_seen_global/) {
1005 clear_highlights ('local');
1006 $JS->cl_broadcast_relay (highlights_seen => bummskraut_1_0 => undef)
1007 if $JS;
1008
1009 } elsif ($input =~ m/^\/highlights_seen_local/) {
1010 clear_highlights ('local');
1011
1012 } elsif ($input =~ m/^\/highlights_seen/) {
1013 clear_highlights;
1014
1015 } elsif ($input =~ m/^\/config_scheme\s*(\S*)/) {
1016 if ($1 eq '') {
1017 write_temp_info ("Current config scheme: '$config_scheme'");
1018
1019 } else {
1020 change_config_scheme ($1);
1021 write_temp_info ("Config scheme changed to '$1'");
1022 }
1023
1024 } elsif ($input =~ m/^\/toggle_inhibit_highlight/) {
1025 set_buffer_attr (current_buffer (), 'inhibit_highlight');
1026
1027 } elsif ($input =~ m/^\/toggle_highlight_activity/) {
1028 set_buffer_attr (current_buffer (), 'highlight_activity');
1029
1030 } elsif ($input =~ m/^\/reconnect/) {
1031 connect_bummskraut;
1032
1033 } elsif ($input =~ m/^\/history\s*(.*)$/) {
1034 my $lines = $1;
1035 my $dest = "" . current_buffer ();
1036 unless ($dest =~ m/^[^:]+:/) {
1037 write_temp_error ("Can't send regular messages in this buffer: '$dest'.");
1038 return;
1039 }
1040
1041 $JS->cl_command_history (undef, $dest, $lines || 20);
1042
1043 } elsif ($input =~ m/^\/meta\s*(.*)$/) {
1044 my $meta = $1;
1045 my $dest = "" . current_buffer ();
1046 unless ($dest =~ m/^[^:]+:/) {
1047 write_temp_error ("Can't send regular messages in this buffer: '$dest'.");
1048 return;
1049 }
1050
1051 $JS->cl_meta_message ($dest, $meta, sub {
1052 my ($JS, $ev, $packet, @arg) = @_;
1053 my ($src, $type, $ts, $content) = @arg;
1054
1055 if ($ev eq 'error') {
1056 write_errorline ($dest, $ts, "Couldn't send meta message: '$meta': $content");
1057 } else {
1058 write_infoline ($dest, $ts, "Sent meta message: '$meta'.");
1059 }
1060 });
1061
1062 } elsif ($input =~ m/^\/raw\s*(.*)$/) {
1063 my $raw = $1;
1064 my $dest = "" . current_buffer ();
1065 unless ($dest =~ m/^[^:]+:/) {
1066 write_temp_error ("Can't send regular messages in this buffer: '$dest'.");
1067 return;
1068 }
1069
1070 $JS->cl_raw_message ($dest, $raw, sub {
1071 my ($JS, $ev, $packet, @arg) = @_;
1072 my ($src, $type, $ts, $content) = @arg;
1073
1074 if ($ev eq 'error') {
1075 write_errorline ($dest, $ts, "Couldn't send raw message: '$raw': $content");
1076 } else {
1077 write_infoline ($dest, $ts, "Sent raw message: '$raw'.");
1078 }
1079 });
1080
1081 } elsif ($input =~ m/^\/notice\s*(.*)$/) {
1082 send_message ('notice', $1);
1083
1084 } elsif ($input =~ m/^\/subscribe\s*(\S*)\s*$/) {
1085 my $id = $1 ne '' ? $1 : current_buffer;
1086 $JS->cl_subscribe ($id, sub {
1087 my ($JS, $ev, $packet, $src, $type, $ts, $content) = @_;
1088 push_buf_history ($id);
1089 if ($ev eq 'info') {
1090 change_buffer ($id);
1091 write_infoline (undef, $ts, "subscribe succeed: $content");
1092 } else {
1093 write_errorline (undef, $ts, "subscribe failed: $content");
1094 }
1095 1
1096 });
1097
1098 } elsif ($input =~ m/^\/unsubscribe\s*(\S*)\s*$/) {
1099 my $id = $1 ne '' ? $1 : current_buffer;
1100 $JS->cl_unsubscribe ($id, sub {
1101 my ($JS, $ev, $packet, $src, $type, $ts, $content) = @_;
1102 if ($ev eq 'info') {
1103 write_infoline (undef, $ts, "unsubscribe succeed: $content");
1104 } else {
1105 write_errorline (undef, $ts, "unsubscribe failed: $content");
1106 }
1107 1
1108 });
1109
1110 } elsif ($input =~ m/^\/alias\s*(\S*)\s*(.*)$/) {
1111 my ($newcmd, $cmd) = ($1, $2);
1112 if ($newcmd ne '') {
1113 $::CFG->{aliases}->{$1} = $2;
1114 save_config ("Added alias /$1 => '$2'");
1115 } else {
1116 print_temporary_line (undef, [7, 'aliases:']);
1117 for (keys %{$::CFG->{aliases}}) {
1118 print_temporary_line (undef, [
1119 0, ' /', 0, (sprintf "%-15s", $_), 0, ' => ', 0, $::CFG->{aliases}->{$_}
1120 ]);
1121 }
1122 }
1123
1124 } elsif ($input =~ m/^\/unalias\s*(\S+)/) {
1125 my $alias = delete $::CFG->{aliases}->{$1};
1126 if (defined $alias) {
1127 save_config ("Removed alias /$1 => $alias");
1128 } else {
1129 write_temp_error ("No such alias: '$1'");
1130 }
1131
1132 } elsif ($input =~ m/^\/exit/) {
1133 exit
1134
1135 } elsif ($input =~ m/^\/help/) {
1136 print_temporary_line (undef, [7, 'Bummskraut client commands:']);
1137 for (@command_help) {
1138 if (length $_->[0] > 30) {
1139 print_temporary_line (undef, [0, ' ', 7, $_->[0]]);
1140 print_temporary_line (undef, ['p4', 0, ' - ', 0, $_->[1]]);
1141 } else {
1142 print_temporary_line (undef, ['p33', 0, ' ', 7, (sprintf "%-30s ", $_->[0]), 0, '- ', 0, $_->[1]]);
1143 }
1144 }
1145 print_temporary_line (undef,
1146 [
1147 70, "For more help, please type '",
1148 64, "perldoc bummskraut",
1149 70, "' in your favorite terminal and read it."
1150 ]
1151 );
1152 print_temporary_line (undef,
1153 [6, '(To clear this output use: /clear_temporaries)']
1154 );
1155
1156 } elsif ($input =~ m/^\/set_groups\s*(.*)$/) {
1157 my (@grp) = split /,/, $1;
1158 my $id = current_buffer;
1159 $JS->cl_set_group ($id, \@grp, sub {
1160 my ($JS, $ev, $packet, $src, $type, $ts, $content) = @_;
1161 if ($ev eq 'error') {
1162 write_errorline ($id, $ts, "Couldn't set groups for $id: $content");
1163 } else {
1164 write_infoline ($id, $ts, "Successfully set groups for $id.");
1165 }
1166 1
1167 });
1168
1169 } elsif ($input =~ m/^\/set_nick\s*(.*)$/) {
1170 my $nick = $1;
1171 $nick =~ s/^\s*(.*?)\s*$/\1/;
1172 my $id = current_buffer;
1173 $JS->cl_set_nick ($id, $nick, sub {
1174 my ($JS, $ev, $packet, $src, $type, $ts, $content) = @_;
1175 if ($ev eq 'error') {
1176 write_errorline ($id, $ts, "Couldn't set nick for $id: $content");
1177 } else {
1178 write_infoline ($id, $ts, "Successfully set nick for $id.");
1179 }
1180 1
1181 });
1182
1183 } elsif ($input =~ m/^\/(xa|dnd|away|present)\s*(.*)$/) {
1184 $JS->cl_set_presence ($1, $2 ne '' ? $2 : undef);
1185
1186 } elsif ($input =~ m/^\/(\S+)\s*(.*)$/) {
1187 if (exists $::CFG->{aliases}->{$1}) {
1188 $input_cb->($::CFG->{aliases}->{$1} . " " . $2);
1189 } else {
1190 write_temp_error ("Not a recognized command or alias: '$input'");
1191 }
1192
1193 } else {
1194 send_message ('normal', $input);
1195 }
1196 });
1197
1198 #####################################################################################
1199
1200 read_auth_key;
1201
1202 my $c = AnyEvent->condvar;
1203
1204 Net::Bummskraut::CursesChatWindow::init;
1205 change_buffer ('status');
1206 write_infoline ('status', undef, 70,
1207 "Welcome to the Bummskraut client, please type '/help' for some clues!"
1208 );
1209 write_infoline ('status', undef, 70,
1210 "For information about IRC configuration type 'help' in the cfg:irc buffer: /goto cfg:irc"
1211 );
1212 #write_infoline ('status', undef, 70,
1213 # "For information about Jabber configuration type 'help' in the cfg:xmpp buffer: /goto cfg:xmpp"
1214 #);
1215
1216 connect_bummskraut;
1217
1218 $c->wait;
1219
1220 Net::Bummskraut::CursesChatWindow::end;
1221
1222 __DATA__
1223
1224 =head1 NAME
1225
1226 bummskraut - A chat client framework
1227
1228 =head1 SYNOPSIS
1229
1230 bummskraut_server [<backend-port>]
1231 bummskraut [<backend-host> <backend-port>]
1232
1233 Example:
1234
1235 # nohup bummskraut_server >/dev/null 2>/dev/null &
1236 # bummskraut
1237
1238 =head1 DESCRIPTION
1239
1240 Welcome to the chat client framework 'Bummskraut'.
1241 It's aim is to provide a unique interface to multiple chat protocols.
1242
1243 As you might have some questions, the FAQ as first:
1244
1245 =head1 FAQ
1246
1247 Q: I'm getting:
1248 'ERROR: Error on connect to bummskraut_server at localhost:1236: Connection refused'
1249 on startup of the client.
1250 A: You need to start the backend first: See below in L</Starting the backend>.
1251
1252 Q: I'm getting: 'Couldn't open ~/.bummskraut_key: No such file or directory.'
1253 when starting the bummskraut frontend.
1254 A: You need to start the backend first or create a file called '.bummskraut_key'
1255 in the home directory of the bummskraut frontend which contains
1256 the authorisation key which is printed to STDOUT by the backend on startup.
1257
1258 =head1 MANUAL
1259
1260 =head2 Starting the backend
1261
1262 Starting the backend is an easy job, you either run the backend in C<screen>
1263 or just use this line to start the backend in the background.
1264
1265 # nohup bummskraut_server >/dev/null 2>/dev/null &
1266
1267 I recommend to start the backend in a screen, so you might have a chance to look at
1268 the debug logs, you could also just use C<nohup> and redirect the output of course.
1269
1270 =head2 Starting the client
1271
1272 I assume you started the backend as described above in L<Starting the backend>.
1273
1274 You simply start the client by this:
1275
1276 # bummskraut
1277
1278 Or if the backend runs somewhere else you might want to give the frontend
1279 the hostname and port to contact, for that you might start the client like this:
1280
1281 # bummskraut <host> <port>
1282
1283 =head1 AUTHOR
1284
1285 Robin Redeker, C<< <elmex at ta-sa.org> >>
1286
1287 =head1 ACKNOWLEDGEMENTS
1288
1289 =head1 COPYRIGHT & LICENSE
1290
1291 Copyright 2007 Robin Redeker, all rights reserved.
1292
1293 This program is free software; you can redistribute it and/or modify it
1294 under the same terms as Perl itself.