| 1 |
#!/opt/perl/bin/perl |
| 2 |
use strict; |
| 3 |
use utf8; |
| 4 |
use URI; |
| 5 |
use JSONConnection; |
| 6 |
use JSON::Syck; |
| 7 |
use POSIX qw(strftime); |
| 8 |
use CursesChatMainwindow; |
| 9 |
|
| 10 |
our $id_seq = 0; |
| 11 |
|
| 12 |
my $HOST = 'localhost'; |
| 13 |
my $PORT = 1236; |
| 14 |
|
| 15 |
our @highlight; |
| 16 |
our $CFG; |
| 17 |
our $js; |
| 18 |
our %buffer_nicks; |
| 19 |
our %on_reply; |
| 20 |
our %buffer_attrs; |
| 21 |
|
| 22 |
our %completion = map { $_ => 1 } qw{ |
| 23 |
/goto |
| 24 |
/kill |
| 25 |
/colors |
| 26 |
/clear_temporaries |
| 27 |
/buffers |
| 28 |
/toggle_inhibit_highlight |
| 29 |
/toggle_highlight_activity |
| 30 |
/reload |
| 31 |
/remote_reload |
| 32 |
/reconnect |
| 33 |
/pop |
| 34 |
}; |
| 35 |
|
| 36 |
our $temporary_timer; |
| 37 |
sub start_temporary_killer { |
| 38 |
my ($buffer, $timeout) = @_; |
| 39 |
$::temporary_timer = AnyEvent->timer (after => $timeout || 4, cb => sub { |
| 40 |
clear_buffer_temporaries ($buffer); |
| 41 |
$temporary_timer = undef; |
| 42 |
}); |
| 43 |
} |
| 44 |
|
| 45 |
sub on_reply { |
| 46 |
my ($id, $cb) = @_; |
| 47 |
push @{$on_reply{$id}}, $cb; |
| 48 |
} |
| 49 |
|
| 50 |
sub do_reply { |
| 51 |
my ($id, $status, $data) = @_; |
| 52 |
for my $cb (@{$on_reply{$id} || []}) { |
| 53 |
$cb->($status, $data); |
| 54 |
} |
| 55 |
delete $on_reply{$id}; |
| 56 |
} |
| 57 |
|
| 58 |
sub print_temporary_line { |
| 59 |
my ($buffer, $line, $timeout) = @_; |
| 60 |
$buffer = current_buffer () unless defined $buffer; |
| 61 |
unshift @$line, 't'; |
| 62 |
printline ($buffer, $line); |
| 63 |
if ($timeout) { |
| 64 |
start_temporary_killer ($buffer); |
| 65 |
} |
| 66 |
} |
| 67 |
|
| 68 |
sub write_chatline { |
| 69 |
my ($buffer, $id, $time, $msg, $is_echo, $type, $msg_scope, $highlight) = @_; |
| 70 |
my ($host, $nick) = get_id_parts ($id); |
| 71 |
|
| 72 |
my $nick_color = |
| 73 |
$is_echo |
| 74 |
? 0 |
| 75 |
: ( |
| 76 |
$msg_scope eq 'private' |
| 77 |
? 4 |
| 78 |
: ($highlight ? 70 : 7) |
| 79 |
); |
| 80 |
my $ts = POSIX::strftime ("%T", localtime ($time)); |
| 81 |
|
| 82 |
my ($adel, $bdel) = ('<', '>'); |
| 83 |
if ($type eq 'notice') { |
| 84 |
($adel, $bdel) = ('{', '}'); |
| 85 |
} |
| 86 |
|
| 87 |
my (@chatline) = ( |
| 88 |
("p".(length ($ts) + 4 + length ($nick))), |
| 89 |
# 0, "[$host] ", |
| 90 |
0, $ts, |
| 91 |
0, " $adel", |
| 92 |
$nick_color, "$nick", |
| 93 |
0, "$bdel ", |
| 94 |
0, $msg); |
| 95 |
|
| 96 |
printline ($buffer, \@chatline); |
| 97 |
} |
| 98 |
|
| 99 |
sub write_infoline { |
| 100 |
my ($buffer, $time, $msg) = @_; |
| 101 |
unless (defined $buffer) { |
| 102 |
write_infoline (status => $time, $msg); |
| 103 |
write_infoline (current_buffer () => $time, $msg) if current_buffer () ne 'status'; |
| 104 |
return; |
| 105 |
} |
| 106 |
|
| 107 |
my $ts = POSIX::strftime ("%T", localtime ($time || time ())); |
| 108 |
my (@chatline) = (("p".length $ts), 0, $ts, 0, " ", 3, $msg); |
| 109 |
printline ($buffer, \@chatline); |
| 110 |
} |
| 111 |
|
| 112 |
sub write_errorline { |
| 113 |
my ($buffer, $time, $msg) = @_; |
| 114 |
unless (defined $buffer) { |
| 115 |
write_errorline (status => $time, $msg); |
| 116 |
write_errorline (current_buffer () => $time, $msg) if current_buffer () ne 'status'; |
| 117 |
return; |
| 118 |
} |
| 119 |
|
| 120 |
my $ts = POSIX::strftime ("%T", localtime ($time || time ())); |
| 121 |
my (@chatline) = (("p".length $ts), 0, $ts, 0, " ", 68, "ERROR: ", 4, $msg); |
| 122 |
printline ($buffer, \@chatline); |
| 123 |
} |
| 124 |
|
| 125 |
sub load_cfg { |
| 126 |
$CFG ||= {}; |
| 127 |
return unless -e "$ENV{HOME}/.jsonircclrc"; |
| 128 |
open CFGH, "<", "$ENV{HOME}/.jsonircclrc" or die "Couldn't open ~/.jsonircclrc: $!"; |
| 129 |
$::CFG = JSON::Syck::Load (do { local $/; <CFGH> }); |
| 130 |
} |
| 131 |
|
| 132 |
sub get_first_highlight { |
| 133 |
return $highlight[0]; |
| 134 |
} |
| 135 |
|
| 136 |
sub maybe_pop_highlight { |
| 137 |
my ($buffer) = @_; |
| 138 |
@highlight = grep { $buffer ne $_ } @highlight; |
| 139 |
printline (msgline => [map { (103, $_, 0, ' ') } @highlight]); |
| 140 |
} |
| 141 |
|
| 142 |
sub push_highlight { |
| 143 |
my ($id) = @_; |
| 144 |
|
| 145 |
unless (grep { $_ eq $id } (@highlight, current_buffer ())) { |
| 146 |
push @highlight, $id; |
| 147 |
printline (msgline => [map { (103, $_, 0, ' ') } @highlight]); |
| 148 |
} |
| 149 |
} |
| 150 |
|
| 151 |
sub set_buffer_attr { |
| 152 |
my ($buf, $attr, $flag) = @_; |
| 153 |
if (defined $flag) { |
| 154 |
$buffer_attrs{$buf}->{$attr} = $flag; |
| 155 |
} else { |
| 156 |
$buffer_attrs{$buf}->{$attr} = not $buffer_attrs{$buf}->{$attr}; |
| 157 |
} |
| 158 |
update_buffer_statusline ($buf); |
| 159 |
} |
| 160 |
|
| 161 |
sub update_buffer_statusline { |
| 162 |
my ($buf) = @_; |
| 163 |
|
| 164 |
my @add_info; |
| 165 |
if ($buf =~ /^jsirc:/) { |
| 166 |
my $u = URI->new ($buf); |
| 167 |
my @ps = $u->path_segments (); |
| 168 |
push @add_info, |
| 169 |
11, '{'.$u->scheme.'} ', |
| 170 |
14, $ps[1], |
| 171 |
11, '@', 13, $u->authority; |
| 172 |
} |
| 173 |
push @add_info, 76, " [inhib act]" if $buffer_attrs{$buf}->{inhibit_highlight}; |
| 174 |
push @add_info, 12, " [highlight act]" if $buffer_attrs{$buf}->{highlight_activity}; |
| 175 |
printline (statusline => [11, "$buf | ", @add_info, 'f', 11, ""]); |
| 176 |
} |
| 177 |
|
| 178 |
sub change_buffer { |
| 179 |
my ($new_buf) = @_; |
| 180 |
maybe_pop_highlight ($new_buf); |
| 181 |
select_buffer ($new_buf); |
| 182 |
update_buffer_statusline ($new_buf); |
| 183 |
} |
| 184 |
|
| 185 |
sub get_id_parts { |
| 186 |
my ($id) = @_; |
| 187 |
my $uri = URI->new ($id); |
| 188 |
my $a = $uri->authority; |
| 189 |
my $p = ($uri->path_segments ())[1]; |
| 190 |
($a, $p) |
| 191 |
} |
| 192 |
|
| 193 |
sub prettyfy_id { |
| 194 |
my ($id) = @_; |
| 195 |
my ($a, $p) = get_id_parts ($id); |
| 196 |
"$a/$p" |
| 197 |
} |
| 198 |
|
| 199 |
sub protocolize_id { |
| 200 |
my ($pretty_id) = @_; |
| 201 |
if ($pretty_id =~ m/^([^\/]+)\/?(.*)$/) { |
| 202 |
my ($auth, $path) = ($1, $2); |
| 203 |
my $uri = URI->new; |
| 204 |
$uri->scheme ('jsirc'); |
| 205 |
$uri->authority ($auth); |
| 206 |
$uri->path ($path); |
| 207 |
return "$uri"; |
| 208 |
} |
| 209 |
undef |
| 210 |
} |
| 211 |
|
| 212 |
sub connect_json { |
| 213 |
eval { |
| 214 |
$js->connect ($1 || $HOST, $2 || $PORT); |
| 215 |
}; |
| 216 |
if ($@) { |
| 217 |
write_errorline (undef, undef, "Error on connect to jsonsrv at $HOST:$PORT: $@"); |
| 218 |
} else { |
| 219 |
write_infoline (undef, undef, "Connected to jsonsrv at $HOST:$PORT."); |
| 220 |
} |
| 221 |
} |
| 222 |
|
| 223 |
load_cfg (); |
| 224 |
|
| 225 |
my $c = AnyEvent->condvar; |
| 226 |
|
| 227 |
#timer (); |
| 228 |
|
| 229 |
$js = |
| 230 |
JSONClientConnection->new ( |
| 231 |
packet_cb => sub { |
| 232 |
my ($js, $data) = @_; |
| 233 |
require JSON::Syck; |
| 234 |
|
| 235 |
if ($data->{type} eq 'message' or $data->{type} eq 'notice') { |
| 236 |
my ($src_id) = ($data->{src}); |
| 237 |
|
| 238 |
my $highlight = 0; |
| 239 |
unless ($buffer_attrs{$src_id}->{inhibit_highlight}) { |
| 240 |
if ($buffer_attrs{$src_id}->{highlight_activity} |
| 241 |
or $data->{msg_scope} eq 'private') |
| 242 |
{ |
| 243 |
push_highlight ($src_id); |
| 244 |
} else { |
| 245 |
for (@{$::CFG->{highlight}}) { |
| 246 |
if ($data->{message} =~ m/$_/) { |
| 247 |
push_highlight ($src_id); |
| 248 |
$highlight = 1; |
| 249 |
last; |
| 250 |
} |
| 251 |
} |
| 252 |
} |
| 253 |
} |
| 254 |
|
| 255 |
write_chatline ($src_id, $data->{from}->{id}, $data->{timestamp}, $data->{message}, $data->{is_echo}, $data->{type}, $data->{msg_scope}, $highlight); |
| 256 |
|
| 257 |
} elsif ($data->{type} eq 'subid') { |
| 258 |
my $src_id = $data->{src}; |
| 259 |
my $it = $data->{command}; |
| 260 |
|
| 261 |
if ($it eq 'add') { |
| 262 |
for (@{$data->{ids}}) { |
| 263 |
my ($h, $n) = get_id_parts ($_); |
| 264 |
$buffer_nicks{$src_id}->{$n} = 1; |
| 265 |
} |
| 266 |
write_infoline ($src_id, $data->{timestamp}, |
| 267 |
"sub id add: " . join (', ', map { prettyfy_id ($_) } sort @{$data->{ids}})); |
| 268 |
|
| 269 |
} elsif ($it eq 'remove') { |
| 270 |
for (@{$data->{ids}}) { |
| 271 |
my ($h, $n) = get_id_parts ($_); |
| 272 |
delete $buffer_nicks{$src_id}->{$n}; |
| 273 |
} |
| 274 |
write_infoline ($src_id, $data->{timestamp}, |
| 275 |
"sub id remove: " . join (', ', map { prettyfy_id ($_) } sort @{$data->{ids}})); |
| 276 |
} elsif ($it eq 'change') { |
| 277 |
my ($oh, $on) = get_id_parts ($data->{old_id}); |
| 278 |
delete $buffer_nicks{$src_id}->{$on}; |
| 279 |
my ($h, $n) = get_id_parts ($data->{new_id}); |
| 280 |
$buffer_nicks{$src_id}->{$n} = 1; |
| 281 |
|
| 282 |
write_infoline ($src_id, $data->{timestamp}, |
| 283 |
"sub id change: " . prettyfy_id ($data->{old_id}) . " => " . prettyfy_id ($data->{new_id})); |
| 284 |
|
| 285 |
} elsif ($it eq 'list') { |
| 286 |
$buffer_nicks{$src_id} = {}; |
| 287 |
for (@{$data->{ids}}) { |
| 288 |
my ($h, $n) = get_id_parts ($_); |
| 289 |
$buffer_nicks{$src_id}->{$n} = 1 |
| 290 |
} |
| 291 |
write_infoline ($src_id, $data->{timestamp}, |
| 292 |
"sub id list: " . join (', ', map { prettyfy_id ($_) } sort @{$data->{ids}})); |
| 293 |
|
| 294 |
|
| 295 |
} elsif ($it eq 'special') { |
| 296 |
write_infoline ($src_id, $data->{timestamp}, "[$data->{message}]"); |
| 297 |
} |
| 298 |
|
| 299 |
} elsif ($data->{type} eq 'info') { |
| 300 |
write_infoline (undef, $data->{timestamp} => $data->{message}); |
| 301 |
do_reply ($data->{id}, info => $data); |
| 302 |
|
| 303 |
} elsif ($data->{type} eq 'error') { |
| 304 |
do_reply ($data->{id}, 'error' => $data); |
| 305 |
write_errorline (undef, $data->{timestamp}, "$data->{error_type}: $data->{message}"); |
| 306 |
|
| 307 |
} elsif ($data->{type} eq 'reply') { |
| 308 |
do_reply ($data->{id}, 'reply' => $data); |
| 309 |
} |
| 310 |
|
| 311 |
printline (debug => [0, JSON::Syck::Dump ($data)]); |
| 312 |
}, |
| 313 |
disconnect_cb => sub { |
| 314 |
write_errorline (undef, undef, "Lost connection to jsonsrv: $_[0]"); |
| 315 |
} |
| 316 |
); |
| 317 |
|
| 318 |
CursesChatMainwindow::init; |
| 319 |
|
| 320 |
change_buffer ('status'); |
| 321 |
connect_json; |
| 322 |
|
| 323 |
sub find_common_prefix { |
| 324 |
my (@words) = @_; |
| 325 |
@words = sort { length ($a) <=> length ($b) } @words; |
| 326 |
my $shortest = $words[0]; |
| 327 |
|
| 328 |
while ($shortest ne '') { |
| 329 |
my $no_match = 0; |
| 330 |
for (@words) { |
| 331 |
unless (/^\Q$shortest\E/) { |
| 332 |
$no_match = 1; |
| 333 |
last; |
| 334 |
} |
| 335 |
} |
| 336 |
|
| 337 |
return $shortest if not $no_match; |
| 338 |
substr $shortest, -1, 1, ''; |
| 339 |
} |
| 340 |
|
| 341 |
return ''; |
| 342 |
} |
| 343 |
|
| 344 |
CursesChatMainwindow::register_complete_cb (sub { |
| 345 |
my ($word, $idx, @line) = @_; |
| 346 |
|
| 347 |
# TODO: make completion cycling with $first_compl |
| 348 |
#d# printline (undef, [0, "[$idx] [$word]"]); |
| 349 |
|
| 350 |
my @found; |
| 351 |
|
| 352 |
if ($idx == 0) { |
| 353 |
for (keys %{$buffer_nicks{current_buffer ()} || {}}) { |
| 354 |
my $n = $_ . ":"; |
| 355 |
if ($n =~ /^\Q$word\E/) { |
| 356 |
push @found, $n; |
| 357 |
} |
| 358 |
} |
| 359 |
|
| 360 |
for (keys %completion) { |
| 361 |
if (/^\Q$word\E/) { |
| 362 |
push @found, $_; |
| 363 |
} |
| 364 |
} |
| 365 |
|
| 366 |
} else { |
| 367 |
my %buffers = map { $_ => 1 } list_buffers; |
| 368 |
|
| 369 |
for (keys %{$buffer_nicks{current_buffer ()} || {}}) { |
| 370 |
if (/^\Q$word\E/) { |
| 371 |
push @found, $_; |
| 372 |
} |
| 373 |
} |
| 374 |
|
| 375 |
for (keys %buffers) { |
| 376 |
if (m/^jsirc:/) { |
| 377 |
my $pi = prettyfy_id ($_); |
| 378 |
if ($pi =~ /^\Q$word\E/) { |
| 379 |
push @found, $pi; |
| 380 |
} |
| 381 |
} else { |
| 382 |
if (/^\Q$word\E/) { |
| 383 |
push @found, $_; |
| 384 |
} |
| 385 |
} |
| 386 |
} |
| 387 |
} |
| 388 |
|
| 389 |
return "$found[0] " if @found == 1; |
| 390 |
|
| 391 |
if (@found > 10) { |
| 392 |
my $longest; |
| 393 |
for (@found) { $longest = length $_ > $longest ? length $_ : $longest } |
| 394 |
|
| 395 |
my %first_chars; |
| 396 |
my $len = 1; |
| 397 |
while ((keys %first_chars) <= 1 && $len < $longest) { |
| 398 |
%first_chars = (); |
| 399 |
for (@found) { $first_chars{(substr $_, 0, $len)} = 1 } |
| 400 |
$len++; |
| 401 |
} |
| 402 |
|
| 403 |
print_temporary_line (undef, [t => 7, "$word: ", map { (3, "$_-", 0, ', ') } sort keys %first_chars], 1); |
| 404 |
return find_common_prefix (keys %first_chars); |
| 405 |
|
| 406 |
} elsif (@found) { |
| 407 |
print_temporary_line (undef, [t => 7, "$word: ", map { (3, $_, 0, ', ') } @found], 1); |
| 408 |
return find_common_prefix (@found); |
| 409 |
} |
| 410 |
|
| 411 |
return $word; |
| 412 |
}); |
| 413 |
|
| 414 |
CursesChatMainwindow::register_input_cb (sub { |
| 415 |
my ($input, $escape) = @_; |
| 416 |
|
| 417 |
unless (defined $input) { |
| 418 |
if (exists $CFG->{buffers}->{$escape}) { |
| 419 |
change_buffer (my $buf = $CFG->{buffers}->{$escape} || 'status'); |
| 420 |
} else { |
| 421 |
change_buffer ('status'); |
| 422 |
} |
| 423 |
return; |
| 424 |
} |
| 425 |
|
| 426 |
if ($input =~ m/^\/goto\s*(\S+)/) { |
| 427 |
my $buf = $1; |
| 428 |
if ($buf =~ m/^[^\/:]+\/\S*$/) { |
| 429 |
change_buffer (protocolize_id ($buf)); |
| 430 |
} else { |
| 431 |
change_buffer ("$buf"); |
| 432 |
} |
| 433 |
|
| 434 |
} elsif ($input =~ m/^\/kill\s*(\S+)/) { |
| 435 |
change_buffer ('status') if "$1" eq current_buffer (); |
| 436 |
if (clear_buffer ("$1") or "$1" eq current_buffer ()) { |
| 437 |
write_infoline (undef, undef, "Killed buffer '$1'."); |
| 438 |
} |
| 439 |
|
| 440 |
} elsif ($input =~ m/^\/buffers/) { |
| 441 |
print_temporary_line (undef, [0, "buffers:"]); |
| 442 |
for (sort { $a cmp $b } (list_buffers ())) { |
| 443 |
if (/^jsirc:/) { |
| 444 |
print_temporary_line (undef, ['p12', 0, sprintf "- (%6s) | %s", 'jsirc', prettyfy_id ($_)]); |
| 445 |
} else { |
| 446 |
print_temporary_line (undef, ['p12', 0, sprintf "- (%6s) | %s", 'other', $_]); |
| 447 |
} |
| 448 |
} |
| 449 |
|
| 450 |
} elsif ($input =~ m/^\/colors/) { |
| 451 |
CursesChatMainwindow::print_colors; |
| 452 |
|
| 453 |
} elsif ($input =~ m/^\/clear_temporaries/) { |
| 454 |
clear_buffer_temporaries (current_buffer ()); |
| 455 |
|
| 456 |
} elsif ($input =~ m/^\/toggle_inhibit_highlight/) { |
| 457 |
set_buffer_attr (current_buffer (), 'inhibit_highlight'); |
| 458 |
|
| 459 |
} elsif ($input =~ m/^\/toggle_highlight_activity/) { |
| 460 |
set_buffer_attr (current_buffer (), 'highlight_activity'); |
| 461 |
|
| 462 |
} elsif ($input =~ m/^\/reconnect\s*(\S*)\s*(\S*)/) { |
| 463 |
connect_json; |
| 464 |
|
| 465 |
} elsif ($input =~ m/^\/raw\s+(.*)$/) { |
| 466 |
my $raw = $1; |
| 467 |
my $dest_id = "" . current_buffer (); |
| 468 |
unless ($dest_id =~ m/^[^:]+:/) { |
| 469 |
write_errorline ($dest_id, undef, "Can't send regular messages in this buffer: '$dest_id'."); |
| 470 |
return; |
| 471 |
} |
| 472 |
|
| 473 |
my $msg = { |
| 474 |
type => 'raw', |
| 475 |
dest => $dest_id, |
| 476 |
message => $raw, |
| 477 |
id => $id_seq |
| 478 |
}; |
| 479 |
|
| 480 |
$js->send_data ($msg); |
| 481 |
|
| 482 |
on_reply ($id_seq => sub { |
| 483 |
if ($_[0] eq 'error') { |
| 484 |
write_errorline ($dest_id, undef, "Couldn't send raw message: '$raw': $_[1]->{message}"); |
| 485 |
} else { |
| 486 |
write_infoline ($dest_id, undef, "Sent raw message: '$raw'."); |
| 487 |
} |
| 488 |
}); |
| 489 |
|
| 490 |
$id_seq++; |
| 491 |
} elsif ($input =~ m/^\/reload/) { |
| 492 |
load_cfg (); |
| 493 |
|
| 494 |
} elsif ($input =~ m/^\/remote_reload/) { |
| 495 |
$js->send_data ({ type => 'command', command => 'reload', id => $id_seq }); |
| 496 |
on_reply ($id_seq => sub { write_infoline (undef, undef, "reloaded jsonsrv") }); |
| 497 |
$id_seq++; |
| 498 |
|
| 499 |
} elsif ($input =~ m/^\/pop/) { |
| 500 |
my $buf = get_first_highlight (); |
| 501 |
if (my $buf = get_first_highlight ()) { |
| 502 |
change_buffer ($buf); |
| 503 |
} else { |
| 504 |
write_errorline (current_buffer (), undef, "There are no highlights to pop."); |
| 505 |
} |
| 506 |
|
| 507 |
} elsif ($input =~ m/^\//) { |
| 508 |
write_errorline (current_buffer (), undef, "Not a recognized command: '$input'"); |
| 509 |
|
| 510 |
} else { |
| 511 |
my $dest_id = "" . current_buffer (); |
| 512 |
unless ($dest_id =~ m/^[^:]+:/) { |
| 513 |
write_errorline ($dest_id, undef, "Can't send regular messages in this buffer: '$dest_id'."); |
| 514 |
return; |
| 515 |
} |
| 516 |
|
| 517 |
my $msg = { |
| 518 |
type => 'message', |
| 519 |
dest => $dest_id, |
| 520 |
message => $input, |
| 521 |
id => $id_seq |
| 522 |
}; |
| 523 |
|
| 524 |
$js->send_data ($msg); |
| 525 |
printline (debug => [0, JSON::Syck::Dump ($msg)]); |
| 526 |
|
| 527 |
on_reply ($id_seq => sub { |
| 528 |
if ($_[0] eq 'error') { |
| 529 |
write_errorline ($dest_id, time, "Couldn't send message: '$input': $_[1]->{message}"); |
| 530 |
} |
| 531 |
}); |
| 532 |
|
| 533 |
$id_seq++; |
| 534 |
} |
| 535 |
}); |
| 536 |
|
| 537 |
$c->wait; |
| 538 |
|
| 539 |
CursesChatMainwindow::end; |
