package MConnection;
use strict;
use vars qw(
  @ISA
  %Connections
  $ListenSocket
  $NextConID
  %InputHandlers
  %EnterHandlers
  $Running
  %Subclasses
);

use Carp;
use Cwd;
use IO::Socket;
use IO::File;
use MCoreTools;
use MLoaders qw(call_hooks);
use MObject;
use MUnique;
use MCollection;

$NextConID = 1 unless $NextConID; # uid for connection
$Running = 0 unless $Running;     # used for handling connections while starting up

# Each line of input is directed to one of these subroutines, depending on
# the 'state' of the connection.
%InputHandlers = (
'wait' => sub {},
'login' => sub {
  my ($self, $input) = @_;
  $input or return;
  my $name = ucfirst $input;
  $self->{login_name} = $name;
  if ($name !~ /^[A-Za-z]{1,20}$/) {
    $self->send("Names must be entirely letters and less than 21 characters long.");
# } elsif (!-e pfilename($name, 'obj')) {
  } elsif (!MUnique->exists($name)) {
    $self->setstate('confirm_name');
  } elsif (has_password($name)) {
    $self->setstate('pass');
  } else {
    $self->setstate('menu', 'login');
  }
},
'pass' => sub {
  my ($self, $input) = @_;
  my $name = $self->{'login_name'};
  unless (authenticate($name, $input)) {
    $self->send('Incorrect password.');
    $self->id_log("bad login attempt.");
    $self->disconnect;
    return;
  }
  $self->setstate('menu', 'login');
},
'newpass_old' => sub {
  my ($self, $input) = @_;
  $input or do {$self->send("Cancelled."); $self->setstate('menu'); return};
  my $name = $self->{'login_name'};
  unless (authenticate($name, $input)) {
    $self->send('Incorrect password.');
    $self->setstate('menu');
    return;
  }
  $self->setstate('newpass_new');
},
'newpass_new' => sub {
  my ($self, $input) = @_;
  $input or do {$self->send("Cancelled."); $self->setstate('menu'); return};
  $self->{"new_password"} = $input;
  $self->setstate('newpass_new2');
},
'newpass_new2' => sub {
  my ($self, $input) = @_;
  $input or do {$self->send("Cancelled."); $self->setstate('menu'); return};
  if ($input eq $self->{"new_password"}) {
    set_player_password($self->{'login_name'}, $input);
    $self->send('Password changed.');
    $self->setstate('menu');
  } else {
    $self->send("The two passwords did not match.");
    $self->setstate('newpass_new');
  }
},
'confirm_name' => sub {
  my ($self, $input) = @_;
  if ($input !~ /^y/i) {
    $self->setstate('login', 'badname');
    return;
  }
  $self->id_log("entering character creation.");
  $self->send("Creating new player.");
  $self->{newplayer} = 1;
  $self->setstate('select_species');
  $self->{ok_species} = {map {($_ =~ m#/([^/]+)$#)[0], 1}
                        grep {MObject->obj_proto($_)->ok_for_pc}
                        (
                          MZone->by_path('/lib/species') or do {
                            mudlog "ERROR/WORLD: /lib/species not found, creating char without prototype.";
                            $self->setstate('menu', 'login');
                            return;
                          }
                        )->all_keys('obj')};
},
'select_species' => sub {
  my ($self, $input) = @_;
  $input ||= 'human';
  if (MObject->proto_exists("/lib/species/" . lc $input)) {
    $self->{np_proto} = "/lib/species/" . lc $input;
    $self->setstate('select_gender');
    $self->{ok_genders} = MObject->obj_proto($self->{np_proto})->allow_genders;
    return;
  }
  $self->send("Invalid choice.");
},
'select_gender' => sub {
  my ($self, $input) = @_;
  if ($self->{ok_genders}->{lc $input}) {
    $self->send("Don't forget to set your password.");
    $self->{np_gender} = lc $input;
    $self->setstate('menu', 'login');
    return;
  } 
  $self->send("Invalid choice.");
},
'menu' => sub {
  my ($self, $input) = @_;
  &{{
    0 => sub {$self->disconnect('normal')},
    1 => sub {$self->do_connect($self->{login_name})},
    p => sub {$self->setstate(has_password($self->{login_name}) ? 'newpass_old' : 'newpass_new')},
    d => sub {$self->send("Sorry, that's not implemented yet.")},
  }->{lc $input} || sub {$self->send("That is not a valid choice.")}};
},
'command' => sub {
  my ($self, $input) = @_;
  ($self->{'object'} or do {
    mudlog "ERROR: No object for connection #$self->{id}!";
    $self->send("Error: No object to send your command to!");
    return;
  })->do($input);
},
);

%EnterHandlers = (
'menu' => sub {
  my ($self, $reason) = @_;
  
  return unless $reason and $reason eq 'login';
  $self->id_log("logged in.");
  $self->read_prefs;
},
'login' => sub {
  my ($self, $reason) = @_;
  
  return if $reason and $reason eq 'badname';
  $self->send('');
  $self->send($::Texts{splash});
  $self->send('');
},
);

###

### Class methods ### ### ### ### ### ### ### ### ### ### ###

sub start_prompts {
  $Running = 1;
}

sub all {
  return MCollection->new(values %Connections);
}

sub all_do {
  my ($class, $callback) = @_;

  foreach my $obj (values %Connections) {
    $callback->($obj);
  }
}

sub all_idle {
  for (keys %Subclasses) {$_->_listen_run}
  for (values %Connections) {$_->idle}
  return scalar values %Connections;
}

sub by_id {
  my ($class, $id) = @_;
  return $Connections{$id};
}

sub listen_start {
  for (keys %Subclasses) {$_->_listen_start}
}

sub listen_stop {
  for (keys %Subclasses) {$_->_listen_stop}
}

### Connections ### ### ### ### ### ### ### ### ### ### ###

sub new {
  my $class = shift;

  my $self = bless {
    in_buffer => '',
    out_buffer => [],
    lastprompt => '',
    state => '',
    prefs => {
    },
  }, $class;
  print "$self CREATED\n" if ::GC_DEBUG;

  $Connections{my $id = $NextConID++} = $self;
  $self->{id} = $id;

  $self->setstate($self->initial_state);
  $self->_subnew(@_);
  $self->id_log("connected."); 

  return $self;
}

sub initial_state {'login'}

sub _subnew {}
sub send_str_raw {confess "must be overridden"}
sub send_echo_on  {confess "must be overridden"}
sub send_echo_off {confess "must be overridden"}
sub send_incomplete {}
sub escape_handler {confess "must be overridden"}
sub escape_rlen_handler {confess "must be overridden"}

sub send_str {
  my ($self, $text) = @_;

  return unless $self->open;
  my $esub = $self->escape_handler;
  $text =~ s/&(([a-z]+)(;?)|&)/$1 eq '&' ? '&' : $esub->($self, $2, $3)/eg;
  if ($self->{prefs}{'combine_output'}) {
    push @{$self->{out_buffer}}, $text;
  } else {
    $self->send_str_raw($text);
  }
}

sub display_length {
  my ($self, $text) = @_;
  my $esub = $self->escape_rlen_handler;
  $text =~ s/&(([a-z]+)(;?)|&)/$1 eq '&' ? '&' : $esub->($self, $2, $3)/eg;
  return length $text;
}

sub send {
  my ($self, $text) = @_;

  if (not defined $text) {
    complain "Undef passed to MConnection::send";
    return;
  }
  $text =~ s/\n+$//;
  return unless $self->open;
  $self->send_str( (!$self->{needsprompt} and !$self->{gotline} and $self->{lastprompt})
                   ? "\n$text\n" : "$text\n"
                 );
  $self->{needsprompt} = 1;
  1;
}

sub format_wrap {
  my ($self, $text, %opts) = @_;

  if (not defined $text) {
    complain "Undef passed to MConnection::format_wrap";
    return;
  }

  my @pict = $opts{picture} ? split /\n/, $opts{picture} : ();

  my $fmtext = '';
  my $t;
  my $wid = $self->scr_width;
  foreach (split /\n/, $text) {
    $t = $_;
    {
      $t = shift(@pict) . $t if @pict;
      my $char = length $t;
      if ($self->display_length($t) > $wid) {
        $char = $wid + 1;
        $char-- while substr($t, $char - 1, 1) !~ /\s/;
      }
      my $out = substr($t, 0, $char);
      $out =~ s/\s+$//;
      $fmtext .= "$out\n";
      next if $char >= length $t;
      $t = substr($t, $char);
      redo if $t;
    }
  }
  return $fmtext . join("\n", @pict);
}

sub do_page {
  my $self = shift;
  $self->send($self->format_wrap(@_));
}

sub do_multicol {
  my ($self, @items) = @_;
  my $maxlen = 0;
  foreach (@items) {                                 # compute needed width of columns
    my $na = $self->display_length($_);
    $maxlen = $na if $na > $maxlen;
  }
  $maxlen++;                                         # provide one space of separation between columns
  my $cols = int($self->scr_width / $maxlen) || 1;   # compute # of columns to use
  my $lines = @items / $cols;                        # number of lines needed
  $lines = int($lines) + 1 if $lines != int($lines); # round line count up to integer
  $lines = @items if $lines <= 5 and @items <= 5;    # make sure we don't get columns with less than 6 items
                                                     # (for appearance's sake)

  my $buf = '';
  for (my $v = 0; $v < $lines; $v++) {
    for (my $h = 0; $h < $cols; $h++) {
      my $str = ($items[$v + $h * $lines] || '');
      my $padding = $maxlen - $self->display_length($str);
      $buf .= $str . ($h == $cols - 1 ? '' : ' ' x $padding);
    }
    $buf .= "\n";
  }
  $self->send($buf);
}

sub object {
  my ($self, $obj) = @_;

  $self->{object} = $obj if defined $obj;
  $self->{object};
}

sub force_prompt {
  $_[0]->{'needsprompt'} = 1;
}

sub source {"#".$_->id}

sub id_log {
  my ($self, $str) = @_;
  mudlog $self->source . ($self->login_name ? " ($self->{login_name})" : '') . ": $str";
}

sub idle {
  my ($self) = @_;

  $self->_read_input() or return;
  
  if ($self->{needsprompt}) {
    $self->send_str($self->{lastprompt} = &{{
      'wait' => sub {''},
      #'ansi' => sub {'Does your terminal support ANSI color [Y/n]? '},
      'login' => sub {'By what name do you wish to be known? '},
      'pass' => sub {'Password: '},
      'confirm_name' => sub {"There is no character named \"$self->{login_name}\". Create a new character? [y/N]? "},
      'select_species' => sub {'Select your species (' . join(', ', sort keys %{$self->{ok_species}}) . '): '},
      'select_gender'  => sub {'Select your gender ('  . join(', ', sort keys %{$self->{ok_genders}}) . '): '},
      'newpass_old' => sub {'Enter your old password: '},
      'newpass_new' => sub {'Enter your new password: '},
      'newpass_new2' => sub {'Confirm your new password: '},
      'menu' => sub {qq{
&c;  +---------------------------+
  | 0. Quit                   |
  | 1. Enter the world        |
  | P. Change password        |
  | D. Delete this player     |
  +---------------------------+&n;

What do you want to do? }},
      'command' => sub {
        my $obj = $self->{'object'};
        return '> ' unless $obj;
        return '' if $obj->{commands_paused} or $self->{prefs}{noprompt};
        my $hit   = int($obj->c_hit  / ($obj->m_hit  || 1) * 100); $hit  = "&r;$hit&n;"  if $hit < 20;
        my $move  = int($obj->c_move / ($obj->m_move || 1) * 100); $move = "&r;$move&n;" if $move < 20;
        #my $mana = int($obj->c_mana);
        "\n".($obj->invisible ? 'invis ' : '')
            .($obj->unique ? '' : $obj->name . ' ')
            ."${hit}%h ${move}%v> ";
      },
    }->{$self->{'state'}} || sub {die "no prompt for state: $self->{'state'}"}});

    if (@{$self->{out_buffer}}) {
      my $obuf = $self->{out_buffer};
      my ($buf, %seen, @out) = '';
      while (my $item = shift @$obuf) {
        $seen{$item}++ and next;
        push @out, $item;
      }
      foreach (@out) {
        $buf .= sprintf('(x%d) ', $seen{$_}) if $seen{$_} > 1;
        $buf .= $_;
      }
      $self->send_str_raw($buf);
    }
    

    $self->send_echo_off if _is_noecho_state($self->{state})
                       and !_is_noecho_state($self->{last_state});
    $self->send_incomplete if $self->{lastprompt};
    $self->{needsprompt} = 0;
  }

  while ($self->open and $self->{in_buffer} =~ s/^(.*?)[\015\012]//) {
    my $input = $1;
    $self->{in_buffer} =~ s/^[\015\012]//;
    for ($input) {
      1 while s/[^\x08]\x08//g; # handle backspace
      s/^\s+//;
      s/\s+$//;
      tr/\x00-\x1F\x7F-\xFF//d; # this does chomp's job too
    }
    $self->{'gotline'} = 1;
    try {
      $InputHandlers{$self->{'state'}}->($self, $input);
    } catch {
      (my $lt = $_) =~ s#\s*\n\s*(\S)# / $1#g;
      mudlog "ERROR/CORE: death in input handler for state $self->{'state'}: $lt";
    };
    if ($self->open) {
      $self->{gotline} = 0;
      $self->{needsprompt} = 1;
    }
  }
}

sub setstate {
  my ($self, $state, $reason) = @_;
  $self->{last_state} = $self->{state};
  $EnterHandlers{$state}->($self, $reason) if $EnterHandlers{$state};
  $self->{state} = $state;
  $self->{needsprompt} = 1;
  $self->send_echo_on if _is_noecho_state($self->{last_state})
                     and !_is_noecho_state($self->{state});
}

sub _is_noecho_state {
  $_[0] =~ /^(new)?pass/;
}


sub do_connect {
  my ($self, $name) = @_;

  my ($obj, $recon);
  if (!MUnique->exists($name)) {
    $self->send("New player.");
    $obj = $self->make_new_player($name);
  } elsif ($obj = &{sub{ (MUnique->get_in_world($name) or return)->object }}) { # eww
    $self->send('Reconnecting.');
    $recon = 1;
    $self->id_log("$name has reconnected");
  } else {
    $self->send('Restoring player.');
    my $unique = MUnique->get($name);
    $unique->place_in_world;
    $obj = $unique->object;
  }
  #mudlog "DEBUG: in do_connect obj is $obj";
  $self->link_to_player($obj, $recon);
}

sub link_to_player {
  my ($self, $obj, $recon) = @_;

  my $replace;
  $self->setstate('command');
  if ($obj->connection) {
    $obj->act('Multiple login detected...disconnecting.',
              $obj->name . " momentarily gets a disturbed look on $GENDER_POSS{$obj->gender} face.");
    $self->id_log("replacing old connection");
    $obj->connection->disconnect('silent');
    $replace = 1;
  }
  $obj->connection($self);
  $self->object($obj);
  
  $obj->do('look');
  $obj->act(undef, $recon
    ? $obj->name . " has reconnected."
    : "You feel a distortion of reality and " . $obj->name . " appears.") unless $replace;
}

sub link_to_object {
  my ($self, $obj, $opts) = @_;
  
  if (my $old = $obj->connection) {
    $old->send("Your connection has been replaced!");
    $old->disconnect("silent"); # FIXME: weird args
  }

  $obj->connection($self);
  $self->object($obj);
}

sub detach {
  my ($self) = @_;

  if (ref $self->object) {
    $self->object->reset_val('connection');
  }
  $self->object(undef);
  $self->setstate('menu');
}

sub make_new_player {
  my ($self, $name) = @_;

  $self->id_log("New player: '$name'");
  my $unique = MUnique->new($name,
    name => $name,
    ($self->{np_proto} ? ('prototype' => $self->{np_proto}) : ()),
    gender => $self->{np_gender},
  );
  $unique->place_in_world;
  return $unique->object;
}

=for old_pc_code

sub make_new_player {
  my ($self, $name) = @_;

  $self->id_log("New player: '$name'");
  my $obj = MObject->new(
    ispc => 1,
    player_name => $name,
    name => $name,
    xxaliases => [lc $name],
    ($self->{np_proto} ? ('prototype' => $self->{np_proto}) : ()),
    gender => $self->{np_gender},
  );
  $obj->c_hit($obj->m_hit);
  $obj->c_move($obj->m_move);
  call_hooks('new_player_setup', $obj);
  if (!-e players_dir()) {
    mudlog "BOOTSTRAP: Player save dir not found, creating first player as controller";
    $obj->set_val(immortal => 1);
    $obj->set_val(unrestricted_edit => 1);
    $obj->set_val(CONTROLLER => 1);
    File::Path::mkpath(players_dir(), 0, DATA_PERMS|0110);
  }
  
  { ($::Rooms{$obj->get_val('loadroom')} or last)->add_contents($obj) }; # tricky
  return $obj;
}

sub load_player {
  my ($name) = @_;

  my $file = pfilename($name, 'obj');
  my $hand = IO::File->new("< $file") or die $!;
  local $/;
  <$hand> =~ /^(.*)$/s; # FIXME: untaint
  my $obj = MObject->thaw($1);
  $obj->c_hit(10) if $obj->c_hit < 10;
  $obj->c_move(10) if $obj->c_move < 10;
  $obj->body_pos('standing') if MLoaders->mloaded('body_pos');
  my $loadroom = $::Rooms{$obj->loadroom};
  $loadroom->add_contents($obj) if $loadroom;
  $obj;
}

sub find_named_player {
  my ($name) = @_;

  my $found = 0;
  foreach my $obj (values %MObject::Objects) {
    $found = $obj, last if $obj->ispc and lc $obj->player_name eq lc $name;
  }
}

sub pfilename {
  my ($name, $ext) = @_;
  
  # the 'lc' is in there for those broken file systems that care about filename case.     :)
  (my $dname) = lc($name) =~ /(^\w+$)/ or die "bad name: $name";
  (my $dext) = $ext =~ /(^\w+$)/ or die "bad ext: $ext";
  my $path = File::Spec->catfile(fastcwd(), 'world', '_players', "\L$dname.$dext");
  return ($path =~ /^(.*)$/)[0];
}

sub players_dir {return File::Spec->catdir(fastcwd(), 'world', '_players')}

=cut

sub authenticate {
  my ($name, $pass) = @_;

  local *PFILE;
  $name = lc $name;
  open PFILE, MUnique->filename($name, 'pass') or return 1;
  my $realpass = <PFILE>;
  chomp $realpass;
  close PFILE;
  return (my_crypt($pass, substr($realpass, 0, 2)) eq $realpass);
}

sub has_password {
  my ($name) = @_;

  return -e MUnique->filename($name, 'pass');
}

sub set_player_password {
  my ($name, $newpass) = @_;

  (my $dname) = $name =~ /(^\w+$)/ or die "bad name: $name";
  $dname = lc $dname;
  local *PFILE;
  open PFILE, "> " . MUnique->filename($name, 'pass') or return '';
  my @chars = ('a'..'z', 'A'..'Z', 0..9, '.');
  print PFILE my_crypt($newpass, $chars[rand @chars] . $chars[rand @chars]);
  close PFILE;
}

sub do_alias_cmd {
  my ($self, $args) = @_;

  my ($name, $cmds) = split /\s+/, $args, 2;
  my $atab = $self->{prefs}{aliases};
  if (defined $name) {
    if (defined $cmds) {
      $atab->{$name} = $cmds;
      # $self->send("Set alias.");
    } else {
      delete $atab->{$name};
      # $self->send("Deleted alias.");
    }
  } else {
    $self->send("Currently defined aliases:");
    foreach (keys %$atab) {
      $self->send(sprintf "%-16s -> %s", $_, $atab->{$_});
    }
  }
}

sub pref {
  my ($self, $key, $value) = @_;
  if (defined $value) {
    $self->{prefs}{$key} = $value;
  }
  return $self->{prefs}{$key} || ($key eq 'aliases' ? ($self->{prefs}{aliases} = {}) : undef);
}

sub read_prefs {
  my ($self) = @_;
  mudlog "Reading player prefs for $self->{login_name}";
  PREAD: {
    my $prefs_file = IO::File->new(MUnique->filename($self->{'login_name'}, 'pref'), '<') or do {
      mudlog "Error opening player prefs file for $self->{'login_name'}: $!"
        unless $! =~ /No such file/;
      last PREAD;
    };
    local $/;
    binmode $prefs_file;
    $prefs_file->getline =~ /^(.*)$/s;
    my $prefs;
    eval { $prefs = MFreezer::thaw($1); };
    if ($@) {
      mudlog "ERROR/UNIQUE: $self->{login_name}: Bad prefs file";
      last PREAD;
    }
    $prefs_file->close;
    foreach (keys %$prefs) {
      # Don't override already set prefs (e.g. autoset terminal size), except for
      # color, because the user might want to not have color even if his terminal
      # supports it.
      next if exists $self->{prefs}{$_} and $_ ne 'color';
      $self->{prefs}{$_} = $prefs->{$_};
    }
  }
  $self->{prefs_ok} = 1;
}

sub write_prefs {
  my ($self) = @_;
  #print "DEBUG: in write_prefs login $self->{'login_name'} pok $self->{prefs_ok}\n";
  if ($self->{'login_name'} and $self->{prefs_ok}) {
    mudlog "Writing player prefs for $self->{login_name}";
    #print "DEBUG: passed write tests\n";
    my $prefs_file = IO::File->new(MUnique->filename($self->{'login_name'}, 'pref'), '>', DATA_PERMS)
      or mudlog "Couldn't open prefs file for $self->{'login_name'} for writing: $!" and return;
    binmode $prefs_file;
    $prefs_file->print(MFreezer::freeze($self->{prefs}));
    $prefs_file->close;
  }
  1;
}

sub my_crypt ($$) {
  my ($str, $salt) = @_;

  my $ret;
  eval {$ret = crypt $str, $salt};
  return $ret unless $@;
  return $str;
}

sub ip {$_[0]{ip}}
sub port {$_[0]{port}}
sub login_name {$_[0]{login_name}}

sub color {$_[0]->{prefs}{color}}
sub scr_width {$_[0]->{prefs}{scr_width} || 80}
sub scr_height {$_[0]->{prefs}{scr_height} || 24}
sub id {$_[0]{'id'}}

sub disconnect {
  my ($self, $opt) = @_;

  return unless %$self and $self->{'id'};
  $self->send_str_raw(join '', @{$self->{out_buffer}}) if $opt eq 'normal' and $self->open; # flush
  $self->id_log(($opt and $opt eq 'normal') ? "disconnected normally." : "disconnected."); 
  delete $Connections{$self->{'id'}} if $self->{'id'};
  if ($self->{'object'}) {
    $self->{'object'}->act(undef, $self->{'object'}->name . " has lost $GENDER_POSS{$self->{'object'}->gender} connection.")
      unless !$self->{'object'}->unique or $opt and $opt eq 'silent';
    $self->{'object'}->reset_val('connection');
  }
  $self->write_prefs();
  %{$self} = ();
}

sub DESTROY {
  my ($self) = @_;
  $self->disconnect;
  print "$self DESTROYED\n" if ::GC_DEBUG;
  1;
}


1;
