view release on metacpan or  search on metacpan

bench/benchmark.pl  view on Meta::CPAN

#!/usr/bin/env perl
use strict;
use warnings;
use Benchmark qw(cmpthese timethese);
use FindBin;
use lib "$FindBin::Bin/../blib/lib", "$FindBin::Bin/../blib/arch";

use Data::Path::XS qw(path_get path_set path_exists path_delete
                      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];
        }
    }
    if (ref $data eq 'HASH') {
        $data->{$last} = $value;
    } elsif (ref $data eq 'ARRAY') {
        $data->[$last] = $value;
    }
    $value;
}

# Test data
my $deep = {
    level1 => {
        level2 => {
            level3 => {
                level4 => {
                    level5 => { value => 'deep' }
                }
            }
        }
    },
    arr => [0, [1, [2, [3, [4, 'nested']]]]],
};

my $shallow = { foo => 'bar', num => 42 };

print "=" x 70, "\n";
print "Data::Path::XS Benchmark (XS vs Pure Perl vs Native expressions)\n";
print "=" x 70, "\n\n";

print "--- Shallow get: /foo ---\n";
cmpthese(-2, {
    'XS'     => sub { path_get($shallow, '/foo') },
    'Perl'   => sub { pp_path_get($shallow, '/foo') },
    'Native' => sub { no autovivification; $shallow->{foo} },
});

print "\n--- Deep get: /level1/level2/level3/level4/level5/value ---\n";
cmpthese(-2, {
    'XS'     => sub { path_get($deep, '/level1/level2/level3/level4/level5/value') },
    'Perl'   => sub { pp_path_get($deep, '/level1/level2/level3/level4/level5/value') },
    'Native' => sub { no autovivification; $deep->{level1}{level2}{level3}{level4}{level5}{value} },
});

print "\n--- Array get: /arr/1/1/1/1/1 ---\n";
cmpthese(-2, {
    'XS'     => sub { path_get($deep, '/arr/1/1/1/1/1') },
    'Perl'   => sub { pp_path_get($deep, '/arr/1/1/1/1/1') },
    'Native' => sub { no autovivification; $deep->{arr}[1][1][1][1][1] },
});

print "\n--- Deep get (missing key): /level1/level2/nope/x ---\n";