package Mcp;
#: Version: 0.0.1
#: Description: MUD Client Protocol v2.1 & simpleedit
#: Author: James C. Deikun
#

use strict;
use Carp qw(cluck);

use Gtk2 -init;


sub help {
  $::world->echonl(<<'EOHELP');
MCP 2.1 with simpleedit.  Currently no user-serviceable parts, it either works or it doesn't.
EOHELP
}



#################################################################
# Constants
#
use constant {
  PHASE_INIT => 0,
  PHASE_NEGOTIATE => 1,
  PHASE_NORMAL => 2,
};


#################################################################
# Grammar
#
our $DIGIT = qr/[0-9]/;
our $ALPHA = qr/[a-zA-Z_]/;
our $OTHER_SIMPLE = qr/[-~`!@#\$%^&()=+{}\[\]|';?\/><.,]/;
our $SIMPLE_CHAR = qr/[^" \\]/; # differs from MCP 2.1
our $SIMPLE_CHAR_STRICT = qr/$ALPHA | $DIGIT | $OTHER_SIMPLE/x;
our $QUOTE_CHAR = qr/\" | \\/x;
our $LINE_CHAR = qr/[^\n]/x; # differs from MCP 2.1
our $STRING_CHAR = qr/[^"\\] | \\./x; # differs from MCP 2.1
our $IDENT_CHAR = qr/$ALPHA | $DIGIT | \-/x;

our $SPACE = qr/\  +/x;

our $IDENT_CHARS = qr/$IDENT_CHAR */x;
our $STRING_CHARS = qr/$STRING_CHAR */x;
our $LINE = qr/$LINE_CHAR */x;

our $IDENT = qr/$ALPHA $IDENT_CHARS/x;
our $UNQUOTED_STRING = qr/$SIMPLE_CHAR +/x;
our $UNQUOTED_STRING_STRICT = qr/$SIMPLE_CHAR_STRICT +/x;
our $QUOTED_STRING = qr/\" $STRING_CHARS \"/x;

our $MESSAGE_NAME = $IDENT;
our $AUTH_KEY = $UNQUOTED_STRING;
our $DATATAG = $UNQUOTED_STRING;

our $VALUE = qr/$UNQUOTED_STRING | $QUOTED_STRING/x;
our $MULTILINE_KEY = qr/$IDENT \*/x;
our $SIMPLE_KEY = $IDENT;
our $KEY = qr/$SIMPLE_KEY | $MULTILINE_KEY/x;
our $KEYVAL = qr/$KEY \: $SPACE $VALUE/x;
our $KEYVALS = qr/(?:$SPACE $KEYVAL)*/x;

our $MESSAGE_START = qr/$MESSAGE_NAME (?: $SPACE $AUTH_KEY )? $KEYVALS/x;
our $MESSAGE_CONTINUE = qr/\* $SPACE $DATATAG $SPACE $SIMPLE_KEY \: \  $LINE/x;
our $MESSAGE_END = qr/\: $SPACE $DATATAG/x;

our $MESSAGE = qr/$MESSAGE_START 
                 |$MESSAGE_CONTINUE
                 |$MESSAGE_END/x;

our $MESSAGE_LINE = qr/^\#\$\# $MESSAGE $/x;

#################################################################
# Variables
#
our $active_auth_key;
our %registered_packages;
our %registered_cord_types;
our %active_packages;
our %active_multilines;
our %active_cords;
our $active_version;
our $phase = PHASE_INIT;
our $did_unescape = 0;

#################################################################
# Hooks
#
$::world->hook('OnConnect',
               '/Mcp::reset_connection()',
               { name    => 'mcp:reset',
                 enabled => 1 });
$::world->hook('OnDisconnect',
               '/Mcp::reset_connection()',
               { name    => 'mcp:reset',
                 enabled => 1 });

#################################################################
# Triggers
#
$::world->trigger('^\\#\\$\\#',
                  '/Mcp::did_unescape=0',
                  { rewriter => 1, });
$::world->trigger('^\\#\\$\\"',
                  '/Mcp::unescape_oob()',
                  { rewriter => 1, });
$::world->trigger('(?(?{$Mcp::did_unescape})(*FAIL))^\\#\\$\\#',
                  '/Mcp::parse_oob($::colorline)',
                  { gag => 1, });
# this incredibly gross cascade brought to you by KildClient's
#   epically broken way of ordering triggers by effect.
#   Requires perl 5.10, although you could probably figure out
#   an alternative to (*FAIL) that didn't ...

#################################################################
# Internal functions
#
sub unescape_oob {
  $::colorline =~ s/^\#\$\"//;
  $did_unescape = 1;
}

sub parse_oob {
  my($line) = @_;

  my $message;
  if (($message,) = $line =~ /^\#\$\#(.*)$/) {
    if ($message =~ /\A$MESSAGE_START\z/) {
      return parse_message_start($message);
    } elsif ($message =~ /\A$MESSAGE_CONTINUE\z/) {
      return parse_message_continue($message);
    } elsif ($message =~ /\A$MESSAGE_END\z/) {
      return parse_message_end($message);
    }
  }
}

sub parse_message_start {
  my($message) = @_;

  # this regexp needs perl 5.10 for (?|)
  my($name, $auth_key, @keyvals) = $message =~ /(?|\A($MESSAGE_NAME) (?: $SPACE ($AUTH_KEY) (?=$KEYVALS \z) ) ? | \G $SPACE ($KEY) \: $SPACE ($VALUE))/gx;
  if (defined $active_auth_key and $auth_key ne $active_auth_key) {
    return;
  }
  my %args;
  my @multilines;
  my $key;
  my $val;
  while (@keyvals) {
    $key = lc shift @keyvals;
    $val = shift @keyvals;
    if ($key =~ s/\*$//) {
      push @multilines, $key;
      $key = -$key;
      $val = '""';
    }
    if (substr($val,0,1) eq '"') {
      # needs 5.10 for (?|)
      $val =~ s/(?|\A"()|\\(.)|"\z())/$1/g;
    }
    if (exists $args{$key}) {
      # malformed message - includes duplicate args
      return 0;
    }
    $args{$key} = $val;
  }
  return dispatch_initial($name, \%args, \@multilines);
}

sub dispatch_initial {
  my($name, $args, $multilines) = @_;

  if (@$multilines) {
    return 0 unless exists $args->{"_data-tag"};
    my $data_tag = $args->{"_data-tag"};
    return 0 unless $data_tag =~ /\A$UNQUOTED_STRING\z/;
    my $receiver;
    my $prefix;
    my $msg;
    if (defined($receiver = $active_packages{$name}) and $receiver->can("mcp_Start_Empty")) {
      $msg = "mcp_Start_Empty";
    } elsif (($prefix, $msg) = $name =~ /(.*)-(.*)/) {
      $receiver = $active_packages{$prefix};
      if (defined $receiver and $receiver->can("mcp_Start_$msg")) {
        $msg = "mcp_Start_$msg";
      } else {
        undef $msg;
      }
    }
    my $result;
    if (defined $msg) {
      $result = $receiver->$msg($name, {%$args}, [@$multilines])
    }
    if (!defined $result) {
      $result = accumulator($name, $args, $multilines);
    }
    $active_multilines{$data_tag} = $result;
    # XXX should proactively fail both multilines if an active tag is reused
  } else {
    return dispatch($name, $args);
  }
}

sub parse_message_continue {
  my($message) = @_;

  my($data_tag, $key, $line) = $message =~ /\A \* $SPACE ($DATATAG) $SPACE ($SIMPLE_KEY) \: \  ($LINE) \z/x;
  my $accum = $active_multilines{$data_tag};
  return unless defined $accum;
  dispatch_cord_msg($accum, $key, { line => $line });
}

sub parse_message_end {
  my($message) = @_;

  my($data_tag) = $message =~ /\A \: $SPACE ($DATATAG)\z/x;
  my $accum = delete $active_multilines{$data_tag};
  return unless defined $accum;
  return $accum->() if ref($accum) eq 'CODE';
  $accum->cord_Closed();
}

sub dispatch {
  my($name, $args) = @_;

  if ($phase == PHASE_INIT) {
    if ($name eq 'mcp') {
      my $version = best_version($args->{version}, $args->{to}, "2.1", "2.1");
      if (defined $version) {
        $active_version = $version;
        $::world->echonl("Enabled MCP version $version.");
        $phase = PHASE_NEGOTIATE;
        my $auth_key = int(rand(2**32 - 1));
        send_message("mcp", {version => "2.1", to => "2.1", 'authentication-key' => $auth_key });
        $active_auth_key = $auth_key;
        # need to activate mcp-negotiation before negotiation actually takes place!
        attempt_activation('mcp-negotiate', '1.0', '2.0');
        my($pkgname, $pkgref);
        while (($pkgname, $pkgref) = each %registered_packages) {
          send_message("mcp-negotiate-can", { 'package' => $pkgname, 'min-version' => $pkgref->mcp_Min_Version, 'max-version' => $pkgref->mcp_Max_Version });
        }
        send_message("mcp-negotiate-end", +{});
      }
    }
  } elsif ($phase == PHASE_NEGOTIATE) {
    return unless $name =~ /^mcp-negotiate(?:-|$)/;
  }
  my $receiver;
  my $prefix;
  my $msg;
  if (defined($receiver = $active_packages{$name}) and $receiver->can("mcp_Empty")) {
    $msg = "mcp_Empty";
  } elsif (($prefix, $msg) = $name =~ /(.*)-(.*)/) {
    $receiver = $active_packages{$prefix};
    if (defined $receiver and $receiver->can("mcp_$msg")) {
      $msg = "mcp_$msg";
    } else {
      undef $msg;
    }
  }
  if (defined $msg) {
    return $receiver->$msg($name, $args);
  }
}

sub Mcp::Accumulator::new {
  my($pkg, $msg, $args, $multilines) = @_;

  my $self = bless +{
    msg => $msg,
    args => $args,
  }, $pkg;
  my $k;
  for $k (@$multilines) {
    $self->{args}{-$k} = '';
  }
  return $self;
}

sub Mcp::Accumulator::cord_Wild {
  my($self, $msg, $args) = @_;

  return unless exists $self->{args}{-$msg};
  return unless exists $args->{line};
  $self->{args}{-$msg} .= "$args->{line}\n";
}

sub Mcp::Accumulator::cord_Closed {
  my($self) = @_;

  dispatch($self->{msg}, $self->{args});
}

sub accumulator {
  return Mcp::Accumulator->new(@_);
}

sub dispatch_cord_msg {
  my($cord, $name, $args) = @_;

  my $msg;
  if (ref($cord) eq 'CODE') {
    return $cord->($name, $args);
  } elsif ($cord->can("cord_$name")) {
    $msg = "cord_$name";
  } elsif ($cord->can("cord_Wild")) {
    $msg = "cord_Wild";
  } else {
    return;
  }
  $cord->$msg($name, $args);
}

sub reset_connection {
  my $pkg;
  for $pkg (keys %active_packages) {
    $active_packages{$pkg}->mcp_Deactivate($pkg);
  }
  %active_packages = ();
  %active_multilines = ();
  %active_cords = ();
  $active_auth_key = undef;
  $phase = PHASE_INIT;
}

sub best_version {
  my($eir_min, $eir_max, $my_min, $my_max) = @_;

  if (version_geq($my_max, $eir_min) and version_geq($eir_max, $my_min)) {
    if (version_geq($my_max, $eir_max)) {
      return $eir_max;
    } else {
      return $my_max;
    }
  } else {
    return;
  }
}

sub version_geq {
  my($l, $r) = @_;

  cluck "left version not defined" unless defined $l;
  cluck "right version not defined" unless defined $r;
  my($lmaj, $lmin) = split /\./, $l, 2;
  my($rmaj, $rmin) = split /\./, $r, 2;

  if ($lmaj > $rmaj) {
    return 1;
  } elsif ($lmaj == $rmaj and $lmin >= $rmin) {
    return 1;
  } else {
    return 0;
  }
}

sub attempt_activation {
  my($pkg, $eir_min, $eir_max) = @_;

  my $ob = $registered_packages{$pkg};
  return unless defined $ob;
  my $ver = best_version($eir_min, $eir_max, $ob->mcp_Min_Version, $ob->mcp_Max_Version);
  return unless defined $ver;
  $active_packages{$pkg} = $ob->mcp_Activate($pkg, $ver) || $ob;
}

sub UNLOAD {
  for my $pkg (keys %registered_packages) {
    $registered_packages{$pkg}->mcp_Unload($pkg);
  }
  for my $type (keys %registered_cord_types) {
    $registered_cord_types{$type}->mcp_Unload($type);
  }
  # XXX active cords and multilines too?
}

#################################################################
# User callable routines
#
sub send_message {
  my($name, $args) = @_;

  my $msg = '#$#' . $name;
  if (defined($active_auth_key)) {
    $msg = $msg . " $active_auth_key";
  }
  my($key, $val);
  my %multilines;
  while (($key, $val) = each %$args) {
    next if ($key eq '_data-tag'); # always reset this to make it unique
    # XXX vet key syntax
    if ($key =~ s/^-//) {
      $multilines{$key} = $val;
      $key .= '*';
      $val = '';
    }
    if ($val !~ /\A$UNQUOTED_STRING_STRICT\z/) {
      $val =~ s/([\\"])/\\$1/g;
      $val = "\"$val\"";
    }
    $msg .= " $key: $val";
  }
  my $data_tag = int(rand(2**32-1));
  if (%multilines) {
    $msg .= " _data-tag: $data_tag";
  }
  my @lines = ($msg);
  if (%multilines) {
    while (($key, $val) = each %multilines) {
      chomp $val;
      my @vlines = split /\n/, $val, -1;
      push @lines, map { "#\$#* $data_tag $key: $_" } @vlines;
    }
    push @lines, "#\$#: $data_tag";
  }
  $::world->writetolog(map { "MCP SENT: $_" } @lines);
  $::world->sendnoecho(@lines);
}

sub register {
  my($ob, $mcp_pkg) = @_;

  $registered_packages{$mcp_pkg} = $ob;
}

sub register_cord_type {
  my($ob, $cord_type) = @_;

  $registered_cord_types{$cord_type} = $ob;
}

#################################################################
# mcp-negotiate implementation
#

## package Mcp::Negotiate;

sub Mcp::Negotiate::mcp_Min_Version { '1.0' }
sub Mcp::Negotiate::mcp_Max_Version { '2.0' }

sub Mcp::Negotiate::mcp_Activate {
  # currently ignored
}

sub Mcp::Negotiate::mcp_Deactivate {
  # currently ignored
}

sub Mcp::Negotiate::mcp_Unload {
  # currently ignored
}

sub Mcp::Negotiate::mcp_can {
  my($pkg, $name, $args) = @_;

  Mcp::attempt_activation($args->{'package'}, $args->{'min-version'}, $args->{'max-version'});
}

sub Mcp::Negotiate::mcp_end {
  my($pkg, $name, $args) = @_;

  $Mcp::phase = Mcp::PHASE_NORMAL;
}

Mcp::register(Mcp::Negotiate:: => 'mcp-negotiate');


#################################################################
# mcp-cord implementation
#

## package Mcp::Cord;

sub Mcp::Cord::mcp_Min_Version { '1.0' }
sub Mcp::Cord::mcp_Max_Version { '1.0' }

sub Mcp::Cord::mcp_Activate {
  # IGNORE
}

sub Mcp::Cord::mcp_Deactivate {
  # IGNORE
}

sub Mcp::Cord::mcp_Unload {
  # IGNORE
}

our $cord_seq = 0;

sub Mcp::Cord::open_cord {
  my($type, $ob) = @_;

  my $new_id = 'R' . $cord_seq++;
  $new_id = 'R' . $cord_seq++ while exists $Mcp::active_cords{$new_id};
  $Mcp::active_cords{$new_id} = $ob;
  Mcp::send_message('mcp-cord-open', { _id => $new_id, _type => $type });
}

sub Mcp::Cord::mcp_opened {
  my($pkg, $name, $args) = @_;

  my $id = delete $args->{_id};
  my $type = delete $args->{_type};
  my $factory = $Mcp::registered_cord_types{$type};
  return unless $factory;
  my $ob;
  if (ref($factory) eq 'CODE') {
    $ob = $factory->($type, $id);
  } elsif ($factory->can("cord_Opened")) {
    $ob = $factory->cord_Opened($type, $id);
  }
  if ($ob) {
    $Mcp::active_cords{$id} = $ob;
  }
}

sub Mcp::Cord::mcp_Empty {
  my($pkg, $name, $args) = @_;

  my $id = delete $args->{_id};
  my $message = lc delete $args->{_message};
  my $ob = $Mcp::active_cords{$id};
  return unless $ob;
  my $msg;
  if (ref($ob) eq 'CODE') {
    return $ob->($message, $args);
  } elsif ($ob->can("cord_$message")) {
    $msg = "cord_$message";
  } elsif ($ob->can("cord_Wild")) {
    $msg = "cord_Wild";
  } else {
    return;
  }
  return $ob->$msg($message, $args);
}

sub Mcp::Cord::mcp_closed {
  my($pkg, $name, $args) = @_;

  my $id = delete $args->{_id};
  my $ob = delete $active_cords{$id};
  return unless $ob;
  if (ref($ob) eq 'CODE') {
    return $ob->();
  } elsif ($ob->can('cord_Closed')) {
    return $ob->cord_Closed();
  }
  return;
}

sub Mcp::Cord::close_cord {
  my($id) = @_;

  return unless $Mcp::active_cords{$id};
  Mcp::send_message("mcp-cord-closed", {_id => $id});
  delete $Mcp::active_cords{$id};
}

sub Mcp::Cord::tell_cord {
  my($id, $message, $args) = @_;

  return unless $Mcp::active_cords{$id};
  $args = {%$args};
  $args->{_id} = $id;
  $args->{_message} = $message;

  Mcp::send_message("mcp-cord", $args);
}

Mcp::register(Mcp::Cord:: => 'mcp-cord');

#################################################################
# simpleedit implementation
#

## package Mcp::Simpleedit;

our $se_next_id = 1;
our %se_drafts = ();
our %se_windows = ();

$::world->makepermanent('%Mcp::se_drafts');

sub Mcp::Simpleedit::mcp_Min_Version { '1.0' }
sub Mcp::Simpleedit::mcp_Max_Version { '1.0' }

sub Mcp::Simpleedit::get_id {
  while (exists $se_drafts{$se_next_id}) {
    $se_next_id++;
  }
  $se_next_id;
}

sub Mcp::Simpleedit::create_window {
  my($id, $name, $type, $reference, $text) = @_;
  my $text_view = Gtk2::TextView->new();
  my $text_buffer = $text_view->get_buffer;
  my $window = Gtk2::Window->new();
  $window->set_title($::world->getname(). ": $name");
  $window->signal_connect(delete_event => sub { Mcp::Simpleedit::confirm_close($id, $window, $text_buffer); });
  $window->signal_connect(focus_out_event => sub { Mcp::Simpleedit::backup_text($id, $text_buffer); });

  my $vbox = Gtk2::VBox->new();

  my $scrolled_window = Gtk2::ScrolledWindow->new();
  $scrolled_window->set_policy('never', 'always');
  $scrolled_window->add($text_view);

  $vbox->pack_start($scrolled_window, 1, 1, 0);

  my $hbox = Gtk2::HBox->new();

  my $save_button = Gtk2::Button->new_from_stock('gtk-save');
  $save_button->signal_connect(clicked => sub { Mcp::Simpleedit::save_text($id, $text_buffer); });
  my $close_button = Gtk2::Button->new_from_stock('gtk-close');
  $close_button->signal_connect(clicked => sub { Mcp::Simpleedit::confirm_close($id, $window, $text_buffer) || $window->destroy; });
  $hbox->pack_end($save_button, 0, 0, 0);
  $hbox->pack_end($close_button, 0, 0, 0);
  $vbox->pack_end($hbox, 0, 0, 0);
  $text_buffer->set_text($text);
  $text_buffer->set_modified(0);
  $window->add($vbox);
  $window->set_default_size(450, 600);
  $se_windows{$id} = +{
    window => $window,
    buffer => $text_buffer,
  };
  $window->show_all;
}

sub Mcp::Simpleedit::mcp_Unload {
  my $w;
  for $w (keys %se_windows) {
    backup_text($w, $se_windows{$w}{buffer});
  }
  for $w (values %se_windows) {
    $w->{window}->destroy;
  }
  %se_windows = ();
}

sub Mcp::Simpleedit::confirm_close {
  my($id, $window, $text_buffer) = @_;

  if ($text_buffer->get_modified) {
    my $dialog = Gtk2::Dialog->new_with_buttons(
      'Close window?',
      $window,
      [qw/modal destroy-with-parent/],
      "Close" => 'ok',
      "Keep"  => 'cancel');
    $dialog->vbox->add(Gtk2::Label->new("The content of $se_drafts{$id}{name} has changed.  Close without saving?"));
    $dialog->set_default_response('cancel');
    # could use 'run' here, but don't want to freeze too much stuff ...
    $dialog->signal_connect(response => sub { $_[0]->destroy;
                                              if ($_[1] eq 'ok') {
                                                  delete $se_drafts{$id};
                                                  delete $se_windows{$id};
                                                  $window->destroy;
                                              }
                                            });
    $dialog->show_all;
    return 1;
  }
  delete $se_drafts{$id};
  delete $se_windows{$id};
  return 0;
}

sub Mcp::Simpleedit::backup_text {
  my($id, $text_buffer) = @_;

  $se_drafts{$id}{text} = $text_buffer->get_text($text_buffer->get_bounds(), 1);
  $se_drafts{$id}{dirty} = $text_buffer->get_modified;
}

sub Mcp::Simpleedit::save_text {
  my($id, $text_buffer) = @_;

  Mcp::send_message('dns-org-mud-moo-simpleedit-set', {
                    reference => $se_drafts{$id}{reference},
                    type => $se_drafts{$id}{type},
                    -content => $text_buffer->get_text($text_buffer->get_bounds(), 1)});
  $text_buffer->set_modified(0);
  Mcp::Simpleedit::backup_text($id, $text_buffer);
}

sub Mcp::Simpleedit::mcp_content {
  my($pkg, $name, $args) = @_;

  my $id = Mcp::Simpleedit::get_id();
  $se_drafts{$id} = { reference => $args->{reference},
                   type => $args->{type},
                   name => $args->{name},
                   text => $args->{-content},
                   dirty => 0,
                 };
  Mcp::Simpleedit::create_window($id, $se_drafts{$id}{name}, $se_drafts{$id}{type}, $se_drafts{$id}{reference}, $se_drafts{$id}{text});
  return;
}

sub Mcp::Simpleedit::mcp_Activate {
  my($pkg, $mcp_pkg, $ver) = @_;

  # recreate any saved drafts
  for my $id (keys %se_drafts) {
    next if exists $se_windows{$id};
    my $dirty = $se_drafts{$id}{dirty};
    Mcp::Simpleedit::create_window($id, $se_drafts{$id}{name}, $se_drafts{$id}{type}, $se_drafts{$id}{reference}, $se_drafts{$id}{text});
    $se_windows{$id}{buffer}->set_modified($dirty);
  }
}

sub Mcp::Simpleedit::mcp_Deactivate {
  # currently ignored
}

Mcp::register(Mcp::Simpleedit:: => 'dns-org-mud-moo-simpleedit');

1;
