File Coverage

blib/lib/App/yajg.pm

Criterion	Covered	Total	%
statement	178	217	82.0
branch	91	130	70.0
condition	64	91	70.3
subroutine	18	22	81.8
pod	1	12	8.3
total	352	472	74.5

package App::yajg;

use 5.014000;
use strict;
use warnings;
no if $] >= 5.017011, warnings => 'experimental::smartmatch';
use utf8;

use Data::Dumper;
use JSON::XS qw();

our $VERSION = '0.18';

our %CAN;

BEGIN {
    $CAN{'highlight'} = eval {
        # FIXME: probably will not work if not unix os
        qx(which highlight 2>/dev/null) and $? == 0
    };
    # $CAN{'highlight'}->{'error'} = $@;
    $CAN{'ddp'} = eval { require Data::Printer };
    $CAN{'_error'}->{'ddp'} = $@;
}

sub MAX_RECURSION () {300}

{
    my $inc = caller() ? $INC{ __PACKAGE__ =~ s/::/\//r . '.pm' } : undef;
    my $at = join '|' => "\Q$0\E", '\(eval [0-9]++\)', '-[eE]', $inc ? "\Q$inc\E" : ();
    my $re = qr/at (?:$at) line [0-9]++(?:\.|, <> (?:chunk|line) [0-9]++\.)/;
    sub remove_at_line ($) { (shift // '') =~ s/$re//r }
}

sub warn_without_line { warn remove_at_line shift }
sub die_without_line  { die remove_at_line shift }

sub size ($) {
    ref $_[0] eq 'ARRAY' and @{ $_[0] } or ref $_[0] eq 'HASH' and %{ $_[0] }
}

sub values_ref ($) {
    ref $_[0] eq 'ARRAY'    ? @{ $_[0] }
      : ref $_[0] eq 'HASH' ? (values %{ $_[0] })
      : wantarray           ? ()
      : 0
}

sub read_next_json_file () {
    local $/;
    local $SIG{__WARN__} = \&warn_without_line;
    while (<>) {
        utf8::encode($_) if utf8::is_utf8($_);
        $_ = eval { JSON::XS::decode_json($_) };
        warn "Failed to parse $ARGV: $@" if $@;
        next unless ref $_;
        return $_;
    }
    return;
}

sub parse_select ($;$) {
    my $select = shift // return;
    my $args   = shift // {};
    my @select_path;
    # split by '.' exept '\.'
    for (split /(? $select) {
        # now we can do unescape '\.'
        s/\\\././g;
        my $type = '';
        # {....}
        if (s/^\{(.*)\}$/$1/) {
            $type = 'HASH';
            if ($args->{'ignore_case'}) {
                $type = 'HASH_IC';
                $_    = lc($_);
            }
        }
        # [....]
        elsif (s/^\[(.*)\]$/$1/) {
            $type = 'SLICE';
            s/^\s*|\s*$//g;
            # '2, 3, -2' -> [2, 3, 4]
            my $list = [];
            my $err;
            for (split ',') {
                s/^\s*|\s*$//g;
                next unless length $_;
                unless (m/^[+-]?[0-9]++$/) {
                    warn "Failed to parse select: '$_' not a number\n";
                    $err = 1;
                    next;
                }
                push @$list, int($_);
            }
            die "Failed to parse select: '$_' not a number or list of numbers\n"
              if $err or not @$list;
            $_ = $list;
        }
        # /..../
        elsif (s/^\/(.*)\/$/$1/) {
            $type = 'REGEXP';
            local $SIG{__DIE__} = \&die_without_line;
            my $pat = $_;
            $pat = '(?i)' . $pat if $args->{'ignore_case'};
            eval { $_ = qr/$pat/ } or die "Failed to parse select: $@";
        }
        else {
            $type = 'UNKNOWN';
            no warnings 'uninitialized';
            s/^\\(\/)|\\(\/)$/$1$2/g;    # \/...\/ -> /.../
            s/^\\(\{)|\\(\})$/$1$2/g;    # \{...\} -> {...}
            s/^\\(\[)|\\(\])$/$1$2/g;    # \[...\] -> [...]
            if ($args->{'ignore_case'}) {
                $type = 'UNKNOWN_IC';
                $_    = lc($_);
            }
        }
        push @select_path, {
            type => $type,
            val  => $_,
        };
    }
    return @select_path;
}

sub select_by_path {
    my $data = shift;

    # no path
    return $data unless @_;
    # we can select only at ARRAY or HASH
    return undef unless ref $data ~~ [qw/HASH ARRAY/];

    my $current = shift;
    my $type    = $current->{'type'};
    my $val     = $current->{'val'};
    if (ref $data eq 'HASH') {
        given ($type) {
            when ([qw/HASH UNKNOWN/]) {
                return undef unless exists $data->{$val};
                my $selected = select_by_path($data->{$val}, @_);
                return undef if @_ and not defined $selected;
                return { $val => $selected };
            }
            when ([qw/HASH_IC UNKNOWN_IC/]) {
                my %selected = ();
                for (grep { lc($_) eq $val } keys %$data) {
                    my $selected = select_by_path($data->{$_}, @_);
                    next if @_ and not defined $selected;
                    $selected{$_} = $selected;
                }
                return %selected ? \%selected : undef;
            }
            when ('REGEXP') {
                my %selected = ();
                for (grep {m/$val/} keys %$data) {
                    my $selected = select_by_path($data->{$_}, @_);
                    next if @_ and not defined $selected;
                    $selected{$_} = $selected;
                }
                return %selected ? \%selected : undef;
            }
            default { return undef }
        }
    }
    elsif (ref $data eq 'ARRAY') {
        given ($type) {
            when ('SLICE') {
                my @slice = @$data[@$val];
                return undef unless @slice;
                my @selected;
                for (@slice) {
                    my $selected = select_by_path($_, @_);
                    next if @_ and not defined $selected;
                    push @selected, $selected;
                }
                return @selected ? \@selected : undef;
            }
            when ('REGEXP') {
                my @selected;
                for (grep {m/$val/} keys @$data) {
                    my $selected = select_by_path($data->[$_], @_);
                    next if @_ and not defined $selected;
                    push @selected, $selected;
                }
                return @selected ? \@selected : undef;
            }
            when ([qw/UNKNOWN UNKNOWN_IC/]) {
                return undef unless $val =~ m/^[+-]?[0-9]++$/;
                return undef unless exists $data->[$val];
                my $selected = select_by_path($data->[$val], @_);
                return undef if @_ and not defined $selected;
                return [$selected];
            }
            default { return undef }
        }
    }
    return undef;
}

sub filter {
    my ($data, $key_pat, $val_pat, $i, $visited, $r) = @_;

    # Nothing to filter if we have no filter patterns
    return $data unless defined $key_pat or defined $val_pat;

    # $i - invert match flag

    # Deep recursion protection
    $r //= 0;
    if (++$r > MAX_RECURSION) {
        warn "Too deep filtering\n";
        return $data;
    }

    # for $val_pat we do grep at array or hash loops
    return $data unless ref $data ~~ [qw/ARRAY HASH/];

    # If we have been already visited this ref
    $visited //= {};
    return $visited->{$data} if $visited->{$data};

    my $ret;

    if (ref $data eq 'HASH') {
        $ret = {};
        for (keys %$data) {
            if (
                # only key_pat
                (defined $key_pat and not defined $val_pat and m/$key_pat/)
                # otherwise data must be defined scalar
                or (not ref $data->{$_} and defined $data->{$_}
                    and (not defined $key_pat or m/$key_pat/)
                    and (not defined $val_pat or ($data->{$_} =~ m/$val_pat/ xor $i))
                )
                # if invert match and we have $val_pat we need to allow
                # empty arrays, empty hashes, undef values and other refes
                or ($i and defined $val_pat
                    and (not defined $data->{$_}
                        or ref $data->{$_} and not size($data->{$_})
                    )
                )
              ) {
                $ret->{$_} = $data->{$_};
            }
            elsif (ref $data->{$_} ~~ [qw/ARRAY HASH/]) {
                my $filtered = filter($data->{$_}, $key_pat, $val_pat, $i, $visited, $r);
                $ret->{$_} = $filtered if size($filtered);
            }
            else {
                next;
            }
        }
    }
    elsif (ref $data eq 'ARRAY') {
        $ret = [];
        for (@$data) {
            if (ref $_ ~~ [qw/HASH ARRAY/]) {
                my $filtered = filter($_, $key_pat, $val_pat, $i, $visited, $r);
                push @$ret, $filtered if size($filtered);
            }
            elsif (defined $val_pat
                and (defined $_ and not ref $_ and (m/$val_pat/ xor $i)
                    # if invert match and we have $val_pat we need to allow
                    # empty arrays, empty hashes, undef values and other refes
                    or ($i and (not defined $_ or ref $_ and not size($_)))
                )
              ) {
                push @$ret, $_;
            }
        }
    }

    return $visited->{$data} = $ret;
}

sub modify_data {
    return if @_ == 1;

    my $r       = 0;
    my $visited = {};
    if (@_ > 2) {
        $r       = pop;
        $visited = pop;
    }
    my $hooks = pop;
    return unless size $hooks;

    if (++$r > MAX_RECURSION) {
        warn "Too deep modification\n";
        return;
    }

    if (ref $_[0] eq 'HASH') {
        return if $visited->{ $_[0] };
        modify_data($_, $hooks, $visited, $r) for values %{ $_[0] };
        $visited->{ $_[0] } = 1;
    }
    elsif (ref $_[0] eq 'ARRAY') {
        return if $visited->{ $_[0] };
        modify_data($_, $hooks, $visited, $r) for @{ $_[0] };
        $visited->{ $_[0] } = 1;
    }
    else {
        $_->($_[0]) for @$hooks;
    }
}

sub highlight ($$) {
    my ($string, $lang) = @_;

    return $string unless $CAN{'highlight'};

    # IPC::Open2 hangs on big data so we will do like this
    my $pid = open(my $hl_out, '-|');
    if (not defined $pid) {
        warn "highlight failed: $!\n";
        return $string;
    }
    my $utf8 = utf8::is_utf8($string);

    unless ($pid) {
        open(my $hl_in, '|-', 'highlight', '-O', 'ansi', '-S', $lang)
          or die "$!\n";
        utf8::encode($string) if utf8::is_utf8($string);
        print $hl_in $string;
        close $hl_in;
        exit 0;
    }

    local $/;
    my $highlighted = <$hl_out>;
    close $hl_out;    # may be waitpid($pid, 0); ??
    return $string unless $? == 0;
    utf8::decode($highlighted) if $utf8 and not utf8::is_utf8($highlighted);

    return $highlighted || $string;
}

our %OUT = (
    'ddp' => sub {
        my ($data, $args) = @_;
        my $ddp = Data::Printer::np($data,
            colored   => $args->{'color'},
            max_depth => $args->{'max_depth'},
        );
        utf8::encode($ddp) if utf8::is_utf8($ddp);
        say $ddp;
    },
    'json' => sub {
        my ($data, $args) = @_;
        local $SIG{__WARN__} = \&warn_without_line;

        if ($args->{'max_depth'}) {
            my $VAR1;
            eval Data::Dumper->new([$data])->Maxdepth($args->{'max_depth'})->Dump();
            if ($@ or not defined $VAR1) {
                warn "max_depth failed: $@";
            }
            else {
                $data = $VAR1;
            }
        }

        my $json = eval {
            JSON::XS
              ->new
              ->pretty(int not $args->{'minimal'})
              ->allow_nonref
              ->canonical
              ->encode($data)
        };
        warn($@), return if $@;
        $json = highlight($json, 'js') if $args->{'color'};
        utf8::encode($json) if utf8::is_utf8($json);
        print $json;
    },
    'perl' => sub {
        my ($data, $args) = @_;
        local $SIG{__WARN__} = \&warn_without_line;
        local $Data::Dumper::Useperl = 1;
        no warnings 'redefine';
        local *Data::Dumper::qquote = sub {
            my $d = shift;
            utf8::encode $d if utf8::is_utf8($d);
            return "'$d'";
        };
        my $perl = eval {
            Data::Dumper->new([$data])
              ->Indent(int not $args->{'minimal'})
              ->Pair($args->{'minimal'} ? '=>' : ' => ')
              ->Terse(1)
              ->Sortkeys(int not $args->{'minimal'})
              ->Useqq(1)
              ->Maxdepth($args->{'max_depth'})
              ->Dump()
        };
        warn($@), return if $@;
        $perl = highlight($perl, 'perl') if $args->{'color'};
        utf8::encode($perl) if utf8::is_utf8($perl);
        print $perl;
    },
);

sub validate_output ($) {
    my $output = shift;
    die 'Output must be one of ' . join(', ' => map {"'$_'"} sort keys %OUT) . "\n"
      unless $OUT{$output};
    die "Can't require Data::Printer : $CAN{'_error'}->{'ddp'}\n"
      if not $CAN{'ddp'} and $output eq 'ddp';
}

1;

__END__