#!/opt/perl/bin/perl
use strict;
use Event;
use AnyEvent;
use Net::Bummskraut::Connection;
use Net::Bummskraut::Util;
use POSIX qw/strftime/;
use Net::Bummskraut::CursesChatWindow;
use Digest::HMAC_SHA1 qw/hmac_sha1_hex/;
use JSON::XS;

our $JS;

our $TSFORMAT="%d %T";
our $CFG;
our $AUTH_KEY;
our $config_scheme = $ARGV[2] || 'default';
our @highlight;
our @buffer_history;
our @buffer_history_prev;
our $temporary_timer;
our %buffer_nicks;
our %buffer_states;
our %buffer_groups;
our %id_aliases;
our $is_scrolled;

our $HOST = $ARGV[0] || 'localhost';
our $PORT = $ARGV[1] || 16100;

#####################################################################################

sub read_auth_key {
   open my $k, $ENV{HOME}."/.bummskraut_key"
      or die "Couldn't open $ENV{HOME}/.bummskraut_key: $!.\n"
            ."It is needed for authentication!\n"
            ."Get it from the bummskraut_server output.\n";
   $AUTH_KEY = do { local $/; <$k> };
   $AUTH_KEY =~ s/\s+//g;
}

#####################################################################################

our %completion = map { $_ => 1 } qw{
   /goto
   /pop
   /prev
   /next
   /kill
   /buffers

   /set_nick
   /set_groups

   /xa
   /away
   /dnd
   /present

   /alias
   /unalias
   /bind
   /unbind
   /list_subids

   /help

   /colors
   /clear_temporaries
   /toggle_inhibit_highlight
   /toggle_highlight_activity
   /config_scheme

   /highlights_seen
   /highlights_seen_global
   /highlights_seen_local

   /meta
   /history
   /subscribe
   /unsubscribe

   /reconnect
   /exit
};

our @command_help = (
   ['/goto <buffer>'       , 'Swaps to another buffer'],
   ['/pop'                 , 'Jumps to the first buffer displayed in the highlight line'],
   ['/prev'                , 'Jumps to the previous shown buffer'],
   ['/next'                , 'If you used /prev this command will jump back again'],
   ['/buffers [-(t|p|g|i)+] [<regex>]'   , 'List all buffers (also by <regex> optionally)'],
   ['/alias [<newname> <command line>]',
                             'Creates a new alias for <command line> and makes it '
                             .'available as /<newname>. If called without parameters '
                             .'it lists all defined aliases.'],
   ['/unalias <name>'      , 'Removes an alias.'],
   ['/bind <char> [(<buffer>|/<command> <args>)]',
                             'Binds META+<char> to jump to the buffer <buffer> or '
                             .'execute an command. If called without buffer or command '
                             .'argument the current buffer will be bound. If called '
                             .'without any argument the currently defined bindings '
                             .'will be listed.'],
   ['/unbind <char>'       , 'Removes a binding'],
   ['/list_subids'         , 'Lists all sub IDs of the current buffer (if any).'],

   ['/help [<topic>]'      , 'This text (without the <topic> argument).'],
   ['/colors'              , 'A debugging command to show all possible colors'],
   ['/config_scheme <name>', 'Sets the scheme of the configuration.'],

   ['/clear_temporaries'   , 'Clears temporary text from your buffer, '
                             .'(for example completion guides or /buffers, and other stuff)'],
   ['/highlights_seen'     , 'Clears the highlight line (the listed highlights also in other frontends)'],
   ['/xa'                  , 'Sets your presence to extended away'],
   ['/dnd'                  , 'Sets your presence to do not disturb'],
   ['/away'                  , 'Sets your presence to away'],
   ['/present'                  , 'Sets your presence to present'],
   ['/highlights_seen_local' , 'Clears the highlight line (only in this frontends)'],
   ['/highlights_seen_global', 'Clears the highlight line in all frondends completly'],
   ['/toggle_inhibit_highlight', 'Will inhibit any highlighting of the currently '
                                 .'selected buffer'],
   ['/toggle_highlight_activity', 'Will highlight any activity in the currently '
                                  .'selected buffer'],
   ['/subscribe [<uri>]'     , 'Subscribes contact to <uri> (or current buffer) '
                               .'(eg. irc:*<channel>@<ircserver>, '
                               .'or irc:~<nickname>@<ircserver>)'],
   ['/unsubscribe [<uri>]'   , 'Unsubscribes contact to <uri> (or current buffer).'],
   ['/set_nick <nickname>'   , 'Sets the nickname/alias for the current buffer id.'],
   ['/set_groups <group1>[,<group2>,...]', 'Sets the groups for the current buffer id.'],
   ['/history [<lines>]'   , 'The backend will send you <lines> of lines from the chat history. (<lines> is per default 20)'],
   ['/meta <command>'      , 'Sends a meta command to the connected id of the current '
                             .'buffer, the interpretation of the command depends on '
                             .'the id scheme.'],
   ['/reconnect'           , 'Reconnects to the backend.'],
   ['/exit'                , 'Forcefully exits this frontend, CTRL-C might work better'],
);

#####################################################################################

sub get_id_parts {
   my ($id) = @_;
   split_irc_uri ($id)
}

sub get_id_nickname {
   my ($dest, $src) = @_;
   my $nick;

   if (exists $buffer_nicks{$dest}) {
      $nick = exists $buffer_nicks{$dest}->{$src}
                 ? $buffer_nicks{$dest}->{$src}->[1]
                 : $src
   } else {
      $nick = $id_aliases{$src} || $src
   }

   $nick
}

#####################################################################################

sub start_temporary_killer {
   my ($buffer, $timeout) = @_;

   if (0) { # XXX: Disabled because this seems to be too annoying
      $::temporary_timer = AnyEvent->timer (after => $timeout || 4, cb => sub {
         clear_buffer_temporaries ($buffer);
         undef $::temporary_timer;
      });
   }
}

sub print_temporary_line {
   my ($buffer, $line, $timeout) = @_;
   $buffer = current_buffer () unless defined $buffer;
   unshift @$line, 't';
   printline ($buffer, $line);
   if ($timeout) {
      start_temporary_killer ($buffer);
   }
}

#####################################################################################

sub update_buffer_statusline {
   my $buf = current_buffer ();

   my @add_info;
   #if ($buf =~ /^irc:/) {
   #   my ($p, $a) = split_irc_uri ($buf);
   #   push @add_info,
   #      11, '{irc} ',
   #      78, $p,
   #      11, '@',
   #      13, $a,
   #      11, " | ";
   #}

   push @add_info, 75, $buf;

   push @add_info, 76, " [inhib act]"     if $::CFG->{buffer_attrs}->{$config_scheme}->{$buf}->{inhibit_highlight};
   push @add_info, 12, " [highlight act]" if $::CFG->{buffer_attrs}->{$config_scheme}->{$buf}->{highlight_activity};
   push @add_info, 75, " ", 103, "[scrolled window]" if $is_scrolled;
   printline (statusline => [@add_info, 'f', 11, ""]);
}

sub get_buffer_attr_tags {
   my ($buf) = @_;
   my $at = $::CFG->{buffer_attrs}->{$config_scheme}->{$buf};
   my $tags;
   for ([qw/inhibit_highlight i/], [qw/highlight_activity h/]) {
      $tags .= $_->[1] if $at->{$_->[0]};
   }
   $tags
}

sub set_buffer_attr {
   my ($buf, $attr, $flag) = @_;
   if (defined $flag) {
      $::CFG->{buffer_attrs}->{$config_scheme}->{$buf}->{$attr} = $flag;
   } else {
      $::CFG->{buffer_attrs}->{$config_scheme}->{$buf}->{$attr} = not $::CFG->{buffer_attrs}->{$config_scheme}->{$buf}->{$attr};
   }
   update_buffer_statusline ($buf);
   save_config ("Changed buffer attribute of '$buf' in config scheme '$config_scheme'");
}

sub change_buffer {
   my ($new_buf) = @_;
   my $old_buf = current_buffer;
   maybe_pop_highlight ($new_buf);
   select_buffer ($new_buf);
   update_buffer_statusline ($new_buf);

   $JS->cl_broadcast_relay (buffers_seen => bummskraut_1_0 => [$new_buf], time)
      if $JS;
}

sub monitored_buffer {
   my ($buf) = @_;
   not (grep { $buf eq $_ } qw/status debug monitor/)
}

#####################################################################################

sub push_buf_history {
   my ($next_buf) = @_;
   my $cb = current_buffer;
   return if $next_buf eq $cb;

   push @buffer_history, $cb
      if not (@buffer_history)
         || $buffer_history[-1] ne $cb;
}

sub prev_buf_history {
   my $next = pop @buffer_history;
   if (defined $next) {
      push @buffer_history_prev, current_buffer
   }
   $next
}

sub next_buf_history {
   my $prev = pop @buffer_history_prev;
   if (defined $prev) {
      push @buffer_history, current_buffer
   }
   $prev
}

#####################################################################################

sub write_infoline_rec {
   my ($buffer, $time, $rec, @msg) = @_;

   @msg = (@msg > 1 ? @msg : (3, $msg[0]));

   @msg = map { s/\n\r?//; $_ } @msg; # FIXME: make multiline infos!

   my $ts = POSIX::strftime ($TSFORMAT, localtime ($time || time ()));
   my (@chatline) = (("p".length $ts), 0, $ts, 0, " ", @msg);

   if ($rec && $buffer eq current_buffer && $buffer ne 'status') {
      print_temporary_line ($buffer, \@chatline);
   } else {
      printline ($buffer, \@chatline);
   }

   unless ($rec) {
      printline ('monitor', ["p".(length ($ts) + 1), 0, $ts, 7, " [", 0, $buffer, 7, "] ", @msg])
         if monitored_buffer $buffer;
   }
}

sub write_infoline {
   my ($buffer, $time, @msg) = @_;
   if (defined $buffer) {
     write_infoline_rec ($buffer, $time, 0, @msg);
   } else {
     write_infoline_rec (status            => $time, 1, @msg);
     write_infoline_rec (current_buffer () => $time, 1, @msg) if current_buffer () ne 'status';
   }
}

sub write_errorline_rec {
   my ($buffer, $time, $rec, $msg) = @_;

   $msg =~ s/\n\r?//g; # FIXME: make multiline errors!

   my $ts = POSIX::strftime ($TSFORMAT, localtime ($time || time ()));
   my (@chatline) = (("p".length $ts), 0, $ts, 0, " ", 68, "ERROR: ", 4, $msg);

   if ($rec && $buffer eq current_buffer && $buffer ne 'status') {
      print_temporary_line ($buffer, \@chatline);
   } else {
      printline ($buffer, \@chatline);
   }

   unless ($rec) {
      printline ('monitor', ["p".(length ($ts) + 1), 0, $ts, 7, " [", 0, $buffer, 7, "]", 68, " ERROR: ", 4, $msg])
         if monitored_buffer $buffer;
   }

}

sub write_errorline {
   my ($buffer, $time, $msg) = @_;

   if (defined $buffer) {
     write_errorline_rec ($buffer, $time, 0, $msg);
   } else {
     write_errorline_rec (status            => $time, 1, $msg);
     write_errorline_rec (current_buffer () => $time, 1, $msg) if current_buffer () ne 'status';
     return;
   }

}

sub printmultiline {
   my ($buffer, $pad, $msgcolor, $msg, @first) = @_;

   my @msglines = split /\r?\n/, $msg;
   my $first = shift @msglines;

   printline ($buffer, ["p$pad", @first, $msgcolor, $first]);

   for (@msglines) {
      printline ($buffer, ["p$pad", 0, " " x $pad, 0, $_]);
   }
}

sub write_chatline {
   my ($buffer, $src, $time, $msg, $is_echo, $type, $msg_scope, $highlight) = @_;
   my $nick = get_id_nickname ($buffer, $src);

   my $nick_color =
      $is_echo
         ? 7
         : (
            $msg_scope eq 'private'
               ? 4
               : ($highlight ? 70 : 0)
         );
   my $ts = POSIX::strftime ($TSFORMAT, localtime ($time));

   my $adel_color = 0;

   my ($adel, $bdel) = ('<', '>');
   if ($type eq 'notice') {
      ($adel, $bdel) = ('{', '}');
   } elsif ($type eq 'action') {
      ($adel, $bdel) = ('* ', '');
      $adel_color = 5;
   }

   my $pad = length ($ts) + 4 + length ($nick);
   printmultiline (
      $buffer, $pad,
      0, $msg,
      0, $ts, $adel_color, " $adel", $nick_color, "$nick", 0, "$bdel "
   );

   printmultiline (
      'monitor', length ($ts) + 1, 0, $msg,
      0, $ts, 7, " [", 0, $buffer, 7, "]",
      $adel_color, " $adel", $nick_color, "$nick", 0, "$bdel "
   ) if monitored_buffer $buffer;
}

sub write_metaline {
   my ($buffer, $src, $time, $msg) = @_;
   my $nick = get_id_nickname ($buffer, $src);

   my $ts = POSIX::strftime ($TSFORMAT, localtime ($time));

   my (@chatline) = (
      ("p".(length ($ts) + 4 + length ($nick))),
      0, $ts,
      5, " $nick",
      0, " | ",
      69, $msg);

   printline ($buffer, \@chatline);

   printline (
      'monitor', [
         "p".(length ($ts) + 1), 0, $ts, 7, " [", 0, $buffer, 7, "]",
         5, " $nick", 0, " | ", 69, $msg
      ]
   ) if monitored_buffer $buffer;
}

sub write_temp_error {
   my (@error) = @_;
   print_temporary_line (undef, (@error > 1 ? @error : [4, $error[0]]));
}

sub write_temp_info {
   my (@error) = @_;
   print_temporary_line (undef, (@error > 1 ? @error : [3, $error[0]]));
}

#####################################################################################

sub get_first_highlight {
   return $highlight[0];
}

sub maybe_pop_highlight {
   my ($buffer) = @_;
   @highlight = grep { $buffer ne $_ } @highlight;
   printline (msgline => [map { (103, $_, 0, ' ') } @highlight]);
}

sub push_highlight {
   my ($id) = @_;

   unless (grep { $_ eq $id } (@highlight, current_buffer ())) {
      push @highlight, $id;
      printline (msgline => [map { (103, $_, 0, ' ') } @highlight]);
   }
}

sub check_highlight {
   my ($dest, $scope, $type, $do_highlight) = @_;

   my $highlight = $do_highlight;

   if ($::CFG->{buffer_attrs}->{$config_scheme}->{$dest}->{highlight_activity}
          or ($scope eq 'private' and $type ne 'notice'))
   {
      push_highlight ($dest)
         unless $::CFG->{buffer_attrs}->{$config_scheme}->{$dest}->{inhibit_highlight};

   } elsif ($do_highlight) {
      push_highlight ($dest)
         unless $::CFG->{buffer_attrs}->{$config_scheme}->{$dest}->{inhibit_highlight};
      $highlight = 1;
   }

   $highlight
}

sub clear_highlights {
   my ($local) = @_;

   unless ($local) {
      $JS->cl_broadcast_relay (buffers_seen => bummskraut_1_0 => [@highlight], time)
         if $JS;
   }

   @highlight = ();
   printline (msgline => []);
}

#####################################################################################

sub handle_message {
   my ($JS, $package, $src, $id, $scope, $type,
       $is_echo, $do_highlight, $ts, $content) = @_;

   write_chatline (
      $id, $src, $ts, $content, $is_echo,
      $type, $scope, check_highlight ($id, $scope, $type, $do_highlight)
   );

   # clear any highlights if we answered in this buffer
   if ($is_echo) { maybe_pop_highlight ($id) }

   1;
}

sub handle_meta_message {
   my ($JS, $packet, $src, $dest, $ts, $content) = @_;

   write_metaline ($dest, $src, $ts, $content);

   1
}

sub handle_state_change {
   my ($JS, $packet, $id, $ts, $state, $desc, $alias) = @_;

   $buffer_states{$id}->{state} = [$state, $desc];
   $id_aliases{$id} = ($alias eq '' ? undef : $alias) if defined $alias;

   write_infoline ($id, $ts,
       2, $id,
       ($id_aliases{$id} ? (2, " (aka $id_aliases{$id})") : ()),
       3, " state: ",
       0, $state . ($desc ? ", $desc" : "")
   );

   if ($state eq 'n/a') {
      delete $buffer_nicks{$id};

   } elsif ($state eq 'dead') {
      delete $buffer_states{$id};
      delete $buffer_nicks{$id};
      delete $id_aliases{$id};
   }

   update_buffer_statusline ($id);

   1
}

sub handle_set_group {
   my ($JS, $packet, $id, $groups) = @_;

   $buffer_groups{$id} = $groups;
   update_buffer_statusline ($id);

   1
}

sub handle_add_subid {
   my ($JS, $packet, $id, $timestamp, $ids) = @_;

   for (@$ids) {
      $buffer_nicks{$id}->{$_->[0]} = $_;
      write_infoline ($id, $timestamp,
         66, "+ ", map { (2, (sprintf "%-30s", $_->[0]), 0, " as ", 3, $_->[1]) } ($_)
      );
   }

   1;
}

sub handle_remove_subid {
   my ($JS, $packet, $id, $timestamp, $ids) = @_;

   for (@$ids) {
      delete $buffer_nicks{$id}->{$_->[0]};
      write_infoline ($id, $timestamp,
         68, "- ", map { (2, (sprintf "%-30s", $_->[0]), 0, " was ", 3, $_->[1]) } ($_)
      );
   }

   1;
}

sub handle_change_subid {
   my ($JS, $packet, $id, $timestamp, $subid, $new_subid, $oldnick, $newnick) = @_;

   delete $buffer_nicks{$id}->{$subid};
   $buffer_nicks{$id}->{$new_subid} = [$new_subid, $newnick];

   write_infoline ($id, $timestamp,
      67, "% ", 2, $subid, 2, " was ", 3, $oldnick, 0, " => ", 2, $new_subid, 2, " is ", 3, $newnick
   );

   1;
}

sub handle_info {
   my ($JS, $packet, $id, $type, $ts, $content) = @_;
   write_infoline ($id, $ts => "$type: $content");

   1;
}

sub handle_error {
   my ($JS, $packet, $id, $type, $ts, $content) = @_;
   write_errorline ($id, $ts => "$type: $content");

   1;
}

sub handle_config_state {
   my ($JS, $packet, $cfgname, $cfg) = @_;
   $::CFG = $cfg;
   write_infoline ('status', time, "Retrieved config update for '$cfgname' from server.");

   1;
}

sub handle_broadcast_relay {
   my ($JS, $packet, $command, $tag, $data, $ts) = @_;

   unless (grep { $_ eq $tag } qw/bummskraut_1_0/) {
      return 1
   }

   if ($command eq 'buffers_seen') {
      maybe_pop_highlight ($_) for @$data;

   } elsif ($command eq 'highlights_seen') {
      clear_highlights ('local')
   }

   1;
}

#####################################################################################

sub find_common_prefix {
   my (@words) = @_;
   @words = sort { length ($a) <=> length ($b) } @words;
   my $shortest = $words[0];

   while ($shortest ne '') {
      my $no_match = 0;
      for (@words) {
         unless (/^\Q$shortest\E/) {
            $no_match = 1;
            last;
         }
      }

      return $shortest if not $no_match;
      substr $shortest, -1, 1, '';
   }

   return '';
}

Net::Bummskraut::CursesChatWindow::register_complete_cb (sub {
   my ($word, $idx, @line) = @_;

   # TODO: make completion cycling with $first_compl
   #d# printline (undef, [0, "[$idx] [$word]"]);

   my @found;

   my @nicks = map { $_->[1] } values %{$buffer_nicks{current_buffer ()} || {}};
   my @commands = ((keys %completion), (map { "/$_" } keys %{$::CFG->{aliases}}));
   my @buffers = map { $_ } list_buffers;

   if ($idx == 0) {
      for (@nicks) {
         my $n = $_ . ":";
         if ($n =~ /^\Q$word\E/) {
            push @found, $n;
         }
      }

      for (@commands) {
         if (/^\Q$word\E/) {
            push @found, $_;
         }
      }

   } else {
      for (@nicks) {
         if (/^\Q$word\E/) {
            push @found, $_;
         }
      }

      for (@buffers) {
         if (/^\Q$word\E/) {
            push @found, $_;
         }
      }

      for (@commands) {
         if (/^\Q$word\E/) {
            push @found, $_;
         }
      }
   }

   return "$found[0] " if @found == 1;

   if (@found > 10) {
      my $longest;
      for (@found) { $longest = length $_ > $longest ? length $_ : $longest }

      my %first_chars;
      my $len = 1;
      while ((keys %first_chars) <= 1 && $len < $longest) {
         %first_chars = ();
         for (@found) { $first_chars{(substr $_, 0, $len)} = 1 }
         $len++;
      }

      print_temporary_line (undef, [t => 7, "$word: ", map { (3, "$_-", 0, ', ') } sort keys %first_chars], 1);
      return find_common_prefix (keys %first_chars);

   } elsif (@found) {
      print_temporary_line (undef, [t => 7, "$word: ", map { (3, $_, 0, ', ') } @found], 1);
      return find_common_prefix (@found);
   }

   return $word;
});

#####################################################################################

sub change_config_scheme {
   my ($scheme) = @_;
   $config_scheme = $scheme;
   update_buffer_statusline;
}

sub load_config {
   $JS->cl_config_get (bummskraut_1_0 => sub {
      my ($JS, $ev, $packet, @arg) = @_;

      if ($ev eq 'error') {
         my ($src, $type, $ts, $content) = @arg;
         write_errorline (undef, $ts, "Couldn't get config: ($type) $content");

      } else {
         my ($cfgname, $cfg) = @arg;
         $CFG = $cfg;
         change_config_scheme ($config_scheme); # just trigger an update
         write_infoline ('status', time, "Retrieved config for '$cfgname' from server.");
      }

      1
   });
}

sub save_config {
   my ($act) = @_;

   $JS->cl_config_set (bummskraut_1_0 => $CFG, sub {
      my ($JS, $ev, $packet, @arg) = @_;
      my ($id, $type, $ts, $content) = @arg;

      if ($ev eq 'error') {
         write_errorline (undef, $ts, "Couldn't save config: ($type) $content");
      } else {
         write_infoline (undef, $ts, "Saved config [$act]: ($type) $content");
      }

      1
   });
}

#####################################################################################

sub disconnect_cleanup {
   %buffer_nicks  = ();
   %buffer_states = ();
   %id_aliases    = ();
   update_buffer_statusline;
}

sub connect_bummskraut {
   if ($JS) { $JS->disconnect }

   $JS = Net::Bummskraut::Connection->new;

   $JS->reg_cb (
      connect => sub {
         my ($JS, $cl) = @_;
         $JS->cl_hello;
         1
      },
      auth_challenge => sub {
         my ($JS, $packet, $challenge) = @_;
         $JS->cl_auth_response (hmac_sha1_hex ($challenge, $AUTH_KEY));
         0
      },
      hello => sub {
         write_infoline (undef, undef, "Connected to bummskraut_server at $HOST:$PORT.");
         load_config;
      },
      connect_error => sub {
         my ($JS, $e) = @_;
         write_errorline (undef, undef, "Error on connect to bummskraut_server at $HOST:$PORT: $e");
         1
      },
      disconnect => sub {
         write_errorline (undef, undef, "Lost connection to bummskraut_server at $HOST:$PORT: $_[1]");
         disconnect_cleanup;

         1
      },
      broadcast_relay => \&handle_broadcast_relay,
      config_state => \&handle_config_state,
      message      => \&handle_message,
      meta_message => \&handle_meta_message,
      state_change => \&handle_state_change,
      add_subid    => \&handle_add_subid,
      remove_subid => \&handle_remove_subid,
      change_subid => \&handle_change_subid,
      info         => \&handle_info,
      error        => \&handle_error,
      set_group    => \&handle_set_group,
      debug_recv   => sub {
         my ($JS, $packet) = @_;
         printline (debug => [0, "<= $_"]) for split /\n/, JSON::XS->new->canonical (1)->encode ($packet);
         1
      },
      debug_send   => sub {
         my ($JS, $packet) = @_;
         printline (debug => [0, "=> $_"]) for split /\n/, JSON::XS->new->canonical (1)->encode ($packet);
         1
      }
   );

   $JS->connect ($HOST, $PORT);
}

#####################################################################################

Net::Bummskraut::CursesChatWindow::register_scroll_cb (sub {
   my ($is_s) = @_;
   $is_scrolled = $is_s;
   update_buffer_statusline;
});

#####################################################################################

sub send_message {
   my ($type, $content) = @_;
   my $dest = "" . current_buffer ();
   unless ($dest =~ m/^[^:]+:/) {
      write_temp_error ("Can't send regular messages in this buffer: '$dest'.");
      return;
   }

   $JS->cl_message ($dest, 'public', $type, $content, sub {
      my ($JS, $ev, $packet, $src, $id, $ts) = @_;
      return 0 if $ev eq 'message_sent';
      write_errorline ($dest, $ts, "Couldn't send message to '$dest': '$content'");
   });
}

my $input_cb;
Net::Bummskraut::CursesChatWindow::register_input_cb ($input_cb = sub {
   my ($input, $escape) = @_;

   unless (defined $input) {
      my $cmd = $CFG->{buffers}->{$escape};
      if ($cmd !~ m/^\//) {
         push_buf_history ($cmd);
         if (defined $cmd) {
            change_buffer ($cmd || 'status');
         } else {
            change_buffer ('status');
         }
         return;
      } else {
         $input = $cmd;
      }
   }

   if ($input =~ m/^\/goto\s*(\S+)/) {
      push_buf_history ($1);
      change_buffer ($1);

   } elsif ($input =~ m/^\/next/) {
      my $b = next_buf_history;
      if (defined $b) {
         change_buffer ($b) if defined $b;
      } else {
         write_temp_error ("There are no buffer histories left.");
      }

   } elsif ($input =~ m/^\/prev/) {
      my $b = prev_buf_history;
      if (defined $b) {
         change_buffer ($b) if defined $b;
      } else {
         write_temp_error ("There are no buffer histories left.");
      }

   } elsif ($input =~ m/^\/pop/) {
      if (my $buf = get_first_highlight ()) {
         push_buf_history ($buf);
         change_buffer ($buf);
      } else {
         write_temp_error ("There are no highlights to pop.");
      }

   } elsif ($input =~ m/^\/kill\s*(\S*)/) {
      my $b = $1 ne '' ? $1 : current_buffer ();
      change_buffer ('status')
         if "$b" eq current_buffer ();
      if (clear_buffer ($b) || "$b" eq current_buffer ()) {
         write_temp_info ("Killed buffer '$b'.");
      }

   } elsif ($input =~ m/^\/bind\s*(\S)?(?:\s+(\S+))?/) {
      if ($1 ne '') {
         $CFG->{buffers}->{$1} = $2 ne '' ? $2 : current_buffer;
         save_config ("added binding $1 => $2");
      } else {
         print_temporary_line (undef, [7, "bindings:"]);
         for (sort keys %{$CFG->{buffers}}) {
            print_temporary_line (undef,
               [0, sprintf "  '%1s' => %s", $_, $CFG->{buffers}->{$_}]
            );
         }
      }

   } elsif ($input =~ m/^\/unbind\s*(\S)/) {
      delete $CFG->{buffers}->{$1};
      save_config ("removed binding '$1'");

   } elsif ($input =~ m/^\/list_subids/) {
      my $id = current_buffer;

      if (exists $buffer_nicks{$id}) {
         my @subs = values %{$buffer_nicks{$id}};

         for (sort { lc ($a->[1]) cmp lc ($b->[1]) } @subs) {
            print_temporary_line ($id, [7, "  *", 2, (sprintf " %-40s", $_->[0]), 0, " as ", 3, $_->[1]]);
         }

         print_temporary_line ($id, [7, scalar (@subs), 0, " sub IDs in ", 2, $id]);
      } else {
         write_temp_error ("This buffer has no sub IDs.");
      }

   } elsif ($input =~ m/^\/buffers\s*(?:-(\S+)\s*)?(.*?)\s*$/) {
      my $rgx = $2 ne '' ? $2 : '';
      my $opt = $1;
      my %opts;
      for (split //, $1) {
         $opts{lc $_} = 1;
      }

      eval {
         my @matches =
               grep { $rgx ne '' ? ($opts{i} ? not ($_ =~ /$rgx/) : $_ =~ /$rgx/) : 1 }
                 (list_buffers ());

         if ($opts{p}) {
            @matches =
               grep {
                  $buffer_states{$_} and $buffer_states{$_}->{state}->[0] ne 'n/a'
               } @matches;
         }

         if ($opts{t}) {
            @matches =
               grep {
                  get_buffer_attr_tags ($_)
               } @matches;
         }

         print_temporary_line (undef,
            [7, scalar (@matches) . " "
                . ($rgx ne ''
                     ? "buffers [opt: ".(join '', keys %opts)."] matching /$rgx/:"
                     : "buffers [opt: ".(join '', keys %opts)."]:")
            ]
         );

         for my $id ( sort { lc ($a) cmp lc ($b) } @matches) {
            my $tags = get_buffer_attr_tags ($id);
            print_temporary_line (undef, ['p4',
               67, (sprintf "  %-40s ", $id),
               5,  (sprintf "%-5s",
                      ($tags ne '' ? "[$tags]" : "")),
               0, sprintf " %s",
                     $id_aliases{$id} ? "(aka $id_aliases{$id})" : ''
            ]);

            if ($buffer_states{$id}) {
               my $state = $buffer_states{$id}->{state}->[0];
               my $color = $state eq 'present' ? 2 : 6;
               print_temporary_line (undef, ['p6',
                  0, "    - ",
                  $color, (sprintf "%-8s", $state),
                  0, ": " . $buffer_states{$id}->{state}->[1],
               ]);
            }

            if ($opts{g}) {
               if ($buffer_groups{$id} && @{$buffer_groups{$id}}) {
                  print_temporary_line (undef, ['p6', 0, "    * ", 0, (join ", ", map { "'$_'" } @{$buffer_groups{$id}})]);
               }
            }
         }
      };
      if ($@) {
         write_temp_error ("Couldn't match buffers, bad regex?");
      }

   } elsif ($input =~ m/^\/colors/) {
      Net::Bummskraut::CursesChatWindow::print_colors;

   } elsif ($input =~ m/^\/clear_temporaries/) {
      clear_buffer_temporaries (current_buffer ());

   } elsif ($input =~ m/^\/highlights_seen_global/) {
      clear_highlights ('local');
      $JS->cl_broadcast_relay (highlights_seen => bummskraut_1_0 => undef)
         if $JS;

   } elsif ($input =~ m/^\/highlights_seen_local/) {
      clear_highlights ('local');

   } elsif ($input =~ m/^\/highlights_seen/) {
      clear_highlights;

   } elsif ($input =~ m/^\/config_scheme\s*(\S*)/) {
      if ($1 eq '') {
         write_temp_info ("Current config scheme: '$config_scheme'");

      } else {
         change_config_scheme ($1);
         write_temp_info ("Config scheme changed to '$1'");
      }

   } elsif ($input =~ m/^\/toggle_inhibit_highlight/) {
      set_buffer_attr (current_buffer (), 'inhibit_highlight');

   } elsif ($input =~ m/^\/toggle_highlight_activity/) {
      set_buffer_attr (current_buffer (), 'highlight_activity');

   } elsif ($input =~ m/^\/reconnect/) {
      connect_bummskraut;

   } elsif ($input =~ m/^\/history\s*(.*)$/) {
      my $lines = $1;
      my $dest = "" . current_buffer ();
      unless ($dest =~ m/^[^:]+:/) {
         write_temp_error ("Can't send regular messages in this buffer: '$dest'.");
         return;
      }

      $JS->cl_command_history (undef, $dest, $lines || 20);

   } elsif ($input =~ m/^\/meta\s*(.*)$/) {
      my $meta = $1;
      my $dest = "" . current_buffer ();
      unless ($dest =~ m/^[^:]+:/) {
         write_temp_error ("Can't send regular messages in this buffer: '$dest'.");
         return;
      }

      $JS->cl_meta_message ($dest, $meta, sub {
         my ($JS, $ev, $packet, @arg) = @_;
         my ($src, $type, $ts, $content) = @arg;

         if ($ev eq 'error') {
            write_errorline ($dest, $ts, "Couldn't send meta message: '$meta': $content");
         } else {
            write_infoline ($dest, $ts, "Sent meta message: '$meta'.");
         }
      });

   } elsif ($input =~ m/^\/raw\s*(.*)$/) {
      my $raw = $1;
      my $dest = "" . current_buffer ();
      unless ($dest =~ m/^[^:]+:/) {
         write_temp_error ("Can't send regular messages in this buffer: '$dest'.");
         return;
      }

      $JS->cl_raw_message ($dest, $raw, sub {
         my ($JS, $ev, $packet, @arg) = @_;
         my ($src, $type, $ts, $content) = @arg;

         if ($ev eq 'error') {
            write_errorline ($dest, $ts, "Couldn't send raw message: '$raw': $content");
         } else {
            write_infoline ($dest, $ts, "Sent raw message: '$raw'.");
         }
      });

   } elsif ($input =~ m/^\/notice\s*(.*)$/) {
      send_message ('notice', $1);

   } elsif ($input =~ m/^\/subscribe\s*(\S*)\s*$/) {
      my $id = $1 ne '' ? $1 : current_buffer;
      $JS->cl_subscribe ($id, sub {
         my ($JS, $ev, $packet, $src, $type, $ts, $content) = @_;
         push_buf_history ($id);
         if ($ev eq 'info') {
            change_buffer ($id);
            write_infoline (undef, $ts, "subscribe succeed: $content");
         } else {
            write_errorline (undef, $ts, "subscribe failed: $content");
         }
         1
      });

   } elsif ($input =~ m/^\/unsubscribe\s*(\S*)\s*$/) {
      my $id = $1 ne '' ? $1 : current_buffer;
      $JS->cl_unsubscribe ($id, sub {
         my ($JS, $ev, $packet, $src, $type, $ts, $content) = @_;
         if ($ev eq 'info') {
            write_infoline (undef, $ts, "unsubscribe succeed: $content");
         } else {
            write_errorline (undef, $ts, "unsubscribe failed: $content");
         }
         1
      });

   } elsif ($input =~ m/^\/alias\s*(\S*)\s*(.*)$/) {
      my ($newcmd, $cmd) = ($1, $2);
      if ($newcmd ne '') {
         $::CFG->{aliases}->{$1} = $2;
         save_config ("Added alias /$1 => '$2'");
      } else {
         print_temporary_line (undef, [7, 'aliases:']);
         for (keys %{$::CFG->{aliases}}) {
            print_temporary_line (undef, [
               0, '  /', 0, (sprintf "%-15s", $_), 0, ' => ', 0, $::CFG->{aliases}->{$_}
            ]);
         }
      }

   } elsif ($input =~ m/^\/unalias\s*(\S+)/) {
      my $alias = delete $::CFG->{aliases}->{$1};
      if (defined $alias) {
         save_config ("Removed alias /$1 => $alias");
      } else {
         write_temp_error ("No such alias: '$1'");
      }

   } elsif ($input =~ m/^\/exit/) {
      exit

   } elsif ($input =~ m/^\/help/) {
      print_temporary_line (undef, [7, 'Bummskraut client commands:']);
      for (@command_help) {
         if (length $_->[0] > 30) {
            print_temporary_line (undef, [0, '  ', 7, $_->[0]]);
            print_temporary_line (undef, ['p4', 0, '    - ', 0, $_->[1]]);
         } else {
            print_temporary_line (undef, ['p33', 0, '  ', 7, (sprintf "%-30s ", $_->[0]), 0, '- ', 0, $_->[1]]);
         }
      }
      print_temporary_line (undef,
         [
            70, "For more help, please type '",
            64, "perldoc bummskraut",
            70, "' in your favorite terminal and read it."
         ]
      );
      print_temporary_line (undef,
         [6, '(To clear this output use: /clear_temporaries)']
      );

   } elsif ($input =~ m/^\/set_groups\s*(.*)$/) {
      my (@grp) = split /,/, $1;
      my $id = current_buffer;
      $JS->cl_set_group ($id, \@grp, sub {
         my ($JS, $ev, $packet, $src, $type, $ts, $content) = @_;
         if ($ev eq 'error') {
            write_errorline ($id, $ts, "Couldn't set groups for $id: $content");
         } else {
            write_infoline ($id, $ts, "Successfully set groups for $id.");
         }
         1
      });

   } elsif ($input =~ m/^\/set_nick\s*(.*)$/) {
      my $nick = $1;
      $nick =~ s/^\s*(.*?)\s*$/\1/;
      my $id = current_buffer;
      $JS->cl_set_nick ($id, $nick, sub {
         my ($JS, $ev, $packet, $src, $type, $ts, $content) = @_;
         if ($ev eq 'error') {
            write_errorline ($id, $ts, "Couldn't set nick for $id: $content");
         } else {
            write_infoline ($id, $ts, "Successfully set nick for $id.");
         }
         1
      });

   } elsif ($input =~ m/^\/(xa|dnd|away|present)\s*(.*)$/) {
      $JS->cl_set_presence ($1, $2 ne '' ? $2 : undef);

   } elsif ($input =~ m/^\/(\S+)\s*(.*)$/) {
      if (exists $::CFG->{aliases}->{$1}) {
         $input_cb->($::CFG->{aliases}->{$1} . " " . $2);
      } else {
         write_temp_error ("Not a recognized command or alias: '$input'");
      }

   } else {
      send_message ('normal', $input);
   }
});

#####################################################################################

read_auth_key;

my $c = AnyEvent->condvar;

Net::Bummskraut::CursesChatWindow::init;
change_buffer ('status');
write_infoline ('status', undef, 70,
   "Welcome to the Bummskraut client, please type '/help' for some clues!"
);
write_infoline ('status', undef, 70,
   "For information about IRC configuration type 'help' in the cfg:irc buffer: /goto cfg:irc"
);
#write_infoline ('status', undef, 70,
#   "For information about Jabber configuration type 'help' in the cfg:xmpp buffer: /goto cfg:xmpp"
#);

connect_bummskraut;

$c->wait;

Net::Bummskraut::CursesChatWindow::end;

__DATA__

=head1 NAME

bummskraut - A chat client framework

=head1 SYNOPSIS

   bummskraut_server [<backend-port>]
   bummskraut [<backend-host> <backend-port>]

Example:

   # nohup bummskraut_server >/dev/null 2>/dev/null &
   # bummskraut

=head1 DESCRIPTION

Welcome to the chat client framework 'Bummskraut'.
It's aim is to provide a unique interface to multiple chat protocols.

As you might have some questions, the FAQ as first:

=head1 FAQ

   Q: I'm getting:
      'ERROR: Error on connect to bummskraut_server at localhost:1236: Connection refused'
      on startup of the client.
   A: You need to start the backend first: See below in L</Starting the backend>.

   Q: I'm getting: 'Couldn't open ~/.bummskraut_key: No such file or directory.'
      when starting the bummskraut frontend.
   A: You need to start the backend first or create a file called '.bummskraut_key'
      in the home directory of the bummskraut frontend which contains
      the authorisation key which is printed to STDOUT by the backend on startup.

=head1 MANUAL

=head2 Starting the backend

Starting the backend is an easy job, you either run the backend in C<screen>
or just use this line to start the backend in the background.

   # nohup bummskraut_server >/dev/null 2>/dev/null &

I recommend to start the backend in a screen, so you might have a chance to look at
the debug logs, you could also just use C<nohup> and redirect the output of course.

=head2 Starting the client

I assume you started the backend as described above in L<Starting the backend>.

You simply start the client by this:

   # bummskraut

Or if the backend runs somewhere else you might want to give the frontend
the hostname and port to contact, for that you might start the client like this:

   # bummskraut <host> <port>

=head1 AUTHOR

Robin Redeker, C<< <elmex at ta-sa.org> >>

=head1 ACKNOWLEDGEMENTS

=head1 COPYRIGHT & LICENSE

Copyright 2007 Robin Redeker, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.