A Reverse Polish Notation for JSON processing.

json_rpn.pl

use JSON;
use Encode;

#--------------------------------------------------
sub pop1{pop@{$_[0]}}
sub pop2{$_=shift;(pop@$_,pop@$_)}
sub pop3{$_=shift;(pop@$_,pop@$_,pop@$_)}
sub popN{my($n,$_)=@_;map{pop@$_}(1..$n)}

sub popL{
    my $s=shift;
    if ($s->[-1] eq ']') {
	my @res=();
	pop @$s;
	push @res,(pop @$s) while ($s->[-1] ne '[');
	pop @$s;
	return \@res;
    }
    return undef;
}

sub p{print "[$_] ",_p($_[0][$_]),"\n" for (0..$#{$_[0]})}
sub _p{
    my $x=shift;
    my $t=ref $x;
    if ($t eq "ARRAY") {
	"[".join(',',map{_p($_)}@$x)."]";
    } elsif ($t eq "HASH") {
	"{".join(',',map{$_."=>"._p($x->{$_})}keys(%$x))."}";
    } else {
	Encode::encode_utf8($x);
    }
}

sub deep_copy {
    my $d=shift;
    my $t=ref $d;
    if ($t eq 'ARRAY') {
	my @res=map{deep_copy($_)}@$d;
	return \@res;
    } elsif ($t eq 'HASH') {
	my %res;
	$res{$_}=deep_copy($d->{$_}) for keys(%$d);
	return \%res;
    } else {
	my $res=$d;
	return $res;
    }
}

#--------------------------------------------------
our %op;

$op{','} = sub{};

$op{'='} = sub { # shallow dup
    my ($j)=pop1($_[0]);
    push @{$_[0]},$j,$j;
};

$op{':'} = sub { # deep dup
    my ($j)=pop1($_[0]);
    push @{$_[0]},$j,deep_copy($j);
};

$op{';'} = sub { # deep dup in-place
    my ($j)=pop1($_[0]);
    push @{$_[0]},deep_copy($j);
};

$op{'~'}=sub{ # swap
    my ($x,$y)=pop2($_[0]);
    push @{$_[0]},$x,$y;
}; 

$op{'^'}=sub{ # del
    pop1($_[0]);
}; 

$op{'.'} = sub { # proj
    my ($k,$j)=pop2($_[0]);
    my $t=ref $j;
    if ($t eq 'ARRAY') {
	push @{$_[0]},$j->[$k]
    } elsif ($t eq 'HASH') {
	push @{$_[0]},$j->{$k}
    }
};

$op{'['} = sub { 
    push @{$_[0]},'[',@{pop1($_[0])},']';
};

$op{']'} = sub {
    push @{$_[0]},popL($_[0]);
};

our $op2 = sub {
    my ($x,$y)=pop2($_[0]);
    my $t=ref $y;
    if ($t eq 'ARRAY') {
	$y->[$_]=$_[1]->($x,$y->[$_]) for (0..$#{$y});
	push @{$_[0]},$y;
    } elsif ($t eq 'HASH') {
	$y->{$_}=$_[1]->($x,$y->{$_}) for (keys %$y);
	push @{$_[0]},$y;
    } else {
	push @{$_[0]},$_[1]->($x,$y);
    }
};

$op{'+'} = sub{$op2->($_[0],sub{$_[0]+$_[1]})};
$op{'-'} = sub{$op2->($_[0],sub{$_[0]-$_[1]})};
$op{'*'} = sub{$op2->($_[0],sub{$_[0]*$_[1]})};
$op{'/'} = sub{$op2->($_[0],sub{$_[0]/$_[1]})};
$op{'%'} = sub{$op2->($_[0],sub{$_[0]%$_[1]})};


#--------------------------------------------------
sub _doq {
    return $_[1] unless $_[0];
    $_[0] =~ s/^\s*(\w+|[,\.\[\]\+\-\*\/\^~%]|=+)//x;
    return $_[1] if ($1 eq '');
    my $f=$op{$1};
    $f ? $f->($_[1]) : push @{$_[1]},$1;
#    print "pattern '$_[0]'\n";
#    print "token '$1'\n";
#    p $_[1];
    goto &_doq;
}

sub doq {my($p,$j)=@_;_doq($p,[$j])}

sub json_doq {doq($_[0],JSON::decode_json($_[1]))}

#--------------------------------------------------
sub main {
    print "Usage: $0 [pattern] [json_file]\nHere are test.\n" unless @_;
    p(json_doq(@$_)) for @{
	-e $_[1] ? [[$_[0],`cat $_[1]`]] : [
	     ['=0.1+2*3/~~^','[[1,2,3],{"text":"hoge"}]'],
	    ]};
}

main(@ARGV);