view release on metacpan or  search on metacpan

lib/JSON/Transform.pm  view on Meta::CPAN

package JSON::Transform;

use strict;
use warnings;
use Exporter 'import';
use Storable qw(dclone);
use JSON::Transform::Grammar;
use XML::Invisible qw(make_parser);

use constant DEBUG => $ENV{JSON_TRANSFORM_DEBUG};

our $VERSION = '0.03';
our @EXPORT_OK = qw(
  parse_transform
);

my %QUOTED2LITERAL = (
  b => "\b",
  f => "\f",
  n => "\n",
  r => "\r",
  t => "\t",
  '\\' => "\\",
  '$' => "\$",
  '`' => "`",
  '"' => '"',
  '/' => "/",
);
my %IS_BACKSLASH_ENTITY = map {$_=>1} qw(
  jsonBackslashDouble
  jsonBackslashDollar
  jsonBackslashQuote
  jsonBackslashGrave
);

my $parser = make_parser(JSON::Transform::Grammar->new);
sub parse_transform {
  my ($input_text) = @_;
  my $transforms = $parser->($input_text);
  sub {
    my ($data) = @_;
    $data = dclone $data; # now can mutate away
    my $uservals = {};
    for (@{$transforms->{children}}) {
      my $name = $_->{nodename};
      my ($srcptr, $destptr, $mapping);
      if ($name eq 'transformImpliedDest') {
        ($srcptr, $mapping) = @{$_->{children}};
        $destptr = $srcptr;
      } elsif ($name eq 'transformCopy') {
        ($destptr, $srcptr, $mapping) = @{$_->{children}};
      } elsif ($name eq 'transformMove') {
        ($destptr, $srcptr) = @{$_->{children}};
        $srcptr = _eval_expr($data, $srcptr, _make_sysvals(), $uservals, 1);
        die "invalid src pointer '$srcptr'" if !_pointer(1, $data, $srcptr);
        my $srcdata = _pointer(0, $data, $srcptr, 1);
        _apply_destination($data, $destptr, $srcdata, $uservals);
        return $data;
      } else {
        die "Unknown transform type '$name'";
      }
      my $srcdata = _eval_expr($data, $srcptr, _make_sysvals(), $uservals);
      my $newdata;
      if ($mapping) {
        my $opFrom = $mapping->{attributes}{opFrom};
        die "Expected '$srcptr' to point to hash"
          if $opFrom eq '<%' and ref $srcdata ne 'HASH';
        die "Expected '$srcptr' to point to array"
          if $opFrom eq '<@' and ref $srcdata ne 'ARRAY';
        $newdata = _apply_mapping($data, $mapping->{children}[0], dclone $srcdata, $uservals);
      } else {
        $newdata = $srcdata;
      }
      _apply_destination($data, $destptr, $newdata, $uservals);
    }
    $data;
  };
}

sub _apply_destination {
  my ($topdata, $destptr, $newdata, $uservals) = @_;
  my $name = $destptr->{nodename};
  if ($name eq 'jsonPointer') {
    $destptr = _eval_expr($topdata, $destptr, _make_sysvals(), $uservals, 1);
    _pointer(0, $_[0], $destptr, 0, $newdata);
  } elsif ($name eq 'variableUser') {
    my $var = $destptr->{children}[0];
    $uservals->{$var} = $newdata;
  } else {
    die "unknown destination type '$name'";
  }
}

sub _apply_mapping {
  my ($topdata, $mapping, $thisdata, $uservals) = @_;
  my $name = $mapping->{nodename};
  my @pairs = _data2pairs($thisdata);
  if ($name eq 'exprObjectMapping') {
    my ($keyexpr, $valueexpr) = @{$mapping->{children}};
    my %data;
    for (@pairs) {
      my $sysvals = _make_sysvals($_, \@pairs);
      my $key = _eval_expr($topdata, $keyexpr, $sysvals, $uservals);
      my $value = _eval_expr($topdata, $valueexpr, $sysvals, $uservals);
      $data{$key} = $value;
    }
    return \%data;
  } elsif ($name eq 'exprArrayMapping') {
    my ($valueexpr) = @{$mapping->{children}};
    my @data;
    for (@pairs) {
      my $sysvals = _make_sysvals($_, \@pairs);
      my $value = _eval_expr($topdata, $valueexpr, $sysvals, $uservals);
      push @data, $value;
    }
    return \@data;
  } elsif ($name eq 'exprSingleValue') {
    my ($valueexpr) = $mapping;
    my $sysvals = _make_sysvals(undef, \@pairs);
    return _eval_expr($topdata, $valueexpr, $sysvals, $uservals);
  } else {
    die "Unknown mapping type '$name'";
  }
}

sub _make_sysvals {
  my ($pair, $pairs) = @_;
  my %vals = (E => \%ENV);
  $vals{C} = scalar @$pairs if $pairs;
  @vals{qw(K V)} = @$pair if $pair;
  return \%vals;
}