File Coverage

blib/lib/Filter/Heredoc/Rule.pm
Criterion Covered Total %
statement 52 58 89.6
branch 18 26 69.2
condition 2 3 66.6
subroutine 9 9 100.0
pod 1 1 100.0
total 82 97 84.5


line stmt bran cond sub pod time code
1             package Filter::Heredoc::Rule;
2              
3 26     26   50213 use 5.010;
  26         99  
  26         1102  
4 26     26   201 use strict;
  26         44  
  26         858  
5 26     26   130 use warnings;
  26         49  
  26         1692  
6              
7             our $VERSION = '0.02';
8              
9             =head1 NAME
10              
11             Filter::Heredoc::Rule - Load or unload rules for heredoc processing
12              
13             =head1 VERSION
14              
15             Version 0.02
16              
17             =cut
18              
19 26     26   166 use base qw(Exporter);
  26         68  
  26         2577  
20 26     26   177 use feature 'state';
  26         52  
  26         22498  
21              
22             # Private subroutine used in author tests. _hd* is used by Filter::Heredoc
23             our @EXPORT_OK = qw (
24             hd_syntax
25             _hd_is_rules_ok_line
26             _is_lonely_redirect
27             );
28              
29             ### Export_ok subroutines starts here ###
30              
31             ### INTERFACE SUBROUTINE ###
32             # Usage : hd_syntax ( $rulename ) or hd_syntax()
33             # Purpose : Accessor subroutine to get/set the helper rules to use.
34             # If 'none' is used in $rulename, all existing
35             # rule is set to the $EMPTY_STR in the hash.
36             # Limitation : Can not apply multiple rules during one run.
37             # Returns : Hash of available rule(s).
38             # Throws : No
39              
40             sub hd_syntax {
41 86     86 1 12661 my $language = shift;
42 86         574 my $EMPTY_STR = q{};
43              
44             # Default to no rules
45 86         116 state $pod = $EMPTY_STR;
46 86         234 my %syntax = ( pod => $pod, );
47              
48             # Sets a new language (rule)
49 86 100       234 if ( defined $language ) {
50 26         44 my $POD = q{pod};
51 26         34 my $NONE = q{none};
52              
53 26         206 chomp $language;
54              
55             # Reset all rules with 'none' keyword, ignore case
56 26         122 $language = lc($language);
57 26 100       2336 if ( $language eq $NONE ) {
    100          
58 9         18 $syntax{pod} = $EMPTY_STR;
59 9         178 $pod = $EMPTY_STR; # update persistent variable
60             }
61              
62             # Set one of the defined rules
63             elsif ( exists( $syntax{$language} ) ) {
64 13 50       221 if ( $language eq $POD ) {
65 13         23 $syntax{pod} = $POD;
66 13         76 $pod = $POD; # update persistent variable
67             }
68             }
69              
70             } # end language rule defined
71              
72             # The existing rule (possible changed)
73 86         369 return %syntax;
74             }
75              
76              
77             ### INTERNAL (Filter::Heredoc only) INTERFACE SUBROUTINE ###
78             # Usage : _hd_is_rules_ok_line ( $line )
79             # Purpose : Test if $line should be trusted compared to any set
80             # rules, i.e. should not initiate an ingress/egress change.
81             # Returns : Returns "False" if line is "false positive" - i.e. not ok.
82             # Throws : No
83              
84             sub _hd_is_rules_ok_line {
85 56     56   175 my $line = shift;
86 56         107 my $EMPTY_STR = q{};
87 56         230 my $NONE = q{none};
88 56         94 my $POD = q{pod};
89              
90 56         316 my %syntax = hd_syntax();
91              
92             # Line is to be trusted (to 'none rules')
93 56 100       382 if ( $syntax{pod} eq $EMPTY_STR ) {
    50          
94 50         245 return 1;
95             }
96              
97             # Apply pod rules
98             elsif ( $syntax{pod} eq $POD ) {
99              
100             # 'False line', '<<' and '>>' on line
101 6 100       20 if ( _is_redirector_pair($line) ) {
    50          
102 2         11 return $EMPTY_STR;
103             }
104              
105             # 'False line', empty '<<' line
106             elsif ( _is_lonely_redirect($line) ) {
107 4         22 return $EMPTY_STR;
108             }
109              
110              
111             }
112              
113 0         0 return 1; # Default - line is ok if reaching down here
114              
115             }
116              
117             ### The Module private subroutines starts here ###
118              
119             ### INTERNAL UTILITY ###
120             # Usage : _is_lonely_redirect( $line )
121             # Purpose : Bugfix DBNX#1: Prevent a false ingress change
122             # when line is 'cat <<' or 'cat <<-'
123             # Returns : True (1) if redirector is lonely, otherwise False.
124             # Throws : No
125              
126             sub _is_lonely_redirect {
127 4     4   7 my $EMPTY_STR = q{};
128 4         6 my $line;
129              
130 4 50       14 if ( !defined( $line = shift ) ) {
131 0         0 return $EMPTY_STR;
132             }
133              
134             # lonely '<<' with no characters on line after it
135 4 50       23 if ( $line =~ m/(<<)$/ ) {
136 4         37 return 1;
137             }
138              
139             # lonely '<<-' with no characters on line after it
140 0 0       0 if ( $line =~ m/(-)$/ ) {
141 0         0 return 1;
142             }
143              
144 0         0 return $EMPTY_STR; # It's not a lonely redirect (return false)
145             }
146              
147             ### INTERNAL UTILITY ###
148             # Usage : _is_redirector_pair( $line )
149             # Purpose : Bugfix DBNX#16: Prevent a false ingress change
150             # when line is '<<' and '>>' typical POD
151             # Returns : True (1) if pair is found, otherwise False.
152             # Throws : No
153              
154             sub _is_redirector_pair {
155 6     6   9 my $EMPTY_STR = q{};
156 6         11 my $line;
157              
158 6 50       20 if ( !defined( $line = shift ) ) {
159 0         0 return $EMPTY_STR;
160             }
161              
162             # POD use matching << and >> but not any here document syntax
163 6 100 66     75 if ( ( $line =~ m/<>/ ) ) {
164 2         8 return 1;
165             }
166              
167 4         22 return $EMPTY_STR; # It's not a POD pair (return false)
168             }
169              
170             =head1 SYNOPSIS
171              
172             use 5.010;
173             use Filter::Heredoc::Rule qw( hd_syntax );
174            
175             # load the 'pod' rule (i.e. activate it)
176             my %rule = hd_syntax( q{pod} );
177              
178             # print capability and status
179             foreach ( keys %rule ) {
180             print "'$_' '$rule{$_}'\n";
181             }
182              
183             # unload all with keyword 'none';
184             hd_syntax( 'none' );
185              
186             =head1 DESCRIPTION
187              
188             Support here document parsing with rules to prevent "false positives".
189              
190             =head1 SUBROUTINES
191              
192             I exports following subroutine only on request.
193              
194             hd_syntax # load/unload a script syntax rule
195              
196             =head2 B
197            
198             %rule = hd_syntax( $rulename );
199             %rule = hd_syntax();
200            
201             Load or unload the syntax rule to use when parsing a here document.
202             This subroutine use a key/value hash to hold capability and status.
203              
204             %rule = (
205             pod => 'pod',
206             )
207              
208             The rule capability is given by the hash key. To load a rule, use the
209             key as the value in the argument. A rule is deactivated if the value is
210             equal to an $EMPTY_STR (q{}). Supplying the special word 'none' (not
211             case sensitive) deactivates all rules. Only one rule (i.e. 'pod') exists
212             in this release. Returns the hash with key/values.
213            
214             =head1 ERRORS
215              
216             No messages are printed from any subroutine.
217            
218             =head1 BUGS AND LIMITATIONS
219              
220             This version only supports one rule.
221              
222             Please report any bugs or feature requests to
223             L or at
224             C<< >>.
225              
226             =head1 SEE ALSO
227              
228             L, L
229              
230             =head1 LICENSE AND COPYRIGHT
231              
232             Copyright 2011-12, Bertil Kronlund
233              
234             This program is free software; you can redistribute it and/or modify it
235             under the terms of either: the GNU General Public License as published
236             by the Free Software Foundation; or the Artistic License.
237              
238             See http://dev.perl.org/licenses/ for more information.
239              
240             =cut
241              
242             1; # End of Filter::Heredoc::Rule