File Coverage

blib/lib/Aspect/Pointcut/Or.pm
Criterion Covered Total %
statement 80 103 77.6
branch 31 52 59.6
condition n/a
subroutine 10 12 83.3
pod 6 7 85.7
total 127 174 72.9


line stmt bran cond sub pod time code
1             package Aspect::Pointcut::Or;
2              
3 21     21   997 use strict;
  21         29  
  21         1338  
4 21     21   99 use warnings;
  21         26  
  21         2182  
5 21     21   9071 use Aspect::Pointcut::Logic ();
  21         35  
  21         19370  
6              
7             our $VERSION = '0.97_06';
8             our @ISA = 'Aspect::Pointcut::Logic';
9              
10              
11              
12              
13              
14             ######################################################################
15             # Constructor
16              
17             sub new {
18 18     18 1 21 my $class = shift;
19 18         24 my @parts = @_;
20              
21             # Validate the pointcut subexpressions
22 18         23 foreach my $part ( @parts ) {
23 37 50       217 next if Params::Util::_INSTANCE($part, 'Aspect::Pointcut');
24 0         0 Carp::croak("Attempted to apply pointcut logic to non-pointcut '$part'");
25             }
26              
27             # Collapse nested or statements at constructor time so we don't have
28             # to do so multiple times later on during currying.
29 18         25 while ( scalar grep { $_->isa('Aspect::Pointcut::Or') } @parts ) {
  56         132  
30             @parts = map {
31 6 100       6 $_->isa('Aspect::Pointcut::Or') ? @$_ : $_
  12         32  
32             } @parts;
33             }
34              
35 18         49 $class->SUPER::new(@parts);
36             }
37              
38              
39              
40              
41              
42             ######################################################################
43             # Weaving Methods
44              
45             sub compile_weave {
46 3     3 1 6 my $self = shift;
47 3         9 my @children = map { $_->compile_weave } @$self;
  6         23  
48              
49             # Collapse string conditions together,
50             # and further collapse code conditions together.
51 3         5 my @string = ();
52 3         4 my @code = ();
53 3         14 foreach my $child ( @children ) {
54             # Short-cut if we contain any purely runtime pointcuts
55 6 50       15 unless ( ref $child ) {
56 6 50       14 return 1 if $child eq 1;
57 6         6 push @string, $child;
58 6         8 next;
59             }
60 0 0       0 if ( @string ) {
61 0         0 my $group = join ' or ', map { "( $_ )" } @string;
  0         0  
62 0         0 push @code, eval "sub () { $group }";
63 0         0 @string = ();
64             }
65 0         0 push @code, $child;
66             }
67              
68 3 50       8 if ( @string ) {
69 3         6 my $group = join ' or ', map { "( $_ )" } @string;
  6         19  
70 3 50       8 unless ( @code ) {
71             # This is the only thing we have
72 3         9 return $group;
73             }
74 0         0 push @code, eval "sub () { $group }";
75             }
76              
77             # Join the groups
78             return sub {
79 0     0   0 foreach my $child ( @code ) {
80 0 0       0 return 0 unless $child->();
81             }
82 0         0 return 1;
83 0         0 };
84              
85             }
86              
87             sub compile_runtime {
88 1     1 1 1 my $self = shift;
89 1         3 my @children = map { $_->compile_runtime } @$self;
  2         9  
90              
91             # Collapse string conditions together,
92             # and further collapse code conditions together.
93 1         2 my @string = ();
94 1         1 my @code = ();
95 1         3 foreach my $child ( @children ) {
96             # Short-cut if we contain any purely runtime pointcuts
97 2 50       3 unless ( ref $child ) {
98 2 50       4 return 1 if $child eq 1;
99 2         3 push @string, $child;
100 2         2 next;
101             }
102 0 0       0 if ( @string ) {
103 0         0 my $group = join ' or ', map { "( $_ )" } @string;
  0         0  
104 0         0 push @code, eval "sub () { $group }";
105 0         0 @string = ();
106             }
107 0         0 push @code, $child;
108             }
109              
110 1 50       2 if ( @string ) {
111 1         2 my $group = join ' or ', map { "( $_ )" } @string;
  2         8  
112 1 50       4 unless ( @code ) {
113             # This is the only thing we have
114 1         2 return $group;
115             }
116 0         0 push @code, eval "sub () { $group }";
117             }
118              
119             # Join the groups
120             return sub {
121 0     0   0 foreach my $child ( @code ) {
122 0 0       0 return 0 unless $child->();
123             }
124 0         0 return 1;
125 0         0 };
126              
127             }
128              
129             sub match_contains {
130 9     9 1 9 my $self = shift;
131 9 50       56 my $count = $self->isa($_[0]) ? 1 : 0;
132 9         37 foreach my $child ( @$self ) {
133 18         38 $count += $child->match_contains($_[0]);
134             }
135 9         19 return $count;
136             }
137              
138             sub match_runtime {
139 7     7 0 10 my $self = shift;
140 7         14 foreach my $child ( @$self ) {
141 15 100       39 return 1 if $child->match_runtime;
142             }
143 2         7 return 0;
144             }
145              
146             sub curry_weave {
147 4     4 1 2802 my $self = shift;
148 4         9 my @list = @$self;
149              
150             # Curry down our children. Any null element always matches, and
151             # therefore in an OR scenario the entire expression always matches.
152 4         8 my @or = ();
153 4         9 foreach my $child ( @list ) {
154 8 100       20 my $curried = $child->curry_weave or return;
155 7         11 push @or, $curried;
156             }
157              
158             # If none are left, curry us away to nothing
159 3 50       9 return unless @or;
160              
161             # If only one remains, curry us away to just that child
162 3 50       7 return $list[0] if @or == 1;
163              
164             # Create our clone to hold the curried subset
165 3         11 return ref($self)->new(@or);
166             }
167              
168             sub curry_runtime {
169 7     7 1 1490 my $self = shift;
170 7         16 my @list = @$self;
171              
172             # Should we strip out the call pointcuts
173 7         8 my $strip = shift;
174 7 100       16 unless ( defined $strip ) {
175             # Are there any elements that MUST exist at run-time?
176 6 100       11 if ( $self->match_runtime ) {
177             # If we have any nested logic that themselves contain
178             # call pointcuts, we can't strip.
179             $strip = not scalar grep {
180 4 50       6 $_->isa('Aspect::Pointcut::Logic')
  13         43  
181             and
182             $_->match_contains('Aspect::Pointcut::Call')
183             } @list;
184             } else {
185             # Nothing at runtime, so we can strip
186 2         3 $strip = 1;
187             }
188             }
189              
190             # Curry down our children
191 8         14 @list = grep { defined $_ } map {
192 7 100       13 $_->isa('Aspect::Pointcut::Call')
  20 100       68  
193             ? $strip
194             ? $_->curry_runtime($strip)
195             : $_
196             : $_->curry_runtime($strip)
197             } @list;
198              
199             # If none are left, curry us away to nothing
200 7 100       23 return unless @list;
201              
202             # If only one remains, curry us away to just that child
203 5 100       15 return $list[0] if @list == 1;
204              
205             # Create our clone to hold the curried subset
206 2         9 return ref($self)->new( @list );
207             }
208              
209             1;
210              
211             __END__