File Coverage

blib/lib/Perl/Tidy/Sweetened/Keyword/Block.pm
Criterion Covered Total %
statement 74 74 100.0
branch 6 10 60.0
condition 2 2 100.0
subroutine 16 16 100.0
pod 4 11 36.3
total 102 113 90.2


line stmt bran cond sub pod time code
1             package Perl::Tidy::Sweetened::Keyword::Block;
2              
3             # ABSTRACT: Perl::Tidy::Sweetened filter plugin to define new subroutine and class keywords
4              
5 13     13   329 use 5.010; # Needed for balanced parens matching with qr/(?-1)/
  13         55  
6 13     13   87 use strict;
  13         31  
  13         273  
7 13     13   66 use warnings;
  13         31  
  13         383  
8 13     13   91 use Carp;
  13         28  
  13         10126  
9             $|++;
10              
11             our $VERSION = '1.18';
12              
13             # Regex to match balanced params. Reproduced from Regexp::Common to avoid
14             # adding a non-core dependency.
15             # $RE{balanced}{-parens=>'()'};
16             # The (?-1) construct requires 5.010
17             our $Paren = '(?:((?:\((?:(?>[^\(\)]+)|(?-1))*\))))';
18              
19             sub new {
20 130     130 0 422 my ( $class, %args ) = @_;
21 130 50       303 croak 'keyword not specified' if not exists $args{keyword};
22 130 50       259 croak 'marker not specified' if not exists $args{marker};
23 130 50       231 croak 'replacement not specified' if not exists $args{replacement};
24 130 50       301 $args{clauses} = [] unless exists $args{clauses};
25 130         768 return bless {%args}, $class;
26             }
27              
28 1061     1061 1 3371 sub keyword { return $_[0]->{keyword} }
29 1048     1048 1 2802 sub marker { return $_[0]->{marker} }
30 1048     1048 1 2698 sub replacement { return $_[0]->{replacement} }
31              
32             sub emit_placeholder {
33 108     108 0 748 my ( $self, $subname, $brace, $clauses ) = @_;
34              
35             # Store the signature and returns() for later use
36 108         763 my $id = sprintf "%03d", $self->{counter}++;
37 108         395 $self->{store_clause}->{$id} = $clauses;
38 108         306 $self->{store_sub}->{$id} = $subname;
39              
40             # Turns 'my_method_name' into 'SUB004hod_name'
41 108         304 my $marker = $self->marker . $id;
42 108         375 substr( $subname, 0, length($marker), $marker );
43              
44 108         362 return sprintf '%s %s %s', $self->replacement, $marker, $brace;
45             }
46              
47             sub emit_keyword {
48 108     108 0 563 my ( $self, $brace, $id ) = @_;
49              
50             # Get the signature and returns() from store
51 108         405 my $clauses = $self->{store_clause}->{$id};
52              
53 108         316 my $subname = $self->{store_sub}->{$id};
54              
55             # Combine clauses (parameter list, returns(), etc) into a string separate
56             # each with a space and lead with a space if there are any
57 108         379 my $clause = join ' ', grep { length $_ } @$clauses;
  229         847  
58              
59             # FIXME: This forces space between sub/func/method name and clauses list
60             # (ignores perltidy settings)
61 108 100       440 $clause = ' ' . $clause if length $clause;
62              
63 108         409 return sprintf '%s %s%s%s', $self->keyword, $subname, $clause, $brace;
64             }
65              
66             sub emit_csc {
67 13     13 0 28 my ( $self, $id, $cscp ) = @_;
68 13         30 return sprintf "%s %s %s", $cscp, $self->keyword, $self->{store_sub}->{$_};
69             }
70              
71             sub clauses {
72 940     940 1 1427 my $self = shift;
73              
74             # Create a regex (as a string) for all the clauses (ie, parameter list,
75             # returns(), etc).
76 940         1773 my $clause_re = '';
77 940         1435 my $i = 0;
78 940         1379 for my $clause ( @{ $self->{clauses} } ) {
  940         2223  
79 1410         2872 $clause =~ s{PAREN}{$Paren}g;
80              
81 1410         3659 $clause_re .= "(?<clause_$i> $clause ) \\s* \n";
82 1410         2532 $i++;
83             }
84              
85 940         50660 return $clause_re;
86             }
87              
88             sub identifier { # method or package identifier
89 1880     1880 0 3158 my $self = shift;
90              
91 1880         3314 return '\w+ (?: ::\w+ )*'; # words, possibly separated by ::
92             }
93              
94             sub prefilter {
95 940     940 0 2079 my ( $self, $code ) = @_;
96 940         1836 my $keyword = $self->keyword;
97 940         1850 my $subname = $self->identifier;
98              
99 940         1689 $code =~ s{
100             ^\s*\K # okay to have leading whitespace (preserve)
101             $keyword \s+ # the "func/method" keyword
102             (?<subname> $subname) # the function name or class name (needs ::)
103             (?!\w|\s*=>) \s* # check to make sure this isn't a sub call with params
104 940         1782 @{[ $self->clauses ]} # any clauses defined (ie, a parameter list)
105             (?<brace> .*?) # anything else (ie, comments) including brace
106             $
107             }{
108 108         366 my $i = 0;
109 108         258 my $clauses = [];
110 13     13   6486 while( exists $+{"clause_$i"} ){
  13         5381  
  13         4048  
  108         1330  
111             ## warn "# clause_$i: " . $+{"clause_$i"} . "\n";
112 229         1321 push @$clauses, $+{"clause_$i"};
113 229         1113 $i++;
114             }
115 108         690 $self->emit_placeholder( $+{subname}, $+{brace}, $clauses )
116             }egmx;
117              
118 940         5233 return $code;
119             }
120              
121             sub postfilter {
122 940     940 0 2225 my ( $self, $code, $args ) = @_;
123 940         1993 my $marker = $self->marker;
124 940         1946 my $replacement = $self->replacement;
125 940         1931 my $subname = $self->identifier;
126 940         1514 my @ids;
127              
128             # Convert back to method
129 940         51393 $code =~ s{
130             ^\s*\K # preserve leading whitespace
131             $replacement \s+ # keyword was converted to sub/package
132             $marker #
133             (?<id> \d\d\d) # the identifier
134             [\w:]* \b # the rest of the orignal sub/package name
135             (?<newline> \n? \s* ) # possible newline and indentation
136             (?<brace> .*? ) [ ]* # opening brace on followed orig comments
137             [ ]* # trailing spaces (not all whitespace)
138             }{
139 108         1382 push @ids, $+{id};
140 108         1238 $self->emit_keyword( $+{newline} . $+{brace}, $+{id} );
141             }egmx;
142              
143             # Restore the orig sub name when inserted via the -csc flag
144 940   100     5784 my $cscp = $args->{'-cscp'} || '## end';
145             $code =~ s{
146             \Q${cscp}\E \s sub \s ${marker} $_
147             }{
148 13         38 $self->emit_csc( $_, $cscp );
149 940         3902 }egx for @ids;
150              
151 940         3678 return $code;
152             }
153              
154             1;
155              
156             __END__
157              
158             =pod
159              
160             =head1 NAME
161              
162             Perl::Tidy::Sweetened::Keyword::Block - Perl::Tidy::Sweetened filter plugin to define new subroutine and class keywords
163              
164             =head1 VERSION
165              
166             version 1.18
167              
168             =head1 SYNOPSIS
169              
170             our $plugins = Perl::Tidy::Sweetened::Pluggable->new();
171              
172             $plugins->add_filter(
173             Perl::Tidy::Sweetened::Keyword::Block->new(
174             keyword => 'method',
175             marker => 'METHOD',
176             replacement => 'sub',
177             clauses => [ 'PAREN?', '(returns \s* PAREN)?' ],
178             ) );
179              
180             =head1 DESCRIPTION
181              
182             This is a Perl::Tidy::Sweetened filter which enables the definition of
183             arbitrary keywords for subroutines with any number of potential signature
184             definitions. New accepts:
185              
186             =over 4
187              
188             =item keyword
189              
190             keyword => 'method'
191              
192             Declares a new keyword (in this example the "method" keyword).
193              
194             =item marker
195              
196             marker => 'METHOD'
197              
198             Provides a text marker to be used to flag the new keywords during
199             C<prefilter>. The source code will be filtered prior to formatting by
200             Perl::Tidy such that:
201              
202             method foo {
203             }
204              
205             is turned into:
206              
207             sub foo { # __METHOD 1
208             }
209              
210             =item replacement
211              
212             replacement => 'sub'
213              
214             Will convert the keyword to a C<sub> as shown above.
215              
216             =item clauses
217              
218             clauses => [ 'PAREN?' ]
219              
220             Provides a list of strings which will be turned into a regex to capture
221             additional clauses. The regex will include the 'xm' flags (so be sure to escape
222             spaces). The clause can be marked optional with '?'. The special text "PAREN"
223             can be used to capture a balanced parenthetical.
224              
225             This example will capture a parameter list enclosed by parenthesis, ie:
226              
227             method foo (Int $i) {
228             }
229              
230             No formatting is done on the clauses at this time. The order of declaration
231             is significant.
232              
233             =back
234              
235             =head1 AUTHOR
236              
237             Mark Grimes E<lt>mgrimes@cpan.orgE<gt>
238              
239             =head1 SOURCE
240              
241             Source repository is at L<https://github.com/mvgrimes/Perl-Tidy-Sweetened>.
242              
243             =head1 BUGS
244              
245             Please report any bugs or feature requests on the bugtracker website L<http://github.com/mvgrimes/Perl-Tidy-Sweetened/issues>
246              
247             When submitting a bug or request, please include a test-file or a
248             patch to an existing test-file that illustrates the bug or desired
249             feature.
250              
251             =head1 COPYRIGHT AND LICENSE
252              
253             This software is copyright (c) 2021 by Mark Grimes E<lt>mgrimes@cpan.orgE<gt>.
254              
255             This is free software; you can redistribute it and/or modify it under
256             the same terms as the Perl 5 programming language system itself.
257              
258             =cut