view release on metacpan or  search on metacpan

lib/App/Greple/jq.pm  view on Meta::CPAN

use Carp;

our $VERSION = "0.06";

use Exporter 'import';
our @EXPORT = qw(&jq_filter);

use App::Greple::Common;
use App::Greple::Regions qw(match_regions merge_regions);
use Data::Dumper;

my %config;
sub set   { %config = @_ }
sub debug { set debug => 1 }
sub noif  { set noif  => 1 }

my $indent = '  ';
my $indent_re = qr/$indent/;

sub finalize {
    my($mod, $argv) = @_;
    if ($config{noif}) {
	my @default = $mod->default;
	$mod->setopt(default => grep { $_ ne '--jq-filter' } @default);
    }
}

sub re {
    my $pattern = shift;
    my $re = eval { qr/$pattern/ };
    if ($@) {
	die sprintf("$pattern: pattern error - %s\n",
		    $@ =~ /(.*?(?=;|$))/);
    }
    return $re;
}

sub prefix_regex {
    my $path = shift;
    my @prefix_re;
    my $level = '';
    while ($path =~ s/^([^.\n]*?)(\.+)//) {
	my($label, $dot) = ($1, $2);
	$label =~ s/%/.*/g;
	my $label_re = re($label);
	my $start_with = '';
	my $prefix_re = do {
	    if ($label eq '') {
		length($dot) > 1 ? '' : qr{ ^ (?= $indent_re \S) }xm;
	    } else {
		if (length($dot) == 1) {
		    ## using same capture group name is not a good idea
		    ## so make sure to put just for the last one
		    $level      = '?<level>' if $path eq '';
		    $start_with = qr/(?=\S)/;
		}
		qr{
		    ^ (${level} $indent_re*) "$label_re": .* \n
		    (?:
			## single line key-value pair
			\g{-1} $indent_re $start_with .++ \n
		    |
			## indented array/hash
			\g{-1} $indent_re \S .* [\[\{] \n
			(?: \g{-1} $indent_re \s .*+ \n) *+
			\g{-1} $indent_re [\]\}] ,? \n
		    ) *?
		}xm;
	    }
	};
	push @prefix_re, $prefix_re if $prefix_re;
    }
    if ($level eq '') {
	## refering named capture group causes error if it is not used
	## so put dummy expression just to fail
	push @prefix_re, qr/(?<level>(?!))?/;
    }
    @prefix_re
}

sub IN {
    my %opt = @_;
    my $target = delete $opt{&FILELABEL} or die;
    my($label, $pattern) = @opt{qw(label pattern)};
    my @prefix_re = $label =~ s/^((?:.*\.)?)// && prefix_regex($1);
    $label =~ s/%/.*/g;
    my($label_re, $pattern_re) = map re($_), $label, $pattern;
    my $re = qr{
	@prefix_re \K
	^
	(?(<level>) (?= \g{level} $indent_re \S ) )	# required level
	(?<in> [ ]*) "$label_re": [ ]*+			# find given label
	(?: . | \n\g{in} \s++ ) *			# and look for ...
	$pattern_re					# pattern
	(?: . | \n\g{in} (?: \s++ | [\]\}] ) ) *	# and take the rest
    }xm;
    warn "$re\n" if $config{debug};
    match_regions pattern => $re;
}

1;

__DATA__

define JSON-OBJECTS ^([ ]*)\{(?s:.*?)^\g{-1}\},?\n

option default --json-block --jq-filter

option --jq-filter --if='jq "if type == \"array\" then .[] else . end"'

option --json-block --block JSON-OBJECTS

define CALL_IN __PACKAGE__::IN(label=$<shift>,pattern=$<shift>)

option --AND  --IN
option --IN   --le  &CALL_IN --face +E
option --MUST --le +&CALL_IN --face +E
option --NOT  --le -&CALL_IN

#  LocalWords:  JSON jq json Zaphod greple CPANMINUS cpanm
#  LocalWords:  perl pid regex LESSANSIENDCHARS greplerc Kazumasa Mjq
#  LocalWords:  Utashiro Android committer mina ppid blockend