File Coverage

blib/lib/Perl/ToPerl6/Theme.pm
Criterion Covered Total %
statement 64 64 100.0
branch 10 12 83.3
condition 3 6 50.0
subroutine 15 15 100.0
pod 4 4 100.0
total 96 101 95.0


line stmt bran cond sub pod time code
1             package Perl::ToPerl6::Theme;
2              
3 13     13   259 use 5.006001;
  13         39  
4 13     13   58 use strict;
  13         17  
  13         264  
5 13     13   50 use warnings;
  13         24  
  13         357  
6 13     13   54 use English qw(-no_match_vars);
  13         17  
  13         73  
7 13     13   4702 use Readonly;
  13         21  
  13         598  
8              
9 13     13   378 use Exporter 'import';
  13         18  
  13         430  
10              
11 13     13   57 use List::MoreUtils qw(any);
  13         19  
  13         107  
12              
13 13     13   4789 use Perl::ToPerl6::Utils qw{ :characters :data_conversion };
  13         24  
  13         751  
14 13     13   2901 use Perl::ToPerl6::Exception::Fatal::Internal qw{ &throw_internal };
  13         22  
  13         1175  
15             use Perl::ToPerl6::Exception::Configuration::Option::Global::ParameterValue
16 13     13   68 qw{ &throw_global_value };
  13         19  
  13         283  
17              
18             #-----------------------------------------------------------------------------
19              
20             our $VERSION = '0.03';
21              
22             #-----------------------------------------------------------------------------
23              
24             Readonly::Array our @EXPORT_OK => qw{
25             $RULE_INVALID_CHARACTER_REGEX
26             cook_rule
27             };
28              
29             #-----------------------------------------------------------------------------
30              
31             Readonly::Scalar our $RULE_INVALID_CHARACTER_REGEX =>
32             qr/ ( [^()\s\w\d+\-*&|!] ) /xms;
33              
34             #-----------------------------------------------------------------------------
35              
36             Readonly::Scalar my $CONFIG_KEY => 'theme';
37              
38             #-----------------------------------------------------------------------------
39              
40             sub new {
41              
42 114     114 1 26623 my ( $class, %args ) = @_;
43 114         290 my $self = bless {}, $class;
44 114         434 $self->_init( %args );
45 106         498 return $self;
46             }
47              
48             #-----------------------------------------------------------------------------
49              
50             sub _init {
51              
52 114     114   204 my ($self, %args) = @_;
53 114   66     485 my $rule = $args{-rule} || $EMPTY;
54              
55 114 100       603 if ( $rule =~ m/$RULE_INVALID_CHARACTER_REGEX/xms ) {
56 8         45 throw_global_value
57             option_name => $CONFIG_KEY,
58             option_value => $rule,
59             message_suffix => qq{contains an invalid character: "$1".};
60             }
61              
62 106         253 $self->{_rule} = cook_rule( $rule );
63              
64 106         210 return $self;
65             }
66              
67             #-----------------------------------------------------------------------------
68              
69             sub rule {
70 5     5 1 14 my $self = shift;
71 5         114 return $self->{_rule};
72             }
73              
74             #-----------------------------------------------------------------------------
75              
76             sub transformer_is_thematic {
77              
78 1634     1634 1 4719 my ($self, %args) = @_;
79             my $transformer = $args{-transformer}
80 1634   33     6981 || throw_internal 'The -transformer argument is required';
81 1634 50       35912 ref $transformer
82             || throw_internal 'The -transformer must be an object';
83              
84 1634 100       6155 my $rule = $self->{_rule} or return 1;
85 799         2726 my %themes = hashify( $transformer->get_themes() );
86              
87             # This bit of magic turns the rule into a perl expression that can be
88             # eval-ed for truth. Each theme name in the rule is translated to 1 or 0
89             # if the $transformer belongs in that theme. For example:
90             #
91             # 'bugs && (pbp || core)' ...could become... '1 && (0 || 1)'
92              
93 799         1108 my $as_code = $rule; #Making a copy, so $rule is preserved
94 799 100       3287 $as_code =~ s/ ( [\w\d]+ ) /exists $themes{$1} || 0/gexms;
  1483         6765  
95 799         37841 my $is_thematic = eval $as_code;
96              
97 799 100       2512 if ($EVAL_ERROR) {
98 1         6 throw_global_value
99             option_name => $CONFIG_KEY,
100             option_value => $rule,
101             message_suffix => q{contains a syntax error.};
102             }
103              
104 798         3317 return $is_thematic;
105             }
106              
107             #-----------------------------------------------------------------------------
108              
109             sub cook_rule {
110 195     195 1 6709 my ($raw_rule) = @_;
111 195 50       433 return if not defined $raw_rule;
112              
113             #Translate logical operators
114 195         432 $raw_rule =~ s{\b not \b}{!}ixmsg; # "not" -> "!"
115 195         270 $raw_rule =~ s{\b and \b}{&&}ixmsg; # "and" -> "&&"
116 195         258 $raw_rule =~ s{\b or \b}{||}ixmsg; # "or" -> "||"
117              
118             #Translate algebra operators (for backward compatibility)
119 195         207 $raw_rule =~ s{\A [-] }{!}ixmsg; # "-" -> "!" e.g. difference
120 195         211 $raw_rule =~ s{ [-] }{&& !}ixmsg; # "-" -> "&& !" e.g. difference
121 195         257 $raw_rule =~ s{ [*] }{&&}ixmsg; # "*" -> "&&" e.g. intersection
122 195         239 $raw_rule =~ s{ [+] }{||}ixmsg; # "+" -> "||" e.g. union
123              
124 195         288 my $cooked_rule = lc $raw_rule; #Is now cooked!
125 195         548 return $cooked_rule;
126             }
127              
128              
129             1;
130              
131             __END__
132              
133             #-----------------------------------------------------------------------------
134              
135             =pod
136              
137             =head1 NAME
138              
139             Perl::ToPerl6::Theme - Construct thematic sets of transformers.
140              
141              
142             =head1 DESCRIPTION
143              
144             This is a helper class for evaluating theme expressions into sets of
145             Transformer objects. There are no user-serviceable parts here.
146              
147              
148             =head1 INTERFACE SUPPORT
149              
150             This is considered to be a non-public class. Its interface is subject
151             to change without notice.
152              
153              
154             =head1 METHODS
155              
156             =over
157              
158             =item C<< new( -rule => $rule_expression ) >>
159              
160             Returns a reference to a new Perl::ToPerl6::Theme object. C<-rule> is
161             a string expression that evaluates to true or false for each Transformer..
162             See L<"THEME RULES"> for more information.
163              
164              
165             =item C<< transformer_is_thematic( -transformer => $transformer ) >>
166              
167             Given a reference to a L<Perl::ToPerl6::Transformer|Perl::ToPerl6::Transformer>
168             object, this method returns evaluates the rule against the themes that
169             are associated with the Transformer. Returns 1 if the Transformer satisfies the
170             rule, 0 otherwise.
171              
172              
173             =item C< rule() >
174              
175             Returns the rule expression that was used to construct this Theme.
176             The rule may have been translated into a normalized expression. See
177             L<"THEME RULES"> for more information.
178              
179             =back
180              
181              
182             =head2 THEME RULES
183              
184             A theme rule is a simple boolean expression, where the operands are
185             the names of any of the themes associated with the
186             Perl::ToPerl6::Polices.
187              
188             Theme names can be combined with logical operators to form arbitrarily
189             complex expressions. Precedence is the same as normal mathematics,
190             but you can use parentheses to enforce precedence as well. Supported
191             operators are:
192              
193             Operator Altertative Example
194             ----------------------------------------------------------------
195             && and 'pbp && core'
196             || or 'pbp || (bugs && security)'
197             ! not 'pbp && ! (portability || complexity)
198              
199             See L<Perl::ToPerl6/"CONFIGURATION"> for more information about
200             customizing the themes for each Transformer.
201              
202              
203             =head1 SUBROUTINES
204              
205             =over
206              
207             =item C<cook_rule( $rule )>
208              
209             Standardize a rule into a almost executable Perl code. The "almost"
210             comes from the fact that theme names are left as is.
211              
212              
213             =back
214              
215              
216             =head1 CONSTANTS
217              
218             =over
219              
220             =item C<$RULE_INVALID_CHARACTER_REGEX>
221              
222             A regular expression that will return the first character in the
223             matched expression that is not valid in a rule.
224              
225              
226             =back
227              
228              
229             =head1 AUTHOR
230              
231             Jeffrey Ryan Thalhammer <jeff@imaginative-software.com>
232              
233              
234             =head1 COPYRIGHT
235              
236             Copyright (c) 2006-2011 Imaginative Software Systems
237              
238             This program is free software; you can redistribute it and/or modify
239             it under the same terms as Perl itself. The full text of this license
240             can be found in the LICENSE file included with this module.
241              
242             =cut
243              
244             ##############################################################################
245             # Local Variables:
246             # mode: cperl
247             # cperl-indent-level: 4
248             # fill-column: 78
249             # indent-tabs-mode: nil
250             # c-indentation-style: bsd
251             # End:
252             # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :