#  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

package Tangence::Message;

use strict;
use warnings;

# Currently depends on atleast Perl 5.10.0 to provide the > format modifier
# for pack, to specify big-endian integers. If this code can be modified, this
# restriction could be listed.
use 5.010; 

our $VERSION = '0.19';

use Carp;

use Tangence::Constants;

use Tangence::Class;
use Tangence::Meta::Method;
use Tangence::Meta::Event;
use Tangence::Property;
use Tangence::Meta::Argument;
use Tangence::Struct;
use Tangence::Types;

use Tangence::Object;

use List::Util qw( pairmap );
use Scalar::Util qw( weaken blessed );

# Normally we don't care about hash key order. But, when writing test scripts
# that will assert on the serialisation bytes, we do. Setting this to some
# 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, "" );

   return $class->new( $stream, $code, $record );
}

sub stream
{
   my $self = shift;
   return $self->{stream};
}

sub code
{
   my $self = shift;
   return $self->{code};
}

sub bytes
{
   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 );
   }
   elsif( $num < 0x80 ) {
      $self->{record} .= pack( "CC", ( $type << 5 ) | 0x1f, $num );
   }
   else {
      $self->{record} .= pack( "CN", ( $type << 5 ) | 0x1f, $num | 0x80000000 );
   }
}

sub _peek_leader_type
{
   my $self = shift;

   while(1) {
      length $self->{record} or croak "Ran out of bytes before finding a leader";

      my ( $typenum ) = unpack( "C", $self->{record} );
      my $type = $typenum >> 5;

      return $type unless $type == DATA_META;

      substr( $self->{record}, 0, 1, "" );

      my $num  = $typenum & 0x1f;
      if( $num == DATAMETA_CONSTRUCT ) {
         $self->unpackmeta_construct;
      }
      elsif( $num == DATAMETA_CLASS ) {
         $self->unpackmeta_class;
      }
      elsif( $num == DATAMETA_STRUCT ) {
         $self->unpackmeta_struct;
      }
      else {
         die sprintf("TODO: Data stream meta-operation 0x%02x", $num);
      }
   }
}

sub _unpack_leader
{
   my $self = shift;
   my ( $peek ) = @_;

   my $type = $self->_peek_leader_type;
   my ( $typenum ) = unpack( "C", $self->{record} );

   my $num  = $typenum & 0x1f;

   my $len = 1;
   if( $num == 0x1f ) {
      ( $num ) = unpack( "x C", $self->{record} );

      if( $num < 0x80 ) {
         $len = 2;
      }
      else {
         ( $num ) = unpack( "x N", $self->{record} );
         $num &= 0x7fffffff;
         $len = 5;
      }
   }

   substr( $self->{record}, 0, $len ) = "" if !$peek;

   return $type, $num;
}

sub _pack
{
   my $self = shift;
   $self->{record} .= $_[0];
}

sub _unpack
{
   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, "" );
}

sub pack_bool
{
   my $self = shift;
   my ( $d ) = @_;
   TYPE_BOOL->pack_value( $self, $d );
   return $self;
}

sub unpack_bool
{
   my $self = shift;
   return TYPE_BOOL->unpack_value( $self );
}

sub pack_int
{
   my $self = shift;
   my ( $d ) = @_;
   TYPE_INT->pack_value( $self, $d );
   return $self;
}

sub unpack_int
{
   my $self = shift;
   return TYPE_INT->unpack_value( $self );
}

sub pack_str
{
   my $self = shift;
   my ( $d ) = @_;
   TYPE_STR->pack_value( $self, $d );
   return $self;
}

sub unpack_str
{
   my $self = shift;
   return TYPE_STR->unpack_value( $self );
}

sub pack_record
{
   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};

   my @fields = $struct->fields;
   $self->_pack_leader( DATA_RECORD, scalar @fields );
   $self->pack_int( $stream->peer_hasstruct->{$struct->perlname}->[1] );
   foreach my $field ( @fields ) {
      my $fieldname = $field->name;
      $field->type->pack_value( $self, $rec->$fieldname );
   }

   return $self;
}

sub unpack_record
{
   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};
   if( !$struct ) {
      $struct = $got_struct;
   }
   else {
      $struct->name eq $got_struct->name or
         croak "Expected to unpack a ".$struct->name." but found ".$got_struct->name;
   }

   $num == $struct->fields or croak "Expected ".$struct->name." to unpack from ".(scalar $struct->fields)." fields";

   my %values;
   foreach my $field ( $struct->fields ) {
      $values{$field->name} = $field->type->unpack_value( $self );
   }

   return $struct->perlname->new( %values );
}

sub packmeta_construct
{
   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};

   my $smashkeys = $class->smashkeys;

   $self->_pack_leader( DATA_META, DATAMETA_CONSTRUCT );
   $self->pack_int( $id );
   $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 );
      }

      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} );
         }
      }
      else {
         TYPE_LIST_ANY->pack_value( $self, [ map { $smashdata->{$_} } @$smashkeys ] );
      }
   }
   else {
      $self->_pack_leader( DATA_LIST, 0 );
   }

   weaken( my $weakstream = $stream );
   $stream->peer_hasobj->{$id} = $obj->subscribe_event( 
      destroy => sub { $weakstream->object_destroyed( @_ ) if $weakstream },
   );
}

sub 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, $smashkeys ) = @{ $stream->peer_hasclass->{$class_perlname} };

   my $smasharr;
   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";

      foreach my $prop ( @$smashkeys ) {
         push @$smasharr, $class->property( $prop )->overall_type->unpack_value( $self );
      }
   }
   else {
      $smasharr = TYPE_LIST_ANY->unpack_value( $self );
   }

   my $smashdata;
   $smashdata->{$smashkeys->[$_]} = $smasharr->[$_] for 0 .. $#$smasharr;

   $stream->make_proxy( $id, $class_perlname, $smashdata );
}

sub packmeta_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;

   $self->_pack_leader( DATA_META, DATAMETA_CLASS );

   my $smashkeys = $class->smashkeys;

   my $classid = ++$stream->message_state->{next_classid};

   $self->pack_str( $class->name );
   $self->pack_int( $classid );
   my $classrec = Tangence::Struct::Class->new(
      methods => {
         pairmap {
            $a => Tangence::Struct::Method->new(
               arguments => [ map { $_->type->sig } $b->arguments ],
               returns   => ( $b->ret ? $b->ret->sig : "" ),
            )
         } %{ $class->direct_methods }
      },
      events => {
         pairmap {
            $a => Tangence::Struct::Event->new(
               arguments => [ map { $_->type->sig } $b->arguments ],
            )
         } %{ $class->direct_events }
      },
      properties => {
         pairmap {
            $a => Tangence::Struct::Property->new(
               dimension => $b->dimension,
               type      => $b->type->sig,
               smashed   => $b->smashed,
            )
         } %{ $class->direct_properties }
      },
      superclasses => [ map { $_->name } @superclasses ],
   );
   $self->pack_record( $classrec );

   TYPE_LIST_STR->pack_value( $self, $smashkeys );

   $stream->peer_hasclass->{$class->perlname} = [ $class, $smashkeys, $classid ];
}

sub unpackmeta_class
{
   my $self = shift;

   my $stream = $self->{stream};

   my $name = $self->unpack_str();
   my $classid = $self->unpack_int();
   my $classrec = $self->unpack_record();

   my $class = Tangence::Meta::Class->new( name => $name );
   $class->define(
      methods => { 
         pairmap {
            $a => Tangence::Meta::Method->new(
               class     => $class,
               name      => $a,
               ret       => $b->returns ? Tangence::Type->new_from_sig( $b->returns )
                                        : undef,
               arguments => [ map {
                  Tangence::Meta::Argument->new(
                     type => Tangence::Type->new_from_sig( $_ ),
                  )
               } @{ $b->arguments } ],
            )
         } %{ $classrec->methods }
      },

      events => {
         pairmap {
            $a => Tangence::Meta::Event->new(
               class     => $class,
               name      => $a,
               arguments => [ map {
                  Tangence::Meta::Argument->new(
                     type => Tangence::Type->new_from_sig( $_ ),
                  )
               } @{ $b->arguments } ],
            )
         } %{ $classrec->events }
      },

      properties => {
         pairmap {
            # Need to use non-Meta:: Property so it can generate overall type
            # using Tangence::Type instead of Tangence::Meta::Type
            $a => Tangence::Property->new(
               class     => $class,
               name      => $a,
               dimension => $b->dimension,
               type      => Tangence::Type->new_from_sig( $b->type ),
               smashed   => $b->smashed,
            )
         } %{ $classrec->properties }
      },

      superclasses => do {
         my @superclasses = map {
            ( my $perlname = $_ ) =~ s/\./::/g;
            $stream->peer_hasclass->{$perlname}->[3] or croak "Unrecognised class $perlname";
         } @{ $classrec->superclasses };

         @superclasses ? \@superclasses : [ Tangence::Class->for_name( "Tangence.Object" ) ]
      },
   );

   my $perlname = $class->perlname;

   my $smashkeys = TYPE_LIST_STR->unpack_value( $self );

   $stream->peer_hasclass->{$perlname} = [ $class, $smashkeys, $classid, $class ];
   if( defined $classid ) {
      $stream->message_state->{id2class}{$classid} = $perlname;
   }
}

sub packmeta_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};
   $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 ];
}

sub 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 );
   if( !$struct->defined ) {
      $struct->define(
         fields => [
            map { $names->[$_] => $types->[$_] } 0 .. $#$names
         ]
      );
   }

   $stream->peer_hasstruct->{$struct->perlname} = [ $struct, $structid ];
   $stream->message_state->{id2struct}{$structid} = $struct;
}

sub pack_all_sametype
{
   my $self = shift;
   my $type = shift;

   $type->pack_value( $self, $_ ) for @_;

   return $self;
}

sub unpack_all_sametype
{
   my $self = shift;
   my ( $type ) = @_;
   my @data;
   push @data, $type->unpack_value( $self ) while length $self->{record};

   return @data;
}

=head1 AUTHOR

Paul Evans <leonerd@leonerd.org.uk>

=cut

0x55AA;