File Coverage

blib/lib/Evo/Internal/Util.pm
Criterion Covered Total %
statement 116 124 93.5
branch 31 56 55.3
condition 0 2 0.0
subroutine 23 24 95.8
pod 0 10 0.0
total 170 216 78.7


line stmt bran cond sub pod time code
1             package Evo::Internal::Util;
2 67     67   375 use strict;
  67         136  
  67         1514  
3 67     67   285 use warnings;
  67         397  
  67         1813  
4 67     67   24870 use experimental 'signatures';
  67         182884  
  67         334  
5 67     67   8452 no warnings 'experimental::signatures';
  67         141  
  67         1743  
6 67     67   329 use Carp qw(carp croak);
  67         121  
  67         2891  
7 67     67   349 use B qw(svref_2object);
  67         125  
  67         7228  
8              
9             our $RX_PKG_NOT_FIRST = qr/[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*/;
10             our $RX_PKG = qr/^[A-Z_a-z]$RX_PKG_NOT_FIRST*$/;
11              
12              
13 67     67   429 use constant SUBRE => qr/^[a-zA-Z_]\w*$/;
  67         165  
  67         13639  
14 728     728 0 4269 sub check_subname { $_[0] =~ SUBRE }
15              
16             # usefull?
17 0 0   0 0 0 sub find_caller_except ($skip_ns, $i, $caller) {
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
18 0         0 while ($caller = (caller($i++))[0]) {
19 0 0       0 return $caller if $caller ne $skip_ns;
20             }
21             }
22              
23 2069 50   2069 0 5408 sub monkey_patch ($pkg, %hash) {
  2069 50       4805  
  2069         3290  
  2069         7123  
  2069         3395  
24 67     67   465 no strict 'refs'; ## no critic
  67         135  
  67         6952  
25 2069         8189 *{"${pkg}::$_"} = $hash{$_} for keys %hash;
  5435         74302  
26             }
27              
28             #todo: decide what to do with empty subroutins
29 9 50   9 0 2657 sub monkey_patch_silent ($pkg, %hash) {
  9 50       27  
  9         121  
  9         32  
  9         16  
30 67     67   395 no strict 'refs'; ## no critic
  67         146  
  67         1596  
31 67     67   303 no warnings 'redefine';
  67         129  
  67         14099  
32 9         14 my %restore;
33 9         26 foreach my $name (keys %hash) {
34 10         19 $restore{$name} = *{"${pkg}::$name"}{CODE};
  10         44  
35 10 50 0     38 warn "Can't delete empty ${pkg}::$name" and next unless $hash{$name};
36 10         16 *{"${pkg}::$name"} = $hash{$name};
  10         35  
37             }
38 9         42 \%restore;
39             }
40              
41             # returns a package where code was declared and a name
42             # ->CONST not documented, but exists in B::CV and defined in /CORE/cv.h as
43             # define CvCONST(cv) (CvFLAGS(cv) & CVf_CONST)
44             # this flag is used by Evo::Class to determine that constants should be inherited
45 2741 50   2741 0 9897 sub code2names($r) {
  2741 50       5868  
  2741         3917  
  2741         3762  
46 2741         7171 my $sv = svref_2object($r);
47 2741         7301 my $gv = $sv->GV;
48 2741         6589 my $stash = $gv->STASH;
49 2741         13911 ($stash->NAME, $gv->NAME, $sv->CONST);
50             }
51              
52 3881 50   3881 0 10948 sub names2code ($pkg, $name) {
  3881 50       7285  
  3881         5371  
  3881         5141  
  3881         4863  
53 67     67   407 no strict 'refs'; ## no critic
  67         144  
  67         4925  
54 3881         5214 *{"${pkg}::$name"}{CODE};
  3881         16897  
55             }
56              
57              
58 62 50   62 0 1272 sub list_symbols($pkg) {
  62 50       261  
  62         119  
  62         146  
59 67     67   355 no strict 'refs'; ##no critic
  67         150  
  67         27207  
60 62         106 grep { $_ =~ /^[a-zA-Z_]\w*$/ } keys %{"${pkg}::"};
  1636         3694  
  62         376  
61             }
62              
63             #sub undef_symbols($ns) {
64             # no strict 'refs'; ## no critic
65             # undef *{"${ns}::$_"} for list_symbols($ns);
66             #}
67              
68              
69             #sub uniq {
70             # my %seen;
71             # return grep { !$seen{$_}++ } @_;
72             #}
73              
74             # returns a subroutine than can pretend a code in the other package/file/line
75 1869 50   1869 0 5021 sub inject(%opts) {
  1869         7012  
  1869         2940  
76 1869         5107 my ($package, $filename, $line, $code) = @opts{qw(package filename line code)};
77              
78             ## no critic
79             (
80 1869         110268 eval qq{package $package;
81             #line $line "$filename"
82             sub { \$code->(\@_) }
83             }
84             );
85             }
86              
87             #sub find_subnames ($pkg, $code) {
88             # no strict 'refs'; ## no critic
89             # my %symbols = %{$pkg . "::"};
90             #
91             # # because use constant adds refs to package symbols hash
92             # grep { !ref($symbols{$_}) && (*{$symbols{$_}}{CODE} // 0) == $code } keys %symbols;
93             #}
94              
95              
96 140 50   140   419 sub _parent ($caller) {
  140 50       404  
  140         255  
  140         230  
97 140         509 my @arr = split /::/, $caller;
98 140         276 pop @arr;
99 140         689 join '::', @arr;
100             }
101              
102 2566 50   2566 0 6804 sub resolve_package ($caller, $pkg) {
  2566 50       5748  
  2566         4334  
  2566         4934  
  2566         3952  
103              
104 2566 100       15588 return $pkg if $pkg =~ $RX_PKG;
105              
106 1703 100       14649 return "Evo::$1" if $pkg =~ /^\-($RX_PKG_NOT_FIRST)$/;
107              
108             # parent. TODO: many //
109 251 100       973 if ($pkg =~ /^\/(.*)$/) {
110 140         344 my $rest = $1;
111 140 100       386 my $parent = _parent($caller)
112             or croak "Can't resolve $pkg: can't find parent of caller $caller";
113              
114 139 50       2541 return "$parent$rest" if "$parent$rest" =~ /^$RX_PKG$/;
115             }
116              
117 111 100       2441 return "${caller}::$1" if $pkg =~ /^::($RX_PKG_NOT_FIRST)$/;
118              
119 4         392 croak "Can't resolve $pkg for caller $caller";
120             }
121              
122              
123 3 50   3 0 2842 sub suppress_carp ($me, $caller) {
  3 50       10  
  3         4  
  3         6  
  3         5  
124 67     67   428 no strict 'refs'; ## no critic
  67         136  
  67         5007  
125 3 100       4 push @{"${caller}::CARP_NOT"}, $me if !grep { $_ eq $me } @{"${caller}::CARP_NOT"};
  2         7  
  3         9  
  3         15  
126             }
127              
128             1;
129              
130             __END__