File Coverage

blib/lib/Class/Observable.pm
Criterion Covered Total %
statement 56 73 76.7
branch 13 22 59.0
condition 18 29 62.0
subroutine 14 18 77.7
pod 0 12 0.0
total 101 154 65.5


line stmt bran cond sub pod time code
1 6     6   332229 use strict; use warnings;
  6     6   62  
  6         142  
  6         26  
  6         8  
  6         294  
2              
3             package Class::Observable;
4              
5             our $VERSION = '2.002';
6              
7 6     6   32 use Scalar::Util 'refaddr';
  6         9  
  6         278  
8 6     6   2197 use Class::ISA;
  6         10684  
  6         1389  
9              
10             # Unused; kept for backward compatibility only
11             my ( $DEBUG );
12 0     0 0 0 sub DEBUG { return $DEBUG; }
13 0     0 0 0 sub SET_DEBUG { $DEBUG = $_[0] }
14 0 0   0 0 0 sub observer_log { shift; $DEBUG && warn @_, "\n" }
  0         0  
15 0     0 0 0 sub observer_error { shift; die @_, "\n" }
  0         0  
16              
17             my ( %O, %registry );
18              
19             BEGIN {
20 6     6   36 require Config;
21 6 50 33     111 if ( $^O eq 'Win32' or $Config::Config{'useithreads'} ) {
22 0         0 *NEEDS_REGISTRY = sub () { 1 };
23             *CLONE = sub {
24 0         0 my $have_warned;
25 0         0 foreach my $oldaddr ( keys %registry ) {
26 0         0 my $invocant = delete $registry{ $oldaddr };
27 0         0 my $observers = delete $O{ $oldaddr };
28 0 0       0 if ( defined $invocant ) {
29 0         0 my $addr = refaddr $invocant;
30 0         0 $O{ $addr } = $observers;
31 0         0 Scalar::Util::weaken( $registry{ $addr } = $invocant );
32             } else {
33 0 0       0 $have_warned++ or warn
34             "*** Inconsistent state ***\n",
35             "Observed instances have gone away " .
36             "without invoking Class::Observable::DESTROY\n";
37             }
38             }
39 0         0 };
40             } else {
41 6         3623 *NEEDS_REGISTRY = sub () { 0 };
42             }
43             }
44              
45             sub DESTROY {
46 43     43   16183 my $invocant = shift;
47 43         87 my $addr = refaddr $invocant;
48 43         53 delete $registry{ $addr } if NEEDS_REGISTRY and $addr;
49 43   33     677 delete $O{ $addr || "::$invocant" };
50             }
51              
52             sub add_observer {
53 50     50 0 774 my $invocant = shift;
54 50         94 my $addr = refaddr $invocant;
55 50         55 Scalar::Util::weaken( $registry{ $addr } = $invocant ) if NEEDS_REGISTRY and $addr;
56 50   66     60 push @{ $O{ $addr || "::$invocant" } }, @_;
  50         228  
57             }
58              
59             sub delete_observer {
60 4     4 0 2279 my $invocant = shift;
61 4         14 my $addr = refaddr $invocant;
62 4 50 66     30 my $observers = $O{ $addr || "::$invocant" } or return 0;
63 4   66     32 my %removal = map +( refaddr( $_ ) || "::$_" => 1 ), @_;
64 4   66     28 @$observers = grep !$removal{ refaddr( $_ ) || "::$_" }, @$observers;
65 4 100       13 if ( ! @$observers ) {
66 2         2 delete $registry{ $addr } if NEEDS_REGISTRY and $addr;
67 2   66     9 delete $O{ $addr || "::$invocant" };
68             }
69 4         18 scalar @$observers;
70             }
71              
72             sub delete_all_observers {
73 6     6 0 13 my $invocant = shift;
74 6         15 my $addr = refaddr $invocant;
75 6         7 delete $registry{ $addr } if NEEDS_REGISTRY and $addr;
76 6   66     28 my $removed = delete $O{ $addr || "::$invocant" };
77 6 100       27 $removed ? scalar @$removed : 0;
78             }
79              
80             # Backward compatibility
81             *delete_observers = \&delete_all_observers;
82              
83             sub notify_observers {
84 15     15 0 97 for ( $_[0]->get_observers ) {
85 35 100       165 ref eq 'CODE' ? $_->( @_ ) : $_->update( @_ );
86             }
87             }
88              
89             my %supers;
90             sub get_observers {
91 36     36 0 55 my ( @self, $class );
92 36 100       74 if ( my $pkg = ref $_[0] ) {
93 28         51 @self = $_[0];
94 28         35 $class = $pkg;
95             } else {
96 8         11 $class = $_[0];
97             }
98              
99             # We only find the parents the first time, so if you muck with
100             # @ISA you'll get unexpected behavior...
101 36   100     95 my $cached_supers = $supers{ $class } ||= [
102             grep $_->isa( 'Class::Observable' ), Class::ISA::super_path( $class )
103             ];
104              
105 36         411 map $_->get_direct_observers, @self, $class, @$cached_supers;
106             }
107              
108             sub copy_observers {
109 1     1 0 4 my ( $src, $dst ) = @_;
110 1         3 my @observer = $src->get_observers;
111 1         3 $dst->add_observer( @observer );
112 1         4 scalar @observer;
113             }
114              
115 20     20 0 63 sub count_observers { scalar $_[0]->get_observers }
116              
117             sub get_direct_observers {
118 105     105 0 129 my $invocant = shift;
119 105         144 my $addr = refaddr $invocant;
120 105 50 66     425 my $observers = $O{ $addr || "::$invocant" } or return wantarray ? () : 0;
    100          
121 52         115 @$observers;
122             }
123              
124             1;
125              
126             __END__