view release on metacpan or  search on metacpan

t/025_affix_wrap.t  view on Meta::CPAN

                    [ 'Evil::pkg { system("echo PWNED") }', 'block injection' ],
                    [ '123bad',                             'starts with digit' ],
                    [ 'Evil::pkg::',                        'trailing ::' ],
                    [ '::Evil',                             'leading ::' ],
                    [ 'Evil pkg',                           'space in name' ],
                    [ "Evil\tpkg",                          'tab in name' ],
                    [ 'Evil::pkg#',                         'comment char in name' ],
                    [ "Evil::pkg\nsystem('echo PWNED')",    'newline injection' ],
                );
                for my $t (@bad_pkgs) {
                    my ( $bad_pkg, $desc ) = @$t;
                    ok dies { $binder->generate( 'good_lib', $bad_pkg, '/dev/null' ) }, "rejects $desc: $bad_pkg";
                }
            };

            # Valid $pkg names must be accepted
            subtest 'Valid pkg names accepted' => sub {
                my @good_pkgs = (
                    [ 'Good',     'simple name' ],
                    [ 'GoodName', 'single word' ],
                    [ 'Test123',  'alphanumeric' ],
                    [ '_private', 'leading underscore' ],
                );
                for my $t (@good_pkgs) {
                    my ( $good_pkg, $desc ) = @$t;
                    my $pm_file = $dir->child("good_$good_pkg.pm");
                    lives { $binder->generate( 'good_lib', $good_pkg, $pm_file->stringify ) }
                        or fail "Should accept $desc: $good_pkg";
                    like $pm_file->slurp_utf8, qr/package\s+\Q$good_pkg\E\s*\{/, "Package decl for $desc";
                }

                # Names with :: are valid Perl packages but can't be tested via
                # file I/O on Windows (colon is forbidden in filenames). Verify
                # they pass validation without writing to disk.
                my @ns_pkgs = ( 'Good::Name', 'A::B::C::D' );
                for my $good_pkg (@ns_pkgs) {
                    my $code = eval {
                        my ( $c, $n ) = $binder->_generate_code( 'good_lib', $good_pkg );
                        $c;
                    };
                    ok defined $code, "accepts namespace $good_pkg";
                    like $code, qr/package\s+\Q$good_pkg\E\s*\{/, "Package decl for $good_pkg";
                }
            };

            # Malicious $pkg that looks valid but isn't must be rejected
            subtest 'Borderline pkg names rejected' => sub {
                my @borderline = (
                    [ 'Evil; system("echo PWNED")', 'semicolon, no ::' ],
                    [ 'Evil pkg',                   'space, no ::' ],
                    [ 'Evil::system("echo PWNED")', 'parens in name' ],
                    [ 'Evil->pkg',                  'arrow instead of ::' ],
                );
                for my $t (@borderline) {
                    my ( $bad, $desc ) = @$t;
                    ok dies { $binder->generate( 'lib', $bad, '/dev/null' ) }, "rejects $desc: $bad";
                }
            };

            # $lib with backslashes (Windows paths) must be handled
            subtest 'Windows-style lib paths' => sub {
                my $win_lib = 'C:\Users\Test\lib.dll';
                my $pm_file = $dir->child('winpath.pm');
                lives { $binder->generate( $win_lib, 'WinPathTest', $pm_file->stringify ) }
                    or bail_out 'generate() died on Windows path';
                my $content = $pm_file->slurp_utf8;

                # Backslashes are doubled when escaped for q[...] (\\ -> \\\\)
                like $content, qr/q\[.*C:\\\\Users\\\\Test\\\\lib\.dll\]/, 'Windows path safely quoted';
                my ( undef, undef, $exit ) = capture { system $^X, '-Ilib', '-c', $pm_file->stringify };
                is $exit >> 8, 0, 'Generated code compiles with Windows path';
            };

            # wrap() must also reject bad $pkg
            subtest 'wrap() rejects malicious pkg' => sub {
                ok dies { $binder->wrap( 'good_lib', 'Evil; system("echo PWNED")' ) }, 'wrap() rejects malicious pkg name';
            };
        };
    };
}
run_tests_for_driver( 'Affix::Wrap::Driver::Clang', 'Clang System' ) if $CLANG_AVAIL;
run_tests_for_driver( 'Affix::Wrap::Driver::Regex', 'Regex System (Fallback)' );
#
done_testing();