File Coverage

blib/lib/Method/Signatures/Utils.pm
Criterion Covered Total %
statement 35 39 89.7
branch 6 10 60.0
condition 5 6 83.3
subroutine 8 8 100.0
pod 0 4 0.0
total 54 67 80.6


line stmt bran cond sub pod time code
1             package Method::Signatures::Utils;
2              
3 63     63   235 use strict;
  63         78  
  63         1444  
4 63     63   199 use warnings;
  63         73  
  63         1135  
5 63     63   189 use Carp;
  63         60  
  63         2709  
6              
7 63     63   213 use base qw(Exporter);
  63         72  
  63         24488  
8             our @EXPORT = qw(new_ppi_doc sig_parsing_error carp_location_for DEBUG);
9              
10             sub DEBUG {
11 1476 50   1476 0 9566 return unless $Method::Signatures::DEBUG;
12              
13 0         0 require Data::Dumper;
14 0         0 local $Data::Dumper::Sortkeys = 1;
15 0 0       0 print STDERR "DEBUG: ", map { ref $_ ? Data::Dumper::Dumper($_) : $_ } @_;
  0         0  
16             }
17              
18              
19             sub new_ppi_doc {
20 327     327 0 314 my $code = shift;
21              
22 327         30541 require PPI;
23 327 50       5204672 my $ppi = PPI::Document->new($code) or
24             sig_parsing_error(
25             "source '$$code' cannot be parsed by PPI: " . PPI::Document->errstr
26             );
27              
28 327         315470 return $ppi;
29             };
30              
31              
32             # Generate cleaner error messages...
33             sub carp_location_for {
34 85     85 0 164 my ($class, $target) = @_;
35 85 100       270 $target = qr{(?!)} if !$target;
36              
37             # using @CARP_NOT here even though we're not using Carp
38             # who knows? maybe someday Carp will be capable of doing what we want
39             # until then, we're rolling our own, but @CARP_NOT is still serving roughly the same purpose
40 85         73 our @CARP_NOT;
41 85         164 local @CARP_NOT;
42 85         118 push @CARP_NOT, 'Method::Signatures';
43 85 100       81 push @CARP_NOT, $class unless $class =~ /^${\__PACKAGE__}(::|$)/;
  85         695  
44 85         160 push @CARP_NOT, qw< Class::MOP Moose Mouse Devel::Declare >;
45              
46             # Skip any package in the @CARP_NOT list or their sub packages.
47 85         180 my $carp_not_list_re = join '|', @CARP_NOT;
48 85         1015 my $skip = qr/^ $carp_not_list_re (?: :: | $ ) /x;
49              
50 85         105 my $level = 0;
51 85         73 my ($pack, $file, $line, $method);
52 85   100     69 do {
      66        
53 327         6710 ($pack, $file, $line, $method) = caller(++$level);
54             } while $method !~ $target and $method =~ /$skip/ or $pack =~ /$skip/;
55              
56 85         2353 return ($file, $line, $method);
57             }
58              
59             sub sig_parsing_error {
60 17     17 0 31 my ($file, $line) = carp_location_for(__PACKAGE__, 'Devel::Declare::linestr_callback');
61 17         58 my $msg = join('', @_, " in declaration at $file line $line.\n");
62 17         331 die($msg);
63             }
64              
65             1;