File Coverage

blib/lib/Filter/Heredoc/Rule.pm
Criterion Covered Total %
statement 51 57 89.4
branch 18 26 69.2
condition 2 3 66.6
subroutine 9 9 100.0
pod 1 1 100.0
total 81 96 84.3


line stmt bran cond sub pod time code
1             package Filter::Heredoc::Rule;
2              
3 26     26   102567 use 5.010;
  26         85  
4 26     26   107 use strict;
  26         38  
  26         558  
5 26     26   145 use warnings;
  26         49  
  26         1054  
6              
7             our $VERSION = '0.05';
8              
9             =head1 NAME
10              
11             Filter::Heredoc::Rule - Load or unload rules for heredoc processing
12              
13             =head1 VERSION
14              
15             Version 0.05
16              
17             =cut
18              
19 26     26   142 use base qw(Exporter);
  26         55  
  26         2329  
20 26     26   176 use feature 'state';
  26         48  
  26         13205  
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 6256 my $language = shift;
42 86         122 my $EMPTY_STR = q{};
43              
44             # Default to no rules
45 86         110 state $pod = $EMPTY_STR;
46 86         174 my %syntax = ( pod => $pod, );
47              
48             # Sets a new language (rule)
49 86 100       180 if ( defined $language ) {
50 26         33 my $POD = q{pod};
51 26         29 my $NONE = q{none};
52              
53 26         65 chomp $language;
54              
55             # Reset all rules with 'none' keyword, ignore case
56 26         40 $language = lc($language);
57 26 100       68 if ( $language eq $NONE ) {
    100          
58 9         13 $syntax{pod} = $EMPTY_STR;
59 9         14 $pod = $EMPTY_STR; # update persistent variable
60             }
61              
62             # Set one of the defined rules
63             elsif ( exists( $syntax{$language} ) ) {
64 13 50       27 if ( $language eq $POD ) {
65 13         21 $syntax{pod} = $POD;
66 13         20 $pod = $POD; # update persistent variable
67             }
68             }
69              
70             } # end language rule defined
71              
72             # The existing rule (possible changed)
73 86         256 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   95 my $line = shift;
86 56         79 my $EMPTY_STR = q{};
87 56         79 my $NONE = q{none};
88 56         76 my $POD = q{pod};
89              
90 56         109 my %syntax = hd_syntax();
91              
92             # Line is to be trusted (to 'none rules')
93 56 100       162 if ( $syntax{pod} eq $EMPTY_STR ) {
    50          
94 50         185 return 1;
95             }
96              
97             # Apply pod rules
98             elsif ( $syntax{pod} eq $POD ) {
99              
100             # 'False line', '<<' and '>>' on line
101 6 100       13 if ( _is_redirector_pair($line) ) {
    50          
102 2         19 return $EMPTY_STR;
103             }
104              
105             # 'False line', empty '<<' line
106             elsif ( _is_lonely_redirect($line) ) {
107 4         17 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   6 my $EMPTY_STR = q{};
128 4         6 my $line;
129              
130 4 50       10 if ( !defined( $line = shift ) ) {
131 0         0 return $EMPTY_STR;
132             }
133              
134             # lonely '<<' with no characters on line after it
135 4 50       17 if ( $line =~ m/(<<)$/ ) {
136 4         13 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   18 my $EMPTY_STR = q{};
156 6         8 my $line;
157              
158 6 50       16 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     79 if ( ( $line =~ m/<>/ ) ) {
164 2         5 return 1;
165             }
166              
167 4         27 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-18, 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