File Coverage

blib/lib/Method/Signatures/PP.pm
Criterion Covered Total %
statement 38 40 95.0
branch 7 10 70.0
condition n/a
subroutine 8 8 100.0
pod 0 1 0.0
total 53 59 89.8


line stmt bran cond sub pod time code
1             package Method::Signatures::PP;
2              
3 1     1   55251 use strict;
  1         2  
  1         25  
4 1     1   5 use warnings;
  1         1  
  1         32  
5 1     1   4 use re 'eval';
  1         2  
  1         42  
6 1     1   449 use Filter::Util::Call;
  1         727  
  1         47  
7 1     1   546 use PPR;
  1         31575  
  1         331  
8              
9             our $VERSION = '0.000004'; # v0.0.4
10              
11             $VERSION = eval $VERSION;
12              
13             our $Statement_Start;
14              
15             our @Found;
16              
17             my $grammar = qr{
18             (?(DEFINE)
19             (?
20             (?{ local $Statement_Start = pos() })
21             method (?&PerlOWS)
22             (?&PerlIdentifier) (?&PerlOWS)
23             (?: (?&kw_balanced_parens) (?&PerlOWS) )?+
24             (?&PerlBlock) (?&PerlOWS)
25             (?{ push @Found, [ $Statement_Start, pos() - $Statement_Start ] })
26             )
27             (?
28             \( (?: [^()]++ | (?&kw_balanced_parens) )*+ \)
29             )
30             )
31             $PPR::GRAMMAR
32             }x;
33              
34             sub import {
35 1     1   15 my $done = 0;
36             filter_add(sub {
37 2 100   2   1382 return 0 if $done++;
38 1         25 1 while filter_read();
39             #warn "CODE >>>\n$_<<<";
40 1 50       11 if (defined(my $mangled = mangle($_))) {
41 1         3 $_ = $mangled;
42             }
43 1         122 return 1;
44 1         8 });
45             }
46              
47             sub mangle {
48 1     1 0 29 my ($code) = @_;
49 1         2 local @Found;
50 1 50       32691 unless ($code =~ /\A (?&PerlDocument) \Z $grammar/x) {
51 0         0 warn "Failed to parse file; expect complication errors, sorry.\n";
52 0         0 return undef;
53             }
54 1         319 my $offset = 0;
55 1         6 foreach my $case (@Found) {
56 2         6 my ($start, $len) = @$case;
57 2         4 $start += $offset;
58 2         5 my $stmt = substr($code, $start, $len);
59 2 50       49631 die "Whit?"
60             unless my @match = $stmt =~ m{
61             \A
62             method ((?&PerlOWS))
63             ((?&PerlIdentifier)) ((?&PerlOWS))
64             (?: ((?&kw_balanced_parens)) ((?&PerlOWS)) )?+
65             ((?&PerlBlock)) ((?&PerlOWS))
66             $grammar
67             }x;
68 2         392 my ($ws0, $name, $ws1, $sig, $ws2, $block, $ws3) = @match;
69 2 100       12 my $sigcode = $sig ? " my $sig = \@_;" : '';
70 2         41 $block =~ s{^\{}{\{my \$self = shift;${sigcode}};
71 2         12 my $replace = "sub${ws0}${name}${ws1}${block}${ws3}";
72 2         9 substr($code, $start, $len) = $replace;
73 2         51 $offset += length($replace) - $len;
74             }
75             #warn "FINAL >>>\n$_<<<";
76 1         14 return $code;
77             }
78              
79             1;
80              
81             =head1 NAME
82              
83             Method::Signatures::PP - EXPERIMENTAL pure perl method keyword
84              
85             =head1 SYNOPSIS
86              
87             use strict;
88             use warnings;
89             use Test::More;
90             use Method::Signatures::PP;
91            
92             package Wat;
93            
94             use Moo;
95            
96             method foo {
97             "FOO from ".ref($self);
98             }
99            
100             method bar ($arg) {
101             "WOOO $arg";
102             }
103            
104             package main;
105            
106             my $wat = Wat->new;
107            
108             is($wat->foo, 'FOO from Wat', 'Parenless method');
109            
110             is($wat->bar('BAR'), 'WOOO BAR', 'Method w/argument');
111            
112             done_testing;
113              
114             =head1 DESCRIPTION
115              
116             It's ... a method keyword.
117              
118             method foo { ... }
119              
120             is equivalent to
121              
122             sub foo { my $self = shift; ... }
123              
124             and
125              
126             method bar ($arg) { ... }
127              
128             is equivalent to
129              
130             method bar ($arg) { my $self = shift; my ($arg) = @_; ... }
131              
132             In fact, it isn't just equivalent, this module literally rewrites the source
133             code in the way shown in the examples above. It does so by using a source
134             filter (boo, hiss, yes I know) to slurp the entire file, then Damian's
135             wonderfully insane L module to parse the code to find the keywords, and
136             then rewrites the source before returning the file to perl to compile.
137              
138             The wonderful part of this is that it's 100% pure perl and therefore unlike
139             every other method implementation is amenable to L use. The
140             terrible part of this is that if the parse phase doesn't work, the code has
141             no idea at all what it's doing and ends up not touching the source code at
142             all, at which point the compilation failures from the keyword rewriting not
143             having happened will almost certainly hide the actual problem.
144              
145             So, for the moment, you are strongly advised to not use this module while
146             developing code, and instead use L if you have a not
147             completely ancient perl and L if you're still
148             back in the stone age banging rocks together, and to then switch your 'use'
149             line to this module for fatpacking/shipping/etc. - I may yet come up with
150             a better solution to this and/or beg Damian for help doing so, but at the
151             time of writing I can offer no guarantees.
152              
153             Note that L requires perl 5.10 and as such so does this module. However,
154             if you need to support older perls, you can
155              
156             use Method::Signatures::PP::Compile;
157              
158             which uses ingy's L to generate a .pmc file that should run
159             fine on whatever version of perl the rest of your code requires. This will
160             likely be rewritten to use a slightly less lunatic compilation mechanism in
161             later releases.
162              
163             =head1 AUTHOR
164              
165             mst - Matt S. Trout (cpan:MSTROUT)
166              
167             =head1 CONTRIBUTORS
168              
169             None yet - maybe this software is perfect! (ahahahahahahahahaha)
170              
171             =head1 COPYRIGHT
172              
173             Copyright (c) 2017 the Method::Signatures::PP L and L
174             as listed above.
175              
176             =head1 LICENSE
177              
178             This library is free software and may be distributed under the same terms
179             as perl itself.