package MConnection;
use strict;
use vars qw(
  @ISA
  %Listeners
  %States
  %Namespaces
  %ConMethods
  $PrefDefaultList

  $NextConnectionID
  %Connections %ConnectedObjects
  $Active
);
use MCoreTools;
use MInitializable;
@ISA = qw(MInitializable);

use integer;                  # <<< note this

use MObject;
use MCollection;
use MConnection::Nil;

use MTerminal::ANSI;
use MTerminal::XML;

$NextConnectionID ||= 1;

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

sub _initialize {
  my ($class) = @_;
  require MObjectDB; initialize MObjectDB;
  require MDefList;  initialize MDefList;

  my $statelist = MDefList->new(
    source => 'CORE',
    name => 'States',
    type => 'HASH',
    multiple => 0,
    mirror => \%States,
  );
  
  $statelist->add('CORE', none => {});
  
  MDefList->new(
    source => 'CORE',
    name => 'Elements',
    type => 'HASH',
    multiple => 0,
  );

  MDefList->new(
    source => 'CORE',
    name => 'Namespaces',
    multiple => 0,
    mirror => \%Namespaces,
  );

  $PrefDefaultList = MDefList->new(
    source => 'CORE',
    name => 'PrefDefaults',
    multiple => 0,
  );

  MDefList->new(
    source => 'CORE',
    name => 'ConnectionMethods',
    mirror => \%ConMethods,
    multiple => 0,
  );

}

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

# interesting note: this is ONLY used in the admin 'dcother' command.
sub by_id {
  my ($class, $id) = @_;
  return $Connections{$id};
}

sub listen_start {
  my ($class) = @_;
  $class->initialize;
  return if $Active;
  for (keys %Listeners) {$_->_listen_start}
  $Active = 1;
}

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

sub obj_connections {
  my ($class, $obj) = @_;
  
  return values %{$ConnectedObjects{$obj->id} || {}}
}

sub invoke_for_object {
  my ($class, $meth, $obj) = (shift, shift, shift);
  for (values %{$ConnectedObjects{$obj->id} || {}}) {
    $_->$meth(@_);
  }
}

# to be overridden by subclasses
sub _listen_start {}
sub _listen_stop {}

sub register_listener {
  my ($class, $otherclass) = @_;
  $Listeners{$otherclass} = 1;
  $otherclass->_listen_start if $Active;
}

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

sub new {
  my $class = shift;

  my $self = bless {
    in_buffer => '',
    out_buffer => [],
    page_lines => [],
    last_input_time => time(),
    prefs => {
      scr_width => 80,
      scr_height => 24,
      call_hooks('default_connection_prefs'),
    },
  }, $class;
  print "$self CREATED\n" if ::GC_DEBUG;

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

  $self->{terminal_obj} = MTerminal::ANSI->new($self), # FIXME: eventually have separate ports for
                                                   # whether you want ansi, xml, or something else
  $self->_subnew(@_);
  $self->setstate('none');
  $self->id_log("connected."); 

  $self->terminal->init($self);
  return $self;
}

# The argument to ->disconnect is a textual description of the reason for
# disconnection.

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

  if ($self->{terminal_obj}) {
    # we do this first so the terminal obj has a 'normal'ish state to work with.
    $self->terminal(undef);
  }

  return unless %$self and $self->{'id'} and $::Quit ne 'no_cleanup';
  delete $Connections{$self->{'id'}};

  if ($self->{disconnecting}) {
    carp "ERROR/CORE: MConnection being disconnected again";
    return;
  }
  
  $self->{disconnecting} = 1;
  
  $self->flush if !$iserror and $self->open;

  $self->write_prefs();
  
  $self->id_log("disconnected (@{[$desc || 'unknown reason']})."); 

  if (my $obj = $self->{'object'} and MObjectDB->is_open) {
    $self->detach($obj, 'remote disconnect');
  }

  $self->user(undef);

  MScheduler->remove_owned($self);

  %{$self} = (id => $self->{'id'}, formerly => ref($self));
  bless $self, 'MConnection::Nil';
  $self->now_nil;
}

sub DESTROY {
  my ($self) = @_;
  return if $::Quit and $::Quit eq 'no_cleanup';
  print "in MConnection::DESTROY\n";
  eval {
    print STDOUT "$self DESTROYING\n" if ::GC_DEBUG;
    $self->disconnect('DESTROY');
    print STDOUT "$self DESTROYED\n" if ::GC_DEBUG;
    1;
  };
  print STDOUT $@ if $@;
}

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

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 open {1}

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

use Lingua::EN::Inflect ();

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

  # this is the method called by MTerminal classes to pass the data on to the client
  # translate line endings because there is uncertainty as to what line endings text stored in the DB will have  
  $text =~ s/\cM\cJ?|\cJ/\n/g;
  $self->send_str_raw($text);
}

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

  my %namespace;
  my $elist = MDefList->root->get('Elements');
  
  my $recursor;
  $recursor = sub {
    my ($node) = @_;
    
    wantarray or croak "SX recursor called in scalar context";
    if (not ref $node) {
      return $node if length $node;
      return ();
    }
    
    my @newnodes;
    my $elem = (   (ref $node eq 'MObjectRef') ? 'Object'
                 : (ref $node eq 'ARRAY')      ? $node->[SX_ELEM]
                 : undef
               ); 

    my $inf;
    if ($elem and $inf = $elist->get($elem) and $inf->{OutProcess}) {
      @newnodes = $inf->{OutProcess}->($node, $self->{'object'}, $recursor, $self);
    } else {
      if (ref $node eq 'ARRAY') {
        my @children = map $recursor->($_), @{$node}[SX_CONT..$#$node];
        @children = grep {
          ref $_ ne 'ARRAY' or scalar($#$_) >= SX_CONT or ($elist->get($_->[SX_ELEM]) || {})->{KeepEmpty}
        } @children;
        @newnodes = [@{$node}[SX_ELEM..SX_ATTR], @children];
      } else {
        @newnodes = ($node);
      }
    }
    
    foreach my $newnode (@newnodes) {
      next unless ref $newnode and ref $newnode eq 'ARRAY';
      foreach (                                               # tricky
         ($newnode->[SX_ELEM] =~ /^(.*?):/ ? $1 : ()                              ),
         (                 map +(/^(.*?):/ ? $1 : ()), keys %{$newnode->[SX_ATTR]}),
      ) {
        $namespace{$_}++;
      }
    }
    
    return @newnodes;
  };

  my @processed_nodes = map $recursor->($_), @nodes;
  delete $namespace{xml};

  $recursor = undef; # break circular reference from the closure to itself
  
  ($self->terminal or return 0)->output($self, [out=>{
    map +($Namespaces{$_} ? ("xmlns:$_" => $Namespaces{$_}) : croak "Undefined namespace $_"), keys %namespace
  }, @processed_nodes]);

  return 1;
}

### Object methods - Input, prompts, states ##########################################################################################

sub needs_flush {
  my ($self) = @_;
  unless ($self->{has_flush_evt}) {
    # if we haven't already, register an event to flush output and send a prompt
    if (MScheduler->running) {
      MEvent::Message->new(
        name => "Flush",
        owner => $self,
        target => $self,
        method => 'flush',
        no_store => 1,
        is_real_time => 1,
        time => 0.1,
      )->schedule;
      $self->{has_flush_evt} = 1;
    } else {
      $self->flush;
    }
  }
}

sub needs_prompt {
  $_[0]->terminal->needs_prompt($_[0]);
}

sub flush {
  my ($self) = @_;
  
  if (!ref $self) {
    # method called on class
    for (values %Connections) { $_->flush; }
    return;
  }
  
  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->terminal->needs_prompt($self);
  }
  $self->{has_flush_evt} = 0;
  
}

sub get_prompt {
  my ($self) = @_;
  my $prompt_thing = (my $sr = $self->{staterec})->{prompt} or return '';
  ref $prompt_thing ? $prompt_thing->($self) : $prompt_thing
}

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

  # It is the responsibility of the subclass to translate all line-endings to "\n".

  my $got;
  my $ibuf = \($self->{in_buffer});
  while (
      ($$ibuf =~ s#(^.*?\\\\\n.*\n//)##s) or
      ($$ibuf !~ /\\\\\n/ and $$ibuf =~ s/^((?:.*?[^\\])?)\n//s)
  ) {
    my $input = $1;
    # FIXME: continuations and definition of 'input line' ought to be handled entirely in MTerminal::
    for ($input) {
      if (s#\\\\\n#\n#) { # \\ // style continuations
        s#\n?\/\/$##;
      } else {            # x\y\z style continuations, or maybe none at all
        s/\\\n/\n/g;
      }
    }
    $input = ($self->terminal or die "What the? No terminal while in handle_input!")->input($self, $input);
    $self->send_str_raw("\n") if $self->{staterec}{no_echo};
    my $state = $self->{state};
    eval {
      MScheduler::mon_push("Handling input in $self->{'state'}");
      $self->{staterec}{input}->($self, $input) if $self->{staterec}{input};
      return if $self->is_nil;
      MScheduler::mon_pop();
    };
    if ($@) {
      mudlog "ERROR/CORE: exception in input handler for state $state:\n$@";
      $self->send([error=>{}, "Sorry, an error occurred."]);
    }
    $got = 1;
  }
  { ($self->terminal or last)->input_post($self); }
  $self->reset_idle if $got;
  return;
}

### Object methods - Idle timeout ##########################################################################################

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

  $self->{last_input_time} = time();

  return unless MScheduler->running;

  MScheduler->remove_event($self->{idle_out_event}) if $self->{idle_out_event};
  MScheduler->remove_event($self->{idle_warn_event}) if $self->{idle_warn_event};

  my $timeout = $self->{staterec}{timeout} or return;
  my $warning = $timeout * 7 / 10;

  ($self->{idle_out_event} = MEvent::Message->new(
    name => "Connection Idle Out",
    'time' => $timeout,
    is_real_time => 1,
    owner => $self,
    target => $self,
    method => 'do_timeout',
    arguments => [$timeout],
    no_store => 1,
  ))->schedule;
  ($self->{idle_warn_event} = MEvent::Message->new(
    name => "Connection Idle Warning",
    'time' => $warning, 
    is_real_time => 1,
    owner => $self,
    target => $self,
    method => 'do_timeout_warning',
    arguments => [$warning, $timeout - $warning],
    no_store => 1,
  ))->schedule;
}


sub do_timeout {
  my ($self, $idle_for) = @_;

  $self->send("[Idle for $idle_for seconds, disconnecting.]");
  $self->disconnect("idled $idle_for seconds in state $self->{state}");
}

sub do_timeout_warning {
  my ($self, $idle_for, $disconnect_at) = @_;

  $self->send("[Idle for $idle_for seconds, will disconnect in $disconnect_at seconds.]");
}

sub input_as {
  my ($self, $state, $input) = @_;
  ($States{$state}{input} or return)->($self, $input);
}

sub setstate {
  my ($self, $state, $reason) = @_;
  
  $States{$state} or confess "No such connection state: '$state'";
  
  $self->{last_state} = $self->{state};
  $self->{state} = $state;
  $self->{staterec} = my $sr = $States{$state};
  $self->needs_flush;
  if ($self->{last_state} and ($States{$self->{last_state}}{no_echo} xor $sr->{no_echo})) {
    if ($sr->{no_echo}) {
      $self->send_echo_off;
    } else {
      $self->send_echo_on;
    }
  }
  $sr->{entry}->($self, $reason) if $sr->{entry};
  $self->needs_prompt; # must be after entry handler, in case it sets data that affects prompt
  $self->reset_idle;
  return;
}

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

sub object {$_[0]{object}}
sub objects {$_[0]{object}}

sub attach {
  my ($self, $obj, $extra) = @_;
  
  $obj and $obj->isa('MObjectRef') or croak "MConnection::attach called with non-object-ref argument";
  if ($self->{'object'}) {
    delete $ConnectedObjects{$self->{'object'}->id}{$self->id};
    $self->id_log('implicitly detached from #'.$self->{'object'}->id.'.');
  }

  $self->{object} = $obj;
  $ConnectedObjects{$obj->id}{$self->id} = $self;

  call_hooks('con_attached', $self, $obj, $extra);
}

=item detach OBJ, EXTRA

Detaches the connection from the specified object. Does nothing if
they are not attached.

After detaching, calls the 'con_detached' hook with arguments C<(self, OBJ, EXTRA)>.

=cut

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

  if (my $obj = $self->{'object'}) {
    return if $aobj and $aobj->id != $obj->id;
    $self->id_log('detached from #'.$obj->id.'.');
    delete $self->{object};
    delete $ConnectedObjects{$obj->id}{$self->id};
    call_hooks('con_detached', $self, $obj, $extra);
  } else {
    $self->id_log('detached without object.');
  }
}

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

sub user {
  my ($self, $new) = @_;
  
  if (@_ > 1) {
    if ($self->{user}) {
      MUser->get($self->{user})->inactivate($self);
      delete $self->{user};
    }
    if (defined $new) {
      $new = $new->name if ref $new;
      $self->{user} = lc $new;
      MUser->get($self->{user})->activate($self);
      $self->read_prefs;
    }
  }
  return MUser->get($self->{user} or return undef);
}

sub pref {
  my ($self, $key, $value) = @_;
  $self->{prefs}{$key} = $value if @_ > 2;
  return exists $self->{prefs}{$key} ? $self->{prefs}{$key} : scalar $PrefDefaultList->get($key);
}

sub read_prefs {
  my ($self) = @_;
  return unless $self->user;
  my $stored = $self->user->get('prefs') || {};
  while (my ($k, $v) = each %$stored) {
    $self->{prefs}{$k} = $v unless exists $self->{prefs}{$k};
  }
  $self->{prefs_ok} = 1;
}

sub write_prefs {
  my ($self) = @_;
  
  if ($self->user and $self->{prefs_ok}) {
    $self->user->set('prefs', MFreezer::clone($self->{prefs}));
  }
  1;
}

sub data {
  my ($self, $key, $value) = @_;
  $self->{libdata}{$key} = $value if @_ > 2;
  return $self->{libdata}{$key};
}

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

sub id_log {
  my ($self, $str) = @_;
  mudlog "C $self->{id}" . ($self->user ? "/" . $self->user->name : '') . do {my $ils = $self->il_source; $ils ? "/$ils" : ''} . ": $str";
}

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

sub terminal {
  my ($self, $new) = @_;
  if (@_ > 1) {
    if ($self->{terminal_obj}) {
      $self->{terminal_obj}->dispose($self);
    }
    if (!defined $new) {
      delete $self->{terminal_obj};
    } elsif ($new =~ /^M|:/) {
      $self->{terminal_obj} = $new->new($self);
    } else {
      $self->{terminal_obj} = "MTerminal::\U$new"->new($self);
    }
    $self->{terminal_obj}->init($self) if $self->{terminal_obj};
  }
  $self->{terminal_obj};
}

sub id         {$_[0]{id}}
sub state      {$_[0]{state}}

sub is_nil {0}

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

### Module-defined methods ##########################################################################################


sub AUTOLOAD {
  use vars '$AUTOLOAD';
  goto &{
     $ConMethods{($AUTOLOAD =~ /::([^:]+)$/)[0]} or croak "Undefined method $AUTOLOAD called"
  };
}

1;
