File Coverage

blib/lib/Tangence/Object.pm

Criterion	Covered	Total	%
statement	289	304	95.0
branch	59	92	64.1
condition	7	11	63.6
subroutine	37	38	97.3
pod	13	22	59.0
total	405	467	86.7

#  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-2021 -- [e-mail]

package Tangence::Object 0.29;

use v5.26;
use warnings;
use experimental 'signatures';

use Carp;

use Syntax::Keyword::Match;

use Tangence::Constants;

use Tangence::Types;

use Tangence::Class;

Tangence::Class->declare(
   __PACKAGE__,

   events => {
      destroy => {
         args => [],
      },
   },
);

=head1 NAME

C - base class for accessible objects in a C server

=head1 DESCRIPTION

This class acts as a base class for the accessible objects in a L
server. All the objects actually created and made accessible to clients will
be subclasses of this one, including internally-created objects such as
L.

These objects are not directly constructed by calling the C class method;
instead the C should be used to construct one.

=cut

sub new ( $class, %args )
{
   defined( my $id = delete $args{id} ) or croak "Need a id";
   my $registry = delete $args{registry} or croak "Need a registry";

   my $self = bless {
      id => $id,
      registry => $registry,
      meta => $args{meta} || Tangence::Class->for_perlname( $class ),

      event_subs => {},   # {$event} => [ @cbs ]

      properties => {}, # {$prop} => T:P::Instance struct
   }, $class;

   my $properties = $self->class->properties;
   foreach my $prop ( keys %$properties ) {
      my $meth = "new_prop_$prop";
      $self->$meth();
   }

   return $self;
}

=head1 METHODS

=cut

=head2 destroy

   $obj->destroy

Requests that the object destroy itself, informing all clients that are aware
of it. Once they all report that they have dropped the object, the object is
deconstructed for real.

Not to be confused with Perl's own C method.

=cut

sub destroy ( $self, %args )
{
   $self->{destroying} = 1;

   my $outstanding = 1;

   my $on_destroyed = $args{on_destroyed};

   my $incsub = sub {
      $outstanding++
   };

   my $decsub = sub {
      --$outstanding and return;
      $self->_destroy_really;
      $on_destroyed->() if $on_destroyed;
   };

   foreach my $cb ( @{ $self->{event_subs}->{destroy} } ) {
      $cb->( $self, $incsub, $decsub );
   }

   $decsub->();
}

sub _destroy_really
{
   my $self = shift;

   $self->registry->destroy_object( $self );

   undef %$self; # Now I am dead
   $self->{destroyed} = 1;
}

=head2 id

   $id = $obj->id

Returns the object's C ID number

=cut

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

=head2 describe

   $description = $obj->describe

Returns a textual description of the object, for internal debugging purposes.
Subclasses are encouraged to override this method to return something more
descriptive within their domain of interest

=cut

sub describe
{
   my $self = shift;
   return ref $self;
}

=head2 registry

   $registry = $obj->registry

Returns the L that constructed this object.

=cut

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

sub smash ( $self, $smashkeys )
{
   return undef unless $smashkeys and @$smashkeys;

   my @keys;
   if( ref $smashkeys eq "HASH" ) {
      @keys = keys %$smashkeys;
   }
   else {
      @keys = @$smashkeys;
   }

   return { map {
      my $m = "get_prop_$_";
      $_ => $self->$m()
   } @keys };
}

=head2 class

   $class = $obj->class

Returns the L object representing the class of this
object.

=cut

sub class
{
   my $self = shift;
   return ref $self ? $self->{meta} : Tangence::Class->for_perlname( $self );
}

=head2 can_method

   $method = $obj->can_method( $name )

Returns the L object representing the named method, or
C if no such method exists.

=cut

sub can_method
{
   my $self = shift;
   return $self->class->method( @_ );
}

=head2 can_event

   $event = $obj->can_event( $name )

Returns the L object representing the named event, or
C if no such event exists.

=cut

sub can_event
{
   my $self = shift;
   return $self->class->event( @_ );
}

=head2 can_property

   $property = $obj->can_property( $name )

Returns the L object representing the named
property, or C if no such property exists.

=cut

sub can_property
{
   my $self = shift;
   return $self->class->property( @_ );
}

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

=head2 fire_event

   $obj->fire_event( $event, @args )

Fires the named event on the object. Each event subscription function will be
invoked with the given arguments.

=cut

sub fire_event ( $self, $event, @args )
{
   $event eq "destroy" and croak "$self cannot fire destroy event directly";

   $self->can_event( $event ) or croak "$self has no event $event";

   my $sublist = $self->{event_subs}->{$event} or return;

   foreach my $cb ( @$sublist ) {
      $cb->( $self, @args );
   }
}

=head2 subscribe_event

   $id = $obj->subscribe_event( $event, $callback )

Subscribes an event-handling callback CODE ref to the named event. When the
event is fired by C this callback will be invoked, being passed
the object reference and the event's arguments.

   $callback->( $obj, @args )

Returns an opaque ID value that can be used to remove this subscription by
calling C.

=cut

sub subscribe_event ( $self, $event, $callback )
{
   $self->can_event( $event ) or croak "$self has no event $event";

   my $sublist = ( $self->{event_subs}->{$event} ||= [] );

   push @$sublist, $callback;

   my $ref = \@{$sublist}[$#$sublist];   # reference to last element
   return $ref + 0; # force numeric context
}

=head2 unsubscribe_event

   $obj->unsubscribe_event( $event, $id )

Removes an event-handling callback previously registered with
C.

=cut

sub unsubscribe_event ( $self, $event, $id )
{
   my $sublist = $self->{event_subs}->{$event} or return;

   my $index;
   for( $index = 0; $index < @$sublist; $index++ ) {
      last if \@{$sublist}[$index] + 0 == $id;
   }

   splice @$sublist, $index, 1, ();
}

=head2 watch_property

   $id = $obj->watch_property( $prop, %callbacks )

Watches a named property for changes, registering a set of callback functions
to be invoked when the property changes in certain ways. The set of callbacks
required depends on the dimension of the property being watched.

For all property types:

   $on_set->( $obj, $value )

For hash properties:

   $on_add->( $obj, $key, $value )
   $on_del->( $obj, $key )

For queue properties:

   $on_push->( $obj, @values )
   $on_shift->( $obj, $count )

For array properties:

   $on_push->( $obj, @values )
   $on_shift->( $obj, $count )
   $on_splice->( $obj, $index, $count, @values )
   $on_move->( $obj, $index, $delta )

For objset properties:

   $on_add->( $obj, $added_object )
   $on_del->( $obj, $deleted_object_id )

Alternatively, a single callback may be installed that is invoked after any
change of the property, being passed the new value entirely:

   $on_updated->( $obj, $value )

Returns an opaque ID value that can be used to remove this watch by calling
C.

=cut

sub watch_property ( $self, $prop, %callbacks )
{
   my $pdef = $self->can_property( $prop ) or croak "$self has no property $prop";

   my $callbacks = {};
   my $on_updated;

   if( $callbacks{on_updated} ) {
      $on_updated = delete $callbacks{on_updated};
      ref $on_updated eq "CODE" or croak "Expected 'on_updated' to be a CODE ref";
      keys %callbacks and croak "Expected no key other than 'on_updated'";
      $callbacks->{on_updated} = $on_updated;
   }
   else {
      foreach my $name ( @{ CHANGETYPES->{$pdef->dimension} } ) {
         ref( $callbacks->{$name} = delete $callbacks{$name} ) eq "CODE"
            or croak "Expected '$name' as a CODE ref";
      }
   }

   my $watchlist = $self->{properties}->{$prop}->callbacks;

   push @$watchlist, $callbacks;

   $on_updated->( $self, $self->{properties}->{$prop}->value ) if $on_updated;

   my $ref = \@{$watchlist}[$#$watchlist];  # reference to last element
   return $ref + 0; # force numeric context
}

=head2 unwatch_property

   $obj->unwatch_property( $prop, $id )

Removes the set of callback functions previously registered with
C.

=cut

sub unwatch_property ( $self, $prop, $id )
{
   my $watchlist = $self->{properties}->{$prop}->callbacks or return;

   my $index;
   for( $index = 0; $index < @$watchlist; $index++ ) {
      last if \@{$watchlist}[$index] + 0 == $id;
   }

   splice @$watchlist, $index, 1, ();
}

### Message handling

sub handle_request_CALL ( $self, $ctx, $message )
{
   my $method = $message->unpack_str();

   my $mdef = $self->can_method( $method ) or die "Object cannot respond to method $method\n";

   my $m = "method_$method";
   $self->can( $m ) or die "Object cannot run method $method\n";

   my @args = map { $_->unpack_value( $message ) } $mdef->argtypes;

   my $result = $self->$m( $ctx, @args );

   my $response = Tangence::Message->new( $ctx->stream, MSG_RESULT );
   $mdef->ret->pack_value( $response, $result ) if $mdef->ret;

   return $response;
}

sub generate_message_EVENT ( $self, $conn, $event, @args )
{
   my $edef = $self->can_event( $event ) or die "Object cannot respond to event $event";

   my $response = Tangence::Message->new( $conn, MSG_EVENT )
      ->pack_int( $self->id )
      ->pack_str( $event );

   my @argtypes = $edef->argtypes;
   $argtypes[$_]->pack_value( $response, $args[$_] ) for 0..$#argtypes;

   return $response;
}

sub handle_request_GETPROP ( $self, $ctx, $message )
{
   my $prop = $message->unpack_str();

   my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop";

   my $m = "get_prop_$prop";
   $self->can( $m ) or die "Object cannot get property $prop\n";

   my $result = $self->$m();

   my $response = Tangence::Message->new( $ctx->stream, MSG_RESULT );
   $pdef->overall_type->pack_value( $response, $result );

   return $response;
}

sub handle_request_GETPROPELEM ( $self, $ctx, $message )
{
   my $prop = $message->unpack_str();

   my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop";
   my $dim = $pdef->dimension;

   my $m = "get_prop_$prop";
   $self->can( $m ) or die "Object cannot get property $prop\n";

   my $result;
   match( $dim : == ) {
      case( DIM_QUEUE ), case( DIM_ARRAY ) {
         my $idx = $message->unpack_int();
         $result = $self->$m()->[$idx];
      }
      case( DIM_HASH ) {
         my $key = $message->unpack_str();
         $result = $self->$m()->{$key};
      }
      default {
         die "Property $prop cannot fetch elements";
      }
   }

   my $response = Tangence::Message->new( $ctx->stream, MSG_RESULT );
   $pdef->type->pack_value( $response, $result );

   return $response;
}

sub handle_request_SETPROP ( $self, $ctx, $message )
{
   my $prop  = $message->unpack_str();

   my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop\n";

   my $value = $pdef->overall_type->unpack_value( $message );

   my $m = "set_prop_$prop";
   $self->can( $m ) or die "Object cannot set property $prop\n";

   $self->$m( $value );

   return Tangence::Message->new( $self, MSG_OK );
}

sub generate_message_UPDATE ( $self, $conn, $prop, $how, @args )
{
   my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop\n";
   my $dim = $pdef->dimension;

   my $message = Tangence::Message->new( $conn, MSG_UPDATE )
      ->pack_int( $self->id )
      ->pack_str( $prop );
   TYPE_U8->pack_value( $message, $how );

   my $dimname = DIMNAMES->[$dim];
   if( $how == CHANGE_SET ) {
      my ( $value ) = @args;
      $pdef->overall_type->pack_value( $message, $value );
   }
   elsif( my $code = $self->can( "_generate_message_UPDATE_$dimname" ) ) {
      $code->( $self, $message, $how, $pdef, @args );
   }
   else {
      croak "Unrecognised property dimension $dim for $prop";
   }

   return $message;
}

sub _generate_message_UPDATE_scalar ( $self, $message, $how, $pdef, @args )
{
   croak "Change type $how is not valid for a scalar property";
}

sub _generate_message_UPDATE_hash ( $self, $message, $how, $pdef, @args )
{
   match( $how : == ) {
      case( CHANGE_ADD ) {
         my ( $key, $value ) = @args;
         $message->pack_str( $key );
         $pdef->type->pack_value( $message, $value );
      }
      case( CHANGE_DEL ) {
         my ( $key ) = @args;
         $message->pack_str( $key );
      }
      default {
         croak "Change type $how is not valid for a hash property";
      }
   }
}

sub _generate_message_UPDATE_queue ( $self, $message, $how, $pdef, @args )
{
   match( $how : == ) {
      case( CHANGE_PUSH ) {
         $message->pack_all_sametype( $pdef->type, @args );
      }
      case( CHANGE_SHIFT ) {
         my ( $count ) = @args;
         $message->pack_int( $count );
      }
      default {
         croak "Change type $how is not valid for a queue property";
      }
   }
}

sub _generate_message_UPDATE_array ( $self, $message, $how, $pdef, @args )
{
   match( $how : == ) {
      case( CHANGE_PUSH ) {
         $message->pack_all_sametype( $pdef->type, @args );
      }
      case( CHANGE_SHIFT ) {
         my ( $count ) = @args;
         $message->pack_int( $count );
      }
      case( CHANGE_SPLICE ) {
         my ( $start, $count, @values ) = @args;
         $message->pack_int( $start );
         $message->pack_int( $count );
         $message->pack_all_sametype( $pdef->type, @values );
      }
      case( CHANGE_MOVE ) {
         my ( $index, $delta ) = @args;
         $message->pack_int( $index );
         $message->pack_int( $delta );
      }
      default {
         croak "Change type $how is not valid for an array property";
      }
   }
}

sub _generate_message_UPDATE_objset ( $self, $message, $how, $pdef, @args )
{
   match( $how : == ) {
      case( CHANGE_ADD ) {
         my ( $value ) = @args;
         $pdef->type->pack_value( $message, $value );
      }
      case( CHANGE_DEL ) {
         my ( $id ) = @args;
         $message->pack_int( $id );
      }
      default {
         croak "Change type $how is not valid for an objset property";
      }
   }
}

=head1 AUTHOR

Paul Evans

=cut

0x55AA;