line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
35
|
|
|
35
|
|
1610108
|
use strict; |
|
35
|
|
|
|
|
293
|
|
|
35
|
|
|
|
|
1037
|
|
2
|
35
|
|
|
35
|
|
190
|
use warnings; |
|
35
|
|
|
|
|
74
|
|
|
35
|
|
|
|
|
975
|
|
3
|
35
|
|
|
35
|
|
11088
|
use Data::Printer::Common; |
|
35
|
|
|
|
|
82
|
|
|
35
|
|
|
|
|
18471
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
package # hide from pause |
6
|
|
|
|
|
|
|
Data::Printer::Object::ClassOptions; |
7
|
23
|
|
|
23
|
|
104
|
sub parents { $_[0]->{'parents'} } |
8
|
109
|
|
|
109
|
|
495
|
sub linear_isa { $_[0]->{'linear_isa'} } |
9
|
144
|
|
|
144
|
|
564
|
sub universal { $_[0]->{'universal'} } |
10
|
90
|
|
|
90
|
|
395
|
sub expand { $_[0]->{'expand'} } |
11
|
51
|
|
|
51
|
|
255
|
sub stringify { $_[0]->{'stringify'} } |
12
|
46
|
|
|
46
|
|
118
|
sub show_reftype { $_[0]->{'show_reftype'} } |
13
|
38
|
|
|
38
|
|
124
|
sub show_overloads { $_[0]->{'show_overloads'} } |
14
|
113
|
|
|
113
|
|
344
|
sub show_methods { $_[0]->{'show_methods'} } |
15
|
68
|
|
|
68
|
|
299
|
sub sort_methods { $_[0]->{'sort_methods'} } |
16
|
0
|
|
|
0
|
|
0
|
sub show_wrapped { $_[0]->{'show_wrapped'} } |
17
|
37
|
|
|
37
|
|
82
|
sub inherited { $_[0]->{'inherited'} } |
18
|
71
|
|
|
71
|
|
184
|
sub format_inheritance { $_[0]->{'format_inheritance'} } |
19
|
94
|
|
|
94
|
|
281
|
sub parent_filters { $_[0]->{'parent_filters'} } |
20
|
46
|
|
|
46
|
|
103
|
sub internals { $_[0]->{'internals'} } |
21
|
|
|
|
|
|
|
sub new { |
22
|
246
|
|
|
246
|
|
784
|
my ($class, $params) = @_; |
23
|
246
|
|
|
|
|
591
|
my $self = { |
24
|
|
|
|
|
|
|
'linear_isa' => Data::Printer::Common::_fetch_scalar_or_default($params, 'linear_isa', 'auto'), |
25
|
|
|
|
|
|
|
'show_reftype' => Data::Printer::Common::_fetch_scalar_or_default($params, 'show_reftype', 0), |
26
|
|
|
|
|
|
|
'show_overloads' => Data::Printer::Common::_fetch_scalar_or_default($params, 'show_overloads', 1), |
27
|
|
|
|
|
|
|
'stringify' => Data::Printer::Common::_fetch_scalar_or_default($params, 'stringify', 1), |
28
|
|
|
|
|
|
|
'expand' => Data::Printer::Common::_fetch_scalar_or_default($params, 'expand', 1), |
29
|
|
|
|
|
|
|
'show_methods' => Data::Printer::Common::_fetch_anyof( |
30
|
|
|
|
|
|
|
$params, 'show_methods', 'all', [qw(none all private public)] |
31
|
|
|
|
|
|
|
), |
32
|
|
|
|
|
|
|
'inherited' => Data::Printer::Common::_fetch_anyof( |
33
|
|
|
|
|
|
|
$params, 'inherited', 'public', [qw(none all private public)] |
34
|
|
|
|
|
|
|
), |
35
|
|
|
|
|
|
|
'format_inheritance' => Data::Printer::Common::_fetch_anyof( |
36
|
|
|
|
|
|
|
$params, 'format_inheritance', 'lines', [qw(string lines)] |
37
|
|
|
|
|
|
|
), |
38
|
|
|
|
|
|
|
'parent_filters' => Data::Printer::Common::_fetch_scalar_or_default($params, 'parent_filters', 1), |
39
|
|
|
|
|
|
|
'universal' => Data::Printer::Common::_fetch_scalar_or_default($params, 'universal', 0), |
40
|
|
|
|
|
|
|
'sort_methods' => Data::Printer::Common::_fetch_scalar_or_default($params, 'sort_methods', 1), |
41
|
|
|
|
|
|
|
'show_wrapped' => Data::Printer::Common::_fetch_scalar_or_default($params, 'show_wrapped', 1), |
42
|
|
|
|
|
|
|
'internals' => Data::Printer::Common::_fetch_scalar_or_default($params, 'internals', 1), |
43
|
|
|
|
|
|
|
'parents' => Data::Printer::Common::_fetch_scalar_or_default($params, 'parents', 1), |
44
|
|
|
|
|
|
|
}; |
45
|
246
|
|
|
|
|
1044
|
return bless $self, $class; |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
1; |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
package Data::Printer::Object; |
50
|
35
|
|
|
35
|
|
301
|
use Scalar::Util (); |
|
35
|
|
|
|
|
94
|
|
|
35
|
|
|
|
|
1043
|
|
51
|
35
|
|
|
35
|
|
16454
|
use Data::Printer::Theme; |
|
35
|
|
|
|
|
93
|
|
|
35
|
|
|
|
|
1206
|
|
52
|
35
|
|
|
35
|
|
14906
|
use Data::Printer::Filter::SCALAR; # also implements LVALUE |
|
35
|
|
|
|
|
91
|
|
|
35
|
|
|
|
|
1145
|
|
53
|
35
|
|
|
35
|
|
15048
|
use Data::Printer::Filter::ARRAY; |
|
35
|
|
|
|
|
95
|
|
|
35
|
|
|
|
|
1164
|
|
54
|
35
|
|
|
35
|
|
14720
|
use Data::Printer::Filter::HASH; |
|
35
|
|
|
|
|
98
|
|
|
35
|
|
|
|
|
1154
|
|
55
|
35
|
|
|
35
|
|
14414
|
use Data::Printer::Filter::REF; |
|
35
|
|
|
|
|
104
|
|
|
35
|
|
|
|
|
1099
|
|
56
|
35
|
|
|
35
|
|
14306
|
use Data::Printer::Filter::VSTRING; |
|
35
|
|
|
|
|
99
|
|
|
35
|
|
|
|
|
1178
|
|
57
|
35
|
|
|
35
|
|
14492
|
use Data::Printer::Filter::GLOB; |
|
35
|
|
|
|
|
98
|
|
|
35
|
|
|
|
|
1227
|
|
58
|
35
|
|
|
35
|
|
14197
|
use Data::Printer::Filter::FORMAT; |
|
35
|
|
|
|
|
92
|
|
|
35
|
|
|
|
|
1049
|
|
59
|
35
|
|
|
35
|
|
14320
|
use Data::Printer::Filter::Regexp; |
|
35
|
|
|
|
|
94
|
|
|
35
|
|
|
|
|
1131
|
|
60
|
35
|
|
|
35
|
|
14717
|
use Data::Printer::Filter::CODE; |
|
35
|
|
|
|
|
91
|
|
|
35
|
|
|
|
|
1090
|
|
61
|
35
|
|
|
35
|
|
14716
|
use Data::Printer::Filter::OBJECT; |
|
35
|
|
|
|
|
90
|
|
|
35
|
|
|
|
|
1043
|
|
62
|
35
|
|
|
35
|
|
16223
|
use Data::Printer::Filter::GenericClass; |
|
35
|
|
|
|
|
96
|
|
|
35
|
|
|
|
|
3136
|
|
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
# create our basic accessors: |
65
|
|
|
|
|
|
|
my @method_names =qw( |
66
|
|
|
|
|
|
|
name show_tainted show_unicode show_readonly show_lvalue show_refcount |
67
|
|
|
|
|
|
|
show_memsize memsize_unit print_escapes scalar_quotes escape_chars |
68
|
|
|
|
|
|
|
caller_info caller_message caller_message_newline caller_message_position |
69
|
|
|
|
|
|
|
string_max string_overflow string_preserve resolve_scalar_refs |
70
|
|
|
|
|
|
|
array_max array_overflow array_preserve hash_max hash_overflow |
71
|
|
|
|
|
|
|
hash_preserve unicode_charnames colored theme show_weak |
72
|
|
|
|
|
|
|
max_depth index separator end_separator class_method class hash_separator |
73
|
|
|
|
|
|
|
align_hash sort_keys quote_keys deparse return_value show_dualvar show_tied |
74
|
|
|
|
|
|
|
warnings arrows coderef_stub coderef_undefined |
75
|
|
|
|
|
|
|
); |
76
|
|
|
|
|
|
|
foreach my $method_name (@method_names) { |
77
|
35
|
|
|
35
|
|
275
|
no strict 'refs'; |
|
35
|
|
|
|
|
93
|
|
|
35
|
|
|
|
|
172182
|
|
78
|
|
|
|
|
|
|
*{__PACKAGE__ . "::$method_name"} = sub { |
79
|
10310
|
100
|
|
10310
|
|
21137
|
$_[0]->{$method_name} = $_[1] if @_ > 1; |
80
|
10310
|
|
|
|
|
36244
|
return $_[0]->{$method_name}; |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
} |
83
|
175
|
|
|
175
|
1
|
585
|
sub extra_config { $_[0]->{extra_config} } |
84
|
|
|
|
|
|
|
|
85
|
33
|
|
|
33
|
1
|
189
|
sub current_depth { $_[0]->{_depth} } |
86
|
241
|
|
|
241
|
1
|
520
|
sub indent { $_[0]->{_depth}++ } |
87
|
240
|
|
|
240
|
1
|
557
|
sub outdent { $_[0]->{_depth}-- } |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
sub newline { |
90
|
670
|
|
|
670
|
1
|
1139
|
my ($self) = @_; |
91
|
|
|
|
|
|
|
return $self->{_linebreak} |
92
|
|
|
|
|
|
|
. (' ' x ($self->{_depth} * $self->{_current_indent})) |
93
|
|
|
|
|
|
|
. (' ' x $self->{_array_padding}) |
94
|
670
|
|
|
|
|
3137
|
; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
sub current_name { |
98
|
1545
|
|
|
1545
|
1
|
2698
|
my ($self, $new_value) = @_; |
99
|
1545
|
100
|
|
|
|
2741
|
if (defined $new_value) { |
100
|
604
|
|
|
|
|
1023
|
$self->{_current_name} = $new_value; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
else { |
103
|
941
|
100
|
|
|
|
2193
|
$self->{_current_name} = $self->name unless defined $self->{_current_name}; |
104
|
|
|
|
|
|
|
} |
105
|
1545
|
|
|
|
|
3830
|
return $self->{_current_name}; |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
sub _init { |
109
|
246
|
|
|
246
|
|
425
|
my $self = shift; |
110
|
246
|
100
|
|
|
|
934
|
my $props = { @_ == 1 ? %{$_[0]} : @_ }; |
|
64
|
|
|
|
|
301
|
|
111
|
|
|
|
|
|
|
|
112
|
246
|
|
|
|
|
776
|
$self->{'_linebreak'} = "\n"; |
113
|
246
|
|
|
|
|
480
|
$self->{'_depth'} = 0; |
114
|
246
|
|
|
|
|
497
|
$self->{'_position'} = 0; # depth is for indentation only! |
115
|
246
|
|
|
|
|
457
|
$self->{'_array_padding'} = 0; |
116
|
246
|
|
|
|
|
479
|
$self->{'_seen'} = {}; |
117
|
246
|
|
|
|
|
483
|
$self->{_refcount_base} = 3; |
118
|
246
|
|
|
|
|
844
|
$self->{'warnings'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'warning', 1); |
119
|
246
|
|
|
|
|
618
|
$self->{'indent'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'indent', 4); |
120
|
246
|
|
|
|
|
666
|
$self->{'index'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'index', 1); |
121
|
246
|
|
|
|
|
605
|
$self->{'name'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'name', 'var'); |
122
|
246
|
|
|
|
|
910
|
$self->{'arrows'} = Data::Printer::Common::_fetch_anyof( |
123
|
|
|
|
|
|
|
$props, |
124
|
|
|
|
|
|
|
'arrows', |
125
|
|
|
|
|
|
|
'none', |
126
|
|
|
|
|
|
|
[qw(none first all)] |
127
|
|
|
|
|
|
|
); |
128
|
|
|
|
|
|
|
|
129
|
246
|
|
|
|
|
705
|
$self->{'show_tainted'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_tainted', 1); |
130
|
246
|
|
|
|
|
585
|
$self->{'show_tied'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_tied', 1); |
131
|
246
|
|
|
|
|
577
|
$self->{'show_weak'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_weak', 1); |
132
|
246
|
|
|
|
|
583
|
$self->{'show_unicode'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_unicode', 0); |
133
|
246
|
|
|
|
|
575
|
$self->{'show_readonly'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_readonly', 1); |
134
|
246
|
|
|
|
|
611
|
$self->{'show_lvalue'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_lvalue', 1); |
135
|
246
|
|
|
|
|
763
|
$self->{'show_refcount'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_refcount', 0); |
136
|
246
|
|
|
|
|
572
|
$self->{'show_memsize'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'show_memsize', 0); |
137
|
246
|
|
|
|
|
783
|
$self->{'memsize_unit'} = Data::Printer::Common::_fetch_anyof( |
138
|
|
|
|
|
|
|
$props, |
139
|
|
|
|
|
|
|
'memsize_unit', |
140
|
|
|
|
|
|
|
'auto', |
141
|
|
|
|
|
|
|
[qw(auto b k m)] |
142
|
|
|
|
|
|
|
); |
143
|
246
|
|
|
|
|
682
|
$self->{'print_escapes'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'print_escapes', 0); |
144
|
246
|
|
|
|
|
603
|
$self->{'scalar_quotes'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'scalar_quotes', q(")); |
145
|
246
|
|
|
|
|
756
|
$self->{'escape_chars'} = Data::Printer::Common::_fetch_anyof( |
146
|
|
|
|
|
|
|
$props, |
147
|
|
|
|
|
|
|
'escape_chars', |
148
|
|
|
|
|
|
|
'none', |
149
|
|
|
|
|
|
|
[qw(none nonascii nonlatin1 all)] |
150
|
|
|
|
|
|
|
); |
151
|
246
|
|
|
|
|
673
|
$self->{'caller_info'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'caller_info', 0); |
152
|
246
|
|
|
|
|
582
|
$self->{'caller_message'} = Data::Printer::Common::_fetch_scalar_or_default( |
153
|
|
|
|
|
|
|
$props, |
154
|
|
|
|
|
|
|
'caller_message', |
155
|
|
|
|
|
|
|
'Printing in line __LINE__ of __FILENAME__:' |
156
|
|
|
|
|
|
|
); |
157
|
246
|
|
|
|
|
586
|
$self->{'caller_message_newline'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'caller_message_newline', 1); |
158
|
246
|
|
|
|
|
750
|
$self->{'caller_message_position'} = Data::Printer::Common::_fetch_anyof($props, 'caller_message_position', 'before', [qw(before after)]); |
159
|
246
|
|
|
|
|
610
|
$self->{'resolve_scalar_refs'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'resolve_scalar_refs', 0); |
160
|
246
|
|
|
|
|
627
|
$self->{'string_max'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'string_max', 4096); |
161
|
246
|
|
|
|
|
856
|
$self->{'string_preserve'} = Data::Printer::Common::_fetch_anyof( |
162
|
|
|
|
|
|
|
$props, |
163
|
|
|
|
|
|
|
'string_preserve', |
164
|
|
|
|
|
|
|
'begin', |
165
|
|
|
|
|
|
|
[qw(begin end middle extremes none)] |
166
|
|
|
|
|
|
|
); |
167
|
246
|
|
|
|
|
706
|
$self->{'string_overflow'} = Data::Printer::Common::_fetch_scalar_or_default( |
168
|
|
|
|
|
|
|
$props, |
169
|
|
|
|
|
|
|
'string_overflow', |
170
|
|
|
|
|
|
|
'(...skipping __SKIPPED__ chars...)' |
171
|
|
|
|
|
|
|
); |
172
|
246
|
|
|
|
|
624
|
$self->{'array_max'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'array_max', 100); |
173
|
246
|
|
|
|
|
843
|
$self->{'array_preserve'} = Data::Printer::Common::_fetch_anyof( |
174
|
|
|
|
|
|
|
$props, |
175
|
|
|
|
|
|
|
'array_preserve', |
176
|
|
|
|
|
|
|
'begin', |
177
|
|
|
|
|
|
|
[qw(begin end middle extremes none)] |
178
|
|
|
|
|
|
|
); |
179
|
246
|
|
|
|
|
696
|
$self->{'array_overflow'} = Data::Printer::Common::_fetch_scalar_or_default( |
180
|
|
|
|
|
|
|
$props, |
181
|
|
|
|
|
|
|
'array_overflow', |
182
|
|
|
|
|
|
|
'(...skipping __SKIPPED__ items...)' |
183
|
|
|
|
|
|
|
); |
184
|
246
|
|
|
|
|
578
|
$self->{'hash_max'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'hash_max', 100); |
185
|
246
|
|
|
|
|
829
|
$self->{'hash_preserve'} = Data::Printer::Common::_fetch_anyof( |
186
|
|
|
|
|
|
|
$props, |
187
|
|
|
|
|
|
|
'hash_preserve', |
188
|
|
|
|
|
|
|
'begin', |
189
|
|
|
|
|
|
|
[qw(begin end middle extremes none)] |
190
|
|
|
|
|
|
|
); |
191
|
246
|
|
|
|
|
613
|
$self->{'hash_overflow'} = Data::Printer::Common::_fetch_scalar_or_default( |
192
|
|
|
|
|
|
|
$props, |
193
|
|
|
|
|
|
|
'hash_overflow', |
194
|
|
|
|
|
|
|
'(...skipping __SKIPPED__ keys...)' |
195
|
|
|
|
|
|
|
); |
196
|
246
|
|
|
|
|
556
|
$self->{'unicode_charnames'} = Data::Printer::Common::_fetch_scalar_or_default( |
197
|
|
|
|
|
|
|
$props, |
198
|
|
|
|
|
|
|
'unicode_charnames', |
199
|
|
|
|
|
|
|
0 |
200
|
|
|
|
|
|
|
); |
201
|
246
|
|
|
|
|
571
|
$self->{'colored'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'colored', 'auto'); |
202
|
246
|
|
|
|
|
568
|
$self->{'max_depth'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'max_depth', 0); |
203
|
246
|
|
|
|
|
587
|
$self->{'separator'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'separator', ','); |
204
|
246
|
|
|
|
|
622
|
$self->{'end_separator'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'end_separator', 0); |
205
|
246
|
|
|
|
|
584
|
$self->{'class_method'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'class_method', '_data_printer'); |
206
|
246
|
|
|
|
|
1205
|
$self->{'class'} = Data::Printer::Object::ClassOptions->new($props->{'class'}); |
207
|
246
|
|
|
|
|
744
|
$self->{'hash_separator'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'hash_separator', ' '); |
208
|
246
|
|
|
|
|
636
|
$self->{'align_hash'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'align_hash', 1); |
209
|
246
|
|
|
|
|
579
|
$self->{'sort_keys'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'sort_keys', 1); |
210
|
246
|
|
|
|
|
601
|
$self->{'quote_keys'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'quote_keys', 'auto'); |
211
|
246
|
|
|
|
|
605
|
$self->{'deparse'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'deparse', 0); |
212
|
246
|
|
|
|
|
596
|
$self->{'coderef_stub'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'coderef_stub', 'sub { ... }'); |
213
|
246
|
|
|
|
|
573
|
$self->{'coderef_undefined'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'coderef_undefined', ''); |
214
|
246
|
|
|
|
|
771
|
$self->{'return_value'} = Data::Printer::Common::_fetch_anyof( |
215
|
|
|
|
|
|
|
$props, |
216
|
|
|
|
|
|
|
'return_value', |
217
|
|
|
|
|
|
|
'pass', |
218
|
|
|
|
|
|
|
[qw(pass dump void)] |
219
|
|
|
|
|
|
|
); |
220
|
246
|
|
|
|
|
809
|
$self->{'show_dualvar'} = Data::Printer::Common::_fetch_anyof( |
221
|
|
|
|
|
|
|
$props, |
222
|
|
|
|
|
|
|
'show_dualvar', |
223
|
|
|
|
|
|
|
'lax', |
224
|
|
|
|
|
|
|
[qw(lax strict off)] |
225
|
|
|
|
|
|
|
); |
226
|
|
|
|
|
|
|
|
227
|
246
|
100
|
|
|
|
865
|
if (exists $props->{as}) { |
228
|
1
|
|
|
|
|
4
|
my $msg = Data::Printer::Common::_fetch_scalar_or_default($props, 'as', ''); |
229
|
1
|
|
|
|
|
3
|
$self->{caller_info} = 1; |
230
|
1
|
|
|
|
|
3
|
$self->{caller_message} = $msg; |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
$self->multiline( |
234
|
246
|
|
|
|
|
630
|
Data::Printer::Common::_fetch_scalar_or_default($props, 'multiline', 1) |
235
|
|
|
|
|
|
|
); |
236
|
|
|
|
|
|
|
|
237
|
246
|
|
|
|
|
625
|
$self->fulldump( |
238
|
|
|
|
|
|
|
Data::Printer::Common::_fetch_scalar_or_default($props, 'fulldump', 0) |
239
|
|
|
|
|
|
|
); |
240
|
|
|
|
|
|
|
|
241
|
246
|
100
|
|
|
|
921
|
$self->output(defined $props->{output} ? $props->{output} : 'stderr'); |
242
|
246
|
|
|
|
|
825
|
$self->_load_colors($props); |
243
|
246
|
|
|
|
|
833
|
$self->_load_filters($props); |
244
|
|
|
|
|
|
|
|
245
|
246
|
|
|
|
|
381
|
my %extra_config; |
246
|
246
|
|
|
|
|
617
|
my %core_options = map { $_ => 1 } |
|
12792
|
|
|
|
|
23206
|
|
247
|
|
|
|
|
|
|
(@method_names, qw(as multiline output colors filters)); |
248
|
246
|
|
|
|
|
1381
|
foreach my $key (keys %$props) { |
249
|
765
|
100
|
|
|
|
1752
|
$extra_config{$key} = $props->{$key} unless exists $core_options{$key}; |
250
|
|
|
|
|
|
|
} |
251
|
246
|
|
|
|
|
679
|
$self->{extra_config} = \%extra_config; |
252
|
|
|
|
|
|
|
|
253
|
246
|
|
|
|
|
4200
|
return $self; |
254
|
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
sub output { |
257
|
250
|
|
|
250
|
1
|
511
|
my ($self, $new_output) = @_; |
258
|
250
|
100
|
|
|
|
621
|
if (@_ > 1) { |
259
|
246
|
|
|
|
|
593
|
$self->_load_output_handle($new_output); |
260
|
|
|
|
|
|
|
} |
261
|
250
|
|
|
|
|
560
|
return $self->{output}; |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
sub _load_output_handle { |
265
|
246
|
|
|
246
|
|
516
|
my ($self, $output) = @_; |
266
|
246
|
|
|
|
|
1288
|
my %targets = ( stdout => *STDOUT, stderr => *STDERR ); |
267
|
246
|
|
|
|
|
440
|
my $error; |
268
|
246
|
|
|
|
|
464
|
my $ref = ref $output; |
269
|
246
|
100
|
100
|
|
|
1416
|
if (!$ref and exists $targets{ lc $output }) { |
|
|
100
|
100
|
|
|
|
|
|
|
50
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
270
|
241
|
|
|
|
|
620
|
$self->{output} = lc $output; |
271
|
241
|
|
|
|
|
771
|
$self->{output_handle} = $targets{ $self->{output} }; |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
elsif ( ( $ref and $ref eq 'GLOB') |
274
|
|
|
|
|
|
|
or (!$ref and \$output =~ /GLOB\([^()]+\)$/) |
275
|
|
|
|
|
|
|
) { |
276
|
3
|
|
|
|
|
9
|
$self->{output} = 'handle'; |
277
|
3
|
|
|
|
|
7
|
$self->{output_handle} = $output; |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
elsif (!$ref or $ref eq 'SCALAR') { |
280
|
2
|
50
|
|
1
|
|
78
|
if (open my $fh, '>>', $output) { |
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
15
|
|
281
|
2
|
|
|
|
|
890
|
$self->{output} = 'file'; |
282
|
2
|
|
|
|
|
6
|
$self->{output_handle} = $fh; |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
else { |
285
|
0
|
|
|
|
|
0
|
$error = "file '$output': $!"; |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
else { |
289
|
0
|
|
|
|
|
0
|
$error = 'unknown output data'; |
290
|
|
|
|
|
|
|
} |
291
|
246
|
50
|
|
|
|
577
|
if ($error) { |
292
|
0
|
|
|
|
|
0
|
Data::Printer::Common::_warn($self, "error opening custom output handle: $error"); |
293
|
0
|
|
|
|
|
0
|
$self->{output_handle} = $targets{'stderr'} |
294
|
|
|
|
|
|
|
} |
295
|
246
|
|
|
|
|
743
|
return; |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
sub new { |
299
|
246
|
|
|
246
|
1
|
112236
|
my $class = shift; |
300
|
246
|
|
|
|
|
615
|
my $self = bless {}, $class; |
301
|
246
|
|
|
|
|
747
|
return $self->_init(@_); |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
sub multiline { |
305
|
315
|
|
|
315
|
1
|
697
|
my ($self, $value) = @_; |
306
|
315
|
100
|
|
|
|
806
|
if (defined $value) { |
307
|
246
|
|
|
|
|
605
|
$self->{multiline} = !!$value; |
308
|
246
|
100
|
|
|
|
606
|
if ($value) { |
309
|
209
|
|
|
|
|
406
|
$self->{_linebreak} = "\n"; |
310
|
209
|
|
|
|
|
427
|
$self->{_current_indent} = $self->{indent}; |
311
|
|
|
|
|
|
|
$self->index( $self->{_original_index} ) |
312
|
209
|
50
|
|
|
|
526
|
if exists $self->{_original_index}; |
313
|
|
|
|
|
|
|
$self->hash_separator( $self->{_original_separator} ) |
314
|
209
|
50
|
|
|
|
490
|
if exists $self->{_original_separator}; |
315
|
|
|
|
|
|
|
$self->array_overflow( $self->{_original_array_overflow} ) |
316
|
209
|
50
|
|
|
|
458
|
if exists $self->{_original_array_overflow}; |
317
|
|
|
|
|
|
|
$self->hash_overflow( $self->{_original_hash_overflow} ) |
318
|
209
|
50
|
|
|
|
499
|
if exists $self->{_original_hash_overflow}; |
319
|
|
|
|
|
|
|
$self->string_overflow( $self->{_original_string_overflow} ) |
320
|
209
|
50
|
|
|
|
558
|
if exists $self->{_original_string_overflow}; |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
else { |
323
|
37
|
|
|
|
|
94
|
$self->{_original_index} = $self->index; |
324
|
37
|
|
|
|
|
145
|
$self->index(0); |
325
|
37
|
|
|
|
|
92
|
$self->{_original_separator} = $self->hash_separator; |
326
|
37
|
|
|
|
|
104
|
$self->hash_separator(':'); |
327
|
37
|
|
|
|
|
114
|
$self->{_original_array_overflow} = $self->array_overflow; |
328
|
37
|
|
|
|
|
94
|
$self->array_overflow('(...)'); |
329
|
37
|
|
|
|
|
102
|
$self->{_original_hash_overflow} = $self->hash_overflow; |
330
|
37
|
|
|
|
|
92
|
$self->hash_overflow('(...)'); |
331
|
37
|
|
|
|
|
91
|
$self->{_original_string_overflow} = $self->string_overflow; |
332
|
37
|
|
|
|
|
88
|
$self->string_overflow('(...)'); |
333
|
37
|
|
|
|
|
66
|
$self->{_linebreak} = ' '; |
334
|
37
|
|
|
|
|
93
|
$self->{_current_indent} = 0; |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
} |
337
|
315
|
|
|
|
|
826
|
return $self->{multiline}; |
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
sub fulldump { |
341
|
246
|
|
|
246
|
1
|
539
|
my ($self, $value) = @_; |
342
|
246
|
50
|
|
|
|
654
|
if (defined $value) { |
343
|
246
|
|
|
|
|
564
|
$self->{fulldump} = !!$value; |
344
|
246
|
50
|
|
|
|
530
|
if ($value) { |
345
|
0
|
|
|
|
|
0
|
$self->{_original_string_max} = $self->string_max; |
346
|
0
|
|
|
|
|
0
|
$self->string_max(0); |
347
|
0
|
|
|
|
|
0
|
$self->{_original_array_max} = $self->array_max; |
348
|
0
|
|
|
|
|
0
|
$self->array_max(0); |
349
|
0
|
|
|
|
|
0
|
$self->{_original_hash_max} = $self->hash_max; |
350
|
0
|
|
|
|
|
0
|
$self->hash_max(0); |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
else { |
353
|
|
|
|
|
|
|
$self->string_max($self->{_original_string_max}) |
354
|
246
|
50
|
|
|
|
584
|
if exists $self->{_original_string_max}; |
355
|
|
|
|
|
|
|
$self->array_max($self->{_original_array_max}) |
356
|
246
|
50
|
|
|
|
569
|
if exists $self->{_original_array_max}; |
357
|
|
|
|
|
|
|
$self->hash_max($self->{_original_hash_max}) |
358
|
246
|
50
|
|
|
|
673
|
if exists $self->{_original_hash_max}; |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
sub _load_filters { |
364
|
246
|
|
|
246
|
|
561
|
my ($self, $props) = @_; |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
# load our core filters (LVALUE is under the 'SCALAR' filter module) |
367
|
246
|
|
|
|
|
803
|
my @core_filters = qw(SCALAR ARRAY HASH REF VSTRING GLOB FORMAT Regexp CODE OBJECT GenericClass); |
368
|
246
|
|
|
|
|
558
|
foreach my $class (@core_filters) { |
369
|
2706
|
|
|
|
|
5644
|
$self->_load_external_filter($class); |
370
|
|
|
|
|
|
|
} |
371
|
246
|
|
|
|
|
438
|
my @filters; |
372
|
|
|
|
|
|
|
# load any custom filters provided by the user |
373
|
246
|
100
|
|
|
|
738
|
if (exists $props->{filters}) { |
374
|
39
|
50
|
|
|
|
168
|
if (ref $props->{filters} eq 'HASH') { |
|
|
50
|
|
|
|
|
|
375
|
0
|
|
|
|
|
0
|
Data::Printer::Common::_warn( |
376
|
|
|
|
|
|
|
$self, |
377
|
|
|
|
|
|
|
'please update your code: filters => { ... } is now filters => [{ ... }]' |
378
|
|
|
|
|
|
|
); |
379
|
0
|
|
|
|
|
0
|
push @filters, $props->{filters}; |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
elsif (ref $props->{filters} eq 'ARRAY') { |
382
|
39
|
|
|
|
|
58
|
@filters = @{ $props->{filters} }; |
|
39
|
|
|
|
|
102
|
|
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
else { |
385
|
0
|
|
|
|
|
0
|
Data::Printer::Common::_warn($self, 'filters must be an ARRAY reference'); |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
} |
388
|
246
|
|
|
|
|
538
|
foreach my $filter (@filters) { |
389
|
41
|
|
|
|
|
122
|
my $filter_reftype = Scalar::Util::reftype($filter); |
390
|
41
|
100
|
|
|
|
102
|
if (!defined $filter_reftype) { |
|
|
50
|
|
|
|
|
|
391
|
26
|
|
|
|
|
67
|
$self->_load_external_filter($filter); |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
elsif ($filter_reftype eq 'HASH') { |
394
|
15
|
|
|
|
|
55
|
foreach my $k (keys %$filter) { |
395
|
47
|
50
|
|
|
|
95
|
if ($k eq '-external') { |
396
|
0
|
|
|
|
|
0
|
Data::Printer::Common::_warn( |
397
|
|
|
|
|
|
|
$self, |
398
|
|
|
|
|
|
|
'please update your code: ' |
399
|
|
|
|
|
|
|
. 'filters => { -external => [qw(Foo Bar)}' |
400
|
|
|
|
|
|
|
. ' is now filters => [qw(Foo Bar)]' |
401
|
|
|
|
|
|
|
); |
402
|
0
|
|
|
|
|
0
|
next; |
403
|
|
|
|
|
|
|
} |
404
|
47
|
50
|
|
|
|
117
|
if (Scalar::Util::reftype($filter->{$k}) eq 'CODE') { |
405
|
47
|
|
|
|
|
92
|
my $type = Data::Printer::Common::_filter_category_for($k); |
406
|
47
|
|
|
|
|
73
|
unshift @{ $self->{$type}{$k} }, $filter->{$k}; |
|
47
|
|
|
|
|
142
|
|
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
else { |
409
|
0
|
|
|
|
|
0
|
Data::Printer::Common::_warn( |
410
|
|
|
|
|
|
|
$self, |
411
|
|
|
|
|
|
|
'hash filters must point to a CODE reference' |
412
|
|
|
|
|
|
|
); |
413
|
|
|
|
|
|
|
} |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
else { |
417
|
0
|
|
|
|
|
0
|
Data::Printer::Common::_warn($self, 'filters must be a name or { type => sub {...} }'); |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
} |
420
|
246
|
|
|
|
|
730
|
return; |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
sub _load_external_filter { |
424
|
2732
|
|
|
2732
|
|
5672
|
my ($self, $class) = @_; |
425
|
2732
|
|
|
|
|
6051
|
my $module = "Data::Printer::Filter::$class"; |
426
|
2732
|
|
|
|
|
7779
|
my $error = Data::Printer::Common::_tryme("use $module; 1;"); |
427
|
2732
|
50
|
|
|
|
6470
|
if ($error) { |
428
|
0
|
|
|
|
|
0
|
Data::Printer::Common::_warn($self, "error loading filter '$class': $error"); |
429
|
0
|
|
|
|
|
0
|
return; |
430
|
|
|
|
|
|
|
} |
431
|
2732
|
|
|
|
|
9247
|
my $from_module = $module->_filter_list; |
432
|
2732
|
|
|
|
|
8469
|
foreach my $kind (keys %$from_module) { |
433
|
2732
|
|
|
|
|
4151
|
foreach my $name (keys %{$from_module->{$kind}}) { |
|
2732
|
|
|
|
|
6762
|
|
434
|
3220
|
|
|
|
|
4422
|
unshift @{ $self->{$kind}{$name} }, @{ $from_module->{$kind}{$name} }; |
|
3220
|
|
|
|
|
7742
|
|
|
3220
|
|
|
|
|
9914
|
|
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
} |
437
|
2732
|
|
|
|
|
7065
|
return; |
438
|
|
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
sub _detect_color_level { |
441
|
246
|
|
|
246
|
|
462
|
my ($self) = @_; |
442
|
246
|
|
|
|
|
547
|
my $colored = $self->colored; |
443
|
246
|
|
|
|
|
410
|
my $color_level; |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
# first we honour ANSI_COLORS_DISABLED, colored and writing to files |
446
|
246
|
100
|
33
|
|
|
844
|
if ( !$colored |
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
447
|
|
|
|
|
|
|
|| ($colored eq 'auto' |
448
|
|
|
|
|
|
|
&& (exists $ENV{ANSI_COLORS_DISABLED} |
449
|
|
|
|
|
|
|
|| $self->output eq 'handle' |
450
|
|
|
|
|
|
|
|| $self->output eq 'file' |
451
|
|
|
|
|
|
|
) |
452
|
|
|
|
|
|
|
) |
453
|
|
|
|
|
|
|
) { |
454
|
241
|
|
|
|
|
415
|
$color_level = 0; |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
else { |
457
|
|
|
|
|
|
|
# NOTE: we could try `tput colors` but it may not give |
458
|
|
|
|
|
|
|
# the proper result, so instead we do what most terminals |
459
|
|
|
|
|
|
|
# currently do and rely on environment variables. |
460
|
5
|
50
|
33
|
|
|
123
|
if ($ENV{COLORTERM} && $ENV{COLORTERM} eq 'truecolor') { |
|
|
50
|
33
|
|
|
|
|
|
|
50
|
33
|
|
|
|
|
|
|
50
|
33
|
|
|
|
|
|
|
50
|
33
|
|
|
|
|
|
|
0
|
33
|
|
|
|
|
461
|
0
|
|
|
|
|
0
|
$color_level = 3; |
462
|
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
|
elsif ($ENV{TERM_PROGRAM} && $ENV{TERM_PROGRAM} eq 'iTerm.app') { |
464
|
0
|
|
0
|
|
|
0
|
my $major_version = substr($ENV{TERM_PROGRAM_VERSION} || '0', 0, 1); |
465
|
0
|
0
|
|
|
|
0
|
$color_level = $major_version >= 3 ? 3 : 2; |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
elsif ($ENV{TERM_PROGRAM} && $ENV{TERM_PROGRAM} eq 'Apple_Terminal') { |
468
|
0
|
|
|
|
|
0
|
$color_level= 2; |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
elsif ($ENV{TERM} && $ENV{TERM} =~ /\-256(?:color)?\z/i) { |
471
|
0
|
|
|
|
|
0
|
$color_level = 2; |
472
|
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
elsif ($ENV{TERM} |
474
|
|
|
|
|
|
|
&& ($ENV{TERM} =~ /\A(?:screen|xterm|vt100|rxvt)/i |
475
|
|
|
|
|
|
|
|| $ENV{TERM} =~ /color|ansi|cygwin|linux/i) |
476
|
|
|
|
|
|
|
) { |
477
|
5
|
|
|
|
|
14
|
$color_level = 1; |
478
|
|
|
|
|
|
|
} |
479
|
|
|
|
|
|
|
elsif ($ENV{COLORTERM}) { |
480
|
0
|
|
|
|
|
0
|
$color_level = 1; |
481
|
|
|
|
|
|
|
} |
482
|
|
|
|
|
|
|
else { |
483
|
0
|
0
|
|
|
|
0
|
$color_level = $colored eq 'auto' ? 0 : 1; |
484
|
|
|
|
|
|
|
} |
485
|
|
|
|
|
|
|
} |
486
|
246
|
|
|
|
|
794
|
return $color_level; |
487
|
|
|
|
|
|
|
} |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
sub _load_colors { |
490
|
246
|
|
|
246
|
|
513
|
my ($self, $props) = @_; |
491
|
|
|
|
|
|
|
|
492
|
246
|
|
|
|
|
583
|
$self->{_output_color_level} = $self->_detect_color_level; |
493
|
|
|
|
|
|
|
|
494
|
246
|
|
|
|
|
396
|
my $theme_object; |
495
|
246
|
|
|
|
|
444
|
my $default_theme = 'Material'; |
496
|
246
|
|
|
|
|
771
|
my $theme_name = Data::Printer::Common::_fetch_scalar_or_default($props, 'theme', $default_theme); |
497
|
|
|
|
|
|
|
$theme_object = Data::Printer::Theme->new( |
498
|
|
|
|
|
|
|
name => $theme_name, |
499
|
|
|
|
|
|
|
color_overrides => $props->{colors}, |
500
|
|
|
|
|
|
|
color_level => $self->{_output_color_level}, |
501
|
246
|
|
|
|
|
1484
|
ddp => $self, |
502
|
|
|
|
|
|
|
); |
503
|
246
|
50
|
|
|
|
799
|
if (!$theme_object) { |
504
|
0
|
0
|
|
|
|
0
|
if ($theme_name ne $default_theme) { |
505
|
|
|
|
|
|
|
$theme_object = Data::Printer::Theme->new( |
506
|
|
|
|
|
|
|
name => $default_theme, |
507
|
|
|
|
|
|
|
color_overrides => $props->{colors}, |
508
|
|
|
|
|
|
|
color_level => $self->{_output_color_level}, |
509
|
0
|
|
|
|
|
0
|
ddp => $self, |
510
|
|
|
|
|
|
|
); |
511
|
|
|
|
|
|
|
} |
512
|
0
|
0
|
|
|
|
0
|
Data::Printer::Common::_die("Unable to load default theme. This should never happen - please contact the author") unless $theme_object; |
513
|
|
|
|
|
|
|
} |
514
|
246
|
|
|
|
|
683
|
$self->{theme} = $theme_object; |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
sub _filters_for_type { |
518
|
681
|
|
|
681
|
|
1266
|
my ($self, $type) = @_; |
519
|
681
|
50
|
|
|
|
1565
|
return exists $self->{type_filters}{$type} ? @{ $self->{type_filters}{$type} } : (); |
|
681
|
|
|
|
|
1694
|
|
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
sub _filters_for_class { |
523
|
883
|
|
|
883
|
|
1549
|
my ($self, $type) = @_; |
524
|
883
|
100
|
|
|
|
2089
|
return exists $self->{class_filters}{$type} ? @{ $self->{class_filters}{$type} } : (); |
|
133
|
|
|
|
|
305
|
|
525
|
|
|
|
|
|
|
} |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
sub _filters_for_data { |
528
|
642
|
|
|
642
|
|
1168
|
my ($self, $data) = @_; |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
# we favour reftype() over ref() because you could have |
531
|
|
|
|
|
|
|
# a HASH.pm (or ARRAY.pm or whatever) blessing any variable. |
532
|
642
|
|
|
|
|
1498
|
my $ref_kind = Scalar::Util::reftype($data); |
533
|
642
|
50
|
|
|
|
1317
|
$ref_kind = 'SCALAR' unless $ref_kind; |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
# ref() returns 'Regexp' but reftype() returns 'REGEXP', so we picked one: |
536
|
642
|
100
|
|
|
|
1352
|
$ref_kind = 'Regexp' if $ref_kind eq 'REGEXP'; |
537
|
|
|
|
|
|
|
|
538
|
642
|
|
|
|
|
930
|
my @potential_filters; |
539
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
# first, try class name + full inheritance for a specific name. |
541
|
642
|
|
|
|
|
1313
|
my $class = Scalar::Util::blessed($data); |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
# a regular regexp is blessed, but in that case we want a |
544
|
|
|
|
|
|
|
# regexp filter, not a class filter. |
545
|
642
|
100
|
100
|
|
|
1637
|
if (defined $class && $class eq 'Regexp') { |
546
|
5
|
50
|
0
|
|
|
44
|
if ($ref_kind eq 'Regexp' || ($] < 5.011 && $ref_kind eq 'SCALAR')) { |
|
|
|
33
|
|
|
|
|
547
|
5
|
|
|
|
|
18
|
$ref_kind = 'Regexp'; |
548
|
5
|
|
|
|
|
11
|
undef $class; |
549
|
|
|
|
|
|
|
} |
550
|
|
|
|
|
|
|
} |
551
|
642
|
100
|
|
|
|
1289
|
if (defined $class) { |
552
|
94
|
100
|
|
|
|
229
|
if ($self->class->parent_filters) { |
553
|
93
|
|
|
|
|
257
|
my $linear_ISA = Data::Printer::Common::_linear_ISA_for($class, $self); |
554
|
93
|
|
|
|
|
222
|
foreach my $candidate_class (@$linear_ISA) { |
555
|
146
|
|
|
|
|
276
|
push @potential_filters, $self->_filters_for_class($candidate_class); |
556
|
|
|
|
|
|
|
} |
557
|
|
|
|
|
|
|
} |
558
|
|
|
|
|
|
|
else { |
559
|
1
|
|
|
|
|
3
|
push @potential_filters, $self->_filters_for_class($class); |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
# next, let any '-class' filters have a go: |
562
|
94
|
|
|
|
|
206
|
push @potential_filters, $self->_filters_for_class('-class'); |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
# then, try regular data filters |
566
|
642
|
|
|
|
|
1345
|
push @potential_filters, $self->_filters_for_type($ref_kind); |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
# finally, if it's neither a class nor a known core type, |
569
|
|
|
|
|
|
|
# we must be in a future perl with some type we're unaware of: |
570
|
642
|
|
|
|
|
1739
|
push @potential_filters, $self->_filters_for_class('-unknown'); |
571
|
|
|
|
|
|
|
|
572
|
642
|
|
|
|
|
1624
|
return @potential_filters; |
573
|
|
|
|
|
|
|
} |
574
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
# _see($data): marks data as seen if it was never seen before. |
576
|
|
|
|
|
|
|
# if we are showing refcounts, we return those. Initially we had |
577
|
|
|
|
|
|
|
# this funcionallity separated, but refcounts increase as we find |
578
|
|
|
|
|
|
|
# them again and because of that we were seeing weird refcounting. |
579
|
|
|
|
|
|
|
# So now instead we store the refcount of the variable when we |
580
|
|
|
|
|
|
|
# first see it. |
581
|
|
|
|
|
|
|
# Finally, if we have already seen the data, we return its stringified |
582
|
|
|
|
|
|
|
# position, like "var", "var{foo}[7]", etc. UNLESS $options{seen_override} |
583
|
|
|
|
|
|
|
# is set. Why seen_override? Sometimes we want to print the same data |
584
|
|
|
|
|
|
|
# twice, like the GenericClass filter, which prints the object's metadata |
585
|
|
|
|
|
|
|
# via parse() and then the internal structure via parse_as(). But if we |
586
|
|
|
|
|
|
|
# simply do that, we'd get the "seen" version (because we have already |
587
|
|
|
|
|
|
|
# visited it!) The refcount is still calculated only once though :) |
588
|
|
|
|
|
|
|
sub _see { |
589
|
714
|
|
|
714
|
|
1613
|
my ($self, $data, %options) = @_; |
590
|
714
|
100
|
|
|
|
1633
|
return {} unless ref $data; |
591
|
712
|
|
|
|
|
2738
|
my $id = pack 'J', Scalar::Util::refaddr($data); |
592
|
712
|
100
|
|
|
|
1790
|
if (!exists $self->{_seen}{$id}) { |
593
|
639
|
100
|
|
|
|
1321
|
my $entry = { |
594
|
|
|
|
|
|
|
name => $self->current_name, |
595
|
|
|
|
|
|
|
refcount => ($self->show_refcount ? $self->_refcount($data) : 0), |
596
|
|
|
|
|
|
|
}; |
597
|
|
|
|
|
|
|
# the values returned by tied hashes are temporaries, so we can't |
598
|
|
|
|
|
|
|
# mark them as 'seen'. Ideally, we'd use something like |
599
|
|
|
|
|
|
|
# Hash::Util::Fieldhash::register() (see PR#179) and remove entries |
600
|
|
|
|
|
|
|
# from $self->{_seen} when $data is destroyed. The problem is this |
601
|
|
|
|
|
|
|
# adds a lot of internal magic to the data we're inspecting (we tried, |
602
|
|
|
|
|
|
|
# see Issue#75), effectively changing it. So we just ignore them, at |
603
|
|
|
|
|
|
|
# the risk of missing some circular reference. |
604
|
639
|
100
|
|
|
|
2338
|
$self->{_seen}{$id} = $entry unless $options{tied_parent}; |
605
|
639
|
|
|
|
|
2169
|
return { refcount => $entry->{refcount} }; |
606
|
|
|
|
|
|
|
} |
607
|
73
|
100
|
|
|
|
359
|
return { refcount => $self->{_seen}{$id}->{refcount} } if $options{seen_override}; |
608
|
33
|
|
|
|
|
89
|
return $self->{_seen}{$id}; |
609
|
|
|
|
|
|
|
} |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
sub seen { |
612
|
3
|
|
|
3
|
1
|
7
|
my ($self, $data) = @_; |
613
|
3
|
|
|
|
|
9
|
my $id = pack 'J', Scalar::Util::refaddr($data); |
614
|
3
|
|
|
|
|
10
|
return exists $self->{_seen}{$id}; |
615
|
|
|
|
|
|
|
} |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
sub unsee { |
618
|
20
|
|
|
20
|
1
|
34
|
my ($self, $data) = @_; |
619
|
20
|
50
|
33
|
|
|
46
|
return unless ref $data && keys %{$self->{_seen}}; |
|
20
|
|
|
|
|
65
|
|
620
|
|
|
|
|
|
|
|
621
|
20
|
|
|
|
|
60
|
my $id = pack 'J', Scalar::Util::refaddr($data); |
622
|
20
|
|
|
|
|
55
|
delete $self->{_seen}{$id}; |
623
|
20
|
|
|
|
|
40
|
return; |
624
|
|
|
|
|
|
|
} |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
sub _refcount { |
627
|
74
|
|
|
74
|
|
179
|
my ($self, $data) = @_; |
628
|
|
|
|
|
|
|
|
629
|
74
|
|
|
|
|
399
|
require B; |
630
|
74
|
|
|
|
|
121
|
my $count; |
631
|
74
|
|
|
|
|
345
|
my $rv = B::svref_2object(\$data)->RV; |
632
|
74
|
100
|
66
|
|
|
306
|
if (ref($data) eq 'REF' && ref($$data)) { |
633
|
25
|
|
|
|
|
90
|
$rv = B::svref_2object($data)->RV; |
634
|
|
|
|
|
|
|
} |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
# some SV's are special (represented by B::SPECIAL) |
637
|
|
|
|
|
|
|
# and don't have a ->REFCNT (e.g. \undef) |
638
|
74
|
50
|
|
|
|
330
|
return 0 unless $rv->can( 'REFCNT' ); |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
# 3 is our magical number: so we return the actual reference count |
641
|
|
|
|
|
|
|
# minus the references we added as we were traversing: |
642
|
74
|
|
|
|
|
335
|
return $rv->REFCNT - $self->{_refcount_base}; |
643
|
|
|
|
|
|
|
} |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
sub parse_as { |
646
|
39
|
|
|
39
|
1
|
101
|
my ($self, $type, $data) = @_; |
647
|
39
|
|
|
|
|
120
|
return $self->parse($data, force_type => $type, seen_override => 1); |
648
|
|
|
|
|
|
|
} |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
# parse() must always receive a reference, never a regular copy, because |
651
|
|
|
|
|
|
|
# that's the only way we are able to figure whether the source data |
652
|
|
|
|
|
|
|
# is a weak ref or not. |
653
|
|
|
|
|
|
|
sub parse { |
654
|
714
|
|
|
714
|
1
|
25034
|
my $self = shift; |
655
|
714
|
|
|
|
|
1710
|
my $str_weak = $self->_check_weak( $_[0] ); |
656
|
|
|
|
|
|
|
|
657
|
714
|
|
|
|
|
1829
|
my ($data, %options) = @_; |
658
|
714
|
|
|
|
|
1136
|
my $parsed_string = ''; |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
# if we've seen this structure before, we return its location |
661
|
|
|
|
|
|
|
# instead of going through it again. This avoids infinite loops |
662
|
|
|
|
|
|
|
# when parsing circular references: |
663
|
714
|
|
|
|
|
2016
|
my $seen = $self->_see($data, %options); |
664
|
714
|
100
|
|
|
|
1804
|
if (my $name = $seen->{name}) { |
665
|
33
|
50
|
66
|
|
|
157
|
$parsed_string .= $self->maybe_colorize( |
666
|
|
|
|
|
|
|
((ref $data eq 'SCALAR' && $self->resolve_scalar_refs) |
667
|
|
|
|
|
|
|
? $$data |
668
|
|
|
|
|
|
|
: $name |
669
|
|
|
|
|
|
|
), |
670
|
|
|
|
|
|
|
'repeated' |
671
|
|
|
|
|
|
|
); |
672
|
|
|
|
|
|
|
# on repeated references, the only extra data we put |
673
|
|
|
|
|
|
|
# is whether this reference is weak or not. |
674
|
33
|
|
|
|
|
72
|
$parsed_string .= $str_weak; |
675
|
33
|
|
|
|
|
131
|
return $parsed_string; |
676
|
|
|
|
|
|
|
} |
677
|
681
|
|
|
|
|
1130
|
$self->{_position}++; |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
# Each filter type provides an array of potential parsers. |
680
|
|
|
|
|
|
|
# Once we find the right kind, we go through all of them, |
681
|
|
|
|
|
|
|
# from most precise match to most generic. |
682
|
|
|
|
|
|
|
# The first filter that returns a defined value "wins" |
683
|
|
|
|
|
|
|
# (even if it's an empty string) |
684
|
681
|
100
|
|
|
|
1859
|
foreach my $filter ( |
685
|
|
|
|
|
|
|
exists $options{force_type} |
686
|
|
|
|
|
|
|
? $self->_filters_for_type($options{force_type}) |
687
|
|
|
|
|
|
|
: $self->_filters_for_data($data) |
688
|
|
|
|
|
|
|
) { |
689
|
682
|
100
|
|
|
|
2080
|
if (defined (my $result = $filter->($data, $self))) { |
690
|
681
|
|
|
|
|
1485
|
$parsed_string .= $result; |
691
|
681
|
|
|
|
|
1257
|
last; |
692
|
|
|
|
|
|
|
} |
693
|
|
|
|
|
|
|
} |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
# FIXME: because of prototypes, p(@data) becomes a ref (that we don't care about) |
696
|
|
|
|
|
|
|
# to the data (that we do care about). So we should not show refcounts, memsize |
697
|
|
|
|
|
|
|
# or readonly status for something guaranteed to be ephemeral. |
698
|
681
|
|
|
|
|
1601
|
$parsed_string .= $self->_check_readonly($data); |
699
|
681
|
100
|
|
|
|
1786
|
$parsed_string .= $str_weak if ref($data) ne 'REF'; |
700
|
681
|
|
|
|
|
1528
|
$parsed_string .= $self->_check_memsize($data); |
701
|
|
|
|
|
|
|
|
702
|
681
|
100
|
100
|
|
|
1365
|
if ($self->show_refcount && ref($data) ne 'SCALAR' && $seen->{refcount} > 1 ) { |
|
|
|
100
|
|
|
|
|
703
|
20
|
|
|
|
|
79
|
$parsed_string .= ' (refcount: ' . $seen->{refcount} .')'; |
704
|
|
|
|
|
|
|
} |
705
|
|
|
|
|
|
|
|
706
|
681
|
100
|
|
|
|
1594
|
if (--$self->{'_position'} == 0) { |
707
|
305
|
|
|
|
|
1114
|
$self->{'_seen'} = {}; |
708
|
305
|
|
|
|
|
566
|
$self->{'_refcount_base'} = 3; |
709
|
305
|
|
|
|
|
492
|
$self->{'_position'} = 0; |
710
|
|
|
|
|
|
|
} |
711
|
|
|
|
|
|
|
|
712
|
681
|
|
|
|
|
3831
|
return $parsed_string; |
713
|
|
|
|
|
|
|
} |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
sub _check_memsize { |
716
|
681
|
|
|
681
|
|
1218
|
my ($self, $data) = @_; |
717
|
|
|
|
|
|
|
return '' unless $self->show_memsize |
718
|
|
|
|
|
|
|
&& ( $self->show_memsize eq 'all' |
719
|
681
|
50
|
0
|
|
|
1227
|
|| $self->show_memsize >= $self->{_position}); |
|
|
|
33
|
|
|
|
|
720
|
0
|
|
|
|
|
0
|
my $size; |
721
|
|
|
|
|
|
|
my $unit; |
722
|
|
|
|
|
|
|
my $error = Data::Printer::Common::_tryme(sub { |
723
|
0
|
|
|
0
|
|
0
|
require Devel::Size; |
724
|
0
|
|
|
|
|
0
|
$size = Devel::Size::total_size($data); |
725
|
0
|
|
|
|
|
0
|
$unit = uc $self->memsize_unit; |
726
|
0
|
0
|
0
|
|
|
0
|
if ($unit eq 'M' || ($unit eq 'AUTO' && $size > 1024*1024)) { |
|
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
727
|
0
|
|
|
|
|
0
|
$size = $size / (1024*1024); |
728
|
0
|
|
|
|
|
0
|
$unit = 'M'; |
729
|
|
|
|
|
|
|
} |
730
|
|
|
|
|
|
|
elsif ($unit eq 'K' || ($unit eq 'AUTO' && $size > 1024)) { |
731
|
0
|
|
|
|
|
0
|
$size = $size / 1024; |
732
|
0
|
|
|
|
|
0
|
$unit = 'K'; |
733
|
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
|
else { |
735
|
0
|
|
|
|
|
0
|
$unit = 'B'; |
736
|
|
|
|
|
|
|
} |
737
|
0
|
|
|
|
|
0
|
}); |
738
|
0
|
0
|
|
|
|
0
|
if ($error) { |
739
|
0
|
0
|
|
|
|
0
|
if ($error =~ m{locate Devel/Size.pm}) { |
740
|
|
|
|
|
|
|
Data::Printer::Common::_warn($self, "Devel::Size not found, show_memsize will be ignored") |
741
|
0
|
0
|
|
|
|
0
|
if $self->{_position} == 1; |
742
|
|
|
|
|
|
|
} |
743
|
|
|
|
|
|
|
else { |
744
|
0
|
|
|
|
|
0
|
Data::Printer::Common::_warn($self, "error fetching memory usage: $error"); |
745
|
|
|
|
|
|
|
} |
746
|
0
|
|
|
|
|
0
|
return ''; |
747
|
|
|
|
|
|
|
} |
748
|
0
|
0
|
|
|
|
0
|
return '' unless $size; |
749
|
0
|
0
|
|
|
|
0
|
my $string = ' (' . ($size < 0 ? sprintf("%.2f", $size) : int($size)) . $unit . ')'; |
750
|
0
|
|
|
|
|
0
|
return $self->maybe_colorize($string, 'memsize'); |
751
|
|
|
|
|
|
|
} |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
sub _check_weak { |
754
|
714
|
|
|
714
|
|
1232
|
my ($self) = shift; |
755
|
714
|
100
|
|
|
|
1402
|
return '' unless $self->show_weak; |
756
|
|
|
|
|
|
|
|
757
|
676
|
|
|
|
|
2244
|
my $realtype = Scalar::Util::reftype($_[0]); |
758
|
676
|
|
|
|
|
994
|
my $isweak; |
759
|
676
|
100
|
100
|
|
|
3220
|
if ($realtype && ($realtype eq 'REF' || $realtype eq 'SCALAR')) { |
|
|
|
66
|
|
|
|
|
760
|
440
|
|
|
|
|
1219
|
$isweak = Scalar::Util::isweak($_[0]); |
761
|
|
|
|
|
|
|
} |
762
|
|
|
|
|
|
|
else { |
763
|
236
|
|
|
|
|
647
|
$isweak = Scalar::Util::isweak($_[0]); |
764
|
|
|
|
|
|
|
} |
765
|
676
|
100
|
|
|
|
2228
|
return '' unless $isweak; |
766
|
17
|
|
|
|
|
67
|
return ' ' . $self->maybe_colorize('(weak)', 'weak'); |
767
|
|
|
|
|
|
|
} |
768
|
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
sub _write_label { |
770
|
61
|
|
|
61
|
|
132
|
my ($self) = @_; |
771
|
61
|
100
|
|
|
|
136
|
return '' unless $self->caller_info; |
772
|
2
|
|
|
|
|
49
|
my @caller = caller 1; |
773
|
|
|
|
|
|
|
|
774
|
2
|
|
|
|
|
8
|
my $message = $self->caller_message; |
775
|
|
|
|
|
|
|
|
776
|
2
|
|
|
|
|
7
|
$message =~ s/\b__PACKAGE__\b/$caller[0]/g; |
777
|
2
|
|
|
|
|
17
|
$message =~ s/\b__FILENAME__\b/$caller[1]/g; |
778
|
2
|
|
|
|
|
12
|
$message =~ s/\b__LINE__\b/$caller[2]/g; |
779
|
|
|
|
|
|
|
|
780
|
2
|
50
|
|
|
|
6
|
my $separator = $self->caller_message_newline ? "\n" : ' '; |
781
|
2
|
|
|
|
|
5
|
$message = $self->maybe_colorize($message, 'caller_info'); |
782
|
2
|
100
|
|
|
|
5
|
$message = $self->caller_message_position eq 'before' |
783
|
|
|
|
|
|
|
? $message . $separator |
784
|
|
|
|
|
|
|
: $separator . $message |
785
|
|
|
|
|
|
|
; |
786
|
2
|
|
|
|
|
9
|
return $message; |
787
|
|
|
|
|
|
|
} |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
sub maybe_colorize { |
790
|
1847
|
|
|
1847
|
1
|
17330
|
my ($self, $output, $color_type, $default_color, $end_color) = @_; |
791
|
|
|
|
|
|
|
|
792
|
1847
|
100
|
100
|
|
|
4097
|
if ($self->{_output_color_level} && defined $color_type) { |
793
|
3
|
|
|
|
|
8
|
my $theme = $self->theme; |
794
|
3
|
|
|
|
|
14
|
my $sgr_color = $theme->sgr_color_for($color_type); |
795
|
3
|
100
|
100
|
|
|
14
|
if (!defined $sgr_color && defined $default_color) { |
796
|
1
|
|
|
|
|
93
|
$sgr_color = $theme->_parse_color($default_color); |
797
|
|
|
|
|
|
|
} |
798
|
3
|
100
|
|
|
|
9
|
if ($sgr_color) { |
799
|
1
|
50
|
|
|
|
8
|
$output = $sgr_color |
800
|
|
|
|
|
|
|
. $output |
801
|
|
|
|
|
|
|
. (defined $end_color |
802
|
|
|
|
|
|
|
? $theme->sgr_color_for($end_color) |
803
|
|
|
|
|
|
|
: $theme->color_reset |
804
|
|
|
|
|
|
|
); |
805
|
|
|
|
|
|
|
} |
806
|
|
|
|
|
|
|
} |
807
|
1847
|
|
|
|
|
5438
|
return $output; |
808
|
|
|
|
|
|
|
} |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
sub _check_readonly { |
811
|
681
|
|
|
681
|
|
1248
|
my ($self) = @_; |
812
|
681
|
100
|
100
|
|
|
1299
|
return ' (read-only)' if $self->show_readonly && &Internals::SvREADONLY($_[1]); |
813
|
674
|
|
|
|
|
1432
|
return ''; |
814
|
|
|
|
|
|
|
} |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
42; |
817
|
|
|
|
|
|
|
__END__ |