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, @_ );
  }
}

sub _emit_signal {
  my $self     = shift;
  my $sig_name = shift;
  my $src_id   = refaddr( $self );

  unless ( blessed( $self ) ) {
    croak "Signal '$sig_name' must be invoked as a method\n";
  }

  if ( exists( $signal_busy{$src_id}->{$sig_name} ) ) {
    croak "Attempt to re-enter signal '$sig_name'";
  }

  # Flag this signal as busy
  $signal_busy{$src_id}->{$sig_name}++;

  # We still want to remove the busy lock on the signal
  # even if one of the slots dies - so wrap the whole
  # thing in an eval.
  eval {

    # Get the slots registered with this signal
    my $slots = $signal_map{$src_id}->{$sig_name};

    # Might have none... It's not an error.
    if ( defined $slots ) {
      for my $slot ( @{$slots} ) {
        my ( $dst_obj, $dst_method, $options ) = @{$slot};
        if ( defined( $dst_obj ) ) {

          my @args = @_;

          # The reveal_source option causes a hashref
          # describing the source of the signal to
          # be prepended to the args.
          if ( $options->{reveal_source} ) {
            unshift @args,
             {
              source  => $self,
              signal  => $sig_name,
              options => $options
             };
          }

          # Call an anon sub or a method
          if ( blessed( $dst_obj ) ) {
            $dst_obj->$dst_method( @args );
          }
          else {
            $dst_obj->( @args );
          }
        }
      }
    }
  };

  # 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