File Coverage

blib/lib/Aspect/Pointcut/Or.pm
Criterion Covered Total %
statement 77 100 77.0
branch 31 52 59.6
condition n/a
subroutine 9 11 81.8
pod 6 7 85.7
total 123 170 72.3


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