package MConnection::Telnet;
use strict;
use vars qw(
  @ISA
  %EscapeTable
  $ListenSocket
  
  %CmdName
  %OptName
);

use IO::Socket;
use MCoreTools;
use MConnection;
@ISA = qw(MConnection);
$MConnection::Subclasses{(__PACKAGE__)} = 1;

use constant TEL_DEBUG => 0;

BEGIN {
  %CmdName = map {/^\d/ ? chr($_) : $_} (
    0 => 'IS'    ,
    1 => 'SEND'  ,
    240 => 'SE'  , # subnegotiation end
    241 => 'NOP' ,
    242 => 'DM'  , # Data Mark - not implemented
    243 => 'BRK' , # Break - not implemented
    244 => 'IP'  , # Interrupt Process
    245 => 'AO'  , # Abort output - not implemented
    246 => 'AYT' , # Are You There
    247 => 'EC'  , # Erase character
    248 => 'EL'  , # Erase Line
    249 => 'GA'  , # go ahead
    250 => 'SB'  , # subnegotiation begin
    251 => 'WILL', # \
    252 => 'WONT', #  \ option negotiation 
    253 => 'DO'  , #  /
    254 => 'DONT', # /
    255 => 'IAC' , # Interpret As Command
  );
  foreach (keys %CmdName) {
    eval "sub $CmdName{$_} () {chr(" . ord($_) . ")}";
  }
  %OptName = map {/^\d/ ? chr($_) : $_} (
    1 => 'ECHO',
    24 => 'TERMINAL-TYPE',
    31 => 'NAWS',
  );
  foreach (keys %OptName) {
    my $name = $OptName{$_};
    $name =~ tr/-/_/;
    eval "sub OPT_$name () {chr(" . ord($_) . ")}";
  }
}

# &foo; color substitutions and escapes for desc_gen strings (see core.mod)
%EscapeTable = (
  '&'  => '&',
  'z'  => '',
  'zz' => '',

  n => "\x1B[0m", # normal

  sb => "\x1B[1m", # bold
  su => "\x1B[4m", # underline
  sf => "\x1B[5m", # flash
  si => "\x1B[7m", # inverse

  # fg colors
  fk => "\x1B[30m", k => "\x1B[30m",
  fr => "\x1B[31m", r => "\x1B[31m",
  fg => "\x1B[32m", g => "\x1B[32m",
  fy => "\x1B[33m", 'y'=>"\x1B[33m",
  fb => "\x1B[34m", b => "\x1B[34m",
  fm => "\x1B[35m", 'm'=>"\x1B[35m",
  fc => "\x1B[36m", c => "\x1B[36m",
  fw => "\x1B[37m", w => "\x1B[37m",

  # bg colors
  bk => "\x1B[40m",
  br => "\x1B[41m",
  bg => "\x1B[42m",
  by => "\x1B[43m",
  bb => "\x1B[44m",
  bm => "\x1B[45m",
  bc => "\x1B[46m",
  bw => "\x1B[47m",

  # for desc_gen
  'lt' => '<',
  'gt' => '>',
  colon => ':',
  excl => '!',
);


### Listening - class methods ### ### ### ### ### ### ### ### ### ### ###

sub _listen_start {
  my ($class) = @_;

  my ($addr, $port) = $::Texts{'socket'} =~ /(\w+(?:\.\w+)*)?:(\d+)/;
  $addr ||= '';
  mudlog "Opening listener on $addr:$port...";
  $port or die "Bad format in addr/port specification (socket.txt)!";
  $ListenSocket = new IO::Socket::INET (
    ($addr ? (LocalAddr => $addr) : ()),
    LocalPort => $port,
    Proto     => 'tcp',
    Listen    => 5,
    Timeout   => .000001,
    ($^O ne 'MacOS' ? (Reuse => 1) : ()),
  ) or die "Can't create listener: $!\n";
}

sub _listen_stop {
  my ($class) = @_;

  $ListenSocket->close if $ListenSocket;
  undef $ListenSocket;
}

sub _listen_run {
  my ($class, $timeout) = @_;

  return unless $ListenSocket;
  $ListenSocket->timeout($timeout) if defined $timeout;
  if ($ListenSocket->opened) {
    eval {
      my $newsock = $ListenSocket->accept or return;
      $newsock->timeout(30);
      my $self = $class->new($newsock);
      $self->send("You have connected to $::Texts{name}.");
      #FIXME
      $MConnection::Running or $self->send("We're not quite ready for visitors yet, please wait a few seconds.");
    };
    die $@ if $@ and $@ !~ /timeout/;
    return 1;
  } else {
    return 0;
  }
}

### Instance methods ### ### ### ### ### ### ### ### ### ### ###

sub initial_state {'wait'}

sub _subnew {
  my ($self, $sock) = @_;

  $self->{sock} = $sock;
  $self->{telopt_my_sent} = {};
  $self->{telopt_your_sent} = {};
  $self->{telopt_my} = {};
  $self->{ip} = eval {(join '.', unpack 'C4', $sock->peeraddr)} || 'n/a',
  $self->{port} = eval {$sock->peerport} || 'n/a',
  my $mask = ''; vec($mask,fileno($sock),1) = 1;
  $self->{sockmask} = $mask;
  
  $self->send_telopt(DO,OPT_TERMINAL_TYPE);
  $self->send_telopt(DO,OPT_NAWS);
 }

# In order to produce NO echo at all, we promise the client that we'll
# do the echo, and don't do it.
sub send_echo_off   {$_[0]->send_telopt(WILL,OPT_ECHO)}
sub send_echo_on    {$_[0]->send_telopt(WONT,OPT_ECHO)}
sub send_incomplete {$_[0]->send_str_raw(IAC.GA)}

sub send_str_raw {
  my ($self, $t) = @_;
  $t =~ s/[\n\r]/\015\012/g;
  my $s = $self->{sock};
  goto FAILED unless defined $s and $s->opened;
  my $len = syswrite $s, $t, length($t);
  goto FAILED unless defined $len;
  # die "huh?" if $len != length($t);
  return 1;
  FAILED:
  $self->disconnect();
  return 0;
}

sub send_telopt {
  my ($self, $cmd, $opt) = @_;
  $self->send_str_raw(IAC.$cmd.$opt);
  $self->{($cmd eq DO || $cmd eq DONT) ? 'telopt_your_sent' : 'telopt_my_sent'}{$opt}++;
  $self->id_log("Sending telnet option "
                . $CmdName{$cmd}
                . " "
                . $OptName{$opt}) if TEL_DEBUG;
}

sub escape_handler {return sub {
  my ($self, $name, $semicolon) = @_;
  my $code = $EscapeTable{$name};
  return "&$name$semicolon" unless defined $code;
  return $code if ($code !~ /^\x1B/ or $self->{prefs}{color});
  return '';
}}

sub escape_rlen_handler {return sub {
  my ($self, $name, $semicolon) = @_;
  my $code = $EscapeTable{$name};
  return ($code !~ /^\x1B/ ? $code : '') if defined $code;
  return "&$name$semicolon";
}}

sub _telopt_handler {
  my ($self, $tbuf, $ipos, $cmd, $cname, $ohandlers) = @_;
  length($$tbuf) > $ipos+3 or return 0;
  my $opt = substr($$tbuf, $ipos+2, 1);
  substr($$tbuf, $ipos, 3) = '';
  my $is_my = ($cmd eq DO || $cmd eq DONT);
  my $statekey = $is_my ? 'telopt_my_sent' : 'telopt_your_sent';
  if ($self->{$statekey}{$opt}) {
    # we sent the request, this is a response for it
    $self->id_log("Got $cname in response to option ".($OptName{$opt} || ord($opt))) if TEL_DEBUG;
    if ($is_my) {
      $self->{telopt_my}{$opt} = ($cmd eq DO);
      $self->_telopt_my_new_state($opt, ($cmd eq WILL));
    } else {
      $self->_telopt_their_new_state($opt, ($cmd eq WILL));
    }
    $self->{$statekey}{$opt} = 0;
  } else {
    # we didn't send a request, this is a client-initiated sequence
    $self->id_log("Got $cname client-initiated for option ".($OptName{$opt} || ord($opt))) if TEL_DEBUG;
    &{$ohandlers->{$opt} || sub {
      $self->send_str_raw(IAC.DONT.$opt) if $cmd eq WILL or $cmd eq WONT;
      $self->send_str_raw(IAC.WONT.$opt) if $cmd eq DO   or $cmd eq DONT;
      $self->id_log("Unrecognized option code ".($OptName{$opt} || ord($opt))." in $cname") if TEL_DEBUG;
    }};
  }
  1;
}

sub _telopt_their_new_state {
  my ($self, $opt, $state) = @_;
  return unless $opt eq OPT_TERMINAL_TYPE;
  if ($state) {
    $self->id_log("Sending terminal type request.") if TEL_DEBUG;
    $self->send_str_raw(IAC. SB. OPT_TERMINAL_TYPE. SEND. IAC. SE); # appending byte constants is fun
  } else {
    $self->id_log("Refused to discuss terminal type.") if TEL_DEBUG;
    $self->setstate('login');
  }
}

sub _telopt_my_new_state {
  my ($self, $opt, $state) = @_;
}

sub _read_input {
  my ($self) = @_;
  
  my $tbuf = \$self->{telnet_buffer};
  $self->{sock} or do {$self->disconnect; return 0};

  my ($mask, $mask2) = ($self->{sockmask}, $self->{sockmask});
  return 1 unless select($mask, undef, $mask2, 0);

  my $res = sysread $self->{sock}, my($tx), 4096;
  defined $res or do {$self->disconnect; return 0};
  $$tbuf .= $tx if defined $tx;

  # first handle all the codes we can...
  # any 'last' means that the code was incomplete, so we wait till we recieve
  # enough data that it's complete.
  TCODE: while ((my $ipos = index $$tbuf, IAC) >= 0) {
  
    # dump text preceding IAC into input buffer, so we
    # process the telnet code in the right place in the data stream.
    $self->{in_buffer} .= substr($$tbuf, 0, $ipos);
    substr($$tbuf, 0, $ipos) = '';
    $ipos = 0; # quick hack to implement this, later we stop using $ipos further on
    
    last TCODE if length($$tbuf) <= $ipos;
    my $icmd = substr $$tbuf, $ipos+1, 1;
    #$self->id_log("Telnet-got ".($CmdName{$icmd} || ord($icmd))) if TEL_DEBUG;
    # If one of these command handlers returns 0, that means that
    # it determined that the command is incomplete, and therefore
    # processing of the command will be delayed until the necessary
    # data is received.
    &{{
      (SB) => sub {
        my $sub_end = index $$tbuf, SE, $ipos;
        $sub_end >= 0 or return 0;
        $sub_end--; # skip IAC found before SE
        my $sub_code = substr($$tbuf, $ipos+2, 1);
        my $sub_data = substr($$tbuf, $ipos+3, $sub_end - ($ipos+3));
        $self->id_log("Got SB ".($OptName{$sub_code} || ord($sub_code))) if TEL_DEBUG;
        $sub_data =~ s/\xFF{2}/\xFF/g; # fix escaped IACs
        &{{
          (OPT_NAWS) => sub {
            my ($hsize, $vsize) = unpack 'nn', $sub_data;
            $self->id_log("Received window size info: $hsize x $vsize") if TEL_DEBUG;
            $self->pref(scr_width => $hsize);
            $self->pref(scr_height => $vsize);
          },
          (OPT_TERMINAL_TYPE) => sub {
            my $mode = substr($sub_data, 0, 1);
            return unless $mode eq IS;
            substr($sub_data, 0, 1) = '';
            $self->id_log("Received terminal type: $sub_data") if TEL_DEBUG;
            $self->{terminal_type} = $sub_data;
            #print unpack 'H*', $sub_data;
            $self->{prefs}{color} = 1 if $sub_data =~ /^VT/ or $sub_data eq 'XTERM';
            $self->setstate('login') if $self->{state} eq 'wait';
          },
        }->{$sub_code} || sub {$self->id_log("Unrecognized subnegotiation code ".ord($sub_code)) if TEL_DEBUG}};
        substr($$tbuf, $ipos, $sub_end + 1 - $ipos) = '';
        1;
      },
      (WILL) => sub {_telopt_handler($self, $tbuf, $ipos, WILL, 'WILL', {
        (OPT_NAWS) => sub {$self->send_str_raw(IAC.DO.OPT_NAWS)},
        (OPT_TERMINAL_TYPE) => sub {$self->send_str_raw(IAC.DO.OPT_TERMINAL_TYPE)},
      })},
      (WONT) => sub {_telopt_handler($self, $tbuf, $ipos, WONT, 'WONT', {
        (OPT_NAWS) => sub {$self->send_str_raw(IAC.DONT.OPT_NAWS)},
        (OPT_TERMINAL_TYPE) => sub {$self->send_str_raw(IAC.DONT.OPT_TERMINAL_TYPE)},
      })},
      (DO  ) => sub {_telopt_handler($self, $tbuf, $ipos, DO, 'DO', {
      })},
      (DONT) => sub {_telopt_handler($self, $tbuf, $ipos, DONT, 'DONT', {
      })},
      (AYT) => sub {
        substr($$tbuf, $ipos, 2) = '';
        $self->send_str("\n[Yes, $::Texts{name} is still running.]\n");
        1;
      },
      (IP) => sub {
        substr($$tbuf, $ipos, 2) = '';
        if ($self->{state} eq 'command') {
          $self->{in_buffer} = "stop\n";
          $self->send_str("\nstop\n");
        } else {
          $self->send_str("\n[Interrupt Process is not supported in this state.]\n");
        }
      },
      (EC) => sub {
        substr($$tbuf, $ipos, 2) = '';
        $self->{in_buffer} .= "\b";
        $self->force_prompt;
      },
      (EL) => sub {
        substr($$tbuf, $ipos, 2) = '';
        $self->{in_buffer} =~ s/([\r\n])[^\r\n]*[\r\n]*$/$1/;
        $self->send_str("\n[Cancelled line.]\n");
        $self->force_prompt;
      },
    }->{$icmd} || sub {substr($$tbuf, $ipos, 1) = "\x00"; $self->id_log("Telnet-unknown command ".($CmdName{$icmd} || ord($icmd))) if TEL_DEBUG;1}}
      or last TCODE;
    # unrecognized codes get zapped, MConnection will just toss out the non-printables.
  }
  # but don't dump over the text if there turns out to be a incomplete code.
  unless ((index $$tbuf, IAC) >= 0) {
    $self->{in_buffer} .= $$tbuf;
    $self->{telnet_buffer} = '';
  }

  return 1;
}

sub disconnect {
  my ($self) = @_;
  undef $self->{sock};
  $self->SUPER::disconnect(@_);
}

sub open {$_[0]->{sock} ? 1 : 0}
sub source {my ($self) = @_; $self->{ip} && $self->{port} ? "$self->{ip}:$self->{port}" : "n/a"}


1;
