File Coverage

blib/lib/Tangence/Registry.pm

Criterion	Covered	Total	%
statement	73	79	92.4
branch	3	6	50.0
condition	1	3	33.3
subroutine	17	18	94.4
pod	3	6	50.0
total	97	112	86.6

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

use v5.26;
use warnings;
use Object::Pad 0.800 ':experimental(adjust_params)';

package Tangence::Registry 0.33;
class Tangence::Registry :isa(Tangence::Object);

use Carp;

use Tangence::Constants;
use Tangence::Class;
use Tangence::Property;
use Tangence::Struct;
use Tangence::Type;

use Tangence::Compiler::Parser;

use Scalar::Util qw( weaken );

Tangence::Class->declare(
   __PACKAGE__,

   methods => {
      get_by_id => {
         args => [ [ id => 'int' ] ],
         ret  => 'obj',
      },
   },

   events => {
      object_constructed => {
         args => [ [ id => 'int' ] ],
      },
      object_destroyed => {
         args => [ [ id => 'int' ] ],
      },
   },

   props => {
      objects => {
         dim  => DIM_HASH,
         type => 'str',
      }
   },
);

=head1 NAME

C - object manager for a C server

=head1 DESCRIPTION

This subclass of L acts as a container for all the exposed
objects in a L server. The registry is used to create exposed
objects, and manages their lifetime. It maintains a reference to all the
objects it creates, so it can dispatch incoming messages from clients to them.

=cut

=head1 CONSTRUCTOR

=cut

=head2 new

   $registry = Tangence::Registry->new;

Returns a new instance of a C object. An entire server
requires one registry object; it will be shared among all the client
connections to that server.

=cut

sub BUILDARGS ( $class, %args )
{
   return (
      id => 0,
      registry => "BOOTSTRAP",
      meta => Tangence::Class->for_perlname( $class ),
      %args,
   );
}

field $_nextid  = 1;
field @_freeids;
field %_objects;

ADJUST :params (
   :$tanfile
) {
   my $id = 0;
   weaken( $self->{registry} = $self );

   %_objects = ( $id => $self );
   weaken( $_objects{$id} );
   $self->add_prop_objects( $id => $self->describe );

   $self->load_tanfile( $tanfile );
}

=head1 METHODS

=cut

=head2 get_by_id

   $obj = $registry->get_by_id( $id );

Returns the object with the given object ID.

This method is exposed to clients.

=cut

method get_by_id ( $id )
{
   return $_objects{$id};
}

method method_get_by_id ( $ctx, $id )
{
   return $self->get_by_id( $id );
}

=head2 construct

   $obj = $registry->construct( $type, @args );

Constructs a new exposed object of the given type, and returns it. Any
additional arguments are passed to the object's constructor.

=cut

method construct ( $type, @args )
{
   my $id = shift @_freeids // ( $_nextid++ );

   Tangence::Class->for_perlname( $type ) or
      croak "Registry cannot construct a '$type' as no class definition exists";

   eval { $type->can( "new" ) } or
      croak "Registry cannot construct a '$type' as it has no ->new() method";

   my $obj = $type->new(
      registry => $self,
      id       => $id,
      @args
   );

   $self->fire_event( "object_constructed", $id );

   weaken( $_objects{$id} = $obj );
   $self->add_prop_objects( $id => $obj->describe );

   return $obj;
}

method destroy_object ( $obj )
{
   my $id = $obj->id;

   exists $_objects{$id} or croak "Cannot destroy ID $id - does not exist";

   $self->del_prop_objects( $id );

   $self->fire_event( "object_destroyed", $id );

   push @_freeids, $id; # Recycle the ID
}

=head2 load_tanfile

   $registry->load_tanfile( $tanfile );

Loads additional Tangence class and struct definitions from the given F<.tan>
file.

=cut

method load_tanfile ( $tanfile )
{
   # Merely constructing this has the side-effect of declaring all the classes
   Tangence::Registry::Parser->new->from_file( $tanfile );
}

class Tangence::Registry::Parser :isa(Tangence::Compiler::Parser)
{
   method make_class
   {
      return Tangence::Class->make( @_ );
   }

   method make_struct
   {
      return Tangence::Struct->make( @_ );
   }

   method make_property
   {
      return Tangence::Property->new( @_ );
   }

   method make_type
   {
      return Tangence::Type->make( @_ );
   }
}

=head1 AUTHOR

Paul Evans

=cut

0x55AA;