File Coverage

blib/lib/Circle/GlobalRules.pm
Criterion Covered Total %
statement 33 194 17.0
branch 0 102 0.0
condition 0 3 0.0
subroutine 10 26 38.4
pod 0 17 0.0
total 43 342 12.5


line stmt bran cond sub pod time code
1             # You may distribute under the terms of the GNU General Public License
2             #
3             # (C) Paul Evans, 2008-2012 -- leonerd@leonerd.org.uk
4              
5             package Circle::GlobalRules;
6              
7 4     4   28 use strict;
  4         6  
  4         175  
8 4     4   22 use warnings;
  4         8  
  4         182  
9              
10 4     4   24 use Text::Balanced qw( extract_delimited extract_quotelike );
  4         9  
  4         297  
11              
12 4     4   22 use base qw( Circle::Rule::Store ); # for the attributes
  4         7  
  4         2608  
13              
14             sub unquote_qr
15             {
16 0     0 0 0 my $re = shift;
17              
18 0         0 $re = "$re";
19              
20             # Perl tries to put (?-xism:RE) around our pattern. Lets attempt to remove
21             # it if we can
22             # Recent perls use (?^:RE) instead
23 0         0 $re =~ s/^\(\?-xism:(.*)\)$/$1/;
24 0         0 $re =~ s/^\(\?\^:(.*)\)$/$1/;
25              
26 0 0       0 return ( $2, $1 ) if $re =~ m/^\(\?([ixsm]*)-?[xism]*:(.*)\)$/;
27 0 0       0 return ( $2, $1 ) if $re =~ m/^\(\?\^([ixsm]*):(.*)\)$/;
28              
29             # Failed. Lets just be safe then
30 0         0 return ( $re, "" );
31             }
32              
33             # Not an object class. Instead, just a store of rule subs
34              
35             sub register
36             {
37 3     3 0 5 my ( $rulestore ) = @_;
38              
39 3         13 $rulestore->register_cond( matches => __PACKAGE__ );
40              
41 3         21 $rulestore->register_action( rewrite => __PACKAGE__ );
42 3         13 $rulestore->register_action( format => __PACKAGE__ );
43 3         13 $rulestore->register_action( unformat => __PACKAGE__ );
44 3         12 $rulestore->register_action( level => __PACKAGE__ );
45             }
46              
47             ###### CONDITIONS
48              
49             ### MATCHES
50              
51             sub parse_cond_matches
52             : Rule_description("Look for regexp or substring matches in the text")
53             : Rule_format('/regexp/ or "literal"')
54             {
55 0     0 0 0 shift; # class
56 0         0 my ( $spec ) = @_;
57              
58 0 0       0 if( $spec =~ m{^/} ) {
    0          
59             # Try to pull the flags
60 0 0       0 my ( $content, $flags ) = $spec =~ m{^/(.*)/([i]*)$} or die "Unrecognised regexp string $spec\n";
61              
62 0 0       0 return qr/$content/i if $flags eq "i";
63 0         0 return qr/$content/;
64             }
65             elsif( $spec =~ m{^"} ) {
66 0 0       0 my ( $content ) = $spec =~ m{^"(.*)"$} or die "Unrecognised literal string $spec\n";
67              
68 0         0 return qr/\Q$content/;
69             }
70             else {
71 0         0 die "Unrecognised string type $spec";
72             }
73 4     4   28 }
  4         10  
  4         26  
74              
75             sub deparse_cond_matches
76             {
77 0     0 0   shift; # class
78 0           my ( $re ) = @_;
79              
80 0           my ( $pattern, $flags ) = unquote_qr( $re );
81 0           return "/$pattern/$flags";
82             }
83              
84             sub eval_cond_matches
85             {
86 0     0 0   shift; # class
87 0           my ( $event, $results, $re ) = @_;
88              
89 0           my $text = $event->{text}->str;
90              
91 0           pos( $text ) = 0;
92              
93 0           my $matched;
94              
95 0           while( $text =~ m/$re/g ) {
96 0           my @matchgroups;
97 0           for ( 0 .. $#+ ) {
98 0           my ( $start, $end ) = ( $-[$_], $+[$_] );
99 0           my $len = $end - $start;
100              
101 0           push @matchgroups, [ $start, $len ];
102             }
103              
104 0           $results->push_result( "matchgroups", \@matchgroups );
105 0           $matched = 1;
106             }
107              
108 0           return $matched;
109             }
110              
111             ###### ACTIONS
112              
113             ### REWRITE
114              
115             sub parse_action_rewrite
116             : Rule_description("Rewrite text of the line or matched parts")
117             : Rule_format('line|matches|match(number) "string"|s/pattern/replacement/')
118             {
119 0     0 0 0 shift; # class
120 0         0 my ( $spec ) = @_;
121              
122 0 0       0 $spec =~ s/^(\w+)\s*// or die "Expected type as first argument\n";
123 0         0 my $type = $1;
124              
125 0         0 my $groupnum;
126              
127 0 0       0 if( $type eq "line" ) {
    0          
    0          
128 0         0 $groupnum = -1;
129             }
130             elsif( $type eq "matches" ) {
131 0         0 $groupnum = 0;
132             }
133             elsif( $type eq "match" ) {
134 0 0       0 $spec =~ s/^\((\d+)\)\s*// or die "Expected match group number\n";
135 0         0 $groupnum = $1;
136             }
137             else {
138 0         0 die "Unrecognised format type $type\n";
139             }
140              
141 0 0       0 my ( undef, $remains, undef, $op, $delim, $lhs, undef, undef, $rhs, undef, $mods ) = extract_quotelike( $spec )
142             or die 'Expected "string" or s/pattern/replacement/';
143 0         0 $spec = $remains;
144 0 0       0 $op = $delim if $op eq "";
145              
146 0 0       0 if( $op eq '"' ) {
    0          
147             # Literal
148 0         0 return ( $groupnum, literal => $lhs );
149             }
150             elsif( $op eq "s" ) {
151             # s/foo/bar/
152 0         0 my $global = $mods =~ s/g//;
153             # TODO: Range check that mods contains only /ism
154 0         0 return ( $groupnum, subst => qr/(?$mods:$lhs)/, $rhs, $global );
155             }
156             else {
157 0         0 die 'Expected "string" or s/pattern/replacement/';
158             }
159 4     4   3121 }
  4         12  
  4         20  
160              
161             sub deparse_action_rewrite
162             {
163 0     0 0   shift; # class
164 0           my ( $groupnum, $kind, $lhs, $rhs, $global ) = @_;
165              
166 0 0         my $type = $groupnum == -1 ? "line" :
    0          
167             $groupnum == 0 ? "matches" :
168             "match($groupnum)";
169              
170 0 0         if( $kind eq "literal" ) {
    0          
171 0           return "$type \"$lhs\"";
172             }
173             elsif( $kind eq "subst" ) {
174 0           my ( $pattern, $flags ) = unquote_qr( $lhs );
175 0 0         return "$type s/$pattern/$rhs/$flags" . ( $global ? "g" : "" );
176             }
177             }
178              
179             sub eval_action_rewrite
180             {
181 0     0 0   shift; # class
182 0           my ( $event, $results, $groupnum, $kind, $lhs, $rhs, $global ) = @_;
183              
184 0           my @location;
185 0 0         if( $groupnum == -1 ) {
186 0           @location = ( 0, -1 );
187             }
188             else {
189 0           foreach my $groups ( @{ $results->get_result( "matchgroups" ) } ) {
  0            
190 0 0         my $group = $groups->[$groupnum] or next;
191 0           @location = @$group;
192 0           last; # can only do the first one
193             }
194             }
195              
196 0           my $text = $event->{text}->substr( $location[0], $location[1] );
197              
198 0 0         if( $kind eq "literal" ) {
    0          
199 0           $text = $lhs;
200             }
201             elsif( $kind eq "subst" ) {
202 0 0         $text =~ s/$lhs/$rhs/ if !$global;
203 0 0         $text =~ s/$lhs/$rhs/g if $global;
204             }
205              
206 0           $event->{text}->set_substr( $location[0], $location[1], $text );
207             }
208              
209             ### FORMAT
210              
211             sub parse_action_format
212             : Rule_description("Apply formatting to the line or matched parts")
213             : Rule_format('line|matches|match(number) key="value" [key="value" ...]')
214             {
215 0     0 0 0 shift; # class
216 0         0 my ( $spec ) = @_;
217              
218 0 0       0 $spec =~ s/^(\w+)\s*// or die "Expected type as first argument\n";
219 0         0 my $type = $1;
220              
221 0         0 my $groupnum;
222              
223 0 0       0 if( $type eq "line" ) {
    0          
    0          
224 0         0 $groupnum = -1;
225             }
226             elsif( $type eq "matches" ) {
227 0         0 $groupnum = 0;
228             }
229             elsif( $type eq "match" ) {
230 0 0       0 $spec =~ s/^\((\d+)\)\s*// or die "Expected match group number\n";
231 0         0 $groupnum = $1;
232             }
233             else {
234 0         0 die "Unrecognised format type $type\n";
235             }
236              
237 0         0 my %format;
238 0         0 while( $spec =~ s/^(\w+)=// ) {
239 0         0 my $name = $1;
240              
241 0         0 my $value = extract_delimited( $spec, q{"'} );
242 0         0 s/^["']//, s/["']$// for $value;
243              
244 0         0 $format{$name} = $value;
245              
246 0         0 $spec =~ s/^\s+//;
247             }
248              
249 0 0       0 if( length $spec ) {
250 0         0 die "Unrecognised format spec $spec\n";
251             }
252              
253 0         0 return ( $groupnum, \%format );
254 4     4   4311 }
  4         9  
  4         23  
255              
256             sub deparse_action_format
257             {
258 0     0 0   shift; # class
259 0           my ( $groupnum, $formathash ) = @_;
260              
261 0 0         return unless %$formathash;
262              
263 0 0         my $type = $groupnum == -1 ? "line" :
    0          
264             $groupnum == 0 ? "matches" :
265             "match($groupnum)";
266              
267 0           return "$type ".join( " ", map { qq($_="$formathash->{$_}") } sort keys %$formathash );
  0            
268             }
269              
270             sub eval_action_format
271             {
272 0     0 0   shift; # class
273 0           my ( $event, $results, $groupnum, $formathash ) = @_;
274              
275 0           my $str = $event->{text};
276              
277 0 0         if( $groupnum == -1 ) {
278 0           $str->apply_tag( 0, -1, $_, $formathash->{$_} ) for keys %$formathash;
279             }
280             else {
281 0           foreach my $groups ( @{ $results->get_result( "matchgroups" ) } ) {
  0            
282 0 0         my $group = $groups->[$groupnum] or next;
283 0           my ( $start, $len ) = @$group;
284              
285 0           $str->apply_tag( $start, $len, $_, $formathash->{$_} ) for keys %$formathash;
286             }
287             }
288             }
289              
290             ### UNFORMAT
291              
292             sub parse_action_unformat
293             : Rule_description("Remove formatting from the line or matched parts")
294             : Rule_format('line|matches|match(number) key [key ...]')
295             {
296 0     0 0 0 shift; # class
297 0         0 my ( $spec ) = @_;
298              
299 0 0       0 $spec =~ s/^(\w+)\s*// or die "Expected type as first argument\n";
300 0         0 my $type = $1;
301              
302 0         0 my $groupnum;
303              
304 0 0       0 if( $type eq "line" ) {
    0          
    0          
305 0         0 $groupnum = -1;
306             }
307             elsif( $type eq "matches" ) {
308 0         0 $groupnum = 0;
309             }
310             elsif( $type eq "match" ) {
311 0 0       0 $spec =~ s/^\((\d+)\)\s*// or die "Expected match group number\n";
312 0         0 $groupnum = $1;
313             }
314             else {
315 0         0 die "Unrecognised format type $type\n";
316             }
317              
318 0         0 my @tags;
319 0         0 while( $spec =~ s/^(\w+)// ) {
320 0         0 my $name = $1;
321              
322 0         0 push @tags, $name;
323              
324 0         0 $spec =~ s/^\s+//;
325             }
326              
327 0 0       0 if( length $spec ) {
328 0         0 die "Unrecognised format spec $spec\n";
329             }
330              
331 0         0 return ( $groupnum, \@tags );
332 4     4   3599 }
  4         10  
  4         23  
333              
334             sub deparse_action_unformat
335             {
336 0     0 0   shift; # class
337 0           my ( $groupnum, $taglist ) = @_;
338              
339 0 0         my $type = $groupnum == -1 ? "line" :
    0          
340             $groupnum == 0 ? "matches" :
341             "match($groupnum)";
342              
343 0           my $ret = $type;
344 0           $ret .= " $_" for @$taglist;
345              
346 0           return $ret;
347             }
348              
349             my @alltags = qw( fg bg b u i );
350              
351             sub eval_action_unformat
352             {
353 0     0 0   shift; # class
354 0           my ( $event, $results, $groupnum, $taglist ) = @_;
355              
356 0 0         $taglist = \@alltags unless @$taglist;
357              
358 0           my $str = $event->{text};
359              
360 0 0         if( $groupnum == -1 ) {
361 0           $str->unapply_tag( 0, -1, $_ ) for @$taglist;
362             }
363             else {
364 0           foreach my $groups ( @{ $results->get_result( "matchgroups" ) } ) {
  0            
365 0 0         my $group = $groups->[$groupnum] or next;
366 0           my ( $start, $len ) = @$group;
367              
368 0           $str->unapply_tag( $start, $len, $_ ) for @$taglist;
369             }
370             }
371             }
372              
373             ### LEVEL
374              
375             sub parse_action_level
376             : Rule_description("Set the activity level for the targetted item")
377             : Rule_format('$level')
378             {
379 0     0 0 0 shift; # class
380 0         0 my ( $spec ) = @_;
381              
382 0 0       0 $spec =~ s/^(\d)// or die "Expected level number as first argument\n";
383 0         0 my $level = $1;
384              
385 0 0 0     0 $level >= 0 and $level <= 3 or die "Expected 'level' between 0 and 3\n";
386              
387 0         0 return ( $level );
388 4     4   2476 }
  4         14  
  4         23  
389              
390             sub deparse_action_level
391             {
392 0     0 0   shift; # class
393 0           my ( $level ) = @_;
394              
395 0           return "$level";
396             }
397              
398             sub eval_action_level
399             {
400 0     0 0   shift; # class
401 0           my ( $event, $results, $level ) = @_;
402              
403 0           $event->{level} = $level;
404             }
405              
406             0x55AA;