File Coverage

File:local/lib/perl5/Data/Printer.pm
Coverage:30.4%

linestmtbrancondsubtimecode
1package Data::Printer;
2
2
2
2
2
4
2
31
use strict;
3
2
2
2
2
4
0
22
use warnings;
4
2
2
2
2
421
6011
429
use Term::ANSIColor qw(color colored);
5
2
2
2
2
6
1
31
use Scalar::Util;
6
2
2
2
2
668
2
63
use Sort::Naturally;
7
2
2
2
2
6
2
37
use Carp qw(croak);
8
2
2
2
2
390
2
5
use Clone::PP qw(clone);
9
2
2
2
2
394
8
6
use if $] >= 5.010, 'Hash::Util::FieldHash' => qw(fieldhash);
10
2
2
2
2
7830
3
7
use if $] < 5.010, 'Hash::Util::FieldHash::Compat' => qw(fieldhash);
11
2
2
2
2
33
1
21
use File::Spec;
12
2
2
2
2
753
3
21
use File::HomeDir ();
13
2
2
2
2
5
1
256
use Fcntl;
14
2
2
2
2
223
1301
81
use version 0.77 ();
15
16our $VERSION = '0.35';
17
18BEGIN {
19
2
50
2
349
    if ($^O =~ /Win32/i) {
20
0
0
        require Win32::Console::ANSI;
21
0
0
        Win32::Console::ANSI->import;
22    }
23}
24
25
26# defaults
27my $BREAK = "\n";
28my $properties = {
29    'name'           => 'var',
30    'indent'         => 4,
31    'index'          => 1,
32    'max_depth'      => 0,
33    'multiline'      => 1,
34    'sort_keys'      => 1,
35    'deparse'        => 0,
36    'hash_separator' => '   ',
37    'separator'      => ',',
38    'end_separator'  => 0,
39    'show_tied'      => 1,
40    'show_tainted'   => 1,
41    'show_weak'      => 1,
42    'show_readonly'  => 0,
43    'show_lvalue'    => 1,
44    'print_escapes'  => 0,
45    'quote_keys'     => 'auto',
46    'use_prototypes' => 1,
47    'output'         => 'stderr',
48    'return_value'   => 'dump',       # also 'void' or 'pass'
49    'colored'        => 'auto',       # also 0 or 1
50    'caller_info'    => 0,
51    'caller_message' => 'Printing in line __LINE__ of __FILENAME__:',
52    'class_method'   => '_data_printer', # use a specific dump method, if available
53    'color'          => {
54        'array'       => 'bright_white',
55        'number'      => 'bright_blue',
56        'string'      => 'bright_yellow',
57        'class'       => 'bright_green',
58        'method'      => 'bright_green',
59        'undef'       => 'bright_red',
60        'hash'        => 'magenta',
61        'regex'       => 'yellow',
62        'code'        => 'green',
63        'glob'        => 'bright_cyan',
64        'vstring'     => 'bright_blue',
65        'lvalue'      => 'bright_white',
66        'format'      => 'bright_cyan',
67        'repeated'    => 'white on_red',
68        'caller_info' => 'bright_cyan',
69        'weak'        => 'cyan',
70        'tainted'     => 'red',
71        'escaped'     => 'bright_red',
72        'unknown'     => 'bright_yellow on_blue',
73    },
74    'class' => {
75        inherited    => 'none',   # also 'all', 'public' or 'private'
76        universal    => 1,
77        parents      => 1,
78        linear_isa   => 'auto',
79        expand       => 1,        # how many levels to expand. 0 for none, 'all' for all
80        internals    => 1,
81        export       => 1,
82        sort_methods => 1,
83        show_methods => 'all',    # also 'none', 'public', 'private'
84        show_reftype => 0,
85        _depth       => 0,        # used internally
86    },
87    'filters' => {
88        # The IO ref type isn't supported as you can't actually create one,
89        # any handle you make is automatically blessed into an IO::* object,
90        # and those are separately handled.
91        SCALAR  => [ \&SCALAR   ],
92        ARRAY   => [ \&ARRAY    ],
93        HASH    => [ \&HASH     ],
94        REF     => [ \&REF      ],
95        CODE    => [ \&CODE     ],
96        GLOB    => [ \&GLOB     ],
97        VSTRING => [ \&VSTRING  ],
98        LVALUE  => [ \&LVALUE ],
99        FORMAT  => [ \&FORMAT ],
100        Regexp  => [ \&Regexp   ],
101        -unknown=> [ \&_unknown ],
102        -class  => [ \&_class   ],
103    },
104
105    _output          => *STDERR,     # used internally
106    _current_indent  => 0,           # used internally
107    _linebreak       => \$BREAK,     # used internally
108    _seen            => {},          # used internally
109    _seen_override   => {},          # used internally
110    _depth           => 0,           # used internally
111    _tie             => 0,           # used internally
112};
113
114
115sub import {
116
2
2
1
    my $class = shift;
117
2
2
    my $args;
118
2
50
4
    if (scalar @_) {
119
2
50
5
        $args = @_ == 1 ? shift : {@_};
120
2
50
33
12
        croak 'Data::Printer can receive either a hash or a hash reference.'
121            unless ref $args and ref $args eq 'HASH';
122    }
123
124    # the RC file overrides the defaults,
125    # (and we load it only once)
126
2
50
6
    unless( exists $properties->{_initialized} ) {
127
2
2
        _load_rc_file($args);
128
2
12
        $properties->{_initialized} = 1;
129    }
130
131    # and 'use' arguments override the RC file
132
2
50
3
    if ($args) {
133
2
2
        $properties = _merge( $args );
134    }
135
136
2
50
15
    my $exported = ($properties->{use_prototypes} ? \&p : \&np );
137
2
50
6
    my $imported = $properties->{alias} || 'p';
138
2
4
    my $caller = caller;
139
2
2
2
2
6
2
2318
    no strict 'refs';
140
2
2
2
38
    *{"$caller\::$imported"} = $exported;
141}
142
143
144sub p (\[@$%&];%) {
145
16
16
35
    return _print_and_return( $_[0], _data_printer(!!defined wantarray, @_) );
146}
147
148# np() is a p() clone without prototypes.
149# Just like regular Data::Dumper, this version
150# expects a reference as its first argument.
151# We make a single exception for when we only
152# get one argument, in which case we ref it
153# for the user and keep going.
154sub np  {
155
0
0
0
    my $item = shift;
156
157
0
0
0
0
    if (!ref $item && @_ == 0) {
158
0
0
        my $item_value = $item;
159
0
0
        $item = \$item_value;
160    }
161
162
0
0
    return _print_and_return( $item, _data_printer(!!defined wantarray, $item, @_) );
163}
164
165sub _print_and_return {
166
16
16
16
    my ($item, $dump, $p) = @_;
167
168
16
50
50
43
    if ( $p->{return_value} eq 'pass' ) {
169
0
0
0
0
        print { $p->{_output} } $dump . $/;
170
171
0
0
        my $ref = ref $item;
172
0
0
0
0
0
        if ($ref eq 'ARRAY') {
173
0
0
0
0
            return @{ $item };
174        }
175
0
0
        elsif ($ref eq 'HASH') {
176
0
0
0
0
            return %{ $item };
177        }
178        elsif ( grep { $ref eq $_ } qw(REF SCALAR CODE Regexp GLOB VSTRING) ) {
179
0
0
            return $$item;
180        }
181        else {
182
0
0
            return $item;
183        }
184    }
185    elsif ( $p->{return_value} eq 'void' ) {
186
0
0
0
0
        print { $p->{_output} } $dump . $/;
187
0
0
        return;
188    }
189    else {
190
16
0
50
23
0
        print { $p->{_output} } $dump . $/ unless defined wantarray;
191
16
47
        return $dump;
192    }
193}
194
195sub _data_printer {
196
16
16
14
    my $wantarray = shift;
197
198
16
50
25
    croak 'When calling p() without prototypes, please pass arguments as references'
199        unless ref $_[0];
200
201
16
19
    my ($item, %local_properties) = @_;
202
16
1316
    local %ENV = %ENV;
203
204
16
101
    my $p = _merge(\%local_properties);
205
16
50
31
    unless ($p->{multiline}) {
206
0
0
        $BREAK = ' ';
207
0
0
        $p->{'indent'} = 0;
208
0
0
        $p->{'index'}  = 0;
209    }
210
211    # We disable colors if colored is set to false.
212    # If set to "auto", we disable colors if the user
213    # set ANSI_COLORS_DISABLED or if we're either
214    # returning the value (instead of printing) or
215    # being piped to another command.
216
16
50
20
34
    if ( !$p->{colored}
217          or ($p->{colored} eq 'auto'
218              and (exists $ENV{ANSI_COLORS_DISABLED}
219                   or $wantarray
220                   or not -t $p->{_output}
221                  )
222          )
223    ) {
224
16
63
        $ENV{ANSI_COLORS_DISABLED} = 1;
225    }
226    else {
227
0
0
        delete $ENV{ANSI_COLORS_DISABLED};
228    }
229
230
16
37
    my $out = color('reset');
231
232
16
50
33
126
    if ( $p->{caller_info} and $p->{_depth} == 0 ) {
233
0
0
        $out .= _get_info_message($p);
234    }
235
236
16
24
    $out .= _p( $item, $p );
237
16
735
    return ($out, $p);
238}
239
240
241sub _p {
242
32
32
21
    my ($item, $p) = @_;
243
32
50
46
    my $ref = (defined $p->{_reftype} ? $p->{_reftype} : ref $item);
244
32
21
    my $tie;
245
246
32
16
    my $string = '';
247
248    # Object's unique ID, avoiding circular structures
249
32
33
    my $id = _object_id( $item );
250
32
50
50
79
    if ( exists $p->{_seen}->{$id} ) {
251
0
0
0
        if ( not defined $p->{_reftype} ) {
252
0
0
            return colored($p->{_seen}->{$id}, $p->{color}->{repeated});
253        }
254    }
255    # some filters don't want us to show their repeated refs
256    elsif( !exists $p->{_seen_override}{$ref} ) {
257
32
43
        $p->{_seen}->{$id} = $p->{name};
258    }
259
260
32
26
    delete $p->{_reftype}; # abort override
261
262    # globs don't play nice
263
32
50
67
    $ref = 'GLOB' if "$item" =~ /GLOB\([^()]+\)$/;
264
265
266    # filter item (if user set a filter for it)
267
32
17
    my $found;
268
32
50
46
    if ( exists $p->{filters}->{$ref} ) {
269
32
32
19
35
        foreach my $filter ( @{ $p->{filters}->{$ref} } ) {
270
32
50
32
            if ( defined (my $result = $filter->($item, $p)) ) {
271
32
28
                $string .= $result;
272
32
20
                $found = 1;
273
32
26
                last;
274            }
275        }
276    }
277
278
32
50
33
46
    if (not $found and Scalar::Util::blessed($item) ) {
279        # let '-class' filters have a go
280
0
0
0
0
        foreach my $filter ( @{ $p->{filters}->{'-class'} } ) {
281
0
0
0
            if ( defined (my $result = $filter->($item, $p)) ) {
282
0
0
                $string .= $result;
283
0
0
                $found = 1;
284
0
0
                last;
285            }
286        }
287    }
288
289
32
50
38
    if ( not $found ) {
290        # if it's not a class and not a known core type, we must be in
291        # a future perl with some type we're unaware of
292
0
0
0
0
        foreach my $filter ( @{ $p->{filters}->{'-unknown'} } ) {
293
0
0
0
            if ( defined (my $result = $filter->($item, $p)) ) {
294
0
0
                $string .= $result;
295
0
0
                last;
296            }
297        }
298    }
299
300
32
50
33
84
    if ($p->{show_tied} and $p->{_tie} ) {
301
0
0
        $string .= ' (tied to ' . $p->{_tie} . ')';
302
0
0
        $p->{_tie} = '';
303    }
304
305
32
42
    return $string;
306}
307
308
309
310######################################
311## Default filters
312######################################
313
314sub SCALAR {
315
0
0
0
    my ($item, $p) = @_;
316
0
0
    my $string = '';
317
318
0
0
0
0
    if (not defined $$item) {
319
0
0
        $string .= colored('undef', $p->{color}->{'undef'});
320    }
321    elsif (Scalar::Util::looks_like_number($$item)) {
322
0
0
        $string .= colored($$item, $p->{color}->{'number'});
323    }
324    else {
325
0
0
        my $val = _escape_chars($$item, $p->{color}{string}, $p);
326
327
0
0
        $string .= q["] . colored($val, $p->{color}->{'string'}) . q["];
328    }
329
330
0
0
0
0
    $string .= ' ' . colored('(TAINTED)', $p->{color}->{'tainted'})
331        if $p->{show_tainted} and Scalar::Util::tainted($$item);
332
333
0
0
    $p->{_tie} = ref tied $$item;
334
335
0
0
0
0
    if ($p->{show_readonly} and &Internals::SvREADONLY( $item )) {
336
0
0
        $string .= ' (read-only)';
337    }
338
339
0
0
    return $string;
340}
341
342sub _escape_chars {
343
0
0
0
    my ($str, $orig_color, $p) = @_;
344
345
0
0
    $orig_color   = color( $orig_color );
346
0
0
    my $esc_color = color( $p->{color}{escaped} );
347
348
0
0
0
    if ($p->{print_escapes}) {
349
0
0
        $str =~ s/\e/$esc_color\\e$orig_color/g;
350
351
0
0
        my %escaped = (
352            "\n" => '\n',
353            "\r" => '\r',
354            "\t" => '\t',
355            "\f" => '\f',
356            "\b" => '\b',
357            "\a" => '\a',
358        );
359
0
0
        foreach my $k ( keys %escaped ) {
360
0
0
            $str =~ s/$k/$esc_color$escaped{$k}$orig_color/g;
361        }
362    }
363    # always escape the null character
364
0
0
    $str =~ s/\0/$esc_color\\0$orig_color/g;
365
366
0
0
    return $str;
367}
368
369
370sub ARRAY {
371
0
0
0
    my ($item, $p) = @_;
372
0
0
    my $string = '';
373
0
0
    $p->{_depth}++;
374
375
0
0
0
0
0
    if ( $p->{max_depth} and $p->{_depth} > $p->{max_depth} ) {
376
0
0
        $string .= '[ ... ]';
377    }
378    elsif (not @$item) {
379
0
0
        $string .= '[]';
380    }
381    else {
382
0
0
        $string .= "[$BREAK";
383
0
0
        $p->{_current_indent} += $p->{indent};
384
385
0
0
0
0
        foreach my $i (0 .. $#{$item} ) {
386
0
0
            $p->{name} .= "[$i]";
387
388
0
0
            my $array_elem = $item->[$i];
389
0
0
            $string .= (' ' x $p->{_current_indent});
390
0
0
0
            if ($p->{'index'}) {
391
0
0
                $string .= colored(
392
0
0
                             sprintf("%-*s", 3 + length($#{$item}), "[$i]"),
393                             $p->{color}->{'array'}
394                       );
395            }
396
397
0
0
            my $ref = ref $array_elem;
398
399            # scalar references should be re-referenced
400            # to gain a '\' sign in front of them
401
0
0
0
0
            if (!$ref or $ref eq 'SCALAR') {
402
0
0
                $string .= _p( \$array_elem, $p );
403            }
404            else {
405
0
0
                $string .= _p( $array_elem, $p );
406            }
407
0
0
0
0
            $string .= ' ' . colored('(weak)', $p->{color}->{'weak'})
408                if $ref and Scalar::Util::isweak($item->[$i]) and $p->{show_weak};
409
410
0
0
            $string .= $p->{separator}
411
0
0
0
0
              if $i < $#{$item} || $p->{end_separator};
412
413
0
0
            $string .= $BREAK;
414
415
0
0
            my $size = 2 + length($i); # [10], [100], etc
416
0
0
            substr $p->{name}, -$size, $size, '';
417        }
418
0
0
        $p->{_current_indent} -= $p->{indent};
419
0
0
        $string .= (' ' x $p->{_current_indent}) . "]";
420    }
421
422
0
0
    $p->{_tie} = ref tied @$item;
423
0
0
    $p->{_depth}--;
424
425
0
0
    return $string;
426}
427
428
429sub REF {
430
16
16
10
    my ($item, $p) = @_;
431
16
12
    my $string = '';
432
433    # look-ahead, add a '\' only if it's not an object
434
16
50
25
    if (my $ref_ahead = ref $$item ) {
435
16
112
50
17
96
        $string .= '\\ ' if grep { $_ eq $ref_ahead }
436            qw(SCALAR CODE Regexp ARRAY HASH GLOB REF);
437    }
438
16
29
    $string .= _p($$item, $p);
439
440
16
50
33
46
    $string .= ' ' . colored('(weak)', $p->{color}->{'weak'})
441        if Scalar::Util::isweak($$item) and $p->{show_weak};
442
443
16
21
    return $string;
444}
445
446
447sub CODE {
448
16
16
15
    my ($item, $p) = @_;
449
16
13
    my $string = '';
450
451
16
12
    my $code = 'sub { ... }';
452
16
50
23
    if ($p->{deparse}) {
453
16
23
        $code = _deparse( $item, $p );
454    }
455
16
50
    $string .= colored($code, $p->{color}->{'code'});
456
16
130
    return $string;
457}
458
459
460sub HASH {
461
0
0
0
    my ($item, $p) = @_;
462
0
0
    my $string = '';
463
464
0
0
    $p->{_depth}++;
465
466
0
0
0
0
0
    if ( $p->{max_depth} and $p->{_depth} > $p->{max_depth} ) {
467
0
0
        $string .= '{ ... }';
468    }
469    elsif (not keys %$item) {
470
0
0
        $string .= '{}';
471    }
472    else {
473
0
0
        $string .= "{$BREAK";
474
0
0
        $p->{_current_indent} += $p->{indent};
475
476
0
0
        my $total_keys  = scalar keys %$item;
477
0
0
        my $len         = 0;
478
0
0
        my $multiline   = $p->{multiline};
479
0
0
        my $hash_color  = $p->{color}{hash};
480
0
0
        my $quote_keys  = $p->{quote_keys};
481
482
0
0
        my @keys = ();
483
484        # first pass, preparing keys to display (and getting largest key size)
485
0
0
0
        foreach my $key ($p->{sort_keys} ? nsort keys %$item : keys %$item ) {
486
0
0
            my $new_key = _escape_chars($key, $hash_color, $p);
487
0
0
            my $colored = colored( $new_key, $hash_color );
488
489            # wrap in uncolored single quotes if there's
490            # any space or escaped characters
491
0
0
0
0
            if ( $quote_keys
492                  and (
493                        $quote_keys ne 'auto'
494                        or (
495                             $key eq q()
496                             or $new_key ne $key
497                             or $new_key =~ /\s|\n|\t|\r/
498                        )
499                  )
500            ) {
501
0
0
                $colored = qq['$colored'];
502            }
503
504
0
0
            push @keys, {
505                raw     => $key,
506                colored => $colored,
507            };
508
509            # length of the largest key is used for indenting
510
0
0
0
            if ($multiline) {
511
0
0
                my $l = length $colored;
512
0
0
0
                $len = $l if $l > $len;
513            }
514        }
515
516        # second pass, traversing and rendering
517
0
0
        foreach my $key (@keys) {
518
0
0
            my $raw_key     = $key->{raw};
519
0
0
            my $colored_key = $key->{colored};
520
0
0
            my $element     = $item->{$raw_key};
521
0
0
            $p->{name}     .= "{$raw_key}";
522
523
0
0
            $string .= (' ' x $p->{_current_indent})
524                     . sprintf("%-*s", $len, $colored_key)
525                     . $p->{hash_separator}
526                     ;
527
528
0
0
            my $ref = ref $element;
529            # scalar references should be re-referenced
530            # to gain a '\' sign in front of them
531
0
0
0
0
            if (!$ref or $ref eq 'SCALAR') {
532
0
0
                $string .= _p( \$element, $p );
533            }
534            else {
535
0
0
                $string .= _p( $element, $p );
536            }
537
538
0
0
0
0
            $string .= ' ' . colored('(weak)', $p->{color}->{'weak'})
539                if $ref
540                  and $p->{show_weak}
541                  and Scalar::Util::isweak($item->{$raw_key});
542
543
0
0
0
0
            $string .= $p->{separator}
544              if --$total_keys > 0 || $p->{end_separator};
545
546
0
0
            $string .= $BREAK;
547
548
0
0
            my $size = 2 + length($raw_key); # {foo}, {z}, etc
549
0
0
            substr $p->{name}, -$size, $size, '';
550        }
551
0
0
        $p->{_current_indent} -= $p->{indent};
552
0
0
        $string .= (' ' x $p->{_current_indent}) . "}";
553    }
554
555
0
0
    $p->{_tie} = ref tied %$item;
556
0
0
    $p->{_depth}--;
557
558
0
0
    return $string;
559}
560
561
562sub Regexp {
563
0
0
0
    my ($item, $p) = @_;
564
0
0
    my $string = '';
565
566
0
0
    my $val = "$item";
567    # a regex to parse a regex. Talk about full circle :)
568    # note: we are not validating anything, just grabbing modifiers
569
0
0
0
    if ($val =~ m/\(\?\^?([uladxismpogce]*)(?:\-[uladxismpogce]+)?:(.*)\)/s) {
570
0
0
        my ($modifiers, $val) = ($1, $2);
571
0
0
        $string .= colored($val, $p->{color}->{'regex'});
572
0
0
0
        if ($modifiers) {
573
0
0
            $string .= "  (modifiers: $modifiers)";
574        }
575    }
576    else {
577
0
0
        croak "Unrecognized regex $val. Please submit a bug report for Data::Printer.";
578    }
579
0
0
    return $string;
580}
581
582sub VSTRING {
583
0
0
0
    my ($item, $p) = @_;
584
0
0
    my $string = '';
585
0
0
    $string .= colored(version->declare($$item)->normal, $p->{color}->{'vstring'});
586
0
0
    return $string;
587}
588
589sub FORMAT {
590
0
0
0
    my ($item, $p) = @_;
591
0
0
    my $string = '';
592
0
0
    $string .= colored("FORMAT", $p->{color}->{'format'});
593
0
0
    return $string;
594}
595
596sub LVALUE {
597
0
0
0
    my ($item, $p) = @_;
598
0
0
    my $string = SCALAR( $item, $p );
599
0
0
0
    $string .= colored( ' (LVALUE)', $p->{color}{lvalue} )
600        if $p->{show_lvalue};
601
602
0
0
    return $string;
603}
604
605sub GLOB {
606
0
0
0
    my ($item, $p) = @_;
607
0
0
    my $string = '';
608
609
0
0
    $string .= colored("$$item", $p->{color}->{'glob'});
610
611
0
0
    my $extra = '';
612
613    # unfortunately, some systems (like Win32) do not
614    # implement some of these flags (maybe not even
615    # fcntl() itself, so we must wrap it.
616
0
0
    my $flags;
617
2
2
2
0
0
2
6
1
2241
0
0
    eval { no warnings qw( unopened closed ); $flags = fcntl($$item, F_GETFL, 0) };
618
0
0
0
    if ($flags) {
619
0
0
0
0
        $extra .= ($flags & O_WRONLY) ? 'write-only'
620                : ($flags & O_RDWR)   ? 'read/write'
621                : 'read-only'
622                ;
623
624        # How to avoid croaking when the system
625        # doesn't implement one of those, without skipping
626        # the whole thing? Maybe there's a better way.
627        # Solaris, for example, doesn't have O_ASYNC :(
628
0
0
        my %flags = ();
629
0
0
0
0
        eval { $flags{'append'}      = O_APPEND   };
630
0
0
0
0
        eval { $flags{'async'}       = O_ASYNC    }; # leont says this is the only one I should care for.
631
0
0
0
0
        eval { $flags{'create'}      = O_CREAT    };
632
0
0
0
0
        eval { $flags{'truncate'}    = O_TRUNC    };
633
0
0
0
0
        eval { $flags{'nonblocking'} = O_NONBLOCK };
634
635
0
0
0
0
0
        if (my @flags = grep { $flags & $flags{$_} } keys %flags) {
636
0
0
            $extra .= ", flags: @flags";
637        }
638
0
0
        $extra .= ', ';
639    }
640
0
0
    my @layers = ();
641
0
0
0
0
    eval { @layers = PerlIO::get_layers $$item }; # TODO: try PerlIO::Layers::get_layers (leont)
642
0
0
0
    unless ($@) {
643
0
0
        $extra .= "layers: @layers";
644    }
645
0
0
0
    $string .= "  ($extra)" if $extra;
646
647
0
0
    $p->{_tie} = ref tied *$$item;
648
0
0
    return $string;
649}
650
651
652sub _unknown {
653
0
0
0
    my($item, $p) = @_;
654
0
0
    my $ref = ref $item;
655
656
0
0
    my $string = '';
657
0
0
    $string = colored($ref, $p->{color}->{'unknown'});
658
0
0
    return $string;
659}
660
661sub _class {
662
0
0
0
    my ($item, $p) = @_;
663
0
0
    my $ref = ref $item;
664
665    # if the user specified a method to use instead, we do that
666
0
0
0
0
    if ( $p->{class_method} and my $method = $item->can($p->{class_method}) ) {
667
0
0
        return $method->($item, $p);
668    }
669
670
0
0
    my $string = '';
671
0
0
    $p->{class}{_depth}++;
672
673
0
0
    $string .= colored($ref, $p->{color}->{'class'});
674
675
0
0
0
    if ( $p->{class}{show_reftype} ) {
676
0
0
        $string .= ' (' . colored(
677            Scalar::Util::reftype($item),
678            $p->{color}->{'class'}
679        ) . ')';
680    }
681
682
0
0
0
0
    if ($p->{class}{expand} eq 'all'
683        or $p->{class}{expand} >= $p->{class}{_depth}
684    ) {
685
0
0
        $string .= "  {$BREAK";
686
687
0
0
        $p->{_current_indent} += $p->{indent};
688
689
0
0
0
        if ($] >= 5.010) {
690
0
0
            require mro;
691        } else {
692
0
0
            require MRO::Compat;
693        }
694
0
0
        require Package::Stash;
695
696
0
0
        my $stash = Package::Stash->new($ref);
697
698
0
0
0
0
0
0
        if ( my @superclasses = @{$stash->get_symbol('@ISA')||[]} ) {
699
0
0
0
            if ($p->{class}{parents}) {
700
0
0
                $string .= (' ' x $p->{_current_indent})
701                        . 'Parents       '
702
0
0
                        . join(', ', map { colored($_, $p->{color}->{'class'}) }
703                                     @superclasses
704                        ) . $BREAK;
705            }
706
707
0
0
0
0
            if ( $p->{class}{linear_isa} and
708                  (
709                    ($p->{class}{linear_isa} eq 'auto' and @superclasses > 1)
710                    or
711                    ($p->{class}{linear_isa} ne 'auto')
712                  )
713            ) {
714
0
0
                $string .= (' ' x $p->{_current_indent})
715                        . 'Linear @ISA   '
716
0
0
                        . join(', ', map { colored( $_, $p->{color}->{'class'}) }
717
0
0
                                  @{mro::get_linear_isa($ref)}
718                        ) . $BREAK;
719            }
720        }
721
722
0
0
0
0
        $string .= _show_methods($ref, $p)
723            if $p->{class}{show_methods} and $p->{class}{show_methods} ne 'none';
724
725
0
0
0
        if ( $p->{'class'}->{'internals'} ) {
726
0
0
            $string .= (' ' x $p->{_current_indent})
727                    . 'internals: ';
728
729
0
0
            local $p->{_reftype} = Scalar::Util::reftype $item;
730
0
0
            $string .= _p($item, $p);
731
0
0
            $string .= $BREAK;
732        }
733
734
0
0
        $p->{_current_indent} -= $p->{indent};
735
0
0
        $string .= (' ' x $p->{_current_indent}) . "}";
736    }
737
0
0
    $p->{class}{_depth}--;
738
739
0
0
    return $string;
740}
741
742
743
744######################################
745## Auxiliary (internal) subs
746######################################
747
748# All glory to Vincent Pit for coming up with this implementation,
749# to Goro Fuji for Hash::FieldHash, and of course to Michael Schwern
750# and his "Object::ID", whose code is copied almost verbatim below.
751{
752    fieldhash my %IDs;
753
754    my $Last_ID = "a";
755    sub _object_id {
756
36
36
19
        my $self = shift;
757
758        # This is 15% faster than ||=
759
36
50
82
        return $IDs{$self} if exists $IDs{$self};
760
36
137
        return $IDs{$self} = ++$Last_ID;
761    }
762}
763
764
765sub _show_methods {
766
0
0
0
    my ($ref, $p) = @_;
767
768
0
0
    my $string = '';
769
0
0
    my $methods = {
770        public => [],
771        private => [],
772    };
773
0
0
0
    my $inherited = $p->{class}{inherited} || 'none';
774
775
0
0
    require B;
776
777    my $methods_of = sub {
778
0
0
0
        my ($name) = @_;
779
0
0
        map {
780
0
0
            my $m;
781
0
0
0
0
            if ($_
782                and $m = B::svref_2object($_)
783                and $m->isa('B::CV')
784                and not $m->GV->isa('B::Special')
785            ) {
786
0
0
                [ $m->GV->STASH->NAME, $m->GV->NAME ]
787            } else {
788                ()
789
0
0
            }
790
0
0
        } values %{Package::Stash->new($name)->get_all_symbols('CODE')}
791
0
0
    };
792
793
0
0
    my %seen_method_name;
794
795
0
0
METHOD:
796
0
0
0
    foreach my $method (
797        map $methods_of->($_), @{mro::get_linear_isa($ref)},
798                               $p->{class}{universal} ? 'UNIVERSAL' : ()
799    ) {
800
0
0
        my ($package_string, $method_string) = @$method;
801
802
0
0
0
        next METHOD if $seen_method_name{$method_string}++;
803
804
0
0
0
        my $type = substr($method_string, 0, 1) eq '_' ? 'private' : 'public';
805
806
0
0
0
        if ($package_string ne $ref) {
807
0
0
0
0
            next METHOD unless $inherited ne 'none'
808                           and ($inherited eq 'all' or $type eq $inherited);
809
0
0
            $method_string .= ' (' . $package_string . ')';
810        }
811
812
0
0
0
0
        push @{ $methods->{$type} }, $method_string;
813    }
814
815    # render our string doing a natural sort by method name
816
0
0
    my $show_methods = $p->{class}{show_methods};
817
0
0
    foreach my $type (qw(public private)) {
818
0
0
0
0
        next unless $show_methods eq 'all'
819                 or $show_methods eq $type;
820
821
0
0
0
0
0
0
0
        my @list = ($p->{class}{sort_methods} ? nsort @{$methods->{$type}} : @{$methods->{$type}});
822
823
0
0
        $string .= (' ' x $p->{_current_indent})
824                 . "$type methods (" . scalar @list . ')'
825                 . (@list ? ' : ' : '')
826
0
0
0
                 . join(', ', map { colored($_, $p->{color}->{method}) }
827                              @list
828                   ) . $BREAK;
829    }
830
831
0
0
    return $string;
832}
833
834sub _deparse {
835
16
16
11
    my ($item, $p) = @_;
836
16
61
    require B::Deparse;
837
16
14
    my $i = $p->{indent};
838
16
31
    my $deparseopts = ["-sCi${i}v'Useless const omitted'"];
839
840
16
6367
    my $sub = 'sub ' . B::Deparse->new($deparseopts)->coderef2text($item);
841
16
65
    my $pad = "\n" . (' ' x ($p->{_current_indent} + $i));
842
16
64
40
64
    $sub    =~ s/\n/$pad/gse;
843
16
32
    return $sub;
844}
845
846sub _get_info_message {
847
0
0
0
    my $p = shift;
848
0
0
    my @caller = caller 2;
849
850
0
0
    my $message = $p->{caller_message};
851
852
0
0
    $message =~ s/\b__PACKAGE__\b/$caller[0]/g;
853
0
0
    $message =~ s/\b__FILENAME__\b/$caller[1]/g;
854
0
0
    $message =~ s/\b__LINE__\b/$caller[2]/g;
855
856
0
0
    return colored($message, $p->{color}{caller_info}) . $BREAK;
857}
858
859
860sub _merge {
861
20
20
18
    my $p = shift;
862
20
31
    my $clone = clone $properties;
863
864
20
50
31
    if ($p) {
865
20
37
        foreach my $key (keys %$p) {
866
10
100
50
100
50
67
25
            if ($key eq 'color' or $key eq 'colour') {
867
2
1
                my $color = $p->{$key};
868
2
50
33
7
                if ( not ref $color or ref $color ne 'HASH' ) {
869
0
0
                    Carp::carp q['color' should be a HASH reference. Did you mean 'colored'?];
870
0
0
                    $clone->{color} = {};
871                }
872                else {
873
2
4
                    foreach my $target ( keys %$color ) {
874
32
23
                        $clone->{color}->{$target} = $p->{$key}->{$target};
875                    }
876                }
877            }
878            elsif ($key eq 'class') {
879
0
0
0
0
                foreach my $item ( keys %{$p->{class}} ) {
880
0
0
                    $clone->{class}->{$item} = $p->{class}->{$item};
881                }
882            }
883            elsif ($key eq 'filters') {
884
2
2
                my $val = $p->{$key};
885
886
2
3
                foreach my $item (keys %$val) {
887
2
2
                    my $filters = $val->{$item};
888
889                    # EXPERIMENTAL: filters in modules
890
2
50
3
                    if ($item eq '-external') {
891
2
50
4
                        my @external = ( ref($filters) ? @$filters : ($filters) );
892
893
2
2
                        foreach my $class ( @external ) {
894
4
4
                            my $module = "Data::Printer::Filter::$class";
895
2
2
2
2
2
2
4
2
2
386
2
20
380
2
18
104
                            eval "use $module";
896
4
50
6
                            if ($@) {
897
0
0
                                warn "Error loading filter '$module': $@";
898                            }
899                            else {
900
4
4
2
6
                                my %from_module = %{$module->_filter_list};
901
4
4
4
5
                                my %extras      = %{$module->_extra_options};
902
903
4
7
                                foreach my $k (keys %from_module) {
904
26
26
26
13
17
17
                                    unshift @{ $clone->{filters}->{$k} }, @{ $from_module{$k} };
905
26
50
31
                                    $clone->{_seen_override}{$k} = 1
906                                        if $extras{$k}{show_repeated};
907                                }
908                            }
909                        }
910                    }
911                    else {
912
0
0
0
                        my @filter_list = ( ref $filters eq 'CODE' ? ( $filters ) : @$filters );
913
0
0
0
0
                        unshift @{ $clone->{filters}->{$item} }, @filter_list;
914                    }
915                }
916            }
917            elsif ($key eq 'output') {
918
0
0
                my $out = $p->{output};
919
0
0
                my $ref = ref $out;
920
921
0
0
                $clone->{output} = $out;
922
923
0
0
                my %output_target = (
924                     stdout => *STDOUT,
925                     stderr => *STDERR,
926                );
927
928
0
0
                my $error;
929
0
0
0
0
0
0
0
0
                if (!$ref and exists $output_target{ lc $out }) {
930
0
0
                    $clone->{_output} = $output_target{ lc $out };
931                }
932                elsif ( ( $ref and $ref eq 'GLOB')
933                     or (!$ref and \$out =~ /GLOB\([^()]+\)$/)
934                ) {
935
0
0
                    $clone->{_output} = $out;
936                }
937                elsif ( !$ref or $ref eq 'SCALAR' ) {
938
0
0
0
                    if( open my $fh, '>>', $out ) {
939
0
0
                        $clone->{_output} = $fh;
940                    }
941                    else {
942
0
0
                        $error = 1;
943                    }
944                }
945                else {
946
0
0
                    $error = 1;
947                }
948
949
0
0
0
                if ($error) {
950
0
0
                    Carp::carp 'Error opening custom output handle.';
951
0
0
                    $clone->{_output} = $output_target{ 'stderr' };
952                }
953            }
954            else {
955
6
7
                $clone->{$key} = $p->{$key};
956            }
957        }
958    }
959
960
20
33
    return $clone;
961}
962
963
964sub _load_rc_file {
965
2
50
2
3
    my $args = shift || {};
966
967
2
50
50
9
    my $file = exists $args->{rc_file}    ? $args->{rc_file}
968             : exists $ENV{DATAPRINTERRC} ? $ENV{DATAPRINTERRC}
969             : File::Spec->catfile(File::HomeDir->my_home,'.dataprinter');
970
971
2
50
11
    return unless -e $file;
972
973
2
8
    my $mode = (stat $file )[2];
974
2
50
25
11
    if ($^O !~ /Win32/i && ($mode & 0020 || $mode & 0002) ) {
975
0
0
        warn "rc file '$file' must NOT be writeable to other users. Skipping.\n";
976
0
0
        return;
977    }
978
979
2
50
14
20
    if ( -l $file || (!-f _) || -p _ || -S _ || -b _ || -c _ ) {
980
0
0
        warn "rc file '$file' doesn't look like a plain file. Skipping.\n";
981
0
0
        return;
982    }
983
984
2
50
4
    unless (-o $file) {
985
0
0
        warn "rc file '$file' must be owned by your (effective) user. Skipping.\n";
986
0
0
        return;
987    }
988
989
2
50
19
    if ( open my $fh, '<', $file ) {
990
2
1
        my $rc_data;
991
2
2
2
2
4
138
        { local $/; $rc_data = <$fh> }
992
2
10
        close $fh;
993
994
2
50
5
        if( ${^TAINT} != 0 ) {
995
0
0
0
            if ( $args->{allow_tainted} ) {
996
0
0
                warn "WARNING: Reading tainted file '$file' due to user override.\n";
997
0
0
                $rc_data =~ /(.+)/s; # very bad idea - god help you
998
0
0
                $rc_data = $1;
999            }
1000            else {
1001
0
0
                warn "taint mode on: skipping rc file '$file'.\n";
1002
0
0
                return;
1003            }
1004        }
1005
1006
2
93
        my $config = eval $rc_data;
1007
2
50
50
33
10
        if ( $@ ) {
1008
0
0
            warn "Error loading $file: $@\n";
1009        }
1010        elsif (!ref $config or ref $config ne 'HASH') {
1011
0
0
            warn "Error loading $file: config file must return a hash reference\n";
1012        }
1013        else {
1014
2
5
            $properties = _merge( $config );
1015        }
1016    }
1017    else {
1018
0
        warn "error opening '$file': $!\n";
1019    }
1020}
1021
1022
10231;