view release on metacpan or  search on metacpan

lib/Data/Printer/Common.pm  view on Meta::CPAN

package Data::Printer::Common;
# Private library of shared Data::Printer code.
use strict;
use warnings;
use Scalar::Util;

my $mro_initialized = 0;
my $nsort_initialized;


sub _filter_category_for {
    my ($name) = @_;
    my %core_types = map { $_ => 1 }
        qw(SCALAR LVALUE ARRAY HASH REF VSTRING GLOB FORMAT Regexp CODE OBJECT);
    return exists $core_types{$name} ? 'type_filters' : 'class_filters';
}

# strings are tough to process: there are control characters like "\t",
# unicode characters to name or escape (or do nothing), max_string to
# worry about, and every single piece of that could have its own color.
# That, and hash keys and strings share this. So we put it all in one place.
sub _process_string {
    my ($ddp, $string, $src_color) = @_;

    # colorizing messes with reduce_string because we are effectively
    # adding new (invisible) characters to the string. So we need to
    # handle reduction first. But! Because we colorize string_max
    # *and* we should escape any colors already present, we need to
    # do both at the same time.
    $string = _reduce_string($ddp, $string, $src_color);

    # now we escape all other control characters except for "\e", which was
    # already escaped in _reduce_string(), and convert any chosen charset
    # to the \x{} format. These could go in any particular order:
    $string = _escape_chars($ddp, $string, $src_color);
    $string = _print_escapes($ddp, $string, $src_color);

    # finally, send our wrapped string:
    return $ddp->maybe_colorize($string, $src_color);
}

sub _colorstrip {
    my ($string) = @_;
    $string =~ s{ \e\[ [\d;]* m }{}xmsg;
    return $string;
}

sub _reduce_string {
    my ($ddp, $string, $src_color) = @_;
    my $max = $ddp->string_max;
    my $str_len = length($string);
    if ($max && $str_len && $str_len > $max) {
        my $preserve = $ddp->string_preserve;
        my $skipped_chars = $str_len - ($preserve eq 'none' ? 0 : $max);
        my $skip_message = $ddp->maybe_colorize(
            $ddp->string_overflow,
            'caller_info',
            undef,
            $src_color
        );
        $skip_message =~ s/__SKIPPED__/$skipped_chars/g;
        if ($preserve eq 'end') {
            substr $string, 0, $skipped_chars, '';
            $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge
                if $ddp->print_escapes;
            $string = $skip_message . $string;
        }
        elsif ($preserve eq 'begin') {
            $string = substr($string, 0, $max);
            $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge
                if $ddp->print_escapes;
            $string = $string . $skip_message;
        }
        elsif ($preserve eq 'extremes') {
            my $leftside_chars = int($max / 2);
            my $rightside_chars = $max - $leftside_chars;
            my $leftside = substr($string, 0, $leftside_chars);
            my $rightside = substr($string, -$rightside_chars);
            if ($ddp->print_escapes) {
                $leftside  =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge;
                $rightside =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge;
            }
            $string = $leftside . $skip_message . $rightside;
        }
        elsif ($preserve eq 'middle') {
            my $string_middle = int($str_len / 2);
            my $middle_substr = int($max / 2);
            my $substr_begin  = $string_middle - $middle_substr;
            my $message_begin = $ddp->string_overflow;
            $message_begin =~ s/__SKIPPED__/$substr_begin/gs;
            my $chars_left = $str_len - ($substr_begin + $max);
            my $message_end = $ddp->string_overflow;
            $message_end =~ s/__SKIPPED__/$chars_left/gs;
            $string = substr($string, $substr_begin, $max);
            $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge
                if $ddp->print_escapes;
            $string = $ddp->maybe_colorize($message_begin, 'caller_info', undef, $src_color)
                    . $string
                    . $ddp->maybe_colorize($message_end, 'caller_info', undef, $src_color)
                    ;
        }
        else {
            # preserving 'none' only shows the skipped message:
            $string = $skip_message;
        }
    }
    else {
        # nothing to do? ok, then escape any colors already present:
        $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge
            if $ddp->print_escapes;
    }
    return $string;
}


# _escape_chars() replaces characters with their "escaped" versions.
# Because it may be called on scalars or (scalar) hash keys and they
# have different colors, we need to be aware of that.
sub _escape_chars {
    my ($ddp, $scalar, $src_color) = @_;

    my $escape_kind = $ddp->escape_chars;
    my %target_for = (
        nonascii  => '[^\x{00}-\x{7f}]+',
        nonlatin1 => '[^\x{00}-\x{ff}]+',
    );

    if ($ddp->unicode_charnames) {
        require charnames;
        if ($escape_kind eq 'all') {
            $scalar = join('', map { sprintf '\N{%s}', charnames::viacode(ord $_) } split //, $scalar);
            $scalar = $ddp->maybe_colorize($scalar, 'escaped');
        }
        else {
            $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};
        }
    }
    elsif ($escape_kind eq 'all') {
        $scalar = join('', map { sprintf '\x{%02x}', ord $_ } split //, $scalar);
        $scalar = $ddp->maybe_colorize($scalar, 'escaped');
    }
    else {
        $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};
    }
    return $scalar;
}

# _print_escapes() prints invisible chars if they exist on a string.
# Because it may be called on scalars or (scalar) hash keys and they
# have different colors, we need to be aware of that. Also, \e is
# deliberately omitted because it was escaped from the original
# string earlier, and the \e's we have now are our own colorized
# output.
sub _print_escapes {
    my ($ddp, $string, $src_color) = @_;

    # always escape the null character
    $string =~ s/\0/$ddp->maybe_colorize('\\0', 'escaped', undef, $src_color)/ge;

    return $string unless $ddp->print_escapes;

    my %escaped = (
        "\n" => '\n',  # line feed
        "\r" => '\r',  # carriage return
        "\t" => '\t',  # horizontal tab
        "\f" => '\f',  # formfeed
        "\b" => '\b',  # backspace
        "\a" => '\a',  # alert (bell)
    );
    foreach my $k ( keys %escaped ) {
        $string =~ s/$k/$ddp->maybe_colorize($escaped{$k}, 'escaped', undef, $src_color)/ge;
    }
    return $string;
}

sub _initialize_nsort {
    return 'Sort::Key::Natural'  if $INC{'Sort/Key/Natural.pm'};
    return 'Sort::Naturally'     if $INC{'Sort/Naturally.pm'};
    return 'Sort::Key::Natural'  if !_tryme('use Sort::Key::Natural; 1;');
    return 'Sort::Naturally'     if !_tryme('use Sort::Naturally; 1;');
    return 'core';
}

sub _nsort {
    if (!$nsort_initialized) {
        my $nsort_class = _initialize_nsort();
        if ($nsort_class eq 'Sort::Key::Natural') {
            $nsort_initialized = \&{ $nsort_class . '::natsort' };