| 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. |
