File Coverage

blib/lib/Filter/signatures.pm
Criterion Covered Total %
statement 72 102 70.5
branch 16 30 53.3
condition 5 20 25.0
subroutine 8 10 80.0
pod 0 3 0.0
total 101 165 61.2


line stmt bran cond sub pod time code
1             package Filter::signatures;
2 9     9   150342 use strict;
  9         36  
  9         274  
3 9     9   4923 use Filter::Simple;
  9         169496  
  9         68  
4              
5             our $VERSION = '0.18';
6              
7             =head1 NAME
8              
9             Filter::signatures - very simplistic signatures for Perl < 5.20
10              
11             =head1 SYNOPSIS
12              
13             use Filter::signatures;
14             no warnings 'experimental::signatures'; # does not raise an error
15             use feature 'signatures'; # this now works on <5.20 as well
16              
17             sub hello( $name ) {
18             print "Hello $name\n";
19             }
20              
21             hello("World");
22              
23             sub hello2( $name="world" ) {
24             print "Hello $name\n";
25             }
26             hello2(); # Hello world
27              
28             =head1 DESCRIPTION
29              
30             This module implements a backwards compatibility shim for formal Perl
31             subroutine signatures that were introduced to the Perl core with Perl 5.20.
32              
33             =head1 CAVEATS
34              
35             The technique used is a very simplistic transform to allow for using very
36             simplistic named formal arguments in subroutine declarations. This module
37             does not implement warning if more or fewer parameters than expected are
38             passed in.
39              
40             The module also implements default values for unnamed parameters by
41             splitting the formal parameters on C<< /,/ >> and assigning the values
42             if C<< @_ >> contains fewer elements than expected. Function calls
43             as default values may work by accident. Commas within default values happen
44             to work due to the design of L, which removes them for
45             the application of this filter.
46              
47             =head2 Syntax peculiarities
48              
49             Note that this module inherits all the bugs of L and
50             potentially adds some of its own.
51              
52             =head3 Slashes
53              
54             Most notable is that Filter::Simple sometimes will
55             misinterpret the division operator C<< / >> as a leading character to starting
56             a regex match:
57              
58             my $wait_time = $needed / $supply;
59              
60             This will manifest itself through syntax errors appearing where everything
61             seems in order. The hotfix is to add a comment to the code that "closes"
62             the misinterpreted regular expression:
63              
64             my $wait_time = $needed / $supply; # / for Filter::Simple
65              
66             A better hotfix is to upgrade to Perl 5.20 or higher and use the native
67             signatures support there. No other code change is needed, as this module will
68             disable its functionality when it is run on a Perl supporting signatures.
69              
70             =head3 Size operator interpreted as replacement
71              
72             Filter::Simple sometimes will
73             misinterpret the file size operator on the default filehandle C<< -s _ >>
74             as the start of a replacement
75              
76             my $filesize = -s _;
77              
78             # Misinterpreted as
79              
80             my $filesize = -(s _;..._g);
81              
82             This will manifest itself through syntax errors appearing where everything
83             seems in order. The hotfix is to indicate that C<<_>> is a filehandle by
84             prefixing it with C<<*>>:
85              
86             my $filesize = -s *_;
87              
88             A better hotfix is to upgrade to Perl 5.20 or higher and use the native
89             signatures support there. No other code change is needed, as this module will
90             disable its functionality when it is run on a Perl supporting signatures.
91              
92             =head2 Parentheses in default expressisons
93              
94             Ancient versions of Perl before version 5.10 do not have recursive regular
95             expressions. These will not be able to properly handle statements such
96             as
97              
98             sub foo ($timestamp = time()) {
99             }
100              
101             The hotfix is to rewrite these function signatures to not use parentheses. The
102             better approach is to upgrade to Perl 5.20 or higher.
103              
104             =head2 Regular expression matches in default expressions
105              
106             To keep the argument parser simple, the parsing of regular expressions has been
107             omitted. For Perl below 5.10, you cannot use regular expressions as default
108             expressions. For higher Perl versions, this means that parentheses, curly
109             braces and commas need to be explicitly escaped with a backslash when used as
110             default expressions:
111              
112             sub foo( $x = /,/ ) { # WRONG!
113             sub foo( $x = /\,/ ) { # GOOD!
114              
115             sub foo( $x = /[(]/ ) { # WRONG!
116             sub foo( $x = /[\(]/ ) { # GOOD!
117              
118             The hotfix is to rewrite these default expressions with explicitly quoted
119             commas, parentheses and curly braces. The better approach is to upgrade to
120             Perl 5.20 or higher.
121              
122             =head2 Subroutine attributes
123              
124             Subroutine attributes are currently not supported at all.
125              
126             =head2 Line Numbers
127              
128             Due to a peculiarity of how Filter::Simple treats here documents in some
129             versions, line numbers may get out of sync if you use here documents.
130              
131             If you spread your formal signatures across multiple lines, the line numbers
132             may also go out of sync with the original document.
133              
134             =head2 C<< eval >>
135              
136             L does not trigger when using
137             code such as
138              
139             eval <<'PERL';
140             use Filter::signatures;
141             use feature 'signatures';
142              
143             sub foo (...) {
144             }
145             PERL
146              
147             So, creating subroutines with signatures from strings won't work with
148             this module. The workaround is to upgrade to Perl 5.20 or higher.
149              
150             =head2 Deparsing
151              
152             The generated code does not deparse identically to the code generated on a
153             Perl with native support for signatures.
154              
155             =head1 ENVIRONMENT
156              
157             If you want to force the use of this module even under versions of
158             Perl that have native support for signatures, set
159             C<< $ENV{FORCE_FILTER_SIGNATURES} >> to a true value before the module is
160             imported.
161              
162             =cut
163              
164             my $have_signatures = eval {
165             require feature;
166             feature->import('signatures');
167             1
168             };
169              
170             sub kill_comment {
171 80     80 0 148 my( $str ) = @_;
172 80         254 my @strings = ($str =~ /$Filter::Simple::placeholder/g);
173 80         161 for my $ph (@strings) {
174 7         29 my $index = unpack('N',$ph);
175 7 100 100     26 if( ref $Filter::Simple::components[$index] and ${ $Filter::Simple::components[$index] } =~ /^#/ ) {
  6         30  
176             #warn ">> $str contains comment ${$Filter::Simple::components[$index]}";
177 4         47 $str =~ s!\Q$;$ph$;\E!!g;
178             };
179             }
180             $str
181 80         227 }
182              
183             sub parse_argument_list {
184 47     47 0 148 my( $name, $arglist, $whitespace ) = @_;
185 47         107 (my $args=$arglist) =~ s!^\(\s*(.*)\s*\)!$1!s;
186              
187 47         73 my @args;
188             # A not so simple argument parser, but still good enough for < 5.10:
189             # We want to split on the outermost commas, so we find the position of these
190             # commas by replacing everything inside parentheses and curly brackets with
191             # whitespace. Then we have the positions of the relevant commas and can extract
192             # the arguments from that. Not elegant but works everywhere:
193 47 100       121 if( length $args ) {
194 43         64 my $splitlist = $args;
195 43         88 my $repl = " " x length $;;
196 43         225 $splitlist =~ s!\Q$;\E.{4}\Q$;\E!$repl $repl!sg; # remove all string placeholders
197 43         149 1 while ($splitlist =~ s!\\.! !g); # unquote all the things
198             #warn $splitlist;
199 43         186 1 while ($splitlist =~ s!(\([^(){}]*\)|\{[^(){}]*\})!" " x length($1)!ge); # Now, remove all nested parentheses stuff
  12         74  
200             #warn $splitlist;
201 43         67 my @argument_positions;
202 43         208 while( $splitlist =~ /,/g ) {
203 37         113 push @argument_positions, pos($splitlist);
204             };
205 43         95 push @argument_positions, length( $splitlist )+1;
206 43         59 my $lastpos = 0;
207 80         167 @args = map { kill_comment($_) } map { s!^\s*!!; s!\s*$!!; $_}
  80         238  
  80         311  
  80         176  
208 43         89 map { my $r = substr $args, $lastpos, $_-$lastpos-1;
  80         162  
209             #warn "$lastpos:$_:$r";
210 80         109 $lastpos=$_;
211 80         174 $r
212             } @argument_positions
213             ;
214             };
215 47         82 my $res;
216             # Adjust how many newlines we gobble
217 47   100     106 $whitespace ||= '';
218             #warn "[[$whitespace$args]]";
219 47         193 my $padding = () = (($whitespace . $args) =~ /\n/smg);
220 47 100       114 if( @args ) {
221 43         63 my @defaults;
222 43         123 for( 0..$#args ) {
223             # Keep everything on one line
224 80         147 $args[$_] =~ s/\n/ /g;
225              
226             # Named argument with default
227 80 100       431 if( $args[$_] =~ m!^\s*([\$\%\@]\s*\w+)\s*(//=|\|\|=|=)\s*(.*)$! ) {
    100          
    100          
    50          
228 35         77 my $named = "$1";
229 35         57 my $op = "$2";
230 35         87 my $val = "$3";
231 35 100       77 if( $op eq '=' ) {
232 33         100 push @defaults, "$named $op $val if \@_ <= $_;";
233             } else {
234 2         6 push @defaults, "$named $op $val;";
235             }
236 35         104 $args[$_] = $named;
237              
238             # Named argument
239             } elsif( $args[$_] =~ /^\s*([\$\%\@]\s*\w+)\s*$/ ) {
240 40         91 my $named = "$1";
241 40         85 $args[$_] = $named;
242              
243             # Slurpy discard
244             } elsif( $args[$_] =~ /^\s*\$\s*$/ ) {
245 3         7 $args[$_] = 'undef';
246              
247             # Slurpy discard (at the end)
248             } elsif( $args[$_] =~ /^\s*[\%\@]\s*$/ ) {
249 2         6 $args[$_] = 'undef';
250             } else {
251             #use Data::Dumper;
252             #warn Dumper \@Filter::Simple::components;
253             #die "Weird, unparsed argument '$args[$_]'";
254             };
255              
256             };
257              
258             # Make sure we return undef as the last statement of our initialization
259             # See t/07*
260 43 50       129 push @defaults, "();" if @args;
261              
262 43         251 $res = sprintf 'sub %s { my (%s)=@_;%s%s', $name, join(",", @args), join( "" , @defaults), "\n" x $padding;
263             # die sprintf("Too many arguments for subroutine at %s line %d.\n", (caller)[1, 2]) unless @_ <= 2
264             # die sprintf("Too few arguments for subroutine at %s line %d.\n", (caller)[1, 2]) unless @_ >= 2
265             } else {
266 4         18 $res = sprintf 'sub %s { @_==0 or warn "Subroutine %s called with parameters.";();', $name, $name;
267             };
268              
269 47         1232 return $res
270             }
271              
272             # This is the version that is most downwards compatible but doesn't handle
273             # parentheses in default assignments
274             sub transform_arguments {
275             # This should also support
276             # sub foo($x,$y,@) { ... }, throwing away additional arguments
277             # Named or anonymous subs
278 9     9   9546 no warnings 'uninitialized';
  9         25  
  9         1465  
279             s{\bsub(\s*)(\w*)(\s*)\((\s*)((?:[^)]*?\@?))(\s*)\)(\s*)\{}{
280             parse_argument_list("$2","$5","$1$3$4$6$7")
281             }mge;
282             $_
283             }
284              
285             if( $] >= 5.010 ) {
286             # Perl 5.10 onwards has recursive regex patterns, and comments, and stuff
287              
288             # We have an interesting dependency on the format the string placeholders that
289             # Filter::Simple supplies. They MUST be four characters wide.
290 9     9   73 no warnings 'redefine';
  9         20  
  9         5749  
291 9     9 0 68 eval <<'PERL_5010_onwards';
  9     44   21  
  9         1801  
  44         108452  
  46         338  
  44         143  
292             sub transform_arguments {
293             # We also want to handle arbitrarily deeply nested balanced parentheses here
294             no warnings 'uninitialized';
295             # If you are staring at this, somewhere in your source code, you have
296             # $/ and you want to make sure there is a second slash on the same line,
297             # like `local $/; # / for Filter::signatures`
298             # Or "-s _" , this also trips up Filter::Simple. Replace by "-s *_"
299             #my $msg = $_;
300             #$msg =~ s!([\x00-\x09\x0b-\x1F])!sprintf "\\%03o", ord $1!ge;
301             #print "$msg\n---\n";
302             #use Regexp::Debugger;
303             s{(?\bsub\b) #1
304             (?>(\s*)) #2
305             (?>(\b\w+\b|)) #3
306             (\s*) #4
307             \(
308             (\s*) #5
309             ( #6
310             ( #7
311             (?:
312             \\. # regex escapes and references
313             |
314             (?>".{5}") # strings (that are placeholders)
315             |
316             (?>"[^"]+") # strings (that are not placeholders, mainly for the test suite)
317             |
318             \(
319             (?7)? # recurse for parentheses
320             \)
321             |
322             \{
323             (?7)? # recurse for curly brackets
324             \}
325             |
326             (?>[^\\\(\)\{\}"]+) # other stuff
327             )+
328             )*
329             \@? # optional slurpy discard argument at the end
330             )
331             (\s*)\)
332             (\s*)\{}{
333             parse_argument_list("$3","$6","$2$4$5$9$10")
334             }mgex;
335             $_
336             }
337             PERL_5010_onwards
338             die $@ if $@;
339             }
340              
341             sub import {
342 0     0     my( $class, $scope ) = @_;
343             # Guard against double-installation of our scanner
344 0 0 0       if( $scope and $scope eq 'global' ) {
345              
346 0           my $scan; $scan = sub {
347 0     0     my( $self, $filename ) = @_;
348              
349             # Find the filters/directories that are still applicable:
350 0           my $idx = 0;
351 0   0       $idx++ while ((!ref $INC[$idx] or $INC[$idx] != $scan) and $idx < @INC);
      0        
352 0           $idx++;
353              
354 0           my @found;
355 0           foreach my $prefix (@INC[ $idx..$#INC ]) {
356 0 0         if (ref($prefix) eq 'CODE') {
357             #... do other stuff - see text below ....
358 0           @found = $prefix->( $self, $filename );
359 0 0         if( @found ) { # we found the module
360 0           last;
361             };
362             } else {
363 0           my $realfilename = "$prefix/$filename";
364 0 0 0       next if ! -e $realfilename || -d _ || -b _;
      0        
365              
366 0 0         open my $fh, '<', $realfilename
367             or die "Couldn't read '$realfilename': $!";
368 0           @found = (undef, $fh);
369             };
370             };
371 0 0         if( !ref $found[0] ) {
372 0           $found[0] = \(my $buf = "");
373             };
374 0           ${$found[0]} .= do { local $/; my $fh = $found[1]; my $content = <$fh>; $content };
  0            
  0            
  0            
  0            
  0            
375              
376             # Prepend usages of "feature" with our filter
377 0           ${$found[0]} =~ s!\b(use\s+feature\s+(['"])signatures\2)!use Filter::signatures;\n$1!gs;
  0            
378              
379             return @found
380 0           };
  0            
381             # We need to run as early as possible to filter other modules
382 0           unshift @INC, $scan;
383             };
384             }
385              
386             if( (! $have_signatures) or $ENV{FORCE_FILTER_SIGNATURES} ) {
387             FILTER_ONLY
388             code_no_comments => \&transform_arguments,
389             executable => sub {
390             s!^\s*(use\s+feature\s*(['"])signatures\2;)!#$1!mg;
391             s!^\s*(no\s+warnings\s*(['"])experimental::signatures\2;)!#$1!mg;
392             },
393             ;
394             # Set up a fake 'experimental::signatures' warnings category
395             { package # hide from CPAN
396             experimental::signatures;
397             eval {
398             require warnings::register;
399             warnings::register->import();
400             }
401             }
402              
403             }
404              
405             1;
406              
407             =head1 USAGE WITHOUT SOURCE CODE MODIFICATION
408              
409             If you have a source file that was written for use with signatures and you
410             cannot modify that source file, you can run it as follows:
411              
412             perl -Mlib=some/directory -MFilter::signatures=global myscript.pl
413              
414             This is intended as a quick-fix solution and is not very robust. If your
415             script modifies C<@INC>, the filtering may not get a chance to modify
416             the source code of the loaded module.
417              
418             This currently does not play well with (other) hooks in C<@INC> as it
419             only handles hooks that return a filehandle. Implementations for the
420             rest are welcome.
421              
422             =head1 SEE ALSO
423              
424             L
425              
426             L, which transforms your source code directly between
427             the different notations without employing a source filter
428              
429             L - a module that doesn't use a source filter but optree
430             modification instead
431              
432             L - uses signatures to dispatch to different subroutines
433             based on which subroutine matches the signature
434              
435             L - this module implements subroutine signatures
436             closer to Perl 6, but requires L and L
437              
438             L - adds two new keywords for declaring subroutines and
439             parses their signatures. It supports more features than core Perl, closer to
440             Perl 6, but requires a C compiler and Perl 5.14+.
441              
442             =head1 REPOSITORY
443              
444             The public repository of this module is
445             L.
446              
447             =head1 SUPPORT
448              
449             The public support forum of this module is
450             L.
451              
452             =head1 BUG TRACKER
453              
454             Please report bugs in this module via the RT CPAN bug queue at
455             L
456             or via mail to L.
457              
458             =head1 AUTHOR
459              
460             Max Maischein C
461              
462             =head1 COPYRIGHT (c)
463              
464             Copyright 2015-2023 by Max Maischein C.
465              
466             =head1 LICENSE
467              
468             This module is released under the same terms as Perl itself.
469              
470             =cut