view release on metacpan or  search on metacpan

bench/benchmark.pl  view on Meta::CPAN

                      patha_get patha_set patha_exists patha_delete
                      path_compile pathc_get pathc_set pathc_exists pathc_delete);
use Data::Path::XS ':keywords';
use autovivification;

# Pure Perl implementation for comparison
sub pp_path_get {
    my ($data, $path) = @_;
    return $data if $path eq '';
    die "Invalid path" unless $path =~ s{^/}{};
    for my $p (split m{/}, $path, -1) {
        return undef unless ref $data;
        if (ref $data eq 'HASH') {
            return undef unless exists $data->{$p};
            $data = $data->{$p};
        } elsif (ref $data eq 'ARRAY') {
            return undef unless $p =~ /^\d+$/ && exists $data->[$p];
            $data = $data->[$p];
        } else {
            return undef;
        }
    }
    $data;
}

sub pp_path_exists {
    my ($data, $path) = @_;
    return 1 if $path eq '';
    die "Invalid path" unless $path =~ s{^/}{};
    for my $p (split m{/}, $path, -1) {
        return 0 unless ref $data;
        if (ref $data eq 'HASH') {
            return 0 unless exists $data->{$p};
            $data = $data->{$p};
        } elsif (ref $data eq 'ARRAY') {
            return 0 unless $p =~ /^\d+$/ && exists $data->[$p];
            $data = $data->[$p];
        } else {
            return 0;
        }
    }
    1;
}

sub pp_path_set {
    my ($data, $path, $value) = @_;
    die "Cannot set root" if $path eq '';
    die "Invalid path" unless $path =~ s{^/}{};
    my @parts = split m{/}, $path, -1;
    my $last = pop @parts;
    for my $p (@parts) {
        if (ref $data eq 'HASH') {
            $data->{$p} //= {};
            $data = $data->{$p};
        } elsif (ref $data eq 'ARRAY') {
            $data->[$p] //= {};
            $data = $data->[$p];
        }
    }

eg/json-pointer-bridge.pl  view on Meta::CPAN

sub json_pointer_to_array {
    my ($pointer) = @_;
    return [] if $pointer eq '' || $pointer eq '/';
    die "JSON Pointer must start with '/' or be empty\n"
        unless $pointer =~ s{^/}{};
    return [ map {
        my $c = $_;
        $c =~ s{~1}{/}g;
        $c =~ s{~0}{~}g;
        $c;
    } split m{/}, $pointer, -1 ];
}

if (!@ARGV) {
    # Self-test: round-trip a few pointers and show the parsed components.
    for my $p ('', '/', '/foo', '/foo/0/bar', '/a~1b/c~0d', '/x/') {
        my $components = json_pointer_to_array($p);
        printf "%-20s -> [%s]\n", $p, join(', ', map "'$_'", @$components);
    }
    exit;
}