view release on metacpan or  search on metacpan

xt/c-compat.t  view on Meta::CPAN

        message => '__builtin_* functions are GCC specific',
    },
    
    # === PERL XS ISSUES ===
    
    # NOTE: PERL_NO_GET_CONTEXT is a micro-optimization for threaded perls.
    # Most XS code works fine without it. Only flag if explicitly requested.
    # Disabled by default as it's too noisy.
    
    # NOTE: PL_sv_undef, PL_sv_yes, PL_sv_no, etc. are standard Perl globals
    # that are perfectly safe to use in XS code. They're thread-safe constants.
    # Disabled as it creates too much noise for legitimate XS patterns.
    
    # === MEMORY/SAFETY ISSUES ===
    
    # sprintf without size limit (buffer overflow risk)
    'unsafe_sprintf' => {
        pattern => qr/\bsprintf\s*\(/,
        severity => 'warning',
        message => 'sprintf is unsafe - use snprintf or sv_catpvf for safety',
        only_in_c_files => 1,
    },
    
    # strcpy without size limit
    'unsafe_strcpy' => {
        pattern => qr/\bstrcpy\s*\(/,
        severity => 'warning',
        message => 'strcpy is unsafe - use strncpy or Copy/Move macros',
        only_in_c_files => 1,
    },
    
    # strcat without size limit
    'unsafe_strcat' => {
        pattern => qr/\bstrcat\s*\(/,
        severity => 'warning',
        message => 'strcat is unsafe - use strncat or sv_catpv',
        only_in_c_files => 1,
    },
    
    # gets() - extremely unsafe
    'unsafe_gets' => {
        pattern => qr/\bgets\s*\(/,
        severity => 'error',
        message => 'gets() is extremely unsafe and removed in C11 - use fgets',
        only_in_c_files => 1,
    },
    
    # === PORTABILITY ISSUES ===
    
    # Assuming sizeof(int) or sizeof(pointer)
    'hardcoded_sizes' => {
        pattern => qr/\b(sizeof\s*\(\s*(int|long|void\s*\*)\s*\)\s*==\s*[48]|[48]\s*==\s*sizeof)/,
        severity => 'warning',
        message => 'Hardcoded type sizes are not portable across platforms',
    },
    
    # Platform-specific headers without guards
    'unistd_without_guard' => {
        pattern => qr/^#\s*include\s+<unistd\.h>/m,
        severity => 'info',
        message => '<unistd.h> is Unix-only - may need HAS_UNISTD guard',
        negative_pattern => qr/#\s*if.*HAS_UNISTD|#\s*ifdef.*WIN32|#\s*ifndef.*_WIN32/,
    },
    
    # Windows-specific headers without guards  
    'windows_header_without_guard' => {
        pattern => qr/^#\s*include\s+<windows\.h>/mi,
        severity => 'info',
        message => '<windows.h> is Windows-only - ensure proper guards',
        negative_pattern => qr/#\s*if.*WIN32|#\s*ifdef.*_WIN32/,
    },
);

# Check each XS directory
for my $dir (@xs_dirs) {
    my $full_dir = $dir;
    next unless -d $full_dir;
    
    my $module = $dir;
    $module =~ s|^xs/||;
    
    # Find .c and .h files
    my @files;
    find(sub {
        push @files, $File::Find::name if /\.[ch]$/ && !/ppport\.h$/;
    }, $full_dir);
    
    for my $file (@files) {
        my $content = eval { read_file($file) };
        next unless defined $content;
        
        my $rel_file = $file;
        my $is_compat = $file =~ /_compat\.h$/;
        my $is_c_file = $file =~ /\.c$/;
        
        # Check if this file includes a compat header
        my $has_compat = $content =~ /#include\s+["<]\w+_compat\.h[">]/;
        
        for my $check_name (sort keys %checks) {
            my $check = $checks{$check_name};
            
            # Skip compat-specific checks for compat headers themselves
            next if $is_compat && $check->{skip_in_compat};
            
            # Skip checks that only apply to .c files
            next if $check->{only_in_c_files} && !$is_c_file;
            
            # Skip checks marked to skip
            next if $check->{skip_functions};
            
            if ($content =~ $check->{pattern}) {
                # For negative patterns, skip if the negative pattern matches
                if ($check->{negative_pattern}) {
                    next if $content =~ $check->{negative_pattern};
                }
                
                # For patterns with required_guards, verify all guards are present
                if ($check->{required_guards}) {
                    my $all_guards_present = 1;
                    for my $guard (@{$check->{required_guards}}) {
                        unless ($content =~ $guard) {