view release on metacpan or  search on metacpan

lib/Data/Hash/Patch/Smart/Engine.pm  view on Meta::CPAN

sub patch {
	my ($data, $changes, %opts) = @_;

	my $copy = dclone($data);

	for my $c (@$changes) {
		_apply_change($copy, $c, \%opts);
	}

	return $copy;
}

sub _apply_change {
	my ($root, $c, $opts) = @_;

	my $op = $c->{op} or die 'change missing op';
	my $path = $c->{path} or die 'change missing path';

	# Split path into segments like ('items', '0') or ('items', '*')
	my @parts = _split_path($path);

	# Leaf is the last segment; parent is everything before it
	my $leaf = pop @parts;

	# Structural wildcard (in parent path)
	if (grep { $_ eq '*' } @parts) {
		return _apply_structural_wildcard($root, \@parts, $leaf, $c, $opts);
	}

	# Walk down to the parent container (hash or array)
	my $parent = _walk_to_parent($root, \@parts, $leaf, $opts);

	# Unordered array semantics: leaf is '*'
	if ($leaf eq '*') {
		if ($op eq 'add') {
			_add_unordered($parent, $c->{value}, $opts);
		} elsif ($op eq 'remove') {
			_remove_unordered($parent, $c->{from}, $opts);
		} else {
			die "Unsupported op '$op' for unordered path '$path'";
		}
		return;
	}

	# Normal index/hash semantics
	if ($op eq 'change') {
		_set_value($parent, $leaf, $c->{to}, $opts);
	} elsif ($op eq 'add') {
		_add_value($parent, $leaf, $c->{value}, $opts);
	} elsif ($op eq 'remove') {
		_remove_value($parent, $leaf, $opts);
	} else {
		die "Unsupported op: $op";
	}
}

sub _split_path {
	my $path = $_[0];

	return () if !defined $path || $path eq '';
	my @parts = grep { length $_ } split m{/}, $path;
	return @parts;
}

# Walk down the structure following the given path segments,
# stopping at the parent of the leaf. In strict mode, we die on
# invalid paths. With create_missing => 1, we auto-create
# intermediate hashes/arrays as needed.
sub _walk_to_parent {
	my ($cur, $parts, $leaf, $opts) = @_;

	# Walk all segments that lead to the parent of $leaf
	for (my $i = 0; $i < @$parts; $i++) {
		my $p	= $parts->[$i];
		my $is_last = ($i == $#$parts);

		# For container creation, "next" is either the next part,
		# or, if we're at the last part, the leaf segment.
		my $next = $is_last ? $leaf : $parts->[$i + 1];

		# -----------------------------
		# HASH navigation
		# -----------------------------
		if (ref($cur) eq 'HASH') {

			# Missing key
			if (!exists $cur->{$p}) {
				if ($opts->{create_missing}) {
					# Decide container type based on what comes after
					if (defined $next && $next =~ /^\d+$/) {
						$cur->{$p} = [];
					} else {
						$cur->{$p} = {};
					}
				}
				elsif ($opts->{strict}) {
					die "Invalid path: missing hash key '$p'";
				}
				else {
					return undef;
				}
			}

			$cur = $cur->{$p};
			next;
		}

		# -----------------------------
		# ARRAY navigation
		# -----------------------------
		if (ref($cur) eq 'ARRAY') {

			# Index must be numeric
			if ($p !~ /^\d+$/) {
				die "Invalid path: non-numeric array index '$p'"
					if $opts->{strict};
				return undef;
			}

			# Out of bounds
			if ($p > $#$cur) {