1package Data::Printer::Common;
2# Private library of shared Data::Printer code.
3use strict;
4use warnings;
5use Scalar::Util;
6
7my $mro_initialized = 0;
8my $nsort_initialized;
9
10
11sub _filter_category_for {
12    my ($name) = @_;
13    my %core_types = map { $_ => 1 }
14        qw(SCALAR LVALUE ARRAY HASH REF VSTRING GLOB FORMAT Regexp CODE);
15    return exists $core_types{$name} ? 'type_filters' : 'class_filters';
16}
17
18# strings are tough to process: there are control characters like "\t",
19# unicode characters to name or escape (or do nothing), max_string to
20# worry about, and every single piece of that could have its own color.
21# That, and hash keys and strings share this. So we put it all in one place.
22sub _process_string {
23    my ($ddp, $string, $src_color) = @_;
24
25    # colorizing messes with reduce_string because we are effectively
26    # adding new (invisible) characters to the string. So we need to
27    # handle reduction first. But! Because we colorize string_max
28    # *and* we should escape any colors already present, we need to
29    # do both at the same time.
30    $string = _reduce_string($ddp, $string, $src_color);
31
32    # now we escape all other control characters except for "\e", which was
33    # already escaped in _reduce_string(), and convert any chosen charset
34    # to the \x{} format. These could go in any particular order:
35    $string = _escape_chars($ddp, $string, $src_color);
36    $string = _print_escapes($ddp, $string, $src_color);
37
38    # finally, send our wrapped string:
39    return $ddp->maybe_colorize($string, $src_color);
40}
41
42sub _colorstrip {
43    my ($string) = @_;
44    $string =~ s{ \e\[ [\d;]* m }{}xmsg;
45    return $string;
46}
47
48sub _reduce_string {
49    my ($ddp, $string, $src_color) = @_;
50    my $max = $ddp->string_max;
51    my $str_len = length($string);
52    if ($max && $str_len && $str_len > $max) {
53        my $preserve = $ddp->string_preserve;
54        my $skipped_chars = $str_len - ($preserve eq 'none' ? 0 : $max);
55        my $skip_message = $ddp->maybe_colorize(
56            $ddp->string_overflow,
57            'caller_info',
58            undef,
59            $src_color
60        );
61        $skip_message =~ s/__SKIPPED__/$skipped_chars/g;
62        if ($preserve eq 'end') {
63            substr $string, 0, $skipped_chars, '';
64            $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge
65                if $ddp->print_escapes;
66            $string = $skip_message . $string;
67        }
68        elsif ($preserve eq 'begin') {
69            $string = substr($string, 0, $max);
70            $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge
71                if $ddp->print_escapes;
72            $string = $string . $skip_message;
73        }
74        elsif ($preserve eq 'extremes') {
75            my $leftside_chars = int($max / 2);
76            my $rightside_chars = $max - $leftside_chars;
77            my $leftside = substr($string, 0, $leftside_chars);
78            my $rightside = substr($string, -$rightside_chars);
79            if ($ddp->print_escapes) {
80                $leftside  =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge;
81                $rightside =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge;
82            }
83            $string = $leftside . $skip_message . $rightside;
84        }
85        elsif ($preserve eq 'middle') {
86            my $string_middle = int($str_len / 2);
87            my $middle_substr = int($max / 2);
88            my $substr_begin  = $string_middle - $middle_substr;
89            my $message_begin = $ddp->string_overflow;
90            $message_begin =~ s/__SKIPPED__/$substr_begin/gs;
91            my $chars_left = $str_len - ($substr_begin + $max);
92            my $message_end = $ddp->string_overflow;
93            $message_end =~ s/__SKIPPED__/$chars_left/gs;
94            $string = substr($string, $substr_begin, $max);
95            $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge
96                if $ddp->print_escapes;
97            $string = $ddp->maybe_colorize($message_begin, 'caller_info', undef, $src_color)
98                    . $string
99                    . $ddp->maybe_colorize($message_end, 'caller_info', undef, $src_color)
100                    ;
101        }
102        else {
103            # preserving 'none' only shows the skipped message:
104            $string = $skip_message;
105        }
106    }
107    else {
108        # nothing to do? ok, then escape any colors already present:
109        $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge
110            if $ddp->print_escapes;
111    }
112    return $string;
113}
114
115
116# _escape_chars() replaces characters with their "escaped" versions.
117# Because it may be called on scalars or (scalar) hash keys and they
118# have different colors, we need to be aware of that.
119sub _escape_chars {
120    my ($ddp, $scalar, $src_color) = @_;
121
122    my $escape_kind = $ddp->escape_chars;
123    my %target_for = (
124        nonascii  => '[^\x{00}-\x{7f}]+',
125        nonlatin1 => '[^\x{00}-\x{ff}]+',
126    );
127
128    if ($ddp->unicode_charnames) {
129        require charnames;
130        if ($escape_kind eq 'all') {
131            $scalar = join('', map { sprintf '\N{%s}', charnames::viacode(ord $_) } split //, $scalar);
132            $scalar = $ddp->maybe_colorize($scalar, 'escaped');
133        }
134        else {
135            $scalar =~ s{($target_for{$escape_kind})}{$ddp->maybe_colorize( (join '', map { sprintf '\N{%s}', charnames::viacode(ord $_) } split //, $1), 'escaped', undef, $src_color)}ge if exists $target_for{$escape_kind};
136        }
137    }
138    elsif ($escape_kind eq 'all') {
139        $scalar = join('', map { sprintf '\x{%02x}', ord $_ } split //, $scalar);
140        $scalar = $ddp->maybe_colorize($scalar, 'escaped');
141    }
142    else {
143        $scalar =~ s{($target_for{$escape_kind})}{$ddp->maybe_colorize((join '', map { sprintf '\x{%02x}', ord $_ } split //, $1), 'escaped', undef, $src_color)}ge if exists $target_for{$escape_kind};
144    }
145    return $scalar;
146}
147
148# _print_escapes() prints invisible chars if they exist on a string.
149# Because it may be called on scalars or (scalar) hash keys and they
150# have different colors, we need to be aware of that. Also, \e is
151# deliberately omitted because it was escaped from the original
152# string earlier, and the \e's we have now are our own colorized
153# output.
154sub _print_escapes {
155    my ($ddp, $string, $src_color) = @_;
156
157    # always escape the null character
158    $string =~ s/\0/$ddp->maybe_colorize('\\0', 'escaped', undef, $src_color)/ge;
159
160    return $string unless $ddp->print_escapes;
161
162    my %escaped = (
163        "\n" => '\n',  # line feed
164        "\r" => '\r',  # carriage return
165        "\t" => '\t',  # horizontal tab
166        "\f" => '\f',  # formfeed
167        "\b" => '\b',  # backspace
168        "\a" => '\a',  # alert (bell)
169    );
170    foreach my $k ( keys %escaped ) {
171        $string =~ s/$k/$ddp->maybe_colorize($escaped{$k}, 'escaped', undef, $src_color)/ge;
172    }
173    return $string;
174}
175
176sub _initialize_nsort {
177    return 'Sort::Key::Natural'  if $INC{'Sort/Key/Natural.pm'};
178    return 'Sort::Naturally'     if $INC{'Sort/Naturally.pm'};
179    return 'Sort::Key::Natural'  if eval { require Sort::Key::Natural;  1; };
180    return 'Sort::Naturally'     if eval { require Sort::Naturally;     1; };
181    return 'core';
182}
183
184sub _nsort {
185    if (!$nsort_initialized) {
186        my $nsort_class = _initialize_nsort();
187        if ($nsort_class eq 'Sort::Key::Natural') {
188            $nsort_initialized = \&{ $nsort_class . '::natsort' };
189        }
190        elsif ($nsort_class ne 'core') {
191            $nsort_initialized = \&{ $nsort_class . '::nsort' };
192        }
193        else {
194            $nsort_initialized = \&_nsort_pp
195        }
196    }
197    return $nsort_initialized->(@_);
198}
199
200# this is a very simple 'natural-ish' sorter, heavily inspired in
201# http://www.perlmonks.org/?node_id=657130 by thundergnat and tye
202sub _nsort_pp {
203    my $i;
204    my @unsorted = map lc, @_;
205    foreach my $data (@unsorted) {
206        no warnings 'uninitialized';
207        $data =~ s/((\.0*)?)(\d+)/("\x0" x length $2) . (pack 'aNa*', 0, length $3, $3)/eg;
208        $data .= ' ' . $i++;
209    }
210    return @_[ map { (split)[-1] } sort @unsorted ];
211}
212
213sub _fetch_arrayref_of_scalars {
214    my ($props, $name) = @_;
215    return [] unless exists $props->{$name} && ref $props->{$name} eq 'ARRAY';
216    my @valid;
217    foreach my $option (@{$props->{$name}}) {
218        if (ref $option) {
219            # FIXME: because there is no object at this point, we need to check
220            # the 'warnings' option ourselves.
221            _warn(undef, "'$name' option requires scalar values only. Ignoring $option.")
222                if !exists $props->{warnings} || !$props->{warnings};
223            next;
224        }
225        push @valid, $option;
226    }
227    return \@valid;
228}
229
230sub _fetch_anyof {
231    my ($props, $name, $default, $list) = @_;
232    return $default unless exists $props->{$name};
233    foreach my $option (@$list) {
234        return $option if $props->{$name} eq $option;
235    }
236    _die(
237        "invalid value '$props->{$name}' for option '$name'"
238      . "(must be one of: " . join(',', @$list) . ")"
239    );
240};
241
242
243sub _fetch_scalar_or_default {
244    my ($props, $name, $default) = @_;
245    return $default unless exists $props->{$name};
246
247    if (my $ref = ref $props->{$name}) {
248        _die("'$name' property must be a scalar, not a reference to $ref");
249    }
250    return $props->{$name};
251}
252
253sub _die {
254    my ($message) = @_;
255    my ($file, $line) = _get_proper_caller();
256    die '[Data::Printer] ' . $message . " at $file line $line.\n";
257}
258
259sub _warn {
260    my ($ddp, $message) = @_;
261    return if $ddp && !$ddp->warnings;
262    my ($file, $line) = _get_proper_caller();
263    warn '[Data::Printer] ' . $message . " at $file line $line.\n";
264}
265
266sub _get_proper_caller {
267    my $frame = 1;
268    while (my @caller = caller($frame++)) {
269        if ($caller[0] !~ /\AD(?:DP|ata::Printer)/) {
270            return ($caller[1], $caller[2]);
271        }
272    }
273    return ('n/d', 'n/d');
274}
275
276
277# simple eval++ adapted from Try::Tiny.
278# returns a (true) error message if failed.
279sub _tryme {
280    my ($subref_or_string) = @_;
281
282    my $previous_error = $@;
283    my ($failed, $error);
284
285    if (ref $subref_or_string eq 'CODE') {
286        $failed = not eval {
287            local $SIG{'__DIE__'}; # make sure we don't trigger any exception hooks.
288            $@ = $previous_error;
289            $subref_or_string->();
290            return 1;
291        };
292        $error = $@;
293    }
294    else {
295        my $code = q(local $SIG{'__DIE__'};) . $subref_or_string;
296        $failed = not eval $code;
297        $error = $@;
298    }
299    $@ = $previous_error;
300    # at this point $failed contains a true value if the eval died,
301    # even if some destructor overwrote $@ as the eval was unwinding.
302    return unless $failed;
303    return ($error || '(unknown error)');
304}
305
306
307# When printing array elements or hash keys, we may traverse all of it
308# or just a few chunks. This function returns those chunks' indexes, and
309# a scalar ref to a message whenever a chunk was skipped.
310sub _fetch_indexes_for {
311    my ($array_ref, $prefix, $ddp) = @_;
312
313    my $max_function      = $prefix . '_max';
314    my $preserve_function = $prefix . '_preserve';
315    my $overflow_function = $prefix . '_overflow';
316    my $max      = $ddp->$max_function;
317    my $preserve = $ddp->$preserve_function;
318
319    return (0 .. $#{$array_ref}) if !$max || @$array_ref <= $max;
320
321    my $skip_message = $ddp->maybe_colorize($ddp->$overflow_function, 'overflow');
322    if ($preserve eq 'begin' || $preserve eq 'end') {
323        my $n_elements = @$array_ref - $max;
324        $skip_message =~ s/__SKIPPED__/$n_elements/g;
325        return $preserve eq 'begin'
326            ? ((0 .. ($max - 1)), \$skip_message)
327            : (\$skip_message, ($n_elements .. $#{$array_ref}))
328            ;
329    }
330    elsif ($preserve eq 'extremes') {
331        my $half_max = int($max / 2);
332        my $last_index_of_chunk_one = $half_max - 1;
333        my $n_elements = @$array_ref - $max;
334
335        my $first_index_of_chunk_two = @$array_ref - ($max - $half_max);
336        $skip_message =~ s/__SKIPPED__/$n_elements/g;
337        return (
338            (0 .. $last_index_of_chunk_one),
339            \$skip_message,
340            ($first_index_of_chunk_two .. $#{$array_ref})
341        );
342    }
343    elsif ($preserve eq 'middle') {
344        my $array_middle = int($#{$array_ref} / 2);
345        my $first_index_to_show = $array_middle - int($max / 2);
346        my $last_index_to_show = $first_index_to_show + $max - 1;
347        my ($message_begin, $message_end) = ($skip_message, $skip_message);
348        $message_begin =~ s/__SKIPPED__/$first_index_to_show/gse;
349        my $items_left = $#{$array_ref} - $last_index_to_show;
350        $message_end =~ s/__SKIPPED__/$items_left/gs;
351        return (
352            \$message_begin,
353            $first_index_to_show .. $last_index_to_show,
354            \$message_end
355        );
356    }
357    else { # $preserve eq 'none'
358        my $n_elements = scalar(@$array_ref);
359        $skip_message =~ s/__SKIPPED__/$n_elements/g;
360        return (\$skip_message);
361    }
362}
363
364# helpers below strongly inspired by the excellent Package::Stash:
365sub _linear_ISA_for {
366    my ($class, $ddp) = @_;
367    _initialize_mro($ddp) unless $mro_initialized;
368    my $isa;
369    if ($mro_initialized > 0) {
370        $isa = mro::get_linear_isa($class);
371    }
372    else {
373        # minimal fallback in case Class::MRO isn't available
374        # (should only matter for perl < 5.009_005):
375        $isa = [ $class, _get_superclasses_for($class) ];
376    }
377    return [@$isa, ($ddp->class->universal ? 'UNIVERSAL' : ())];
378}
379
380sub _initialize_mro {
381    my ($ddp) = @_;
382    my $error = _tryme(sub {
383        if ($] < 5.009_005) { require MRO::Compat }
384        else { require mro }
385        1;
386    });
387    if ($error && index($error, 'in @INC') != -1 && $mro_initialized == 0) {
388        _warn(
389            $ddp,
390            ($] < 5.009_005 ? 'MRO::Compat' : 'mro') . ' not found in @INC.'
391          . ' Objects may display inaccurate/incomplete ISA and method list'
392        );
393    }
394    $mro_initialized = $error ? -1 : 1;
395}
396
397sub _get_namespace {
398    my ($class_name) = @_;
399    my $namespace;
400    {
401        no strict 'refs';
402        $namespace = \%{ $class_name . '::' }
403    }
404    # before 5.10, stashes don't ever seem to drop to a refcount of zero,
405    # so weakening them isn't helpful
406    Scalar::Util::weaken($namespace) if $] >= 5.010;
407
408    return $namespace;
409}
410
411sub _get_superclasses_for {
412    my ($class_name) = @_;
413    my $namespace = _get_namespace($class_name);
414    my $res = _get_symbol($class_name, $namespace, 'ISA', 'ARRAY');
415    return @{ $res || [] };
416}
417
418sub _get_symbol {
419    my ($class_name, $namespace, $symbol_name, $symbol_kind) = @_;
420
421    if (exists $namespace->{$symbol_name}) {
422        my $entry_ref = \$namespace->{$symbol_name};
423        if (ref($entry_ref) eq 'GLOB') {
424            return *{$entry_ref}{$symbol_kind};
425        }
426        else {
427            if ($symbol_kind eq 'CODE') {
428                no strict 'refs';
429                return \&{ $class_name . '::' . $symbol_name };
430            }
431        }
432    }
433    return;
434}
435
4361;
437