File Coverage

blib/lib/App/yajg.pm

Criterion	Covered	Total	%
statement	170	193	88.0
branch	90	114	78.9
condition	64	82	78.0
subroutine	16	19	84.2
pod	1	11	9.0
total	341	419	81.3

package App::yajg;

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

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

our $VERSION = '0.20';

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::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 output ($) {
    my $output = shift;
    state $supported = {
        'ddp'  => 'App::yajg::Output::DDP',
        'json' => 'App::yajg::Output::Json',
        'perl' => 'App::yajg::Output::Perl',
        'yaml' => 'App::yajg::Output::Yaml',
    };
    die 'Output must be one of ' . join(', ' => map {"'$_'"} sort keys %$supported) . "\n"
      unless $supported->{$output};

    eval "require $supported->{$output}";
    die "Can't init output $output: $@" if $@;

    return $supported->{$output}->new;
}

1;

__END__