use strict;
use warnings;
use experimental 'signatures';

use Encode qw(encode decode);

my %server_charset = (
    'juggler' => 'iso-2022-jp-1',
   );

my $RT_ONLY = 1;

my $VERSION = '0.1'; # 27daca5ab980b3d
my %IRSSI = (
    authors     => 'Nei',
    contact     => 'Nei @ anti@conference.jabber.teamidiot.de',
    url         => "http://anti.teamidiot.de/",
    name        => 'fullrecode',
    description => 'Experimental script. Tries to fully recode connections to irc.juggler.jp between UTF-8 <=> ISO-2022-JP',
    license     => 'ISC',
   );


my $GID = 1;

use constant IN_IRSSI => __PACKAGE__ ne 'main';
use if IN_IRSSI, 'Irssi';

die 'This script requires Irssi 1.4 or later'
    if IN_IRSSI && (Irssi::parse_special('$abiversion')||0) < 41;

my %target_map;
my %server_info;

my %targ_arg_map = (
    'whois' => [0, 1],
    '276' => [0, 1],
    '301' => [0, 1],
    '307' => [0, 1],
    '311' => [0, 1, 2],
    '312' => [0, 1],
    '313' => [0, 1],
    '314' => [0, 1, 2],
    '315' => [0, 1],
    '317' => [0, 1],
    '318' => [0, 1],
    '319' => [0, 1],
    '320' => [0, 1],
    '322' => [0, 1],
    '324' => [0, 1],
    '329' => [0, 1],
    '330' => [0, 1, 2],
    '331' => [0, 1],
    '332' => [0, 1],
    '333' => [0, 1, 2],
    '336' => [0, 1],
    '338' => [0, 1],
    '341' => [0, 1, 2],
    '345' => [0, 1, 2, 3],
    '346' => [0, 1],
    '347' => [0, 1],
    '348' => [0, 1],
    '349' => [0, 1],
    '352' => [0, 1, 2, 5],
    '353' => [0, 2],
    '355' => [0, 2],
    '366' => [0, 1],
    '367' => [0, 1],
    '368' => [0, 1],
    '369' => [0, 1],
    '378' => [0, 1],
    '379' => [0, 1],
    '401' => [0, 1],
    '403' => [0, 1],
    '404' => [0, 1],
    '405' => [0, 1],
    '406' => [0, 1],
    '407' => [0, 1],
    '408' => [0, 1],
    '416' => [0, 2],
    '432' => [0, 1],
    '433' => [0, 1],
    '436' => [0, 1],
    '437' => [0, 1],
    '441' => [0, 1, 2],
    '442' => [0, 1],
    '443' => [0, 1, 2],
    '467' => [0, 1],
    '471' => [0, 1],
    '473' => [0, 1],
    '474' => [0, 1],
    '475' => [0, 1],
    '476' => [0, 1],
    '477' => [0, 1],
    '478' => [0, 1],
    '482' => [0, 1],
    '525' => [0, 1],
    '615' => [0, 1],
    '616' => [0, 1],
    '617' => [0, 1],
    '663' => [0, 1,  2],
    '665' => [0, 1],
    '671' => [0, 1],
    '690' => [0, 1],
    '696' => [0, 1],
    '711' => [0, 1],
    '712' => [0, 1],
    '713' => [0, 1],
    '714' => [0, 1],
    '716' => [0, 1],
    '717' => [0, 1],
    '718' => [0, 1],
   );

sub get_charset ($server) {
    $server_charset{ $server->{tag} } || $server_charset{ $server->{chatnet} }
}

sub argparse ($data) {
    my %ret;

    if ($data =~ /^\@/) {
	my ($tags, $r) = split ' ', $data, 2;
	$data = $r;
	$ret{tags} = $tags;
    }

    if ($data =~ /^:/) {
	my ($prefix, $r) = split ' ', $data, 2;
	$data = $r;
	$ret{prefix} = $prefix;
    }

    my ($verb, $r) = split ' ', $data, 2;
    $data = $r;
    if ($verb =~ /^\d+$/) {
	$ret{numeric} = $verb;
    } else {
	$ret{command} = $verb;
    }

    my ($args, @args);
    if (defined $data) {
	if ($data =~ s/^://) {
	    @args = $data;
	} else {
	    ($args, @args) = split ' :', $data, 2;
	}
	$ret{last_quoted} = @args;
	unshift @args, split ' ', $args
	    if defined $args;
    }

    $ret{args} = \@args;

    return %ret;
}

sub unparse (%r) {
    my @r;
    push @r, $r{tags} if defined $r{tags};
    push @r, $r{prefix} if defined $r{prefix};
    push @r, $r{numeric} // $r{command};
    my @args = ($r{args} // [])->@*;
    if (@args && ($r{last_quoted} || $args[-1] =~ / / || $args[-1] =~ /^:/)) {
	$args[-1] = ":$args[-1]";
    }
    push @r, @args;
    return "@r";
}

sub dc ($server, $value) {
    encode('utf-8', decode(get_charset($server), $value))
}

sub dct1 ($server, $value) {
    my $re = $server_info{ $server->{tag} }{skip_re};
    my $r = $value;
    if ($r =~ s/^($re)//) {
	my $p = $1;
	$r = $p . dc($server, $r);
    } else {
	$r = dc($server, $r);
    }
    if ($RT_ONLY) {
	my $er = ect1($server, $r);
	return $value unless $er eq $value;
    }
    $target_map{ $server->{tag} }{ $r } = $value;
    $r
}

sub dct ($server, $value) {
    join ',', map { dct1($server, $_) } split ',', $value;
}

sub ec ($server, $value) {
    encode(get_charset($server), decode('utf-8', $value))
}

sub ect1 ($server, $value) {
    $target_map{ $server->{tag} }{ $value } // do {
	my $re = $server_info{ $server->{tag} }{skip_re};
	my $r = $value;
	if ($r =~ s/^($re)//) {
	    my $p = $1;
	    $r = $p . ec($server, $r);
	} else {
	    $r = ec($server, $r);
	}
	$r
    }
}

sub ect ($server, $value) {
    join ',', map { ect1($server, $_) } split ',', $value;
}

sub recode_in ($server, $data) {
    get_charset($server) or return;
    my $id = $GID++;
    my %r = argparse($data);
    if (defined $r{numeric} && $r{numeric} == '251') {
	if (!defined $server->isupport('chantypes')) {
	    my %is = (
		prefix => $r{prefix},
		numeric => '005',
		args => [ $r{args}[0], 'PREFIX=(ov)@+', 'CHANTYPES=#&!+', 'IDCHAN=!:5',
			  'are supported by this server' ],
	    );
	    Irssi::signal_emit('server incoming', $server, unparse(%is));
	}
    }

    if (defined $r{prefix}) {
	my ($nick, $user, $host, $i);
	my $p = substr $r{prefix}, 1;
	$i = rindex $p, '@';
	if ($i != -1) {
	    $host = substr $p, $i + 1;
	    $p = substr $p, 0, $i;
	}
	$i = rindex $p, '!';
	if ($i != -1) {
	    $user = substr $p, $i + 1;
	    $p = substr $p, 0, $i;
	}
	$nick = $p;
	if (defined $user and defined $host) {
	    $nick = dct($server, $nick);
	    $user = dc($server, $user);
	}
	$r{prefix} = ":$nick" . (defined $user ? "!$user" : "") . (defined $host ? "\@$host": "");
    }

    if (defined $r{numeric}) {
	my @targ_args = ($targ_arg_map{$r{numeric}} // [0])->@*;
	for my $i (@targ_args) {
	    next if $i > $r{args}->$#*;
	    $r{args}[$i] = dct($server, $r{args}[$i]);
	}

	if ($r{numeric} == '005') {
	    for my $i (1..$r{args}->$#*-1) {
		if ($r{args}[$i] =~ /^network=/i) {
		    my ($k, $v) = split '=', $_, 2;
		    $r{args}[$i] = "$k=" . dc($server, $v);
		}
	    }
	}
	elsif ($r{numeric} == '004') {
	    #
	}
	elsif ($r{numeric} == '319') {
	    my $re = $server_info{ $server->{tag} }{prefix_re};
	    $r{args}[2] = join ' ', map {
		my $chan = $_;
		$chan =~ s/^($re)//;
		my $p = $1;
		$chan = dct1($server, $chan);
		$chan = $p . $chan
		    if defined $p;
	    } split ' ', $r{args}[2];
	}
	elsif ($r{numeric} == '353') {
	    my $re = $server_info{ $server->{tag} }{prefix_re};
	    $r{args}[3] = join ' ', map {
		my $nick = $_;
		$nick =~ s/^($re)//;
		my $p = $1;
		$nick = dct1($server, $nick);
		$nick = $p . $nick
		    if defined $p;
	    } split ' ', $r{args}[3];
	}
	else {
	    for my $i (0..$r{args}->$#*) {
		next if grep { $_ eq $i } @targ_args;
		$r{args}[$i] = dc($server, $r{args}[$i]);
	    }
	}
    }
    elsif (defined $r{command}) {
	my @targ_args = ($targ_arg_map{lc $r{command}} // [0])->@*;
	for my $i (@targ_args) {
	    next if $i > $r{args}->$#*;
	    $r{args}[$i] = dct($server, $r{args}[$i]);
	}

	if ($r{command} eq '') {
	    # ...;
	}
	else {
	    for my $i (0..$r{args}->$#*) {
		next if grep { $_ eq $i } @targ_args;
		$r{args}[$i] = dc($server, $r{args}[$i]);
	    }
	}
	# ...;
    }
    # ...;
    my $new = unparse(%r);
    Irssi::signal_continue($server, $new);
}

sub recode_out ($server, $data, $crlf) {
    get_charset($server) or return;
    my $id = $GID++;
    my %r = argparse($$data);
    my @targ_args = ($targ_arg_map{lc $r{command}} // [0])->@*;
    for my $i (@targ_args) {
	next if $i > $r{args}->$#*;
	$r{args}[$i] = ect($server, $r{args}[$i]);
    }
    for my $i (0..$r{args}->$#*) {
	next if grep { $_ eq $i } @targ_args;
	$r{args}[$i] = ec($server, $r{args}[$i]);
    }
    # ...;
    $$data = unparse(%r);
}

sub update_infos ($server, @rest) {
    my ($prefixes) = $server->get_nick_flags;
    my $prefix_re = qr/[\Q$prefixes\E]*/;
    my $chantypes = $server->isupport('chantypes');
    my %idchan = map { split ':' } map { split ',' } $server->isupport('idchan')//'';
    my $idtypes = join '', sort keys %idchan;
    $chantypes =~ s/[\Q$idtypes\E]//g
	if length $idtypes;
    my @chants;
    for my $idt (sort { $idchan{$b} <=> $idchan{$a} } keys %idchan) {
	push @chants, "\Q$idt\E" . '.' x $idchan{$idt};
    }
    push @chants, "[\Q$chantypes\E]"
	if length $chantypes;
    my $chant_re = join '|', @chants;
    my $skip_re = qr/($prefix_re(?:$chant_re))/;
    $server_info{ $server->{tag} }{prefix_re} = $prefix_re;
    $server_info{ $server->{tag} }{skip_re} = $skip_re;
}

if (IN_IRSSI) {
    Irssi::signal_add_first('event 376', 'update_infos');
    Irssi::signal_add_first('event 422', 'update_infos');
    Irssi::signal_add_first('server incoming', 'recode_in');
    Irssi::signal_add_last('server outgoing modify', 'recode_out');
    for my $server (Irssi::servers) {
	next unless $server->isa('Irssi::Irc::Server');
	update_infos($server);
    }
}
