view release on metacpan or  search on metacpan

t/12-sdk-validation.t  view on Meta::CPAN

        '/home/user',
        '/Users/username',
        '/root',
        '/home/user/workspace',
    );

    my @unsafe_paths = (
        '/home/user/../etc',
        '/home/user/../../root',
        '/..',
        '/home/..',
    );

    for my $path (@safe_paths) {
        my $is_safe = ($path !~ m{/\.\./} && $path !~ m{/\.\.\z});
        ok($is_safe, "safe path: '$path'");
    }

    for my $path (@unsafe_paths) {
        my $is_unsafe = ($path =~ m{/\.\./} || $path =~ m{/\.\.\z});
        ok($is_unsafe, "unsafe path detected: '$path'");
    }
};

# =============================================================================
# Control character sanitization tests
# =============================================================================

subtest 'Control character sanitization' => sub {
    # From Query.pm: s/[[:cntrl:]]/ /g

    my $sanitize = sub {
        my ($str) = @_;
        $str =~ s/[[:cntrl:]]/ /g;
        return $str;
    };

    is($sanitize->('normal text'), 'normal text', 'normal text unchanged');
    is($sanitize->("line\nbreak"), 'line break', 'newline replaced');
    is($sanitize->("with\ttab"), 'with tab', 'tab replaced');
    is($sanitize->("null\x00byte"), 'null byte', 'null replaced');
    is($sanitize->("carriage\rreturn"), 'carriage return', 'CR replaced');
    is($sanitize->("bell\x07sound"), 'bell sound', 'bell replaced');
    is($sanitize->("escape\x1bseq"), 'escape seq', 'escape replaced');

    # Verify normal printable chars preserved
    my $printable = join('', map { chr } 32..126);
    is($sanitize->($printable), $printable, 'printable ASCII preserved');
};

# =============================================================================
# JSON::Lines safety tests
# =============================================================================

subtest 'JSON structure validation' => sub {
    use JSON::Lines;

    my $jsonl = JSON::Lines->new;

    # Valid JSON line
    my @decoded = $jsonl->decode('{"type":"test"}');
    is(scalar @decoded, 1, 'single object decoded');
    is($decoded[0]->{type}, 'test', 'type key extracted');

    # Array in JSON Lines
    @decoded = $jsonl->decode('[1,2,3]');
    is(scalar @decoded, 1, 'array decoded as single item');
    is_deeply($decoded[0], [1,2,3], 'array content correct');

    # Multiple lines (though JSON::Lines takes one at a time)
    my $line1 = '{"a":1}';
    my $line2 = '{"b":2}';
    @decoded = $jsonl->decode($line1);
    is($decoded[0]->{a}, 1, 'first line decoded');
    @decoded = $jsonl->decode($line2);
    is($decoded[0]->{b}, 2, 'second line decoded');
};

# =============================================================================
# PERL5LIB filtering tests (from SDKServer)
# =============================================================================

subtest 'PERL5LIB path filtering' => sub {
    use Cwd qw(abs_path);
    use File::Spec;

    # Simulate the filtering logic from SDKServer
    my $filter_path = sub {
        my ($path) = @_;
        return 0 unless defined $path;
        return 0 unless $path =~ m{^/};
        return 0 unless -d $path;  # Must exist
        my $real = abs_path($path);
        return 0 unless $real;
        return 0 unless $real =~ m{^/};
        return 0 if $real =~ m{/\.\.(/|$)};  # No parent traversal
        return 1;
    };

    # Test paths that exist
    ok($filter_path->('/tmp'), '/tmp accepted');
    ok($filter_path->('/'), '/ accepted');

    # Test relative paths
    ok(!$filter_path->('relative'), 'relative path rejected');
    ok(!$filter_path->('./relative'), './relative rejected');

    # Test undef
    ok(!$filter_path->(undef), 'undef rejected');

    # Test non-existent paths (should fail -d check)
    ok(!$filter_path->('/definitely/not/existing/path/12345'), 'non-existent rejected');
};

done_testing();