1 files changed, 74 insertions, 177 deletions

diff --git a/lib/Tangence/Message.pm b/lib/Tangence/Message.pm
index 0521415..51c8986 100644
--- a/lib/Tangence/Message.pm
+++ b/lib/Tangence/Message.pm
@@ -1,12 +1,13 @@
 #  You may distribute under the terms of either the GNU General Public License
 #  or the Artistic License (the same terms as Perl itself)
 #
-#  (C) Paul Evans, 2010-2014 -- leonerd@leonerd.org.uk
+#  (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk
 
-package Tangence::Message 0.26;
+use v5.26;
+use Object::Pad 0.41;
 
-use v5.14;
-use warnings;
+package Tangence::Message 0.27;
+class Tangence::Message;
 
 use Carp;
 
@@ -30,86 +31,39 @@ use Scalar::Util qw( weaken blessed );
 # true value will sort keys first
 our $SORT_HASH_KEYS = 0;
 
-sub new
-{
-   my $class = shift;
-   my ( $stream, $code, $record ) = @_;
-
-   $record = "" unless defined $record;
-
-   return bless {
-      stream => $stream,
-      code   => $code,
-      record => $record,
-   }, $class;
-}
-
-sub try_new_from_bytes
-{
-   my $class = shift;
-   my $stream = shift;
-
-   return undef unless length $_[0] >= 5;
-
-   my ( $code, $len ) = unpack( "CN", $_[0] );
-   return 0 unless length $_[0] >= 5 + $len;
-
-   substr( $_[0], 0, 5, "" );
-
-   my $record = substr( $_[0], 0, $len, "" );
+has $_stream  :param :reader;
+has $_code    :param :reader;
+has $_payload :param :reader;
 
-   return $class->new( $stream, $code, $record );
-}
-
-sub stream
-{
-   my $self = shift;
-   return $self->{stream};
-}
-
-sub code
+sub BUILDARGS ( $class, $stream, $code, $payload = "" )
 {
-   my $self = shift;
-   return $self->{code};
+   return ( stream => $stream, code => $code, payload => $payload );
 }
 
-sub bytes
+method _pack_leader ( $type, $num )
 {
-   my $self = shift;
-
-   my $record = $self->{record};
-   return pack( "CNa*", $self->{code}, length($record), $record );
-}
-
-sub _pack_leader
-{
-   my $self = shift;
-   my ( $type, $num ) = @_;
-
    if( $num < 0x1f ) {
-      $self->{record} .= pack( "C", ( $type << 5 ) | $num );
+      $_payload .= pack( "C", ( $type << 5 ) | $num );
    }
    elsif( $num < 0x80 ) {
-      $self->{record} .= pack( "CC", ( $type << 5 ) | 0x1f, $num );
+      $_payload .= pack( "CC", ( $type << 5 ) | 0x1f, $num );
    }
    else {
-      $self->{record} .= pack( "CN", ( $type << 5 ) | 0x1f, $num | 0x80000000 );
+      $_payload .= pack( "CN", ( $type << 5 ) | 0x1f, $num | 0x80000000 );
    }
 }
 
-sub _peek_leader_type
+method _peek_leader_type
 {
-   my $self = shift;
-
    while(1) {
-      length $self->{record} or croak "Ran out of bytes before finding a leader";
+      length $_payload or croak "Ran out of bytes before finding a leader";
 
-      my ( $typenum ) = unpack( "C", $self->{record} );
+      my ( $typenum ) = unpack( "C", $_payload );
       my $type = $typenum >> 5;
 
       return $type unless $type == DATA_META;
 
-      substr( $self->{record}, 0, 1, "" );
+      substr( $_payload, 0, 1, "" );
 
       my $num  = $typenum & 0x1f;
       if( $num == DATAMETA_CONSTRUCT ) {
@@ -127,106 +81,86 @@ sub _peek_leader_type
    }
 }
 
-sub _unpack_leader
+method _unpack_leader ( $peek = 0 )
 {
-   my $self = shift;
-   my ( $peek ) = @_;
-
    my $type = $self->_peek_leader_type;
-   my ( $typenum ) = unpack( "C", $self->{record} );
+   my ( $typenum ) = unpack( "C", $_payload );
 
    my $num  = $typenum & 0x1f;
 
    my $len = 1;
    if( $num == 0x1f ) {
-      ( $num ) = unpack( "x C", $self->{record} );
+      ( $num ) = unpack( "x C", $_payload );
 
       if( $num < 0x80 ) {
          $len = 2;
       }
       else {
-         ( $num ) = unpack( "x N", $self->{record} );
+         ( $num ) = unpack( "x N", $_payload );
          $num &= 0x7fffffff;
          $len = 5;
       }
    }
 
-   substr( $self->{record}, 0, $len ) = "" if !$peek;
+   substr( $_payload, 0, $len ) = "" if !$peek;
 
    return $type, $num;
 }
 
-sub _pack
+method _pack ( $s )
 {
-   my $self = shift;
-   $self->{record} .= $_[0];
+   $_payload .= $s;
 }
 
-sub _unpack
+method _unpack ( $num )
 {
-   my $self = shift;
-   my ( $num ) = @_;
-   length $self->{record} >= $num or croak "Can't pull $num bytes as there aren't enough";
-   return substr( $self->{record}, 0, $num, "" );
+   length $_payload >= $num or croak "Can't pull $num bytes as there aren't enough";
+   return substr( $_payload, 0, $num, "" );
 }
 
-sub pack_bool
+method pack_bool ( $d )
 {
-   my $self = shift;
-   my ( $d ) = @_;
    TYPE_BOOL->pack_value( $self, $d );
    return $self;
 }
 
-sub unpack_bool
+method unpack_bool
 {
-   my $self = shift;
    return TYPE_BOOL->unpack_value( $self );
 }
 
-sub pack_int
+method pack_int ( $d )
 {
-   my $self = shift;
-   my ( $d ) = @_;
    TYPE_INT->pack_value( $self, $d );
    return $self;
 }
 
-sub unpack_int
+method unpack_int
 {
-   my $self = shift;
    return TYPE_INT->unpack_value( $self );
 }
 
-sub pack_str
+method pack_str ( $d )
 {
-   my $self = shift;
-   my ( $d ) = @_;
    TYPE_STR->pack_value( $self, $d );
    return $self;
 }
 
-sub unpack_str
+method unpack_str
 {
-   my $self = shift;
    return TYPE_STR->unpack_value( $self );
 }
 
-sub pack_record
+method pack_record ( $rec, $struct = undef )
 {
-   my $self = shift;
-   my ( $rec, $struct ) = @_;
-
-   my $stream = $self->{stream};
-
    $struct ||= eval { Tangence::Struct->for_perlname( ref $rec ) } or
       croak "No struct for " . ref $rec;
 
-   $self->packmeta_struct( $struct ) unless $stream->peer_hasstruct->{$struct->perlname};
+   $self->packmeta_struct( $struct ) unless $_stream->peer_hasstruct->{$struct->perlname};
 
    my @fields = $struct->fields;
    $self->_pack_leader( DATA_RECORD, scalar @fields );
-   $self->pack_int( $stream->peer_hasstruct->{$struct->perlname}->[1] );
+   $self->pack_int( $_stream->peer_hasstruct->{$struct->perlname}->[1] );
    foreach my $field ( @fields ) {
       my $fieldname = $field->name;
       $field->type->pack_value( $self, $rec->$fieldname );
@@ -235,18 +169,13 @@ sub pack_record
    return $self;
 }
 
-sub unpack_record
+method unpack_record ( $struct = undef )
 {
-   my $self = shift;
-   my ( $struct ) = @_;
-
-   my $stream = $self->{stream};
-
    my ( $type, $num ) = $self->_unpack_leader();
    $type == DATA_RECORD or croak "Expected to unpack a record but did not find one";
 
    my $structid = $self->unpack_int();
-   my $got_struct = $stream->message_state->{id2struct}{$structid};
+   my $got_struct = $_stream->message_state->{id2struct}{$structid};
    if( !$struct ) {
       $struct = $got_struct;
    }
@@ -265,32 +194,27 @@ sub unpack_record
    return $struct->perlname->new( %values );
 }
 
-sub packmeta_construct
+method packmeta_construct ( $obj )
 {
-   my $self = shift;
-   my ( $obj ) = @_;
-
-   my $stream = $self->{stream};
-
    my $class = $obj->class;
    my $id    = $obj->id;
 
-   $self->packmeta_class( $class ) unless $stream->peer_hasclass->{$class->perlname};
+   $self->packmeta_class( $class ) unless $_stream->peer_hasclass->{$class->perlname};
 
    my $smashkeys = $class->smashkeys;
 
    $self->_pack_leader( DATA_META, DATAMETA_CONSTRUCT );
    $self->pack_int( $id );
-   $self->pack_int( $stream->peer_hasclass->{$class->perlname}->[2] );
+   $self->pack_int( $_stream->peer_hasclass->{$class->perlname}->[2] );
 
    if( @$smashkeys ) {
       my $smashdata = $obj->smash( $smashkeys );
 
       for my $prop ( @$smashkeys ) {
-         $stream->_install_watch( $obj, $prop );
+         $_stream->_install_watch( $obj, $prop );
       }
 
-      if( $stream->_ver_can_typed_smash ) {
+      if( $_stream->_ver_can_typed_smash ) {
          $self->_pack_leader( DATA_LIST, scalar @$smashkeys );
          foreach my $prop ( @$smashkeys ) {
             $class->property( $prop )->overall_type->pack_value( $self, $smashdata->{$prop} );
@@ -304,26 +228,22 @@ sub packmeta_construct
       $self->_pack_leader( DATA_LIST, 0 );
    }
 
-   weaken( my $weakstream = $stream );
-   $stream->peer_hasobj->{$id} = $obj->subscribe_event( 
+   weaken( my $weakstream = $_stream );
+   $_stream->peer_hasobj->{$id} = $obj->subscribe_event( 
       destroy => sub { $weakstream->object_destroyed( @_ ) if $weakstream },
    );
 }
 
-sub unpackmeta_construct
+method unpackmeta_construct
 {
-   my $self = shift;
-
-   my $stream = $self->{stream};
-
    my $id = $self->unpack_int();
    my $classid = $self->unpack_int();
-   my $class_perlname = $stream->message_state->{id2class}{$classid};
+   my $class_perlname = $_stream->message_state->{id2class}{$classid};
 
-   my ( $class, $smashkeys ) = @{ $stream->peer_hasclass->{$class_perlname} };
+   my ( $class, $smashkeys ) = @{ $_stream->peer_hasclass->{$class_perlname} };
 
    my $smasharr;
-   if( $stream->_ver_can_typed_smash ) {
+   if( $_stream->_ver_can_typed_smash ) {
       my ( $type, $num ) = $self->_unpack_leader;
       $type == DATA_LIST or croak "Expected to unpack a LIST of smashed data";
       $num == @$smashkeys or croak "Expected to unpack a LIST of " . ( scalar @$smashkeys ) . " elements";
@@ -339,25 +259,20 @@ sub unpackmeta_construct
    my $smashdata;
    $smashdata->{$smashkeys->[$_]} = $smasharr->[$_] for 0 .. $#$smasharr;
 
-   $stream->make_proxy( $id, $class_perlname, $smashdata );
+   $_stream->make_proxy( $id, $class_perlname, $smashdata );
 }
 
-sub packmeta_class
+method packmeta_class ( $class )
 {
-   my $self = shift;
-   my ( $class ) = @_;
-
-   my $stream = $self->{stream};
-
    my @superclasses = grep { $_->name ne "Tangence.Object" } $class->direct_superclasses;
 
-   $stream->peer_hasclass->{$_->perlname} or $self->packmeta_class( $_ ) for @superclasses;
+   $_stream->peer_hasclass->{$_->perlname} or $self->packmeta_class( $_ ) for @superclasses;
 
    $self->_pack_leader( DATA_META, DATAMETA_CLASS );
 
    my $smashkeys = $class->smashkeys;
 
-   my $classid = ++$stream->message_state->{next_classid};
+   my $classid = ++$_stream->message_state->{next_classid};
 
    $self->pack_str( $class->name );
    $self->pack_int( $classid );
@@ -392,15 +307,11 @@ sub packmeta_class
 
    TYPE_LIST_STR->pack_value( $self, $smashkeys );
 
-   $stream->peer_hasclass->{$class->perlname} = [ $class, $smashkeys, $classid ];
+   $_stream->peer_hasclass->{$class->perlname} = [ $class, $smashkeys, $classid ];
 }
 
-sub unpackmeta_class
+method unpackmeta_class
 {
-   my $self = shift;
-
-   my $stream = $self->{stream};
-
    my $name = $self->unpack_str();
    my $classid = $self->unpack_int();
    my $classrec = $self->unpack_record();
@@ -412,11 +323,11 @@ sub unpackmeta_class
             $a => Tangence::Meta::Method->new(
                class     => $class,
                name      => $a,
-               ret       => $b->returns ? Tangence::Type->new_from_sig( $b->returns )
+               ret       => $b->returns ? Tangence::Type->make_from_sig( $b->returns )
                                         : undef,
                arguments => [ map {
                   Tangence::Meta::Argument->new(
-                     type => Tangence::Type->new_from_sig( $_ ),
+                     type => Tangence::Type->make_from_sig( $_ ),
                   )
                } @{ $b->arguments } ],
             )
@@ -430,7 +341,7 @@ sub unpackmeta_class
                name      => $a,
                arguments => [ map {
                   Tangence::Meta::Argument->new(
-                     type => Tangence::Type->new_from_sig( $_ ),
+                     type => Tangence::Type->make_from_sig( $_ ),
                   )
                } @{ $b->arguments } ],
             )
@@ -445,7 +356,7 @@ sub unpackmeta_class
                class     => $class,
                name      => $a,
                dimension => $b->dimension,
-               type      => Tangence::Type->new_from_sig( $b->type ),
+               type      => Tangence::Type->make_from_sig( $b->type ),
                smashed   => $b->smashed,
             )
          } %{ $classrec->properties }
@@ -454,7 +365,7 @@ sub unpackmeta_class
       superclasses => do {
          my @superclasses = map {
             ( my $perlname = $_ ) =~ s/\./::/g;
-            $stream->peer_hasclass->{$perlname}->[3] or croak "Unrecognised class $perlname";
+            $_stream->peer_hasclass->{$perlname}->[3] or croak "Unrecognised class $perlname";
          } @{ $classrec->superclasses };
 
          @superclasses ? \@superclasses : [ Tangence::Class->for_name( "Tangence.Object" ) ]
@@ -465,44 +376,35 @@ sub unpackmeta_class
 
    my $smashkeys = TYPE_LIST_STR->unpack_value( $self );
 
-   $stream->peer_hasclass->{$perlname} = [ $class, $smashkeys, $classid, $class ];
+   $_stream->peer_hasclass->{$perlname} = [ $class, $smashkeys, $classid, $class ];
    if( defined $classid ) {
-      $stream->message_state->{id2class}{$classid} = $perlname;
+      $_stream->message_state->{id2class}{$classid} = $perlname;
    }
 }
 
-sub packmeta_struct
+method packmeta_struct ( $struct )
 {
-   my $self = shift;
-   my ( $struct ) = @_;
-
-   my $stream = $self->{stream};
-
    $self->_pack_leader( DATA_META, DATAMETA_STRUCT );
 
    my @fields = $struct->fields;
 
-   my $structid = ++$stream->message_state->{next_structid};
+   my $structid = ++$_stream->message_state->{next_structid};
    $self->pack_str( $struct->name );
    $self->pack_int( $structid );
    TYPE_LIST_STR->pack_value( $self, [ map { $_->name } @fields ] );
    TYPE_LIST_STR->pack_value( $self, [ map { $_->type->sig } @fields ] );
 
-   $stream->peer_hasstruct->{$struct->perlname} = [ $struct, $structid ];
+   $_stream->peer_hasstruct->{$struct->perlname} = [ $struct, $structid ];
 }
 
-sub unpackmeta_struct
+method unpackmeta_struct
 {
-   my $self = shift;
-
-   my $stream = $self->{stream};
-
    my $name     = $self->unpack_str();
    my $structid = $self->unpack_int();
    my $names    = TYPE_LIST_STR->unpack_value( $self );
    my $types    = TYPE_LIST_STR->unpack_value( $self );
 
-   my $struct = Tangence::Struct->new( name => $name );
+   my $struct = Tangence::Struct->make( name => $name );
    if( !$struct->defined ) {
       $struct->define(
          fields => [
@@ -511,26 +413,21 @@ sub unpackmeta_struct
       );
    }
 
-   $stream->peer_hasstruct->{$struct->perlname} = [ $struct, $structid ];
-   $stream->message_state->{id2struct}{$structid} = $struct;
+   $_stream->peer_hasstruct->{$struct->perlname} = [ $struct, $structid ];
+   $_stream->message_state->{id2struct}{$structid} = $struct;
 }
 
-sub pack_all_sametype
+method pack_all_sametype ( $type, @d )
 {
-   my $self = shift;
-   my $type = shift;
-
-   $type->pack_value( $self, $_ ) for @_;
+   $type->pack_value( $self, $_ ) for @d;
 
    return $self;
 }
 
-sub unpack_all_sametype
+method unpack_all_sametype ( $type )
 {
-   my $self = shift;
-   my ( $type ) = @_;
    my @data;
-   push @data, $type->unpack_value( $self ) while length $self->{record};
+   push @data, $type->unpack_value( $self ) while length $_payload;
 
    return @data;
 }