File Coverage

blib/lib/Dist/Zilla/PluginBundle/Author/ZMUGHAL/Babble/FunctionParameters.pm
Criterion Covered Total %
statement 141 148 95.2
branch 23 26 88.4
condition 6 6 100.0
subroutine 21 23 91.3
pod 0 4 0.0
total 191 207 92.2


line stmt bran cond sub pod time code
1             package Dist::Zilla::PluginBundle::Author::ZMUGHAL::Babble::FunctionParameters;
2             $Dist::Zilla::PluginBundle::Author::ZMUGHAL::Babble::FunctionParameters::VERSION = '0.006';
3 1     1   105796 use strict;
  1         2  
  1         31  
4 1     1   5 use warnings;
  1         2  
  1         26  
5 1     1   477 use Import::Into;
  1         2763  
  1         32  
6 1     1   502 use Mu;
  1         16786  
  1         7  
7              
8             ro setup_package => (
9             default => sub { 'Orbital::Transfer::Common::Setup' },
10             );
11              
12             lazy _import_info => sub {
13 1     1   35 my ($self) = @_;
14 1         17 $self->setup_package->import::into(0);
15 1         1177 my $fp_config = $^H{'Function::Parameters/config'};
16 1         10 $self->setup_package->unimport::out_of(0);
17             return +{
18 1         39 'fp' => $fp_config,
19             };
20             };
21              
22             lazy _fp_keywords_re => sub {
23 1     1   11 my ($self) = @_;
24             return
25             '(?:'
26 1         3 . join("|", map quotemeta, keys %{ $self->_import_info->{fp} })
  1         22  
27             . ')';
28             };
29              
30             my $FPTypeRE = q{
31             (?:
32             [^$@%:(]+ | \( (?&PerlScalarExpression) \)
33             )
34             };
35             my $FPParamRE = q{
36             (?:
37             #(?<type>
38             (?> (?&PerlBabbleFPType)? )
39             #)
40             (?> (?&PerlOWS) )
41             #(?<named>
42             (?> :? )
43             #)
44             #(?<var>
45             (?> \$ (?&PerlIdentifier) )
46             #)
47             (?>
48             (?&PerlOWS)
49             #(?<hasdefault>
50             (?: = )
51             #)
52             (?&PerlOWS)
53             #(?<default>
54             (?: (?&PerlScalarExpression)? )
55             #)
56             )?
57             )
58             |
59             (?:
60             #(?<other>
61             (?: (?> [$@%] ) (?> (?&PerlIdentifier)? ) )
62             #)
63             )
64             };
65              
66             my $FPParamListPartial = q{
67             (?&PerlBabbleFPParam)
68             (?: (?&PerlOWS) [,] (?&PerlOWS) (?&PerlBabbleFPParam))*?
69             };
70              
71             my $FPParamListComplete = qq{
72             \\(
73             (?> (?&PerlOWS) )
74             (?:
75             (?:
76             $FPParamListPartial
77             (?&PerlOWS) [:] (?&PerlOWS)
78             )?
79             (?:
80             $FPParamListPartial
81             )
82             )??
83             (?> (?&PerlOWS) )
84             \\)
85             };
86              
87             sub extend_grammar {
88 1     1 0 3181 my ($self, $g) = @_;
89 1         11 $g->add_rule(BabbleFPType => $FPTypeRE );
90 1         644 $g->add_rule(BabbleFPParam => $FPParamRE );
91 1         53 $g->add_rule(BabbleFPParamList => $FPParamListComplete );
92 1         47 $g->add_rule(FPDeclaration => qq{
93 1         31 @{[ $self->_fp_keywords_re ]}
94             (?&PerlOWS)
95             (?: (?&PerlIdentifier)(?&PerlOWS) )?+
96             (?> (?&PerlBabbleFPParamList) )
97             (?&PerlOWS)
98             (?: (?>(?&PerlAttributes)) (?&PerlOWS) )?+
99             (?&PerlBlock)
100             });
101 1         74 $g->augment_rule(SubroutineDeclaration => '(?&PerlFPDeclaration)');
102 1         118 $g->augment_rule(AnonymousSubroutine => '(?&PerlFPDeclaration)');
103             }
104              
105             sub _do_transform {
106 28     28   119 my ($self, $top, $cb) = @_;
107 28         169 $top->remove_use_statement('Function::Parameters');
108             $top->each_match_within(FPDeclaration => [
109             [ kw => $self->_fp_keywords_re ],
110             [ name => '(?&PerlOWS) (?:(?&PerlIdentifier)(?&PerlOWS))?+' ],
111             [ sig => '(?&PerlBabbleFPParamList)' ],
112             [ rest => q{
113             (?&PerlOWS)
114             (?: (?>(?&PerlAttributes)) (?&PerlOWS) )?+
115             (?&PerlBlock)
116             } ],
117             ] => sub {
118 28     28   330089 my ($m) = @_;
119 28         591 my $gr = $m->grammar_regexp;
120 28         159773 my ($kw, $sig, $rest) = @{$m->submatches}{qw(kw sig rest)};
  28         670  
121 28         125147 my $kw_text = $kw->text;
122 28         620 my $kw_info = $self->_import_info->{fp}{$kw_text};
123 28         318 my $sig_text = $sig->text;
124              
125 28         888624 (my $inner_sig = $sig_text) =~ s/(?: \A \( (?&PerlOWS) | (?&PerlOWS) \) \Z ) $gr//xg;
126 28         937151 my ($invocant_pl, $rest_pl) = $inner_sig =~ /
127             \A
128             (?:
129             ($FPParamListPartial)
130             (?&PerlOWS) [:] (?&PerlOWS)
131             )?
132             ($FPParamListPartial)
133             \Z $gr/x;
134              
135 28         3904 my @invocants = $self->_parse_param_list($m, $invocant_pl);
136 28         106 my @params = $self->_parse_param_list($m, $rest_pl);
137              
138 28         361 $cb->($m, $kw_text, \@invocants, \@params);
139 28         332667 });
140              
141             }
142              
143             sub _transform_to_plain_via_generate_front {
144 14     14   70 my ($self, $kw_text, $invocants, $params) = @_;
145              
146 14         297 my $kw_info = $self->_import_info->{fp}{$kw_text};
147              
148 14         150 my @invocant_vars;
149 14 100 100     153 if( ! @$invocants && $kw_info->{shift} ) {
    100          
150 10         66 push @invocant_vars, split ' ', $kw_info->{shift};
151             } elsif( @$invocants ) {
152 1         4 push @invocant_vars, map { $_->{var} } @$invocants;
  1         6  
153             }
154              
155 14         46 my @front_statements;
156 14 100       57 if( @invocant_vars ) {
157 11         35 my $shift_perl = join "; ", map { "my $_ = shift" } @invocant_vars;
  12         73  
158 11         49 push @front_statements, $shift_perl;
159             }
160 14 100       53 if( @$params ) {
161 13         38 my @params_vars;
162 13         44 push @params_vars, map { $_->{var} } @$params;
  23         81  
163              
164 13         60 my $params_perl = join ", ", @params_vars;
165 13         58 push @front_statements, "my ($params_perl) = \@_";
166             }
167 14         54 my $front = join "; ", @front_statements;
168 14         47 $front .= ";";
169              
170 14         55 return $front;
171             }
172              
173             sub _transform_to_plain_via_deparse_front {
174 14     14   60 my ($self, $kw_text, $invocants, $params) = @_;
175 14         47 my $sig_text = '';
176 14         59 $sig_text .= '(';
177              
178 14 100       75 if( @$invocants ) {
179             $sig_text .= join ", ", map {
180 1         5 $_->{var}
181 1         7 } @$invocants;
182 1         3 $sig_text .= " : ";
183             }
184 14 100       68 if( @$params ) {
185             $sig_text .= join ", ", map {
186 13         47 my $param_reconstitute = join " ", grep defined, @$_{qw(var hasdefault default)};
  23         154  
187 23 100 100     179 if( exists $_->{named} && $_->{named} eq ":" ) {
188 10         32 $param_reconstitute = ":" . $param_reconstitute;
189             }
190             $param_reconstitute
191 23         102 } @$params;
192             }
193              
194 14         41 $sig_text .= ')';
195              
196 14         85 my $front = $self->_fp_arg_code_deparse($kw_text, $sig_text);
197              
198 14         45 return $front;
199             }
200              
201             sub _transform_to_plain_cb {
202 28     28   120 my ($self, $top, $cb) = @_;
203             $self->_do_transform($top, sub {
204 28     28   185 my ($m, $kw_text, $invocants, $params) = @_;
205              
206 28         104 my ($kw, $sig, $rest) = @{$m->submatches}{qw(kw sig rest)};
  28         1560  
207 28         1391 my $kw_info = $self->_import_info->{fp}{$kw_text};
208              
209 28         533 $kw->replace_text('sub');
210              
211 28         8511 my $front = $self->$cb($kw_text, $invocants, $params);
212              
213 28         176 $self->_transform_place_front_in_block($rest, $front);
214 28         6543 $sig->replace_text('');
215 28         255 });
216             }
217              
218             sub transform_to_plain {
219 0     0 0 0 my ($self, $top) = @_;
220             $self->_transform_to_plain_cb( $top, sub {
221 0     0   0 my $front_generate = _transform_to_plain_via_generate_front(@_);
222 0         0 my $front_deparse = _transform_to_plain_via_deparse_front(@_);
223 0 0       0 if( $front_generate ne $front_deparse ) {
224 0         0 warn <<EOF
225             Front not the same:
226             - Gen: $front_generate
227             - Dep: $front_deparse
228              
229             EOF
230             }
231 0         0 return $front_deparse;
232 0         0 });
233             }
234              
235             sub transform_to_plain_via_generate {
236 14     14 0 122932 my ($self, $top) = @_;
237 14         68 $self->_transform_to_plain_cb( $top, \&_transform_to_plain_via_generate_front );
238             }
239              
240             sub transform_to_plain_via_deparse {
241 14     14 0 85381 my ($self, $top) = @_;
242 14         75 $self->_transform_to_plain_cb( $top, \&_transform_to_plain_via_deparse_front );
243             }
244              
245             sub _parse_param_list {
246 56     56   212 my ($self, $m, $param_text) = @_;
247 56 100       283 return () unless $param_text;
248 28         1297 my $gr = $m->grammar_regexp;
249 28         2639 (my $capturing_re = $FPParamRE) =~ s/^(\s*)#/$1/gm;
250 28         116 my @params;
251 28 50       942109 if( $param_text =~ /\A $capturing_re $gr/xg ) {
252 1     1   4990 push @params, +{ %+ };
  1         535  
  1         878  
  28         1563  
253             }
254 28         980466 while( $param_text =~ /\G (?&PerlOWS) [,] (?&PerlOWS) $capturing_re $gr/xg) {
255 20         694257 push @params, +{ %+ };
256             }
257 28         3514 for my $param (@params) {
258 48 100       280 if( exists $param->{other} ) {
259 4         42 $param->{var} = delete $param->{other};
260             }
261             }
262 28         4250 @params;
263             }
264              
265              
266             sub _fp_arg_code_deparse {
267 14     14   65 my ($self, $kw_text, $sig_text) = @_;
268 14         320 my $kw_info = $self->_import_info->{fp}{$kw_text};
269 14         201 my $text = $self->_deparse_fp( $kw_text, $sig_text );
270 14         15682 (my $replaced = $text) =~ s/\Qpackage Eval::Closure::Sandbox_\E.*?^\s*}$//ms;
271 14         94 $replaced =~ s/^\s*\QFunction::Parameters::_croak\E.*;$//mg;
272 14 100       69 if( $kw_info->{instl} ) {
273 1         4 $replaced =~ s/^\s*\Q@{[ $kw_info->{instl} ]}\E\(.*\{$//mg;
  1         32  
274 1         16 $replaced =~ s/^(\s*42;)\n\s*\}\n\s*\);$/$1/mg;
275             }
276 14         260 $replaced =~ s/\A[^{]*?\{\s*|42;\n\}\Z//msg;
277 14         341 $replaced =~ s/^\s*|\s*$//msg;
278 14         103 $replaced =~ s/\n+/ /msg;
279              
280 14         80 $replaced =~ s/shift\(\);/shift;/g;
281 14         83 $replaced =~ s/my\(/my (/g;
282              
283 14         70 $replaced =~ s/\Q%{__rest} = ();\E/(%{__rest}) = ();/;
284              
285 14         55 $replaced;
286             }
287              
288             sub _deparse_fp {
289 14     14   155 require B::Deparse;
290 14         834 require Eval::Closure;
291             # https://github.com/mauke/Function-Parameters/issues/29
292 14         2966 my $deparse = B::Deparse->new("-d");
293 14         6390 my ($self, $kw_text, $sig_text) = @_;
294 14         305 my $kw_info = $self->_import_info->{fp}{$kw_text};
295 14         166 my $code = qq{
296 14         121 use @{[ $self->setup_package ]};
297             };
298 14 100       76 if( $kw_info->{instl} ) {
299 1         6 $code .= qq{
300             sub {
301             $kw_text foo $sig_text { 42 }
302             }
303             };
304             } else {
305 13         67 $code .= qq{
306             $kw_text $sig_text { 42 };
307             };
308             }
309 14         93 my $coderef = Eval::Closure::eval_closure(
310             source => $code,
311             );
312 14         49087 my $text = $deparse->coderef2text( $coderef );
313             }
314              
315             sub _transform_place_front_in_block {
316 28     28   113 my ($self, $rest, $front) = @_;
317 28     28   334 $rest->transform_text(sub { s/^(\s*)\{/${1}{ ${front}/ });
  28         678  
318             }
319              
320             1;
321              
322             __END__
323              
324             =pod
325              
326             =encoding UTF-8
327              
328             =head1 NAME
329              
330             Dist::Zilla::PluginBundle::Author::ZMUGHAL::Babble::FunctionParameters
331              
332             =head1 VERSION
333              
334             version 0.006
335              
336             =head1 AUTHOR
337              
338             Zakariyya Mughal <zmughal@cpan.org>
339              
340             =head1 COPYRIGHT AND LICENSE
341              
342             This software is copyright (c) 2017 by Zakariyya Mughal.
343              
344             This is free software; you can redistribute it and/or modify it under
345             the same terms as the Perl 5 programming language system itself.
346              
347             =cut