Skip to content

Commit

Permalink
path(): independent traverse implemented
Browse files Browse the repository at this point in the history
  • Loading branch information
@mr-mixas
mr-mixas committed Feb 27, 2019
1 parent e8e4b6e commit a72aa7d
Show file tree
Hide file tree
Showing 2 changed files with 110 additions and 99 deletions.
207 changes: 109 additions & 98 deletions lib/Struct/Path.pm
View file
Expand Up @@ -88,11 +88,12 @@ should be a list of desired keys and compiled regular expressions. Empty
hash or empty list for C<K> means all keys, sequence in the list define
resulting sequence.
Coderef step is a hook - subroutine which may filter and/or modify
structure. Path as first argument and a stack (arrayref) of refs to traversed
substructures as second passed to it when executed, C<$_> set to current
substructure, C<$_{opts}> contains passed options. Some true (match) value or
false (doesn't match) value expected as output.
Coderef step is a hook - subroutine which may filter out items and/or modify
structure. Traversed path for first, stack of passed structured for secong and
path remainder for third agrument passed to hook when executed; all passed args
are arrayrefs. Among this two global variables available within hook: C<$_> is
set to current substructure and C<$_{opts}> contains c<path()>'s options. Some
true (match) value or false (doesn't match) value expected as output.
Sample:
Expand Down Expand Up @@ -216,119 +217,129 @@ All options are disabled (C<undef>) by default.
=cut

sub path($$;@) {
my (undef, $path, %opts) = @_;
my (undef, $init_path, %opts) = @_;

croak "Arrayref expected for path" unless (ref $path eq 'ARRAY');
croak "Arrayref expected for path" unless (ref $init_path eq 'ARRAY');
croak "Unable to remove passed thing entirely (empty path passed)"
if ($opts{delete} and not @{$path});

my @level = ([], [\$_[0]]); # alias - to be able to rewrite passed scalar
my $sc = 0; # step counter
my ($items, @next, $steps, $refs, $step_type, @types);

for my $step (@{$path}) {
while (($steps, $refs) = splice @level, 0, 2) {
croak "Reference expected for refs stack entry, step #$sc"
unless (ref $refs->[-1]);

if (($step_type = ref $step) eq 'ARRAY') {
if (ref ${$refs->[-1]} ne 'ARRAY') {
croak "ARRAY expected on step #$sc, got " . ref ${$refs->[-1]}
if ($opts{strict});
next unless ($opts{expand});
${$refs->[-1]} = [];
}
if ($opts{delete} and not @{$init_path});

$items = @{$step} ? $step : [0 .. $#${$refs->[-1]}];
for (@{$items}) {
unless (
$opts{expand} or
@{${$refs->[-1]}} > ($_ >= 0 ? $_ : abs($_ + 1))
) {
croak "[$_] doesn't exist, step #$sc" if ($opts{strict});
next;
}
# use alias for refs - to be able to rewrite passed scalar
my @stack = ([], [\$_[0]], [@{$_[1]}]);
my (@done, $items, $path, $pos, $refs, $rest, $step, $step_type);

while (($path, $refs, $rest) = splice @stack, 0, 3) {
if (not ref $refs->[-1]) {
croak "Reference expected for refs stack entry, step #$pos";
} elsif (not @{$rest}) {
${$refs->[-1]} = $opts{assign} if (exists $opts{assign});

if ($opts{stack}) {
map { $_ = ${$_} } @{$refs} if ($opts{deref});
} else {
$refs = $opts{deref} ? ${pop @{$refs}} : pop @{$refs};
}

if ($_ < 0) {
if (@{${$refs->[-1]}} < abs($_)) {
# expand smoothly for out of range negative indexes
$_ = @{${$refs->[-1]}};
} else {
$_ += @{${$refs->[-1]}};
push @done, ($opts{paths} ? ($path, $refs) : $refs);

next;
}

$step = shift @{$rest};
$pos = ($#{$init_path} - @{$rest});

if (($step_type = ref $step) eq 'HASH') {
if (ref ${$refs->[-1]} ne 'HASH') {
croak "HASH expected on step #$pos, got " . ref ${$refs->[-1]}
if ($opts{strict});
next unless ($opts{expand});
${$refs->[-1]} = {};
}

undef $items;

if (exists $step->{K}) {
croak "Unsupported HASH definition, step #$pos"
if (keys %{$step} > 1);
croak "Unsupported HASH keys definition, step #$pos"
unless (ref $step->{K} eq 'ARRAY');

for my $i (@{$step->{K}}) {
if (ref $i eq 'Regexp') {
push @{$items}, grep { /$i/ } keys %{${$refs->[-1]}};
} else {
unless ($opts{expand} or exists ${$refs->[-1]}->{$i}) {
croak "{$i} doesn't exist, step #$pos"
if $opts{strict};
next;
}
push @{$items}, $i;
}

push @next, [@{$steps}, [$_]], [@{$refs}, \${$refs->[-1]}->[$_]];
}
} else {
croak "Unsupported HASH definition, step #$pos"
if (keys %{$step});
}

if ($opts{delete} and $sc == $#{$path}) {
map { splice(@{${$refs->[-1]}}, $_, 1) if ($_ < @{${$refs->[-1]}}) }
reverse sort @{$items};
}
} elsif ($step_type eq 'HASH') {
if (ref ${$refs->[-1]} ne 'HASH') {
croak "HASH expected on step #$sc, got " . ref ${$refs->[-1]}
if ($opts{strict});
next unless ($opts{expand});
${$refs->[-1]} = {};
for (exists $step->{K} ? @{$items} : keys %{${$refs->[-1]}}) {
push @stack,
[@{$path}, {K => [$_]}],
[@{$refs}, \${$refs->[-1]}->{$_}],
[@{$rest}];

delete ${$refs->[-1]}->{$_}
if ($opts{delete} and not @{$rest});
}
} elsif ($step_type eq 'ARRAY') {
if (ref ${$refs->[-1]} ne 'ARRAY') {
croak "ARRAY expected on step #$pos, got " . ref ${$refs->[-1]}
if ($opts{strict});
next unless ($opts{expand});
${$refs->[-1]} = [];
}

$items = @{$step} ? $step : [0 .. $#${$refs->[-1]}];
for (@{$items}) {
unless (
$opts{expand} or
@{${$refs->[-1]}} > ($_ >= 0 ? $_ : abs($_ + 1))
) {
croak "[$_] doesn't exist, step #$pos" if ($opts{strict});
next;
}

undef $items;

if (exists $step->{K}) {
croak "Unsupported HASH definition, step #$sc"
if (keys %{$step} > 1);
croak "Unsupported HASH keys definition, step #$sc"
unless (ref $step->{K} eq 'ARRAY');

for my $i (@{$step->{K}}) {
if (ref $i eq 'Regexp') {
push @{$items}, grep { $_ =~ $i }
keys %{${$refs->[-1]}};
} else {
unless ($opts{expand} or exists ${$refs->[-1]}->{$i}) {
croak "{$i} doesn't exist, step #$sc" if $opts{strict};
next;
}
push @{$items}, $i;
}
if ($_ < 0) {
if (@{${$refs->[-1]}} < abs($_)) {
# expand smoothly for out of range negative indexes
$_ = @{${$refs->[-1]}};
} else {
$_ += @{${$refs->[-1]}};
}
} else {
croak "Unsupported HASH definition, step #$sc"
if (keys %{$step});
}

for (exists $step->{K} ? @{$items} : keys %{${$refs->[-1]}}) {
push @next, [@{$steps}, {K => [$_]}], [@{$refs}, \${$refs->[-1]}->{$_}];
delete ${$refs->[-1]}->{$_} if ($opts{delete} and $sc == $#{$path});
}
} elsif ($step_type eq 'CODE') {
local $_ = ${$refs->[-1]};
local $_{opts} = \%opts;
$step->($steps, $refs) and push @next, $steps, $refs;
} else {
croak "Unsupported thing in the path, step #$sc";
push @stack,
[@{$path}, [$_]],
[@{$refs}, \${$refs->[-1]}->[$_]],
[@{$rest}];
}
}

@level = splice @next;
$sc++;
}

my @out;
while (($path, $refs) = splice @level, 0, 2) {
${$refs->[-1]} = $opts{assign} if (exists $opts{assign});
if ($opts{delete} and not @{$rest}) {
for (reverse sort @{$items}) {
splice(@{${$refs->[-1]}}, $_, 1)
if ($_ < @{${$refs->[-1]}});
}
}
} elsif ($step_type eq 'CODE') {
local $_ = ${$refs->[-1]};
local $_{opts} = \%opts;

if ($opts{stack}) {
map { $_ = ${$_} } @{$refs} if ($opts{deref});
$step->($path, $refs, $rest) and
push @stack, $path, $refs, [@{$rest}];
} else {
$refs = $opts{deref} ? ${pop @{$refs}} : pop @{$refs};
croak "Unsupported thing in the path, step #$pos";
}

push @out, ($opts{paths} ? ($path, $refs) : $refs);
}

return @out;
return @done;
}

=head2 path_delta
Expand Down
2 changes: 1 addition & 1 deletion t/path-address.t
View file
Expand Up @@ -27,7 +27,7 @@ like($@, qr/^Unsupported thing in the path, step #0/);

# garbage in the refstack
eval { path($s_mixed, [ sub { push @{$_[1]}, undef }, [0] ]) };
like($@, qr/^Reference expected for refs stack entry, step #1/);
like($@, qr/^Reference expected for refs stack entry, step #0/);

# garbage in hash definition 1
eval { path($s_mixed, [ {garbage => ['a']} ]) };
Expand Down

0 comments on commit a72aa7d

Please sign in to comment.