The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;

use Test::More tests => 24;
use Test::Memory::Cycle;

use Tangence::Constants;
use Tangence::Registry;

use Struct::Dumb 0.09;  # _forbid_arrayification

use lib ".";
use t::TestObj;
use t::TestServerClient;

my $registry = Tangence::Registry->new(
   tanfile => "t/TestObj.tan",
);
my $obj = $registry->construct(
   "t::TestObj",
);

my ( $server, $client ) = make_serverclient( $registry );

my $proxy = $client->rootobj;

# SCALAR
{
   my $scalar;
   $proxy->watch_property_with_initial( "scalar",
      on_set => sub { $scalar = shift },
   )->get;

   is( $scalar, "123", 'Initial value from watch_property "scalar"' );

   undef $scalar;
   $obj->set_prop_scalar( "1234" );

   is( $scalar, "1234", 'set scalar value' );

   my $also_scalar;
   $proxy->watch_property_with_initial( "scalar",
      on_updated => sub { $also_scalar = shift },
   )->get;

   is( $also_scalar, "1234", 'Can watch_property a second time' );
}

# HASH
{
   my $hash;
   my ( $a_key, $a_value );
   my ( $d_key );
   $proxy->watch_property_with_initial( "hash",
      on_set => sub { $hash = shift },
      on_add => sub { ( $a_key, $a_value ) = @_ },
      on_del => sub { ( $d_key ) = @_ },
   )->get;

   is_deeply( $hash,
              { one => 1, two => 2, three => 3 },
              'Initial value from watch_property "hash"' );

   $obj->add_prop_hash( four => 4 );

   is( $a_key,   'four', 'add hash key' );
   is( $a_value, 4,      'add hash value' );

   $obj->del_prop_hash( 'one' );

   is( $d_key, 'one', 'del hash key' );
}

# QUEUE
{
   my $queue;
   my ( @p_values );
   my ( $sh_count );
   my ( $s_index, $s_count, @s_values );
   $proxy->watch_property_with_initial( "queue",
      on_set => sub { $queue = shift },
      on_push => sub { @p_values = @_ },
      on_shift => sub { ( $sh_count ) = @_ },
   )->get;

   $obj->push_prop_queue( 6 );

   is_deeply( \@p_values, [ 6 ], 'push queue values' );

   $obj->shift_prop_queue( 1 );

   is( $sh_count, 1, 'shift queue count' );
}

# ARRAY
{
   my $array;
   my ( @p_values );
   my ( $sh_count );
   my ( $s_index, $s_count, @s_values );
   my ( $m_index, $m_delta );
   $proxy->watch_property_with_initial( "array",
      on_set => sub { $array = shift },
      on_push => sub { @p_values = @_ },
      on_shift => sub { ( $sh_count ) = @_ },
      on_splice => sub { ( $s_index, $s_count, @s_values ) = @_ },
      on_move => sub { ( $m_index, $m_delta ) = @_ },
   )->get;

   $obj->push_prop_array( 6 );

   is_deeply( \@p_values, [ 6 ], 'push array values' );

   $obj->shift_prop_array( 1 );

   is( $sh_count, 1, 'shift array count' );

   $obj->splice_prop_array( 1, 2, ( 7 ) );

   is( $s_index, 1, 'splice array index' );
   is( $s_count, 2, 'splice array count' );
   is_deeply( \@s_values, [ 7 ], 'splice array values' );

   $obj->set_prop_array( [ 0 .. 4 ] );
   $obj->move_prop_array( 1, 3 );

   is( $m_index, 1, 'move array index' );
   is( $m_delta, 3, 'move array delta' );
}

# OBJSET
{
   my $objset;
   my $added;
   my $deleted_id;
   $proxy->watch_property_with_initial( "objset",
      on_set => sub { $objset = shift },
      on_add => sub { $added = shift },
      on_del => sub { $deleted_id = shift },
   )->get;

   # Shall have to construct some other TestObj objects to use here, as we can't
   # put regular ints in
   my $new = $registry->construct( "t::TestObj" );

   is_deeply( $objset, {}, 'Initial value from watch_property "objset"' );

   undef $objset;
   $obj->set_prop_objset( { $new->id => $new } );

   is( ref $objset, "HASH", 'set objset value type' );
   is_deeply( [ keys %$objset ], [ $new->id ], 'set objset value keys' );

   $obj->del_prop_objset( $new );

   is( $deleted_id, $new->id, 'del objset deleted_id' );

   $obj->add_prop_objset( $new );

   is( ref $added, "Tangence::ObjectProxy", 'add objset added' );
}

{
   no warnings 'redefine';
   local *Tangence::Property::Instance::_forbid_arrayification = sub {};

   memory_cycle_ok( $registry, '$registry has no memory cycles' );
   memory_cycle_ok( $obj, '$obj has no memory cycles' );
   memory_cycle_ok( $proxy, '$proxy has no memory cycles' );
}

done_testing;