view release on metacpan or  search on metacpan

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

# 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' };
        }
        elsif ($nsort_class ne 'core') {
            $nsort_initialized = \&{ $nsort_class . '::nsort' };
        }
        else {
            $nsort_initialized = \&_nsort_pp
        }
    }
    return $nsort_initialized->(@_);
}

# this is a very simple 'natural-ish' sorter, heavily inspired in
# http://www.perlmonks.org/?node_id=657130 by thundergnat and tye
sub _nsort_pp {
    my $i;
    my @unsorted = map lc, @_;
    foreach my $data (@unsorted) {
        no warnings 'uninitialized';
        $data =~ s/((\.0*)?)(\d+)/("\x0" x length $2) . (pack 'aNa*', 0, length $3, $3)/eg;
        $data .= ' ' . $i++;
    }
    return @_[ map { (split)[-1] } sort @unsorted ];
}

sub _fetch_arrayref_of_scalars {
    my ($props, $name) = @_;
    return [] unless exists $props->{$name} && ref $props->{$name} eq 'ARRAY';
    my @valid;
    foreach my $option (@{$props->{$name}}) {
        if (ref $option) {
            # FIXME: because there is no object at this point, we need to check
            # the 'warnings' option ourselves.
            _warn(undef, "'$name' option requires scalar values only. Ignoring $option.")
                if !exists $props->{warnings} || !$props->{warnings};
            next;
        }
        push @valid, $option;
    }
    return \@valid;
}

sub _fetch_anyof {
    my ($props, $name, $default, $list) = @_;
    return $default unless exists $props->{$name};
    foreach my $option (@$list) {
        return $option if $props->{$name} eq $option;
    }
    _die(
        "invalid value '$props->{$name}' for option '$name'"
      . "(must be one of: " . join(',', @$list) . ")"
    );
};