1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
|
package Data::Printer::Filter::CODE;
use strict;
use warnings;
use Data::Printer::Filter;
use Data::Printer::Common;
use Scalar::Util ();
use Fcntl;
filter 'CODE' => \&parse;
sub parse {
my ($subref, $ddp) = @_;
my $string;
my $color = 'code';
if ($ddp->deparse) {
$string = _deparse($subref, $ddp);
if ($ddp->coderef_undefined && $string =~ /\A\s*sub\s*;\s*\z/) {
$string = $ddp->coderef_undefined;
$color = 'undef';
}
}
elsif ($ddp->coderef_undefined && !_subref_is_reachable($subref)) {
$string = $ddp->coderef_undefined;
$color = 'undef';
}
else {
$string = $ddp->coderef_stub;
}
return $ddp->maybe_colorize($string, $color);
};
#######################################
### Private auxiliary helpers below ###
#######################################
sub _deparse {
my ($subref, $ddp) = @_;
require B::Deparse;
# FIXME: line below breaks encapsulation on Data::Printer::Object
my $i = $ddp->{indent} + $ddp->{_array_padding};
my $deparseopts = ["-sCi${i}v'Useless const omitted'"];
my $sub = 'sub ' . B::Deparse->new($deparseopts)->coderef2text($subref);
my $pad = $ddp->newline;
$sub =~ s/\n/$pad/gse;
return $sub;
}
sub _subref_is_reachable {
my ($subref) = @_;
require B;
my $cv = B::svref_2object($subref);
return !(B::class($cv->ROOT) eq 'NULL' && !${ $cv->const_sv });
}
1;
|
