package MConnection;
use strict;
use vars qw(
  @ISA
  %Subclasses

  %InputHandlers
  %EnterHandlers
  %PromptHandlers
  %CharEscapes

  $NextConID
  %Connections
  $Active
);

use Carp;
use Cwd;
use IO::Socket;
use IO::File;
use MCoreTools;
use MObject;
use MCollection;
use MConnection::Interface;

$NextConID ||= 1;             # unique id for connection

%CharEscapes = (
  '&'  => '&',
  'z'  => '',
  'zz' => '',

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


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

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

sub poll {
  my ($class, $timeout) = @_;
  return unless $Active;
  my $subtimeout = $timeout / (scalar(keys %Subclasses) + scalar(keys %Connections));
  for (keys %Subclasses) {$_->_listen_run($subtimeout)}
  for (values %Connections) {
    if (!ref $_) {
      croak "Non-object '$_' in connections table!";
    }
    $_->_opoll($subtimeout);
  }
  return scalar values %Connections;
}

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

sub listen_start {
  for (keys %Subclasses) {$_->_listen_start}
  $Active = 1;
}

sub listen_stop {
  $Active = 0;
  for (keys %Subclasses) {$_->_listen_stop}
}

sub char_escapes {
  return \%CharEscapes;
}

### Object methods - creation/destruction ##########################################################################################

sub new {
  my $class = shift;

  my $self = bless {
    in_buffer => '',
    out_buffer => [],
    lastprompt => '',
    state => 'login',
    page_lines => [],
    last_input_time => time(),
    pdata => {
    },
  }, $class;
  print "$self CREATED\n" if ::GC_DEBUG;

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

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

  $self->_message();
  return $self;
}

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

  return unless %$self and $self->{'id'};

  delete $Connections{$self->{'id'}};
  $self->send_str_raw(join '', @{$self->{out_buffer}}) if ($opt and $opt eq 'normal') and $self->open; # flush

  $self->write_pdata();
  $self->id_log(($opt and $opt eq 'normal') ? "disconnected normally." : "disconnected."); 

  if ($self->{'object'} and MObjectDB->is_open) {
    if ($self->{'login_name'} eq 'guest') {
      $self->id_log("disposing guest object.");
      $self->{'object'}->dispose;
    } else {
      $self->{'object'}->reset_val('connection');
    }
  }
  %{$self} = ();
}

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

### Object methods - Stuff to be overridden ##########################################################################################

sub _subnew {}
sub _message {}
sub initial_state {'login'}

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 read_input {}
sub escape_handler {sub {0}}
sub open {1}

### Object methods - Sending text ##########################################################################################

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

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

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

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

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

### Object methods - Formatting text ##########################################################################################

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 format_multicol {
  my $self = shift;
  my @items = grep defined, @_;
  
  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";
  }
  return $buf;
}

sub send_multicol {
  my $self = shift;
  $self->send_page($self->format_multicol(@_));
}

### Object methods - Polling, prompts, states ##########################################################################################

sub _opoll {
  my ($self, $timeout) = @_;

  $self->read_input($timeout) or return;
  
  if ($self->{needsprompt}) {
    $self->send_str($self->{lastprompt} = 
      (
        $PromptHandlers{$self->{'state'}} || sub {confess "no prompt for state: $self->{'state'}"}
      )->($self)
    );

    return unless %$self;
    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//; # handle backspace
      s/^\s+//;
      s/\s+$//;
      tr/\x00-\x1F\x7F-\xFF//d; # this does chomp's job too
    }
    $self->{'gotline'} = 1;
    $self->{last_input_time} = time();
    try {
      MScheduler::mon_set("Handling input in $self->{'state'}");
      $InputHandlers{$self->{'state'}}->($self, $input);
    } catch {
      $self->send("&:fr;Sorry, an error occurred.&:n;");
      mudlog "ERROR/CORE: death in input handler for state $self->{'state'}: $_";
    };
    if ($self->open) {
      $self->{gotline} = 0;
      $self->{needsprompt} = 1;
    }
  }
}

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

### Object methods - World-object linkage ##########################################################################################

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

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

sub link_to_object {
  my ($self, $obj, $opts) = @_;
  
  if ($self->{'object'}) {
    $self->{'object'}->reset_val('connection');
  }
  if (my $old = $obj->connection) {
    $old->send("Your connection has been replaced!");
    $self->id_log("replacing old connection.");
    $old->disconnect();
  }

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

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

  if (ref $self->object) {
    $self->object->reset_val('connection');
  }
  $self->object(undef);
  if ($self->{login_name} eq 'guest') {
    $self->send("Thanks for trying $::Config{name}!");
    $self->disconnect;
  } else {
    $self->setstate('menu');
  }
}

### Object methods - Player preferences & data ##########################################################################################

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

sub read_pdata {
  my ($self) = @_;
  return if $self->{login_name} eq 'guest';
  #mudlog "Reading player data for $self->{login_name}";
  PREAD: {
    my $pdata_file = IO::File->new(pfilename($self->{'login_name'}), '<') or do {
      mudlog "Error opening player data file for $self->{'login_name'}: $!";
      last PREAD;
    };
    local $/;
    binmode $pdata_file;
    $pdata_file->getline =~ /^(.*)$/s;
    my $pdata;
    eval { $pdata = MFreezer::thaw($1); };
    if ($@) {
      mudlog "ERROR: $self->{login_name}: Bad pdata file";
      last PREAD;
    }
    $pdata_file->close;
    foreach (keys %$pdata) {
      # 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->{pdata}{$_} and $_ ne 'color';
      $self->{pdata}{$_} = $pdata->{$_};
    }
  }
  $self->{pdata_ok} = 1;
}

sub write_pdata {
  my ($self) = @_;
  #print "DEBUG: in write_pdata login $self->{'login_name'} pok $self->{pdata_ok}\n";
  
  if ($self->{'login_name'} and $self->{login_name} ne 'guest' and $self->{pdata_ok}) {
    #$self->id_log("Writing player data");

    my $bytes = MFreezer::freeze($self->{pdata});
    my $pdata_file = IO::File->new(pfilename($self->{'login_name'}), '>', DATA_PERMS)
      or mudlog "Couldn't open pdata file for $self->{'login_name'} for writing: $!" and return;
    binmode $pdata_file;
    $pdata_file->print($bytes);
    $pdata_file->close;
  }
  1;
}

### Object methods - Accessors, misc functions ##########################################################################################

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

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

# this typically gets overridden - it should provide information about the 
# 'other end' of the connection for use by id_log.
sub source {"#".$_->id}

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

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

sub idle_time {time() - $_[0]->{last_input_time}}

1;
