File Coverage

blib/lib/JSON/Transform.pm

Criterion	Covered	Total	%
statement	175	182	96.1
branch	79	100	79.0
condition	20	30	66.6
subroutine	15	15	100.0
pod	1	1	100.0
total	290	328	88.4

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;
}

sub _eval_expr {
  my ($topdata, $expr, $sysvals, $uservals, $as_location) = @_;
  my $name = $expr->{nodename};
  if ($name eq 'jsonPointer') {
    my $text = join '', '', map _eval_expr($topdata, $_, $sysvals, $uservals),
      @{$expr->{children} || []};
    return $text if $as_location;
    die "invalid src pointer '$text'" if !_pointer(1, $topdata, $text);
    return _pointer(0, $topdata, $text);
  } elsif ($name eq 'variableUser') {
    my $var = $expr->{children}[0];
    die "Unknown user variable '$var'" if !exists $uservals->{$var};
    return $uservals->{$var};
  } elsif ($name eq 'variableSystem') {
    my $var = $expr->{children}[0];
    die "Unknown system variable '$var'" if !exists $sysvals->{$var};
    return $sysvals->{$var};
  } elsif ($name eq 'jsonOtherNotDouble' or $name eq 'jsonOtherNotGrave') {
    return $expr->{children}[0];
  } elsif ($name eq 'exprStringQuoted') {
    my $text = join '', '', map _eval_expr($topdata, $_, $sysvals, $uservals),
      @{$expr->{children} || []};
    return $text;
  } elsif ($name eq 'exprSingleValue') {
    my ($mainexpr, @other) = @{$expr->{children}};
    my $value = _eval_expr($topdata, $mainexpr, $sysvals, $uservals);
    for (@other) {
      my $othername = $_->{nodename};
      if ($othername eq 'exprKeyRemove') {
        my ($keyexpr) = @{$_->{children}};
        my $whichkey = _eval_expr($topdata, $keyexpr, $sysvals, $uservals);
        delete $value->{$whichkey};
      } elsif ($othername eq 'exprKeyAdd') {
        my ($keyexpr, $valueexpr) = @{$_->{children}};
        my $key = _eval_expr($topdata, $keyexpr, $sysvals, $uservals);
        my $addvalue = _eval_expr($topdata, $valueexpr, $sysvals, $uservals);
        $value->{$key} = $addvalue;
      } elsif ($othername eq 'exprApplyJsonPointer') {
        my ($ptrexpr) = @{$_->{children}};
        return _eval_expr($value, $ptrexpr, $sysvals, $uservals);
      } else {
        die "Unknown expression modifier '$othername'";
      }
    }
    return $value;
  } elsif ($IS_BACKSLASH_ENTITY{$name}) {
    my ($what) = @{$expr->{children}};
    my $really = $QUOTED2LITERAL{$what};
    die "Unknown $name '$what'" if !defined $really;
    return $really;
  } elsif ($name eq 'jsonUnicode') {
    my ($what) = @{$expr->{children}};
    return chr hex $what;
  } elsif ($name eq 'exprArrayLiteral') {
    my @contents = @{$expr->{children} || []};
    my @data;
    for (@contents) {
      my $value = _eval_expr($topdata, $_, $sysvals, $uservals);
      push @data, $value;
    }
    return \@data;
  } elsif ($name eq 'exprObjectLiteral') {
    my @colonPairs = @{$expr->{children} || []};
    my %data;
    for (@colonPairs) {
      my ($keyexpr, $valueexpr) = @{$_->{children}};
      my $key = _eval_expr($topdata, $keyexpr, $sysvals, $uservals);
      my $value = _eval_expr($topdata, $valueexpr, $sysvals, $uservals);
      $data{$key} = $value;
    }
    return \%data;
  } else {
    die "Unknown expr type '$name'";
  }
}

sub _data2pairs {
  my ($data) = @_;
  if (ref $data eq 'HASH') {
    return map [ $_, $data->{$_} ], sort keys %$data;
  } elsif (ref $data eq 'ARRAY') {
    my $count = 0;
    return map [ $count++, $_ ], @$data;
  } else {
    die "Given data '$data' neither array nor hash";
  }
}

# based on heart of Mojo::JSON::Pointer
# could be more memory-efficient by shallow-copy/replacing data at each level
sub _pointer {
  my ($contains, $data, $pointer, $is_delete, $set_to) = @_;
  my $is_set = @_ > 4; # if 5th arg supplied, even if false
  return $_[1] = $set_to if $is_set and !length $pointer;
  return $contains ? 1 : $data unless $pointer =~ s!^/!!;
  my $lastptr;
  my @parts = length $pointer ? (split '/', $pointer, -1) : ($pointer);
  while (defined(my $p = shift @parts)) {
    $p =~ s!~1!/!g;
    $p =~ s/~0/~/g;
    if (ref $data eq 'HASH') {
      return undef if !exists $data->{$p} and !$is_set;
      $data = ${ $lastptr = \(
        @parts == 0 && $is_delete ? delete $data->{$p} : $data->{$p}
      )};
    }
    elsif (ref $data eq 'ARRAY') {
      return undef if !($p =~ /^\d+$/ || @$data > $p) and !$is_set;
      $data = ${ $lastptr = \(
        @parts == 0 && $is_delete ? delete $data->[$p] : $data->[$p]
      )};
    }
    else { return undef }
  }
  $$lastptr = $set_to if defined $lastptr and $is_set;
  return $contains ? 1 : $data;
}

1;

__END__