I3.pl

#!/usr/bin/perl -w

package Serialize::LPC;

# Minimalistic LPC. Adapted from JSON::Tiny, and in turn Adapted from Mojo::JSON and Mojo::Util.

# Licensed under the Artistic 2.0 license.
# http://www.perlfoundation.org/artistic_license_2_0.

use strict;
use warnings;
use B;
use Exporter 'import';
use Scalar::Util ();
use Encode ();

our $VERSION = '0.01';
our @EXPORT_OK = qw(j);

# Constructor and accessor: we don't have Mojo::Base.

sub new {
  my $class = shift;
  bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, $class;
}

sub error {
  $_[0]->{error} = $_[1] if @_ > 1;
  return $_[0]->{error};
}

# The rest adapted from Mojo::JSON, with minor mods & naming changes.

# Mojo::JSON sets these up as 'my' lexicals. We use 'our' so that users can
# explicitly override the Booleans with just zero or one if they desire.
# Literal names
our $FALSE = bless \(my $false = 0), 'Serialize::LPC::_Bool';
our $TRUE  = bless \(my $true  = 1), 'Serialize::LPC::_Bool';

# Escaped special character map (with u2028 and u2029)
my %ESCAPE = (
  '"'     => '"',
  '\\'    => '\\',
#  '/'     => '/',
  'b'     => "\x07",
  'f'     => "\x0c",
  'n'     => "\x0a",
  'r'     => "\x0d",
  't'     => "\x09",
  'u2028' => "\x{2028}",
  'u2029' => "\x{2029}"
);
my %REVERSE = map { $ESCAPE{$_} => "\\$_" } keys %ESCAPE;

#for (0x00 .. 0x1f, 0x7f) { $REVERSE{pack 'C', $_} //= sprintf '\u%.4X', $_ }
for( 0x00 .. 0x1f, 0x7f ) {
  my $packed = pack 'C', $_;
  $REVERSE{$packed} = sprintf '\u%.4X', $_
    if ! defined( $REVERSE{$packed} );
}

# Unicode encoding detection
my $UTF_PATTERNS = {
  'UTF-32BE' => qr/^\x00{3}[^\x00]/,
  'UTF-32LE' => qr/^[^\x00]\x00{3}/,
  'UTF-16BE' => qr/^(?:\x00[^\x00]){2}/,
  'UTF-16LE' => qr/^(?:[^\x00]\x00){2}/
};

my $WHITESPACE_RE = qr/[\x20\x09\x0a\x0d]*/;

sub decode {
  my ($self, $bytes) = @_;

  # Clean start
  $self->error(undef);

  # Missing input
  $self->error('Missing or empty input') and return undef unless $bytes; ## no critic (undef)

  # Remove BOM
  $bytes =~ s/^(?:\357\273\277|\377\376\0\0|\0\0\376\377|\376\377|\377\376)//g;

  # Wide characters
  $self->error('Wide character in input') and return undef ## no critic (undef)
    unless utf8::downgrade($bytes, 1);

  # Detect and decode Unicode
  my $encoding = 'UTF-8';
  $bytes =~ $UTF_PATTERNS->{$_} and $encoding = $_ for keys %$UTF_PATTERNS;

  my $d_res = eval { $bytes = Encode::decode($encoding, $bytes, 1); 1 };
  $bytes = undef unless $d_res;

  # Object or array
  my $res = eval {
    local $_ = $bytes;

    # Leading whitespace
    m/\G$WHITESPACE_RE/gc;

    # Array
    my $ref;
    if (m/\G\(\{/gc) { $ref = _decode_array() }

    # Object
    elsif (m/\G\(\[/gc) { $ref = _decode_object() }

    # Invalid character
    else { _exception('Expected array or object') }

    # Leftover data
    unless (m/\G$WHITESPACE_RE\z/gc) {
      my $got = ref $ref eq 'ARRAY' ? 'array' : 'object';
      _exception("Unexpected data after $got");
    }

    $ref;
  };

  # Exception
  if (!$res && (my $e = $@)) {
    chomp $e;
    $self->error($e);
  }

  return $res;
}

sub encode {
  my ($self, $ref) = @_;
  return Encode::encode 'UTF-8', _encode_value($ref);
}

sub false {$FALSE}

sub j {
  my( $d, $j ) = ( shift, __PACKAGE__->new );
  return $j->encode($d) if ref $d eq 'ARRAY' || ref $d eq 'HASH';
  defined and return $_ for $j->decode($d);
  die $j->error;
}

sub true  {$TRUE}

sub _decode_array {
  my @array;
  until (m/\G$WHITESPACE_RE\}\)/gc) {

    # Value
    push @array, _decode_value();

    # Separator
    redo if m/\G$WHITESPACE_RE,/gc;

    # End
    last if m/\G$WHITESPACE_RE\}\)/gc;

    # Invalid character
    _exception('Expected comma or right curly brace and right paren while parsing array');
  }

  return \@array;
}

sub _decode_object {
  my %hash;
  until (m/\G$WHITESPACE_RE\]\)/gc) {

    # Quote
    m/\G$WHITESPACE_RE"/gc
      or _exception('Expected string while parsing object');

    # Key
    my $key = _decode_string();

    # Colon
    m/\G$WHITESPACE_RE:/gc
      or _exception('Expected colon while parsing object');

    # Value
    $hash{$key} = _decode_value();

    # Separator
    redo if m/\G$WHITESPACE_RE,/gc;

    # End
    last if m/\G$WHITESPACE_RE\]\)/gc;

    # Invalid character
    _exception('Expected comma or right square bracket and right paren while parsing object');
  }

  return \%hash;
}

sub _decode_string {
  my $pos = pos;
  # Extract string with escaped characters
  m!\G((?:(?:[^\x00-\x1f\\"]|\\(?:["\\/bfnrt]|u[0-9a-fA-F]{4})){0,32766})*)!gc; # segfault under 5.8.x in t/20-mojo-json.t #83
  my $str = $1;

  # Invalid character
  unless (m/\G"/gc) {
    _exception('Unexpected character or invalid escape while parsing string')
      if m/\G[\x00-\x1f\\]/;
    _exception('Unterminated string');
  }

  # Unescape popular characters
  if (index($str, '\\u') < 0) {
    $str =~ s!\\(["\\/bfnrt])!$ESCAPE{$1}!gs;
    return $str;
  }

  # Unescape everything else
  my $buffer = '';
  while ($str =~ m/\G([^\\]*)\\(?:([^u])|u(.{4}))/gc) {
    $buffer .= $1;

    # Popular character
    if ($2) { $buffer .= $ESCAPE{$2} }

    # Escaped
    else {
      my $ord = hex $3;

      # Surrogate pair
      if (($ord & 0xf800) == 0xd800) {

        # High surrogate
        ($ord & 0xfc00) == 0xd800
          or pos($_) = $pos + pos($str), _exception('Missing high-surrogate');

        # Low surrogate
        $str =~ m/\G\\u([Dd][C-Fc-f]..)/gc
          or pos($_) = $pos + pos($str), _exception('Missing low-surrogate');

        # Pair
        $ord = 0x10000 + ($ord - 0xd800) * 0x400 + (hex($1) - 0xdc00);
      }

      # Character
      $buffer .= pack 'U', $ord;
    }
  }

  # The rest
  return $buffer . substr $str, pos($str), length($str);
}

sub _decode_value {

  # Leading whitespace
  m/\G$WHITESPACE_RE/gc;

  # String
  return _decode_string() if m/\G"/gc;

  # Array
  return _decode_array() if m/\G\(\{/gc;

  # Object
  return _decode_object() if m/\G\(\[/gc;

  # Number
  return 0 + $1
    if m/\G([-]?(?:0|[1-9][0-9]*)(?:\.[0-9]*)?(?:[eE][+-]?[0-9]+)?)/gc;

  # True
  return $TRUE if m/\Gtrue/gc;

  # False
  return $FALSE if m/\Gfalse/gc;

  # Null
  return undef if m/\Gnull/gc;  ## no critic (return)

  # Invalid character
  _exception('Expected string, array, object, number, boolean or null');
}

sub _encode_array {
  my $array = shift;
  return '({' . join(',', map { _encode_value($_) } @$array) . '})';
}

sub _encode_object {
  my $object = shift;
  my @pairs = map { _encode_string($_) . ':' . _encode_value($object->{$_}) }
    keys %$object;
  return '([' . join(',', @pairs) . '])';
}

sub _encode_string {
  my $str = shift;
  $str =~ s!([\x00-\x1f\x7f\x{2028}\x{2029}\\"/\b\f\n\r\t])!$REVERSE{$1}!gs;
  return "\"$str\"";
}

sub _encode_value {
  my $value = shift;

  # Reference
  if (my $ref = ref $value) {

    # Array
    return _encode_array($value) if $ref eq 'ARRAY';

    # Object
    return _encode_object($value) if $ref eq 'HASH';

    # True or false
    return $value  ? 'true' : 'false' if $ref eq 'Serialize::LPC::_Bool';

    # Blessed reference with TO_LPC method
    if (Scalar::Util::blessed $value && (my $sub = $value->can('TO_LPC'))) {
      return _encode_value($value->$sub);
    }

    # References to scalars (including blessed) will be encoded as Booleans.
    return $$value ? 'true' : 'false' if $ref =~ /SCALAR/;

  }

  # Null
  return 'null' unless defined $value;

  # Number
  my $flags = B::svref_2object(\$value)->FLAGS;
  return 0 + $value if $flags & (B::SVp_IOK | B::SVp_NOK) && $value * 0 == 0;


  # String
  return _encode_string($value);
}

sub _exception {

  # Leading whitespace
  m/\G$WHITESPACE_RE/gc;

  # Context
  my $context = 'Malformed LPC: ' . shift;
  if (m/\G\z/gc) { $context .= ' before end of data' }
  else {
    my @lines = split /\n/, substr($_, 0, pos);
    $context .= ' at line ' . @lines . ', offset ' . length(pop @lines || '');
  }

  die "$context\n";
}

# Emulate boolean type
package Serialize::LPC::_Bool;
use overload '0+' => sub { ${$_[0]} }, '""' => sub { ${$_[0]} }, fallback => 1;

1;

package Serialize::MudMode;

use strict;

sub new {
  my $class = shift;
  bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, $class;
}

sub encode {
    my ($self, $ref) = @_;
    my $lpc = new Serialize::LPC;
    my $thing = $lpc->encode($ref);
    my $len = length( $thing ) + 1;
    my $packet = pack( 'NZ*', $len, $thing );
    return $packet;
}

sub decode {
    my ($self, $packet) = @_;
    my $lpc = new Serialize::LPC;
    my ($len, $thing) = unpack( 'NZ*', $packet );
    my $ref = $lpc->decode($thing);
    return $ref;
}

package I3::Packet;

use strict;
use overload (
    '""'    => \&as_string,
    '@{}'   => \&as_array,
);

sub new {
    my $class = shift;
    my $data = shift;
    my @args = @_;

    my $self_array = [ "error", 5, 0, 0, 0, 0, 0, 0, 0 ];
    my $self = {
        type                => "invalid",
        ttl                 => 5,
        originator_mudname  => 0,
        originator_username => 0,
        target_mudname      => 0,
        target_username     => 0,
    };
    $self->{as_array} = $self_array;

    if( ref $data and ref $data eq "ARRAY") {
        # We passed in an array, probably decoded from a mudmode packet.
        if( scalar @$data < 6 or !defined $data->[0]) {
            warn "Invalid initialization data for __PACKAGE__";
            return undef;
        }

        # Valid I3 packets have (int)0 as their "undefined" value.
        for(my $i = 2; $i < scalar @$data; $i++) {
            $self_array->[$i] = (defined $data->[$i]) ? $data->[$i] : 0;
        }

        # Setup the hash to mirror the array contents.
        my $i = 2;
        foreach my $k (qw( originator_mudname originator_username target_mudname target_username )) {
            $self->{$k} = $self_array->[$i++];
        }

    } elsif (ref $data and ref $data eq "HASH" ) {
        # We passed in a hash, either by hand or from an object.
        # We SHOULD be using a subclass, as the base class can only verify fields known to all packet types.
        my $i = 2;
        foreach my $k (qw( originator_mudname originator_username target_mudname target_username )) {
            $self->{$k} = (exists $data->{$k} ? $data->{$k} : 0);
            $self_array->[$i++] = (exists $data->{$k}) ? $data->{$k} : 0;
        }
        foreach my $k (grep { ! /^(type|ttl|originator_mudname|originator_username|target_mudname|target_username)$/ } (keys %$data)) {
            $self->{$k} = $data->{$k};
            $self_array->[$i++] = $data->{$k};
        }
    } elsif (defined $data) {
        # We're asking for a specific type of packet.
        if( $data eq "error" ) {
            return I3::Packet::error->new( @args );
        }
        return undef;
    } else {
        # Nothing passed in at all?  ERROR!
        return I3::Packet::error->new();
    }

    bless $self, $class;
    return $self;
}

sub as_array {
    my $self = shift;

    return $self->{as_array};
}

sub as_string {
    my $self = shift;

    my $lpc = new Serialize::LPC;
    my $mudmode = new Serialize::MudMode;
    my $stuff =  $lpc->encode($self->as_array);
    my $packet = $mudmode->encode($stuff);
    return $packet;
}

sub type {
    my $self = shift;

    return $self->{type};
}

sub ttl {
    my $self = shift;

    return $self->{ttl};
}

sub originator_mudname {
    my $self = shift;
    my $value = shift;

    if(defined $value) {
        $self->{originator_mudname} = $value;
        $self->{as_array}->[2] = $value;
    }
    return $self->{originator_mudname};
}

sub originator_username {
    my $self = shift;
    my $value = shift;

    if(defined $value) {
        $self->{originator_username} = $value;
        $self->{as_array}->[3] = $value;
    }
    return $self->{originator_username};
}

sub target_mudname {
    my $self = shift;
    my $value = shift;

    if(defined $value) {
        $self->{target_mudname} = $value;
        $self->{as_array}->[4] = $value;
    }
    return $self->{target_mudname};
}

sub target_username {
    my $self = shift;
    my $value = shift;

    if(defined $value) {
        $self->{target_username} = $value;
        $self->{as_array}->[5] = $value;
    }
    return $self->{target_username};
}

package I3::Packet::error;

use strict;

our @ISA = qw(I3::Packet);

#use overload (
#    '""'    => \&as_string,
#    '@{}'   => \&as_array,
#);

sub new {
    my $class = shift;
    my $data = shift;

    my $self_array = [ "error", 5, 0, 0, 0, 0, 0, 0, 0 ];
    my $self = {
        type                => "error",
        ttl                 => 5,
        originator_mudname  => 0,
        originator_username => 0,
        target_mudname      => 0,
        target_username     => 0,

        error_code          => 0,
        error_message       => 0,
        error_packet        => 0,
    };
    $self->{as_array} = $self_array;

    if( ref $data and ref $data eq "ARRAY") {
        # We passed in an array, probably decoded from a mudmode packet.
        if( scalar @$data != 9 or $data->[0] != "error" ) {
            warn "Invalid initialization data for __PACKAGE__";
            return undef;
        }

        # Valid I3 packets have (int)0 as their "undefined" value.
        for(my $i = 2; $i < scalar @$data; $i++) {
            $self_array->[$i] = (defined $data->[$i]) ? $data->[$i] : 0;
        }

        # Setup the hash to mirror the array contents.
        my $i = 2;
        foreach my $k (qw( originator_mudname originator_username target_mudname target_username error_code error_message error_packet )) {
            $self->{$k} = $self_array->[$i++];
        }

    } elsif (ref $data and ref $data eq "HASH" ) {
        # We passed in a hash, either by hand or from an object.
        my $i = 2;
        foreach my $k (qw( originator_mudname originator_username target_mudname target_username error_code error_message error_packet )) {
            $self->{$k} = (exists $data->{$k} ? $data->{$k} : 0);
            $self_array->[$i++] = (exists $data->{$k}) ? $data->{$k} : 0;
        }
    } else {
        # We may just be setting up an empty packet.
    }

    bless $self, $class;
    return $self;
}

sub error_code {
    my $self = shift;
    my $value = shift;

    if(defined $value) {
        $self->{error_code} = $value;
        $self->{as_array}->[6] = $value;
    }
    return $self->{error_code};
}

sub error_message {
    my $self = shift;
    my $value = shift;

    if(defined $value) {
        $self->{error_message} = $value;
        $self->{as_array}->[7] = $value;
    }
    return $self->{error_message};
}

sub error_packet {
    my $self = shift;
    my $value = shift;

    if(defined $value) {
        $self->{error_packet} = $value;
        $self->{as_array}->[8] = $value;
    }
    return $self->{error_packet};
}


package I3;

sub new {
    my $class = shift;
    bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, $class;
}

# Accessor methods

sub router {
    my $self = shift;
    my $value = shift;

    $self->{router} = $value if defined $value;
    return $self->{router};
}

sub password {
    my $self = shift;
    my $value = shift;

    $self->{password} = $value if defined $value;
    return $self->{password};
}

sub mudlistid {
    my $self = shift;
    my $value = shift;

    $self->{mudlistid} = $value if defined $value;
    return $self->{mudlistid};
}

sub chanlistid {
    my $self = shift;
    my $value = shift;

    $self->{chanlistid} = $value if defined $value;
    return $self->{chanlistid};
}

sub mudinfo {
    my $self = shift;
    my $value = shift;

    if (defined $value and ref $value and ref $value eq 'HASH') {
        $self->{mudinfo} = $value;
        return $self->{mudinfo};
    }
    if (exists $self->{mudinfo}{$value}) {
        return $self->{mudinfo}{$value};
    }

    return undef;
}

sub mudname {
    my $self = shift;
    my $value = shift;

    $self->{mudname} = $value if defined $value;
    return $self->{mudname};
}

# Packet methods

sub send_startup {
    my $self = shift;

    my $originator_mudname = $self->mudname;
    my $target_mudname = $self->router;
}

package main;

use strict;
use Data::Dumper;
use Data::Hexdumper qw(hexdump);

sub DumpString {
my $s = shift || "";
my @a = unpack('C*',$s);
my $o = 0;
my $i = 0;
print "\tb0 b1 b2 b3 b4 b5 b6 b7\n";
print "\t-- -- -- -- -- -- -- --\n";
while (@a) {
my @b = splice @a,0,8;
my @x = map sprintf("%02x",$_), @b;
my $c = substr($s,$o,8);
$c =~ s/[[:^print:]]/ /g;
printf "w%02d",$i;
print " "x5,join(' ',@x),"\n";
$o += 8;
$i++;
}
}


my %foo = ( 12 => "hello", "bob" => 32112, "a" => [ 1, 2, 3 ], );
my @bar = ( 12, 444, 90, "heil", "ball", \%foo, 34343 );
my $test = <<EOM
({ "channel-m", 5, "Rock the Halo", "thegrauniad", 0, 0, "inews", "TheGrauniad", "Life and style: Ten reasons to love winter [Stuart Heritage] (http://www.theguardian.com/lifeandstyle/2013/oct/25/10-reasons-to-love-winter)" })
EOM
;

my $lpc = new Serialize::LPC;
my $stuff =  $lpc->encode(\@bar);

print "original stuff: " . Dumper(\@bar) . "\n";
print "encoded stuff: $stuff\n";
print "decoded stuff: " . Dumper($lpc->decode($stuff)) . "\n";

print "original test: $test\n";
my $thing = $lpc->decode($test);
print "decoded test: " . Dumper($thing) . "\n";
print "encoded test: " . $lpc->encode($thing) . "\n";

my $mudmode = new Serialize::MudMode;
my $packet = $mudmode->encode($thing);
print "packetized test:\n" . hexdump($packet) . "\n";

my $err = new I3::Packet;
print Dumper($err);

$err->error_code(37);
print $err->error_code . "\n";
print $err->[6] . "\n";
print Dumper($err);

# Intermud
#
# First, open a socket and connect to a router.
# Send a startup-req-3 packet
#
# WHen a reply is received, mudmode says....
#
# read 4 bytes, unpack that as the packet length.
# read LEN more bytes for the packet.
#
# if < LEN bytes are there, fragmented... so save what you have
# and read LEN - whatyougot next time.
#
# decode that into a data structure, and use the handler appropriate