view release on metacpan or  search on metacpan

lib/Class/Observable.pm  view on Meta::CPAN

use strict; use warnings;

package Class::Observable;

our $VERSION = '2.004';

use Scalar::Util 'refaddr';
use Class::ISA;

# Unused; kept for backward compatibility only
my ( $DEBUG );
sub DEBUG     { return $DEBUG; }
sub SET_DEBUG { $DEBUG = $_[0] }
sub observer_log   { shift; $DEBUG && warn @_, "\n" }
sub observer_error { shift; die @_, "\n" }

my ( %O, %registry );

BEGIN {
	require Config;
	if ( $^O eq 'Win32' or $Config::Config{'useithreads'} ) {
		*NEEDS_REGISTRY = sub () { 1 };
		*CLONE = sub {
			my $have_warned;
			foreach my $oldaddr ( keys %registry ) {
				my $invocant  = delete $registry{ $oldaddr };
				my $observers = delete $O{ $oldaddr };
				if ( defined $invocant ) {
					my  $addr   = refaddr $invocant;
					$O{ $addr } = $observers;
					Scalar::Util::weaken( $registry{ $addr } = $invocant );
				} else {
					$have_warned++ or warn
						"*** Inconsistent state ***\n",
						"Observed instances have gone away " .
						"without invoking Class::Observable::DESTROY\n";
				}
			}
		};
	} else {
		*NEEDS_REGISTRY = sub () { 0 };
	}
}

sub DESTROY {
	my $invocant = shift;
	my $addr = refaddr $invocant;
	delete $registry{ $addr } if NEEDS_REGISTRY and $addr;
	delete $O{ $addr || "::$invocant" };
}

sub add_observer {
	my $invocant = shift;
	my $addr = refaddr $invocant;
	Scalar::Util::weaken( $registry{ $addr } = $invocant ) if NEEDS_REGISTRY and $addr;
	push @{ $O{ $addr || "::$invocant" } }, @_;
}

sub delete_observer {
	my $invocant = shift;
	my $addr = refaddr $invocant;
	my $observers = $O{ $addr || "::$invocant" } or return 0;
	my %removal = map +( refaddr( $_ ) || "::$_" => 1 ), @_;
	@$observers = grep !$removal{ refaddr( $_ ) || "::$_" }, @$observers;
	if ( ! @$observers ) {
		delete $registry{ $addr } if NEEDS_REGISTRY and $addr;
		delete $O{ $addr || "::$invocant" };
	}
	scalar @$observers;
}

sub delete_all_observers {
	my $invocant = shift;
	my $addr = refaddr $invocant;
	delete $registry{ $addr } if NEEDS_REGISTRY and $addr;
	my $removed = delete $O{ $addr || "::$invocant" };
	$removed ? scalar @$removed : 0;
}

# Backward compatibility
*delete_observers = \&delete_all_observers;

sub notify_observers {
	for ( $_[0]->get_observers ) {
		ref eq 'CODE' ? $_->( @_ ) : $_->update( @_ );
	}
}

my %supers;
sub get_observers {
	my ( @self, $class );
	if ( my $pkg = ref $_[0] ) {
		@self  = $_[0];
		$class = $pkg;
	} else {
		$class = $_[0];
	}

	# We only find the parents the first time, so if you muck with
	# @ISA you'll get unexpected behavior...
	my $cached_supers = $supers{ $class } ||= [
		grep $_->isa( 'Class::Observable' ), Class::ISA::super_path( $class )
	];

	map $_->get_direct_observers, @self, $class, @$cached_supers;
}

sub copy_observers {
	my ( $src, $dst ) = @_;
	my @observer = $src->get_observers;
	$dst->add_observer( @observer );
	scalar @observer;
}

sub count_observers { scalar $_[0]->get_observers }