Class-Std-Slots

 view release on metacpan or  search on metacpan

lib/Class/Std/Slots.pm  view on Meta::CPAN

package Class::Std::Slots;

use warnings;
use strict;
use Carp;
use Scalar::Util qw(blessed refaddr weaken);

our $VERSION = '0.31';

my %signal_map  = ();   # maps id -> signame -> array of connected slots
my %signal_busy = ();   # maps id -> signame -> busy flag
my %patched     = ();   # classes whose DESTROY we've patched

# Subs we export to caller's namespace
my @exported_subs = qw(
 connect
 disconnect
 signals
 has_slots
 emit_signal
);

sub _massage_signal_names {
  my $sig_names = shift;

  croak "Missing signal name"
   unless defined( $sig_names );

  $sig_names = [$sig_names]
   unless ref( $sig_names );

  croak "Signal name must be a scalar or an array reference"
   unless ref( $sig_names ) eq 'ARRAY';

  for my $sig_name ( @{$sig_names} ) {
    croak "Invalid signal name '$sig_name'"
     unless $sig_name =~ /^\w(?:[\w\d])*$/;
  }

  return $sig_names;
}

sub _check_signals_exist {
  my $class     = shift;
  my $sig_names = shift;

  for my $sig_name ( @{$sig_names} ) {

    # OK to call UNIVERSAL::can() here because we do actually want to
    # know whether a method named after this signal exists rather than
    # whether this class or one of its superclasses can respond to
    # a particular message - so we're not interested in any overridden
    # version of can()
    croak "Signal '$sig_name' undefined"
     unless UNIVERSAL::can( $class, $sig_name );
  }
}

sub emit_signal {
  my $self      = shift;
  my $sig_names = _massage_signal_names( shift );

  for my $sig_name ( @{$sig_names} ) {
    _emit_signal( $self, $sig_name, @_ );
  }
}

lib/Class/Std/Slots.pm  view on Meta::CPAN

  # Remove busy flag
  delete $signal_busy{$src_id}->{$sig_name};

  # Rethrow any error
  die if $@;
}

sub _destroy {
  my $src_id = shift;
  delete $signal_map{$src_id};
  delete $signal_busy{$src_id};
}

sub has_slots {
  my $src_obj   = shift;
  my $sig_names = _massage_signal_names( shift );

  croak 'Usage: $obj->has_slots($sig_name)'
   unless blessed $src_obj;

  for my $sig_name ( @{$sig_names} ) {
    my $src_id = refaddr( $src_obj );
    return 1 if exists $signal_map{$src_id}->{$sig_name};
  }

  return;
}

sub _connect_usage {
  croak
   'Usage: $source->connect($sig_name, $dst_obj, $dst_method [, { options }])';
}

sub connect {
  my $src_obj   = shift;
  my $sig_names = _massage_signal_names( shift );
  my $dst_obj   = shift;
  my $dst_method;

  _connect_usage()
   unless blessed( $src_obj )
     && defined( $dst_obj );

  if ( blessed( $dst_obj ) ) {
    $dst_method = shift || _connect_usage();
    croak "Slot '$dst_method' not handled by " . ref( $dst_obj )
     unless $dst_obj->can( $dst_method );
  }
  else {
    _connect_usage() unless ref( $dst_obj ) eq 'CODE';
  }

  my $options = shift || {};
  my $src_id  = refaddr( $src_obj );
  my $caller  = ref( $src_obj );

  _check_signals_exist( $caller, $sig_names )
   unless $options->{undeclared};

  my $weaken = !( $options->{strong} || ref( $dst_obj ) eq 'CODE' );
  for my $sig_name ( @{$sig_names} ) {

    # Stash the object and method so we can call it later.
    my $dst_data = [ $dst_obj, $dst_method, $options ];
    weaken( $dst_data->[0] ) if $weaken;
    push @{ $signal_map{$src_id}->{$sig_name} }, $dst_data;
  }

  # Now badness: we replace the DESTROY that Class::Std dropped into
  # the caller's namespace with our own. See the note under BUGS AND
  # LIMITATIONS about this technique for replacing Class::Std's
  # destructor.
  unless ( exists $patched{$caller} ) {

    # If there's nothing in the hash for this object we can't have
    # installed our destructor yet - so do it now.

    no strict 'refs';

    my $destroy_func = $caller . '::DESTROY';
    my $current_func = *{$destroy_func}{CODE};

    local $^W = 0;    # Disable subroutine redefined warning
    no warnings;      # Need this too.

    *{$destroy_func} = sub {

      # Destroy our members
      _destroy( $src_id );

      # Chain the existing destructor
      $current_func->( @_ );
    };

    # Remember we've patched this one...
    $patched{$caller}++;
  }

  return;
}

sub disconnect {
  my $src_obj = shift;
  my $src_id  = refaddr( $src_obj );

  croak 'disconnect must be called as a member'
   unless blessed $src_obj;

  if ( @_ ) {
    my $sig_names = _massage_signal_names( shift );
    my $dst_obj   = shift;                            # optional
    my $dst_method = shift;   # optional - undef is ok in the grep below
    my $dst_id = refaddr( $dst_obj );

    for my $sig_name ( @{$sig_names} ) {
      my $slots = $signal_map{$src_id}->{$sig_name};

      if ( defined( $dst_obj ) ) {
        if ( defined $slots ) {

          # Nasty block to filter out matching connections.
          @{$slots} = grep {
                defined $_
             && defined $_->[0]
             && (

lib/Class/Std/Slots.pm  view on Meta::CPAN

        my ($pos, $all) = @_;
        my $percent = int($pos * 100 / $all);
        $uitools->show_progress($percent);
    });

A slot may be connected to multiple signals at the same time by passing an array reference
in place of the signal name:

    $my_thing->connect(['debug_out', 'warning_out'], $logger, 'trace');

Normally a slot is passed exactly the arguments that were passed to the signal - so when
C<< $this_obj->some_signal >> has been connected to C<< $that_obj->some_slot >> emitting the
signal like this:

    $this_obj->some_signal(1, 2, 'Here we go');

will cause C<some_slot> to be called like this:

    $that_obj->some_slot(1, 2, 'Here we go');

Sometimes it is useful to be able to write generic slot functions that can be connected
to many different signals and that are capable of interacting with the object that emitted
the signal. The C<reveal_source> option modifies the argument list of the slot function so
that the first argument is a reference to a hash that describes the source of the signal:

    $this_obj->connect('first_signal',  $generic, 'smart_slot', { reveal_source => 1 });
    $this_obj->connect('second_signal', $generic, 'smart_slot', { reveal_source => 1 });
    $that_obj->connect('first_signal',  $generic, 'smart_slot', { reveal_source => 1 });

When C<< $this_obj->first_signal >> is emitted C<< $generic->smart_slot >> will be called with
this hash ref as its first argument:

    {
        source  => $this_obj,
        signal  => 'first_signal',
        options => { reveal_source => 1 }
    }

When C<< $this_obj->second_signal >> is emitted the hash will look like this:

    {
        source  => $this_obj,
        signal  => 'second_signal',
        options => { reveal_source => 1 }
    }

Note that the options hash passed to C<connect> is passed to the slot. This is so that
additional user defined options can be used to influence the behaviour of the slot
function.

The options recognised by C<connect> itself are:

=over

=item reveal_source

Modify slot arg list to include a hash that describes the source of the signal.

=item strong

Normally the reference to the object containing the slot method is weakened (by
calling C<Scalar::Util::weaken> on it). Set this option to make the reference
strong - which means that once an object has been connected to no other
references to it need be kept.

Anonymous subroutine slots are always strongly referred to - so there is no
need to specify the C<strong> option for them.

=item undeclared

Allow a connection to be made to an undefined signal. It is possible for an object
to emit arbitrary signals by calling C<emit_signal>. Normally C<connect> checks that
a signal has been declared before connecting to it (bugs caused by slightly misnamed
signals are particularly frustrating). This flag overrides that check and makes it
your responsibility to get the signal name right.

=back

=item C<disconnect($sig_name, ...)>

Break signal / slot connections. All connections are broken when the signalling
object is destroyed. To break a connection at any other time use:

    $obj->disconnect('a_signal', $other_obj, 'method');

To break all connections from a signal to slots in a particular object use:

    $obj->disconnect('a_signal', $other_obj);

To break all connections for a particular signal use:

    $obj->disconnect('a_signal');

And finally to break all connections from a signalling object:

    $obj->disconnect();

In other words each additional argument increases the specificity of the connections
that are targetted.

As with connect a reference to an array of signal names may be passed:

    $obj->disconnect(['sig1', 'sig2', 'sig3'], $my_slotz);

Note that it is not possible to disconnect an anonymous slot subroutine without disconnecting
all other slots connected to the same signal:

    $obj->connect('a_signal', sub { });
    $obj->connect('a_signal', $other_obj, 'a_slot');

    # Can't target the anon slot individually
    $obj->disconnect('a_signal');

If this proves to be an enbearable limitation I'll do something about it.

=item C<emit_signal($sig_name, ...)>

It's not always possible to pre-declare all the signals an object may emit. For example an XML
processor may emit signals corresponding to the names of tags in the parsed XML; in that case
it would be overly restrictive to require pre-declaration of the signals.

To emit an arbitrary signal - which may or may not have been declared - call emit() directly