package MCP;

use strict;
use warnings;
use Carp;

=head1 NAME

MCP - MUD Client Protocol support in Perl

=head1 SYNOPSIS

    use MCP;

    $pkg = Define MCP::Package 'dns-org-mud-moo-simpleedit',
      min_version => "1.0",
      max_version => "1.0";

    define_initializer $pkg sub {
       my ($session) = @_;
       $session->write_inband("\@edit me.foo\r\n");
    };

    define_method $pkg content => sub {
       my ($session, $params) = @_;
       print "Reference: $params->{reference}\n";
       print "Name: $params->{name}\n";
       print "Type: $params->{type}\n";
       foreach (@{$params->{content}}) {
	  print "$_\n";
       }
       print "\n";
       $session->write_inband("\@quit\r\n");
    };

    $|=1;
    my $socket = IO::Socket::INET
      ->new(PeerAddr => "random.moo.mud.org", PeerPort => 8888);

    $sess = MCP::Session->new($socket, client => 1);
    $sess->start_mcp();
    $sess->write_inband("connect $user $password\r\n");

    while (<$socket>) { $sess->eat_line($_); }

    $sess->close();

=head1 DESCRIPTION

MUD Client Protocol is a means for multiplexing a bidirectional 
stream of structured messages onto a single line-oriented channel.
For more details see 
  http://www.moo.mud.org/mcp/



=cut

{
   package MCP::Version;
   use Carp;
   use overload '""' => \&str, '<=>' => \&cmpn, '+' => \&add, '-' => \&subtr;
   
   sub new {
      my $class = shift;
      my $str = join '.',@_;
      return undef unless $str =~ /([0-9]+)\.([0-9]+)/;
      bless [0+$1,0+$2], $class;
   }

   sub major { $_[0]->[0]; }
   sub minor { $_[0]->[1]; }

   sub str {
      my $self = shift;
      my ($maj,$min) = @$self;
      "$maj.$min"
   }
   sub cmpn {
      my ($v,$w,$rev) = @_;
      my ($vj,$vi) = @$v;
      my ($wj,$wi) = @$w;
      my $r = (($vj <=> $wj) || ($vi <=> $wi));
      ($rev ? -$r : $r);
   }

   sub add {
      my ($self,$other,$rev) = @_;
      croak "cannot add two versions together" if ref($other);
      if (defined($rev)) {
	 bless [$self->[0],$self->[1]+$other], ref($self);
      }
      else {
	 $self->[1] += $other;
      }
   }
   sub subtr {
      my ($self,$other,$rev) = @_;
      if (ref($other)) {
	 croak "subtraction: different major versions" 
	   if ($self->major != $other->major);
	 return $self->minor - $other->minor;
      }
      else {
	 return $self->add(-$other,$rev);
      }
   }

   sub Range {
      my ($vmin,$vmax) = map { MCP::Version->new($_) } @_;
      return $vmin && $vmax 
	? MCP::Intervalset->range($vmin,$vmax)
        : MCP::Intervalset->empty;
   }
}

{
   package MCP::Intervalset;
   use Carp;
   use overload
       '""' => \&str,
       'bool' => \&bool, 
       '|' => \&union, 
       '&' => \&intersect,
       '==' => \&equal,
       '>=' => \&geq;
   
   my $empty = bless [];
   sub empty { $empty };

   sub range {
      my ($class,$lo,$hi) = @_;
      return $empty if ($hi+1 <= $lo);
      return $class->_new($hi+1, $lo);
   }

   sub _new {
      my ($class) = shift;
      $class = ref($class) if ref($class);
      bless [@_],$class;
   }

   sub bool {
      my ($self) = @_;
      @$self;
   }
   sub str {
      my ($self) = @_;
      my $i = @$self;
      "[" . (($i&1) ? '-oo' : '') . join('', map { 
	 (defined($_) ? (!((--$i) & 1) ? $_ - 1 : $_ ) : "+oo"), 
         (($i & 1) ? " .. " : $i>0 ? ", " : "")
      }
		 reverse @$self) . "]";
   }

   sub equal {
      my ($self,$other) = @_;
      return unless (@$self == @$other);
      for (my $i = 0; $i < @$self; ++$i) {
	 return if $self->[$i] != $other->[$i];
      }
      return 1;
   }

   sub geq {
      my ($self,$other) = @_;
      return equal(union($self,$other,0),$self);
   }

   sub top_interval {
      @{$_[0]} && bless([ $_[0]->[0], $_[0]->[1]]);
   }

   sub max {
      my ($self) = @_;
      return unless $self->[0];
      $self->[0] - 1;
   }
   sub min {
      $_[0]->[int($#{$_[0]}/2)*2+1];
   }
   sub union {
      my ($self,$other,$rev) = @_;
      return $self  unless (@$other);
      return $other unless (@$self);
      return $self->_ui(0,$other);
   }

   sub intersect {
      my ($self,$other,$rev) = @_;
      return $self  unless (@$self);
      return $empty unless (@$other);
      return $self->_ui(1,$other);
   }

   sub _ui {
      my ($self,$intersect,$other) = @_;
      my @s = ($self,$other);
      my @i = (0,0);
      my $x = 0;
      my @r = ();
      goto evil if ($intersect);

      # union-outside / intersection-inside
      for (;;) {
	 # at this point we are looking at two upper [lower] bounds
	 # select whichever list has the larger one
	 # and pop that onto the result
	 $x = ((1 - ($s[0]->[$i[0]] <=> $s[1]->[$i[1]])) >> 1);
	 push @r, $s[$x]->[$i[$x]++];

	 goto done if ($i[$x] >= @{$s[$x]});

       evil:
	 for (;;) {
	    # the selected list is showing a lower [upper] bound
	    # discard every element from the other list that is
	    # >= the selected list element
	    until ($s[$x]->[$i[$x]] > $s[1-$x]->[$i[1-$x]]) { 
	       ++$i[1-$x];
	       if ($i[1-$x] >= @{$s[1-$x]}) {
		  goto done if (($i[1-$x] & 1) xor $intersect);
		  goto push_remaining_list;
	       }
	    }

	    last unless (($i[1-$x] & 1) xor $intersect);
	    $x = 1-$x;
	 }

	 push @r, $s[$x]->[$i[$x]++];

	 if ($i[$x] >= @{$s[$x]}) {
	    $x = 1-$x;
	    last;
	 }
      }
    push_remaining_list:
      do {
	 push @r, $s[$x]->[$i[$x]++];
      } while ($i[$x] < @{$s[$x]});
    done:
      return bless \@r;
   }

   sub range_args {
      my ($self,$from,$to) = @_;
      return unless @$self;
      ($from, $self->[1], $to, $self->[0]-1);
   }


}

{

=head1 MCP::Package

The following methods are available:

=over 4

=cut

   package MCP::Package;
   use strict;
   use warnings;
   use Carp;

   use fields qw(name vset methods initial final file line class pkginst_class);

   ##################
   # class methods

   my %Packages = (); # name -> [@implementations ...]
   our %Versions = (); # name -> vset;

   # MCP::Package->GetLatest(name) -> pkg
   sub GetLatest { 
      my $class = shift;
      my $name = shift;
      my $pkglist = $Packages{$name}->[0] if $Packages{$name};
   }

   # MCP::Package->Get(name,vset) -> (pkg, version)
   sub Get { 
      my $class = shift;
      my $name = shift;
      my $range = shift;

      return unless my $pkglist = $Packages{$name};
      foreach (@{$pkglist}) {
	 my $vset = $range & $_->{vset};
	 return ($_,$vset->max()) if $vset;
      }
      return;
   }

=item MCP::Package->Define(name, [attrib => value,...])

Creates a package definition.  Allowed attributes include

=over 4

=item min_version

Minimum version supported by this implementation

=item max_version

Maximum version supported by this implementation

=item pkginst

The class from which to instantiate package instances if other than C<MCP::PkgInst> 
(class must still be a descendant of C<MCP::PkgInst>).

=item initial

Package initializer.  Supplying this is equivalent to using C<define_initializer> below.

=item final

Package finalizer.  Supplying this is equivalent to using C<define_finalizer> below.

=back

=cut

   sub Define {
      my ($class, $name, %params) = @_;
      my ($perlpkg, $file, $line) = caller();
      $perlpkg = delete $params{class} if $params{class};
      my $self = fields::new($class);

      croak "package name expected" 
	unless $name;
      croak "package name must not end with '-'" 
	if $name =~ /-$/;

      @{$self}{qw/name class file line/} = ($name, $perlpkg, $file, $line);
      $self->{vset} = MCP::Version::Range(delete @params{qw(min_version max_version)})
	or croak "unintelligible version information";

      $self->{pkginst_class} = 'MCP::PkgInst';
      if (my $pkginst_class = delete $params{pkginst}) {
	 croak "pkginst $pkginst_class is not a descendant of MCP::PkgInst"
	   unless bless([], $pkginst_class)->isa('MCP::PkgInst');
	 $self->{pkginst_class} = $pkginst_class;
      }

      my $hide = delete $params{hide};
      my $parent = delete $params{parent};

      %{$self->{methods}} =  $parent ? %{$parent->{methods}} : ();

      foreach (qw(initial final)) {
	 $self->{$_} = delete $params{$_};
      }
      carp "MCP Package $name:  unknown parameter(s):  ".join(', ',keys %params)
	if %params;

      # register the new package
      if ($hide) {
      }
      elsif (!(my $pkglist = $Packages{$name})) {
	 @{$Packages{$name}} = $self;
	 $Versions{$name} = $self->{vset};
      }
      else {
	 my $inserted = 0;
	 my $vset = $self->{vset};
	 @{$Packages{$name}} = map {
	    if ($self->{Vset} >= $_->{vset}) {
	       carp "MCP Package $name in ".$_->{file}.", line ".$_->{line}." subsumed."
		 unless $_->{$file} eq $self->{file} && $_->{line} eq $self->{line};
	       ()
	    }
	    else {
	       $vset = $vset | $_->{vset};
	       (!$inserted && $self->{vset}->max >= $_->{vset}->max
		? (scalar($inserted=1,$self), $_) 
		: ($_))
	    }
	 } @$pkglist;
	 $Versions{$name} = $vset;
      }
      bless $self, $class;
   }

   sub new_pkginst {
      my $pkg = shift;
      return $pkg->{pkginst_class}->new($pkg,@_);
   }

=item $package->name

Returns the package name.

=cut

   sub name { $_[0]->{name} }

   # method name -> string to append to package name to obtain full method name
   sub method_suffix {
      my (undef,$name) = @_;
      return ($name =~ /^-/ || $name eq '' ? '' : '-') . lc($name);
   }


=item $package->method_name($name)

Returns the fully qualified method name corresponding to $name

=cut

   sub method_name {
      my ($pkg,$name) = @_;
      return $pkg->{name} . &method_suffix;
   }

=item define_method $pkg name => sub { my($session,$params) = @_; ... };

=item $pkg->define_method(name => sub { my($session,$params) = @_; ... });

Defines a message handler.

=cut

   sub define_method {
      my ($pkg,$name,$code) = @_;
      $name = &method_suffix;
      carp "Clobbering previous definition of $name" if defined $pkg->{methods}->{$name};
      $pkg->{methods}->{$name} = $code;
   }

=item define_initializer $package sub { my($session,$params) = @_; ... };

=item $package->define_initializer(sub { my($session,$params) = @_; ... });

Defines a package initializer.
Initializers run as soon as version negotiation succeeds in a given session.

=cut

   sub define_initializer {
      my ($pkg,$code) = @_;
      carp "Clobbering previous initial method" if defined $pkg->{initial};
      $pkg->{initial} = $code;
   }

=item define_finalizer $package sub { my($session,$params) = @_; ... };

=item $package->define_finalizer(sub { my($session,$params) = @_; ... });

Defines a package finalizer.

=cut

   sub define_finalizer {
      my ($pkg,$code) = @_;
      carp "Clobbering previous final method" if defined $pkg->{final};
      $pkg->{final} = $code;
   }

   sub full_desc {
      my ($pkg) = @_;
      ($pkg->{name}.$pkg->{vset},$pkg->{file}.", line ".$pkg->{line});
   }

=item $package->inst($session)

Returns $session's package instance object for this package, if any.

=cut

   sub inst {
      my ($pkg,$session) = @_;
      return $session->{pkginsts}->{$pkg->{name}};
   }

=back

=cut

}


#################################################################
# PACKAGE mcp-root 
# PACKAGE mcp-negotiate
#

my $mcp_root = 
  Define MCP::Package 'mcp',
  hide => 1,
  min_version => '2.1',
  max_version => '2.1';

my $mcp_negotiate = 
  Define MCP::Package 'mcp-negotiate',
  hide => 1,
  min_version => '1.0',
  max_version => '2.1';

my $msg_mcp = $mcp_root->method_name('');
my ($authkey_keyword, @mcp_range_keywords) = qw(authentication-key version to);

define_method $mcp_root '' => sub {
   my ($session,$params) = @_;
   my $version = ($mcp_root->{vset} & 
		  MCP::Version::Range(@{$params}{@mcp_range_keywords}))->max;
   unless ($version
	   and ($session->is_client() xor
		$params->{$authkey_keyword})) {
      $session->abort_mcp();
      return;
   }
   $mcp_root->inst($session)->version($version);

   if ($session->is_client()) {
      $session->send_initial_mcp($session->generate_authkey());
   }
   else {
      $session->{authkey} = $params->{$authkey_keyword};
   }

   # ignore further instances of #$#mcp
   $session->disable_pkg($mcp_root); 
   # start listening for mcp-negotiate- messages
   $session->install($mcp_negotiate);
};

   
my $msg_negotiate_can = $mcp_negotiate->method_name('can');
my $msg_negotiate_end = $mcp_negotiate->method_name('end');

my @mcpn_range_keywords = qw(min-version max-version);

my $mcpn_20_restriction = MCP::Version::Range("1.0","2.0");
my $mcpn_default_version = MCP::Version->new("1.0");

define_initializer $mcp_negotiate sub {
   my ($session, $pkg) = @_;
   my ($name, $vset) = @{$mcp_negotiate}{qw(name vset)};
   do {
      $session->send_msg($msg_negotiate_can,
			 package => $name,
			 $vset->range_args(@mcpn_range_keywords));
   } while (($name, $vset) = each %MCP::Package::Versions);
   $session->send_msg($msg_negotiate_end);
};


define_method $mcp_negotiate 'can' => sub {
   my ($session,$params) = @_;
   my $pname = $params->{package};
   my $vset = MCP::Version::Range(@{$params}{@mcpn_range_keywords});
      
   my $pkginst = $session->pkginst($pname);
   if ($pname eq $mcp_negotiate->name) {
      if (defined $pkginst->version) {
	 # another one came through first; limit us to 2.0
	 $vset &= $mcpn_20_restriction;
      }
      my $version = ($mcp_negotiate->{vset} & $vset)->max;
      unless ($version) {
	 $session->abort_mcp();
	 return;
      }
      $pkginst->version($version);
   }
   elsif ($pkginst) {
      # package is already installed; this should not happen for
      # packages other from 'mcp-negotiate', but the peer might 
      # be stuttering with its mcp-negotiate-can messages.  punt.
   }
   else {
      my $mcpn_pkginst = $mcp_negotiate->inst($session);
      unless (defined $mcpn_pkginst->version) {
	 # We are seeing a non-(mcp-negotiate) package first.
	 # This means we *may* be speaking 1.0
	 # and, in any case, we are speaking at most 2.0
	 $mcpn_pkginst->version($mcpn_default_version);
      } 
      if (my ($pkg, $version) = MCP::Package->Get($pname,$vset)) {
	 $session->pkginst($pname, $pkg->new_pkginst($version));
	 $session->install($pkg);
      }
   }
};

define_method $mcp_negotiate 'end' => sub {
   # ignore all further mcp-negotiate messages
   $_[0]->disable_pkg($mcp_negotiate);
};

{
   package MCP::PkgInst;
   use strict;
   use warnings;

   use fields qw(pkg version);

   sub new {
      my ($self,$pkg,$version) = @_;
      $self = fields::new($self) unless ref($self);
      @{$self}{qw(pkg version)} = ($pkg, $version);
      return $self;
   }

   sub pkg {
      return $_[0]->{pkg};
   }

   sub version {
      my $pkginst = shift;
      my $v = $pkginst->{version};
      $pkginst->{version} = shift if (@_);
      return $v;
   }

}

{

=head1 MCP::Session

The following methods are available on session objects:

=over 4

=cut

   package MCP::Session;
   use strict;
   use warnings;
   use Carp;

   use fields
     id       => # id number for this session (unique for this run of the server)
     out      => # filehandle; destination for raw outgoing messages
     authkey  => # authentication-key
     pkginsts => # name -> [pkg, version, pkg_specific...]  ; package instantiations
     multis   => # datatag -> [line,...] ; partially received multiline messages
     handlers => # full_message_name -> message handler code
     nlstate  => # in-band input newline state
     inchars  => # in-band input pending characters
     outchars => # in-band output pending characters
     params   => # session parameters passed in at creation
       ;

   sub h_NOP { }

   my $NEXT_ID = 1;
   sub Generate_ID { 
      my ($given) = @_;
      return defined($given) ? "E$given" : "I".($NEXT_ID++);
   }

=item MCP::Session->new($out, [param => value ...])

Constructs a new C<MCP::Session> object atop the given output filehandle C<$out>.
The following parameters are recognized:

=over 4

=item client => boolean

=item server => boolean

One of C<client> or C<server> should be specified
A server session issues the initial C<#$#mcp> immediately,
A client session waits for the peer to issue the C<#$#mcp>.

=item close  => coderef

A subroutine to be called when this MCP session is terminating.
It should return true according as the caller will be invoking
C<< $session->close_hook() >> by itself

=item abort => coderef

A subroutine to be called if MCP version negotiation fails

=item echo => boolean

echo back all received MCP message lines on output as in-band lines

=item serial

derive the session's id from this string instead of generating one

=back

=cut

   sub new {
      my ($self,$out,%params) = @_;
      $self = fields::new($self) unless ref($self);
      if (exists $params{server}) {
	 $params{client} = !delete $params{server};
      }
      carp "defaulting to server mode" unless exists $params{client};
      @{$self}{qw(id out authkey multis handlers outchars params)}
	= (Generate_ID($params{serial}), $out, undef, {}, {NOP => \&h_NOP}, '', \%params);

      @{$self}{qw(nlstate inchars)} = (0, '');

      $self->{pkginsts} = {
			   map { $_->name, $_->new_pkginst(); }
			   $mcp_root, 
			   $mcp_negotiate
			  };
      return $self;
   }

   sub send_initial_mcp {
      $_[0]->send_msg($msg_mcp, 
		      (@_ <= 1 ? () : ($authkey_keyword => $_[1])),
		      $mcp_root->{vset}->range_args(@mcp_range_keywords));
   }
   sub generate_authkey {
      $_[0]->{authkey} = "" . (int rand(10000))
   }

=item $session->start_mcp()

Begin MCP activity on this session, installing the root message handler
and, for server sessions, sending the initial handshake message.

=cut

   sub start_mcp {       
      $_[0]->install($mcp_root);
      $_[0]->send_initial_mcp() unless($_[0]->is_client());
   }

=item $session->close([$reason])

Call the close parameter supplied to C<new>, if any,
to indicate that this session is to be terminated

=cut

   sub close {
      my ($self,$reason) = @_;
      &{$self->{params}->{close} || sub { 0 }}
	|| $_[0]->close_hook($_[1]);
   }

=item $session->close_hook([$reason])

Does the actual work of terminating a session,
disabling all of the message handlers and
invoking the various package finalizers.

=cut

   sub close_hook {
      my ($self,$reason) = @_;
      $| = 1;
      undef $self->{out};
      foreach (values %{$self->{pkginsts}}) {
	 &{$_->pkg->{final} || \&h_NOP}($self,$_->pkg,$reason);
      }
      $self->{pkginsts} = {};
      # make sure we do not respond to any further messages
      $self->{handlers} = {};
      # just in case anybody puts in a cycle
      $self->{params} = {};
   }

=item $session->is_closed()

Has this session been closed?

=cut

   sub is_closed {
      my ($self) = @_;
      return !defined $self->{out} or !$self->out->opened;
   }

   sub abort_mcp { 
      my ($self) = @_;
      my $abort = $self->{params}->{abort} || \&h_NOP;
      # handle the weird case where something gets activated ahead of mcp-negotiate
      $self->close_hook();
      # inform underlying connection that we have officially become a black hole
      &$abort;
   }

   sub peer_id {
      my ($self) = @_;
      return if $self->is_closed();
      if (my $getport = $self->{out}->can('peerport')) {
	 return $self->{out}->peerhost.':'.&{$getport}($self->{out});
      }
      else {
	 return '<nonsocket>:?';
      }
   }

   sub pkg {
      my ($self,$pname) = @_;
      return $self->{pkginsts}->{$pname}->pkg;
   }

   sub pkginst {
      my $self = shift;
      my $pkg = shift;
      $pkg = $pkg->{name} if ref($pkg);
      my $v = $self->{pkginsts}->{$pkg};
      $self->{pkginsts}->{$pkg} = shift if (@_);
      return $v;
   }

=item $session->is_client()

Is this a client session rather than a server session?

=cut

   sub is_client { $_[0]->{params}->{client} }

   sub state_desc {
      my ($self) = @_;
      my @desc = ();
      foreach (keys %{$self->{pkginsts}}) {
	 my ($pkg,$version) = @{$self->{pkginsts}->{$_}}{qw(pkg version)};
	 my ($fname,$impl) = $pkg->full_desc();
	 push @desc, sprintf('%7s %s',$version,$fname), sprintf('%10s%s','',$impl);
      }
      return @desc;
   }

   sub install {
      my ($session,$pkg) = @_;
      while (my($name,$code) = each %{$pkg->{methods}}) {
	 $session->{handlers}->{$pkg->{name}.$name} = $code;
      }
      &{$pkg->{initial} || \&h_NOP};
   }

   sub disable_pkg {
      my ($session,$pkg) = @_;
      &{$pkg->{final} || \&h_NOP};
      foreach my $name (keys %{ $pkg->{methods} }) {
	 delete $session->{handlers}->{$pkg->{name}.$name};
      }
   }
   

   my $id  = "[A-Za-z_][-A-Za-z_0-9]*";	  # identifier
   my $uq  = '[\!\#-\)\+-\/0-9\;-\@A-Z\[\]-\`a-z\{-\~]+'; # unquoted string
   my $val = $uq. '|"(?:[^"\\\\]|\\\\.)*"';  # value


   sub quote_value_str {
      local $_ = "$_[0]";
      if (/^($uq)$/) { 
	 return $_; 
      }
      else { 
	 s/(["\\])/\\$1/g;
	 return "\"$_\"";
      }
   }

   
   sub build_msg {
      my $session = shift;
      my $msg = shift;
      $msg = "\#\$\#$msg" . ($msg eq $msg_mcp ? '' : " ".$session->{authkey});
      my @multis = ();
      my $datatag;
#      {local $"=','; print "@_\n" }
      while (@_) {
	 my ($k,$v) = (shift, shift);
	 unless (ref($v) =~ /^ARRAY$/) {
	    $msg .= " $k: ".quote_value_str($v);
	 }
	 else {
	    $datatag = "".int rand(100000) unless ($datatag);
	    $msg .= " $k*: \"\"";
	    push @multis, map { "\#\$\#* $datatag $k: $_\r\n" } @$v;
	 }
      }
      if ($datatag) {
	 $msg .= " _data-tag: $datatag";
	 push @multis, "\#\$\#: $datatag\r\n";
      }
      $msg .= "\r\n";
      ($msg, @multis)
   }

=item $session->send_msg($full_method_name [, keyword => value ...])

Sends an out-of-band message.  Scalar values are stringified.
An array-reference value causes the corresponding keyword
to be treated as a multiline key.

=cut

   sub send_msg {
      my ($self) = @_;
      return if $self->is_closed();
      foreach (&build_msg) { print {$self->{out}} $_; }
      return 1;
   }


=item $session->write_inband($string)

Sends an in-band string.  Any lines beginning with the out-of-band
prefix are suitably quoted.

Complete lines are sent immediately.
Any trailing partial line is saved and prefixed to the next write_inband() call.

=cut

   sub write_inband {
      my ($self, $str) = @_;
      $str = $self->{outchars}.$str;
      $str =~ /\A((?:.*\n)*)(.*)\Z/;
      $self->{outchars} = $2;
      $str = $1;
      $str =~ s/^(\#\$["#])/#\$"$1/mg;
      print {$self->{out}} $str;
   }


=item $session->eat_line($string)

Feeds a single network line (including newline) to the session.
If the line is in-band, return it, unquoted as necessary.
If the line is out-of-band, parse it, dispatch it, and return false.

Expected usage is something like:

  while (<>) { $session->eat_line($_); }

=cut

   # old version, assumes we get one line at a time
   sub eat_line {
      (my $self, local $_) = @_;

      # spit back in-band lines
      return substr($_,3) if m/^\#\$\"/;
      return $_ unless m/^\#\$\#/g;
      $self->parse_message(pos);
      return;
   }


=item $session->eat_string($string)

Feeds an arbitrary string of network characters to the session.
Each complete out-of-band line is extracted, parsed, and dispatched.
Quote prefixes are removed from quoted in-band lines.
Remaining complete (in-band) lines are removed from $string and returned as a list (possibly empty).

Any trailing partial line is left behind in $string.

Expected usage is something like:

  while (sysread(HANDLE, $buffer, $chunk_size, length($buffer))) { 
      foreach ($session->eat_string($buffer)) {
          # ... process inband line $_;
      }
  }

=cut

   sub eat_string {
      (my $self,local $_) = @_;
      pos = $self->{nlstate};
      my @slst = ();
      my $b = 0;
      while (m/^#(?:\z|\$(?:\z|([#"]).*))/gmc) {
	 if ($b < $-[0]) {
	    push @slst, split /^/m,substr($_,$b,$-[0]-$b);
	    $b = $-[0];
	 }
	 if ($1 eq '"') {
	    $b = (pos = $+[1]);
	 }
	 elsif (pos >= length) {
	    $self->{nlstate} = 0;
	    substr($_[1],0,$b) = '';

	    if (@slst) {
	       substr($slst[0],0,0) = $self->{inchars} if $self->{inchars};
	       $self->{inchars} = '';
	    }
	    return @slst;
	 }
	 else {
	    # parse mcp message 	     (setq s (mud-mcp-parse-string string (setq b s)))
	    $b = (pos = $self->parse_message($+[1]));
	 }
      }
      $_[1] = '';
      push @slst, split /^/m,substr($_,$b);
      substr($slst[0],0,0) = $self->{inchars} if $self->{inchars};
      if ($self->{nlstate} = m/\n\z/ ? 0 : 1) {
	 $self->{inchars} = pop @slst;
      }
      else {
	 $self->{inchars} = '';
      }
      return @slst;
   }


   # parses message out of $_ where pos() is assumed
   # to point to just after the '#$#'.
   # Always returns position after the newline
   sub parse_message {
      (my $self,pos) = @_;
      if ($self->{params}->{echo}) {
	 my $p = pos;
	 m/\G(.*)/;
	 print {$self->{out}} "(RECVD) #\$#$1\n";
      }
      goto malformed unless m/\G($id|\*|:) +($uq)/gc;
      my ($what,$tag) = ($1,$2);
      if ($what eq '*') {
	 # nth line of multiline
	 goto malformed unless m/\G +($id): ([^\n\r]*)\r?\n/gc;
	 push @{$self->{multis}->{$tag}->{lc($1)}}, $2;
      }
      elsif ($what eq ':') {
	 # end of multiline
	 goto malformed unless m/\G *\r?\n/gc;
	 $self->handle_mcp_msg(delete $self->{multis}->{$tag});
      }
      else {
	 # message or start thereof
	 $what = lc($what);

	 # check authkey
	 if ($what eq $msg_mcp) {
	    # initial mcp message has no authkey
	    goto malformed if defined $self->{authkey}; # this is not the initial msg; buh-bye!
	    pos = $+[1];
	    undef $tag;
	 }
	 else {
	    goto malformed unless defined($self->{authkey}) && ($self->{authkey} eq $tag);
	 }

	 # collect parameters
	 my %keyvals = (NAME => $what);
	 my $multi = 0;
	 while (m/\G +($id)(\*?): +($val)/gc) {
	    my ($k,$v) = ($1,$3);
	    if ($2) {
	       $multi = 1;
	       $v = [];
	    }
	    elsif ($v =~ /^"(.*)"$/) {
	       # unquote value string
	       ($v = $1);
	       $v =~ s/\\(.)/$1/g;
	    }
	    $keyvals{lc($k)} = $v;
	 }
	 goto malformed unless m/\G *\r?\n/gc;

	 if ($multi) { 
	    my $dt = delete $keyvals{'_data-tag'} or goto malformed;
	    $self->{multis}->{$dt} = \%keyvals;
	 }
	 else { 
	    $self->handle_mcp_msg(\%keyvals); 
	 }
      }
      return pos;
    malformed:
      m/\G.*\n/gc;
      return pos;
   }

   sub handle_mcp_msg {
      # Localizing pos() is hard.
      my $p = pos;
      {
	 local $_;
	 &{$_[0]->{handlers}->{$_[1]->{NAME}||'NOP'} || \&h_NOP};
      }
      pos = $p;
   }

=item receive_msg($name, [kwd => $value ...])

(debugging) Simulates receiving an out-of-band message.
Values must be strings or array references (of string arrays).

=cut

   sub receive_msg {
      my ($self,$name,%keyvals) = @_;
      $keyvals{NAME} = $name;
      $self->handle_mcp_msg(\%keyvals);
   }

=item new_from_fd($fd, [kwd => $value ...])

(debugging) Creates a session from an output file descriptor.
Keyword paramters are as for C<new>.

=cut

   sub new_from_fd {
      my ($class,$fd,@params) = @_;
      require IO::Handle;
      my $h = IO::Handle->new();
      open $h,">&$fd" or croak "could not dup $fd";
      $h->autoflush(1);
      return $class->new
	($h, 
	 close => sub {print $h "*** MCP Session closed ($_[1]) ***\n"; $h->close(); 0; },
	 abort => sub {print $h "*** MCP Session aborted ***\n"; $h->close(); },
	 @params
	 );
   }
}



1;

=back

=head1 COPYRIGHT

Copyright 2002 Roger F. Crew.

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut
