The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
use Test::More tests => 27;

# TODO: More tests for disconnection syntax. Make sure the correct things
# always get disconnected. More tests for arrays of signal names.

my @slot_got = ();
my $rc;

sub got_slot {
  push @slot_got, @_;
}

sub get_got {
  my $got = join( ' ', sort @slot_got );
  @slot_got = ();
  return $got;
}

sub get_err {
  my $err = $@;
  # Tidy up error message
  $err =~ s{ \n .* }{}xms;
  $err =~ s{ \s+ at \s+ \S+ \s+ line \s+ \d+ \s* $ }{}xms;
  return $err;
}

package My::Class::One;
use Class::Std;
use Class::Std::Slots;
{
  signals qw(
   my_signal
   other_signal
  );

  sub my_slot {
    my $self = shift;
    main::got_slot( 'my_slot' );
  }

  sub other_slot {
    my $self = shift;
    main::got_slot( 'other_slot' );
    # Guarded with has_slots just to make sure it doesn't
    # make a difference. Don't do this in real code if the
    # signal call is computationally cheap.
    $self->other_signal if $self->has_slots( 'other_signal' );
  }

  sub do_stuff {
    my $self = shift;
    $self->my_signal;    # send signal
  }
}

package My::Class::Two;
use Class::Std;
use Class::Std::Slots;
{
  signals qw(
   another_signal
  );

  sub another_slot {
    my $self = shift;
    main::got_slot( 'another_slot' );
    $self->another_signal;
  }
}

package My::Class::Two::More;
use base qw(My::Class::Two);
use Class::Std;
use Class::Std::Slots;
{
  signals qw(
   unique_to_more
  );

  sub more_slot {
    my $self = shift;
    main::got_slot( 'more_slot' );
    $self->unique_to_more;
  }
}

package main;

my $ob1a = My::Class::One->new();
my $ob1b = My::Class::One->new();
my $ob2  = My::Class::Two->new();
my $ob2m = My::Class::Two::More->new();

ok( !$ob1a->has_slots( 'my_signal' ), 'No slots' );

# No signal yet
$ob1a->do_stuff;
is( get_got, '', 'No slots' );

# Connect to a slot in another class
$ob1a->connect( 'my_signal', $ob2, 'another_slot' );

ok( $ob1a->has_slots( 'my_signal' ),     'Has slots' );
ok( !$ob1b->has_slots( 'my_signal' ),    'No slots (2)' );
ok( !$ob1a->has_slots( 'other_signal' ), 'No slots (3)' );
ok( $ob1a->has_slots( [ 'other_signal', 'my_signal' ] ),
  'Has multiple slots' );

$ob1a->do_stuff;
is( get_got, 'another_slot', 'One slot' );

$ob1a->connect( 'my_signal', sub { got_slot( 'ANON' ); } );

$ob1a->do_stuff;
is( get_got, 'ANON another_slot', 'Two slots' );

$ob1b->do_stuff;
is( get_got, '', 'No slots, other obj' );

# Delete named connection
$ob1a->disconnect( 'my_signal', $ob2, 'another_slot' );

$ob1a->do_stuff;
is( get_got, 'ANON', 'Deleted named slot, anon only' );

$ob1a->disconnect();

$ob1a->do_stuff;
is( get_got, '', 'Deleted everything' );

# More complex connections
$ob1a->connect( ['my_signal'], $ob1b, 'my_signal' );
$ob1b->connect( 'my_signal', $ob2m, 'more_slot' );

$ob1a->my_signal;    # Fire directly
is( get_got, 'more_slot', 'Chained call' );

# Test some errors
eval { $ob1a->connect( 'my_signal', $ob2m, 'bogus_slot' ); };

is(
  get_err,
  "Slot 'bogus_slot' not handled by My::Class::Two::More",
  'Bad slot name'
);

eval { $ob1a->connect( 'my_signal', my $not_an_obj, 'some_slot' ); };

is(
  get_err,
  'Usage: $source->connect($sig_name, $dst_obj, $dst_method [, { options }])',
  'Bad object'
);

eval { $ob1a->connect( 'my_signal', $ob2 ); };

is(
  get_err,
  'Usage: $source->connect($sig_name, $dst_obj, $dst_method [, { options }])',
  'Missing method'
);

eval { $ob1a->connect( 'bad signal name', $ob2m, 'more_slot' ); };

is(
  get_err,
  "Invalid signal name 'bad signal name'",
  'Bad signal name'
);

eval { $ob2->connect( 'unique_to_more', $ob1a, 'my_slot' ); };

is(
  get_err,
  "Signal 'unique_to_more' undefined",
  'Signal only in subclass'
);

eval { $ob1a->connect( 'my_signal', $ob2, 'more_slot' ); };

is(
  get_err,
  "Slot 'more_slot' not handled by My::Class::Two",
  'Slot only in subclass'
);

# Make sure this test still works after all those errors
$ob1a->my_signal;    # Fire directly
is( get_got, 'more_slot', 'Still works' );

# Make a simple circular connection
$ob2m->connect( 'unique_to_more', $ob2m, 'more_slot' );

eval { $ob2m->unique_to_more; };

is(
  get_err,
  "Attempt to re-enter signal 'unique_to_more'",
  'Simple circularity'
);
is( get_got, 'more_slot', 'Simple circularity results' );

for ( $ob1a, $ob1b, $ob2, $ob2m ) {
  $_->disconnect();
}

# Trigger all the signals...
for ( $ob1a, $ob1b ) {
  $_->my_signal;
  $_->other_signal;
}

$ob2->another_signal;
$ob2m->unique_to_more;

# ...and make sure nothing happened
is( get_got, '', 'All disconnected' );

# Make a more complex loop
$ob1a->connect( 'my_signal',    $ob1b, 'other_slot' );
$ob1b->connect( 'other_signal', $ob2,  'another_slot' );
$ob2->connect( 'another_signal', $ob2m, 'more_slot' );
$ob2m->connect( 'unique_to_more', $ob1a, 'my_signal' );

eval { $ob1a->my_signal; };

is(
  get_err,
  "Attempt to re-enter signal 'my_signal'",
  'Complex circularity'
);
is(
  get_got,
  'another_slot more_slot other_slot',
  'Complex circularity results'
);

# Check that has_slots can be called on an undeclared signals

eval { $rc = $ob1a->has_slots( 'made_up_signal_name' ); };

ok( !$rc, 'has_slots with made up signal name' );
is( get_err, '', 'has_slots with made up signal name - not an error' );

for ( $ob1a, $ob1b, $ob2, $ob2m ) {
  $_->disconnect();
}

$ob1a->connect( 'made_up_signal_name', $ob1b, 'other_slot',
  { undeclared => 1 } );
$ob1a->emit_signal( 'made_up_signal_name' );

is( get_got, 'other_slot', 'Synthetic signal name' );